Symaptic: os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclTest.c@260cb5ec6c19 (annotated)

sl@0	1	/*
sl@0	2	* tclTest.c --
sl@0	3	*
sl@0	4	* This file contains C command procedures for a bunch of additional
sl@0	5	* Tcl commands that are used for testing out Tcl's C interfaces.
sl@0	6	* These commands are not normally included in Tcl applications;
sl@0	7	* they're only used for testing.
sl@0	8	*
sl@0	9	* Copyright (c) 1993-1994 The Regents of the University of California.
sl@0	10	* Copyright (c) 1994-1997 Sun Microsystems, Inc.
sl@0	11	* Copyright (c) 1998-2000 Ajuba Solutions.
sl@0	12	* Copyright (c) 2003 by Kevin B. Kenny. All rights reserved.
sl@0	13	* Portions Copyright (c) 2007 Nokia Corporation and/or its subsidiaries. All rights reserved.
sl@0	14	*
sl@0	15	* See the file "license.terms" for information on usage and redistribution
sl@0	16	* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
sl@0	17	*
sl@0	18	* RCS: @(#) $Id: tclTest.c,v 1.62.2.13 2006/09/22 01:26:23 andreas_kupries Exp $
sl@0	19	*/
sl@0	20	#ifndef __SYMBIAN32__
sl@0	21	#define TCL_TEST
sl@0	22	#endif
sl@0	23	#include "tclInt.h"
sl@0	24	#include "tclPort.h"
sl@0	25	#if defined(__SYMBIAN32__)
sl@0	26	#include "tclSymbianGlobals.h"
sl@0	27	#endif
sl@0	28
sl@0	29	/*
sl@0	30	* Required for Testregexp*Cmd
sl@0	31	*/
sl@0	32	#include "tclRegexp.h"
sl@0	33
sl@0	34	/*
sl@0	35	* Required for TestlocaleCmd
sl@0	36	*/
sl@0	37	#include <locale.h>
sl@0	38
sl@0	39	/*
sl@0	40	* Required for the TestChannelCmd and TestChannelEventCmd
sl@0	41	*/
sl@0	42	#include "tclIO.h"
sl@0	43
sl@0	44	/*
sl@0	45	* Declare external functions used in Windows tests.
sl@0	46	*/
sl@0	47
sl@0	48	/*
sl@0	49	* Dynamic string shared by TestdcallCmd and DelCallbackProc; used
sl@0	50	* to collect the results of the various deletion callbacks.
sl@0	51	*/
sl@0	52
sl@0	53	static Tcl_DString delString;
sl@0	54	static Tcl_Interp *delInterp;
sl@0	55
sl@0	56	/*
sl@0	57	* One of the following structures exists for each asynchronous
sl@0	58	* handler created by the "testasync" command".
sl@0	59	*/
sl@0	60
sl@0	61	typedef struct TestAsyncHandler {
sl@0	62	int id; /* Identifier for this handler. */
sl@0	63	Tcl_AsyncHandler handler; /* Tcl's token for the handler. */
sl@0	64	char command; / Command to invoke when the
sl@0	65	* handler is invoked. */
sl@0	66	struct TestAsyncHandler nextPtr; / Next is list of handlers. */
sl@0	67	} TestAsyncHandler;
sl@0	68
sl@0	69	static TestAsyncHandler *firstHandler = NULL;
sl@0	70
sl@0	71	/*
sl@0	72	* The dynamic string below is used by the "testdstring" command
sl@0	73	* to test the dynamic string facilities.
sl@0	74	*/
sl@0	75
sl@0	76	static Tcl_DString dstring;
sl@0	77
sl@0	78	/*
sl@0	79	* The command trace below is used by the "testcmdtraceCmd" command
sl@0	80	* to test the command tracing facilities.
sl@0	81	*/
sl@0	82
sl@0	83	static Tcl_Trace cmdTrace;
sl@0	84
sl@0	85	/*
sl@0	86	* One of the following structures exists for each command created
sl@0	87	* by TestdelCmd:
sl@0	88	*/
sl@0	89
sl@0	90	typedef struct DelCmd {
sl@0	91	Tcl_Interp interp; / Interpreter in which command exists. */
sl@0	92	char deleteCmd; / Script to execute when command is
sl@0	93	* deleted. Malloc'ed. */
sl@0	94	} DelCmd;
sl@0	95
sl@0	96	/*
sl@0	97	* The following is used to keep track of an encoding that invokes a Tcl
sl@0	98	* command.
sl@0	99	*/
sl@0	100
sl@0	101	typedef struct TclEncoding {
sl@0	102	Tcl_Interp *interp;
sl@0	103	char *toUtfCmd;
sl@0	104	char *fromUtfCmd;
sl@0	105	} TclEncoding;
sl@0	106
sl@0	107	/*
sl@0	108	* The counter below is used to determine if the TestsaveresultFree
sl@0	109	* routine was called for a result.
sl@0	110	*/
sl@0	111
sl@0	112	static int freeCount;
sl@0	113
sl@0	114	/*
sl@0	115	* Boolean flag used by the "testsetmainloop" and "testexitmainloop"
sl@0	116	* commands.
sl@0	117	*/
sl@0	118	static int exitMainLoop = 0;
sl@0	119
sl@0	120	/*
sl@0	121	* Event structure used in testing the event queue management procedures.
sl@0	122	*/
sl@0	123	typedef struct TestEvent {
sl@0	124	Tcl_Event header; /* Header common to all events */
sl@0	125	Tcl_Interp* interp; /* Interpreter that will handle the event */
sl@0	126	Tcl_Obj* command; /* Command to evaluate when the event occurs */
sl@0	127	Tcl_Obj* tag; /* Tag for this event used to delete it */
sl@0	128	} TestEvent;
sl@0	129
sl@0	130	/*
sl@0	131	* Forward declarations for procedures defined later in this file:
sl@0	132	*/
sl@0	133
sl@0	134	int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp));
sl@0	135	static int AsyncHandlerProc _ANSI_ARGS_((ClientData clientData,
sl@0	136	Tcl_Interp *interp, int code));
sl@0	137	static void CleanupTestSetassocdataTests _ANSI_ARGS_((
sl@0	138	ClientData clientData, Tcl_Interp *interp));
sl@0	139	static void CmdDelProc1 _ANSI_ARGS_((ClientData clientData));
sl@0	140	static void CmdDelProc2 _ANSI_ARGS_((ClientData clientData));
sl@0	141	static int CmdProc1 _ANSI_ARGS_((ClientData clientData,
sl@0	142	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	143	static int CmdProc2 _ANSI_ARGS_((ClientData clientData,
sl@0	144	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	145	static void CmdTraceDeleteProc _ANSI_ARGS_((
sl@0	146	ClientData clientData, Tcl_Interp *interp,
sl@0	147	int level, char command, Tcl_CmdProc cmdProc,
sl@0	148	ClientData cmdClientData, int argc,
sl@0	149	char **argv));
sl@0	150	static void CmdTraceProc _ANSI_ARGS_((ClientData clientData,
sl@0	151	Tcl_Interp interp, int level, char command,
sl@0	152	Tcl_CmdProc *cmdProc, ClientData cmdClientData,
sl@0	153	int argc, char **argv));
sl@0	154	static int CreatedCommandProc _ANSI_ARGS_((
sl@0	155	ClientData clientData, Tcl_Interp *interp,
sl@0	156	int argc, CONST char **argv));
sl@0	157	static int CreatedCommandProc2 _ANSI_ARGS_((
sl@0	158	ClientData clientData, Tcl_Interp *interp,
sl@0	159	int argc, CONST char **argv));
sl@0	160	static void DelCallbackProc _ANSI_ARGS_((ClientData clientData,
sl@0	161	Tcl_Interp *interp));
sl@0	162	static int DelCmdProc _ANSI_ARGS_((ClientData clientData,
sl@0	163	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	164	static void DelDeleteProc _ANSI_ARGS_((ClientData clientData));
sl@0	165	static void EncodingFreeProc _ANSI_ARGS_((ClientData clientData));
sl@0	166	static int EncodingToUtfProc _ANSI_ARGS_((ClientData clientData,
sl@0	167	CONST char *src, int srcLen, int flags,
sl@0	168	Tcl_EncodingState statePtr, char dst,
sl@0	169	int dstLen, int srcReadPtr, int dstWrotePtr,
sl@0	170	int *dstCharsPtr));
sl@0	171	static int EncodingFromUtfProc _ANSI_ARGS_((ClientData clientData,
sl@0	172	CONST char *src, int srcLen, int flags,
sl@0	173	Tcl_EncodingState statePtr, char dst,
sl@0	174	int dstLen, int srcReadPtr, int dstWrotePtr,
sl@0	175	int *dstCharsPtr));
sl@0	176	static void ExitProcEven _ANSI_ARGS_((ClientData clientData));
sl@0	177	static void ExitProcOdd _ANSI_ARGS_((ClientData clientData));
sl@0	178	static int GetTimesCmd _ANSI_ARGS_((ClientData clientData,
sl@0	179	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	180	static void MainLoop _ANSI_ARGS_((void));
sl@0	181	static int NoopCmd _ANSI_ARGS_((ClientData clientData,
sl@0	182	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	183	static int NoopObjCmd _ANSI_ARGS_((ClientData clientData,
sl@0	184	Tcl_Interp *interp, int objc,
sl@0	185	Tcl_Obj *CONST objv[]));
sl@0	186	static int ObjTraceProc _ANSI_ARGS_(( ClientData clientData,
sl@0	187	Tcl_Interp* interp,
sl@0	188	int level,
sl@0	189	CONST char* command,
sl@0	190	Tcl_Command commandToken,
sl@0	191	int objc,
sl@0	192	Tcl_Obj *CONST objv[] ));
sl@0	193	static void ObjTraceDeleteProc _ANSI_ARGS_(( ClientData ));
sl@0	194	static void PrintParse _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	195	Tcl_Parse *parsePtr));
sl@0	196	static void SpecialFree _ANSI_ARGS_((char *blockPtr));
sl@0	197	static int StaticInitProc _ANSI_ARGS_((Tcl_Interp *interp));
sl@0	198	static int TestaccessprocCmd _ANSI_ARGS_((ClientData dummy,
sl@0	199	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	200	static int PretendTclpAccess _ANSI_ARGS_((CONST char *path,
sl@0	201	int mode));
sl@0	202	static int TestAccessProc1 _ANSI_ARGS_((CONST char *path,
sl@0	203	int mode));
sl@0	204	static int TestAccessProc2 _ANSI_ARGS_((CONST char *path,
sl@0	205	int mode));
sl@0	206	static int TestAccessProc3 _ANSI_ARGS_((CONST char *path,
sl@0	207	int mode));
sl@0	208	static int TestasyncCmd _ANSI_ARGS_((ClientData dummy,
sl@0	209	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	210	static int TestcmdinfoCmd _ANSI_ARGS_((ClientData dummy,
sl@0	211	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	212	static int TestcmdtokenCmd _ANSI_ARGS_((ClientData dummy,
sl@0	213	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	214	static int TestcmdtraceCmd _ANSI_ARGS_((ClientData dummy,
sl@0	215	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	216	static int TestcreatecommandCmd _ANSI_ARGS_((ClientData dummy,
sl@0	217	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	218	static int TestdcallCmd _ANSI_ARGS_((ClientData dummy,
sl@0	219	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	220	static int TestdelCmd _ANSI_ARGS_((ClientData dummy,
sl@0	221	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	222	static int TestdelassocdataCmd _ANSI_ARGS_((ClientData dummy,
sl@0	223	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	224	static int TestdstringCmd _ANSI_ARGS_((ClientData dummy,
sl@0	225	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	226	static int TestencodingObjCmd _ANSI_ARGS_((ClientData dummy,
sl@0	227	Tcl_Interp *interp, int objc,
sl@0	228	Tcl_Obj *CONST objv[]));
sl@0	229	static int TestevalexObjCmd _ANSI_ARGS_((ClientData dummy,
sl@0	230	Tcl_Interp *interp, int objc,
sl@0	231	Tcl_Obj *CONST objv[]));
sl@0	232	static int TestevalobjvObjCmd _ANSI_ARGS_((ClientData dummy,
sl@0	233	Tcl_Interp *interp, int objc,
sl@0	234	Tcl_Obj *CONST objv[]));
sl@0	235	static int TesteventObjCmd _ANSI_ARGS_((ClientData unused,
sl@0	236	Tcl_Interp* interp,
sl@0	237	int argc,
sl@0	238	Tcl_Obj *CONST objv[]));
sl@0	239	static int TesteventProc _ANSI_ARGS_((Tcl_Event* event,
sl@0	240	int flags));
sl@0	241	static int TesteventDeleteProc _ANSI_ARGS_((
sl@0	242	Tcl_Event* event,
sl@0	243	ClientData clientData));
sl@0	244	static int TestexithandlerCmd _ANSI_ARGS_((ClientData dummy,
sl@0	245	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	246	static int TestexprlongCmd _ANSI_ARGS_((ClientData dummy,
sl@0	247	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	248	static int TestexprparserObjCmd _ANSI_ARGS_((ClientData dummy,
sl@0	249	Tcl_Interp *interp, int objc,
sl@0	250	Tcl_Obj *CONST objv[]));
sl@0	251	static int TestexprstringCmd _ANSI_ARGS_((ClientData dummy,
sl@0	252	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	253	static int TestfileCmd _ANSI_ARGS_((ClientData dummy,
sl@0	254	Tcl_Interp interp, int objc, Tcl_Obj CONST objv[]));
sl@0	255	static int TestfilelinkCmd _ANSI_ARGS_((ClientData dummy,
sl@0	256	Tcl_Interp interp, int objc, Tcl_Obj CONST objv[]));
sl@0	257	static int TestfeventCmd _ANSI_ARGS_((ClientData dummy,
sl@0	258	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	259	static int TestgetassocdataCmd _ANSI_ARGS_((ClientData dummy,
sl@0	260	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	261	static int TestgetplatformCmd _ANSI_ARGS_((ClientData dummy,
sl@0	262	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	263	static int TestgetvarfullnameCmd _ANSI_ARGS_((
sl@0	264	ClientData dummy, Tcl_Interp *interp,
sl@0	265	int objc, Tcl_Obj *CONST objv[]));
sl@0	266	static int TestinterpdeleteCmd _ANSI_ARGS_((ClientData dummy,
sl@0	267	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	268	static int TestlinkCmd _ANSI_ARGS_((ClientData dummy,
sl@0	269	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	270	static int TestlocaleCmd _ANSI_ARGS_((ClientData dummy,
sl@0	271	Tcl_Interp *interp, int objc,
sl@0	272	Tcl_Obj *CONST objv[]));
sl@0	273	static int TestMathFunc _ANSI_ARGS_((ClientData clientData,
sl@0	274	Tcl_Interp interp, Tcl_Value args,
sl@0	275	Tcl_Value *resultPtr));
sl@0	276	static int TestMathFunc2 _ANSI_ARGS_((ClientData clientData,
sl@0	277	Tcl_Interp interp, Tcl_Value args,
sl@0	278	Tcl_Value *resultPtr));
sl@0	279	static int TestmainthreadCmd _ANSI_ARGS_((ClientData dummy,
sl@0	280	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	281	static int TestsetmainloopCmd _ANSI_ARGS_((ClientData dummy,
sl@0	282	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	283	static int TestexitmainloopCmd _ANSI_ARGS_((ClientData dummy,
sl@0	284	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	285	static Tcl_Channel PretendTclpOpenFileChannel _ANSI_ARGS_((
sl@0	286	Tcl_Interp interp, CONST char fileName,
sl@0	287	CONST char *modeString, int permissions));
sl@0	288	static Tcl_Channel TestOpenFileChannelProc1 _ANSI_ARGS_((
sl@0	289	Tcl_Interp interp, CONST char fileName,
sl@0	290	CONST char *modeString, int permissions));
sl@0	291	static Tcl_Channel TestOpenFileChannelProc2 _ANSI_ARGS_((
sl@0	292	Tcl_Interp interp, CONST char fileName,
sl@0	293	CONST char *modeString, int permissions));
sl@0	294	static Tcl_Channel TestOpenFileChannelProc3 _ANSI_ARGS_((
sl@0	295	Tcl_Interp interp, CONST char fileName,
sl@0	296	CONST char *modeString, int permissions));
sl@0	297	static int TestpanicCmd _ANSI_ARGS_((ClientData dummy,
sl@0	298	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	299	static int TestparserObjCmd _ANSI_ARGS_((ClientData dummy,
sl@0	300	Tcl_Interp *interp, int objc,
sl@0	301	Tcl_Obj *CONST objv[]));
sl@0	302	static int TestparsevarObjCmd _ANSI_ARGS_((ClientData dummy,
sl@0	303	Tcl_Interp *interp, int objc,
sl@0	304	Tcl_Obj *CONST objv[]));
sl@0	305	static int TestparsevarnameObjCmd _ANSI_ARGS_((ClientData dummy,
sl@0	306	Tcl_Interp *interp, int objc,
sl@0	307	Tcl_Obj *CONST objv[]));
sl@0	308	static int TestregexpObjCmd _ANSI_ARGS_((ClientData dummy,
sl@0	309	Tcl_Interp *interp, int objc,
sl@0	310	Tcl_Obj *CONST objv[]));
sl@0	311	static void TestregexpXflags _ANSI_ARGS_((char *string,
sl@0	312	int length, int cflagsPtr, int eflagsPtr));
sl@0	313	static int TestsaveresultCmd _ANSI_ARGS_((ClientData dummy,
sl@0	314	Tcl_Interp *interp, int objc,
sl@0	315	Tcl_Obj *CONST objv[]));
sl@0	316	static void TestsaveresultFree _ANSI_ARGS_((char *blockPtr));
sl@0	317	static int TestsetassocdataCmd _ANSI_ARGS_((ClientData dummy,
sl@0	318	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	319	static int TestsetCmd _ANSI_ARGS_((ClientData dummy,
sl@0	320	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	321	static int TestseterrorcodeCmd _ANSI_ARGS_((ClientData dummy,
sl@0	322	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	323	static int TestsetobjerrorcodeCmd _ANSI_ARGS_((
sl@0	324	ClientData dummy, Tcl_Interp *interp,
sl@0	325	int objc, Tcl_Obj *CONST objv[]));
sl@0	326	static int TestopenfilechannelprocCmd _ANSI_ARGS_((
sl@0	327	ClientData dummy, Tcl_Interp *interp, int argc,
sl@0	328	CONST char **argv));
sl@0	329	static int TestsetplatformCmd _ANSI_ARGS_((ClientData dummy,
sl@0	330	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	331	static int TeststaticpkgCmd _ANSI_ARGS_((ClientData dummy,
sl@0	332	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	333	static int PretendTclpStat _ANSI_ARGS_((CONST char *path,
sl@0	334	struct stat *buf));
sl@0	335	static int TestStatProc1 _ANSI_ARGS_((CONST char *path,
sl@0	336	struct stat *buf));
sl@0	337	static int TestStatProc2 _ANSI_ARGS_((CONST char *path,
sl@0	338	struct stat *buf));
sl@0	339	static int TestStatProc3 _ANSI_ARGS_((CONST char *path,
sl@0	340	struct stat *buf));
sl@0	341	static int TeststatprocCmd _ANSI_ARGS_((ClientData dummy,
sl@0	342	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	343	static int TesttranslatefilenameCmd _ANSI_ARGS_((ClientData dummy,
sl@0	344	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	345	static int TestupvarCmd _ANSI_ARGS_((ClientData dummy,
sl@0	346	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	347	static int TestWrongNumArgsObjCmd _ANSI_ARGS_((
sl@0	348	ClientData clientData, Tcl_Interp *interp,
sl@0	349	int objc, Tcl_Obj *CONST objv[]));
sl@0	350	static int TestGetIndexFromObjStructObjCmd _ANSI_ARGS_((
sl@0	351	ClientData clientData, Tcl_Interp *interp,
sl@0	352	int objc, Tcl_Obj *CONST objv[]));
sl@0	353	static int TestChannelCmd _ANSI_ARGS_((ClientData clientData,
sl@0	354	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	355	static int TestChannelEventCmd _ANSI_ARGS_((ClientData clientData,
sl@0	356	Tcl_Interp interp, int argc, CONST char *argv));
sl@0	357	/* Filesystem testing */
sl@0	358
sl@0	359	static int TestFilesystemObjCmd _ANSI_ARGS_((ClientData dummy,
sl@0	360	Tcl_Interp *interp, int objc,
sl@0	361	Tcl_Obj *CONST objv[]));
sl@0	362	static int TestSimpleFilesystemObjCmd _ANSI_ARGS_((
sl@0	363	ClientData dummy, Tcl_Interp *interp, int objc,
sl@0	364	Tcl_Obj *CONST objv[]));
sl@0	365
sl@0	366	static void TestReport _ANSI_ARGS_ ((CONST char* cmd, Tcl_Obj* arg1,
sl@0	367	Tcl_Obj* arg2));
sl@0	368
sl@0	369	static Tcl_Obj* TestReportGetNativePath _ANSI_ARGS_ ((
sl@0	370	Tcl_Obj* pathObjPtr));
sl@0	371
sl@0	372	static int TestReportStat _ANSI_ARGS_ ((Tcl_Obj *path,
sl@0	373	Tcl_StatBuf *buf));
sl@0	374	static int TestReportAccess _ANSI_ARGS_ ((Tcl_Obj *path,
sl@0	375	int mode));
sl@0	376	static Tcl_Channel TestReportOpenFileChannel _ANSI_ARGS_ ((
sl@0	377	Tcl_Interp interp, Tcl_Obj fileName,
sl@0	378	int mode, int permissions));
sl@0	379	static int TestReportMatchInDirectory _ANSI_ARGS_ ((
sl@0	380	Tcl_Interp interp, Tcl_Obj resultPtr,
sl@0	381	Tcl_Obj dirPtr, CONST char pattern,
sl@0	382	Tcl_GlobTypeData *types));
sl@0	383	static int TestReportChdir _ANSI_ARGS_ ((Tcl_Obj *dirName));
sl@0	384	static int TestReportLstat _ANSI_ARGS_ ((Tcl_Obj *path,
sl@0	385	Tcl_StatBuf *buf));
sl@0	386	static int TestReportCopyFile _ANSI_ARGS_ ((Tcl_Obj *src,
sl@0	387	Tcl_Obj *dst));
sl@0	388	static int TestReportDeleteFile _ANSI_ARGS_ ((Tcl_Obj *path));
sl@0	389	static int TestReportRenameFile _ANSI_ARGS_ ((Tcl_Obj *src,
sl@0	390	Tcl_Obj *dst));
sl@0	391	static int TestReportCreateDirectory _ANSI_ARGS_ ((Tcl_Obj *path));
sl@0	392	static int TestReportCopyDirectory _ANSI_ARGS_ ((Tcl_Obj *src,
sl@0	393	Tcl_Obj dst, Tcl_Obj *errorPtr));
sl@0	394	static int TestReportRemoveDirectory _ANSI_ARGS_ ((Tcl_Obj *path,
sl@0	395	int recursive, Tcl_Obj **errorPtr));
sl@0	396	static int TestReportLoadFile _ANSI_ARGS_ ((Tcl_Interp *interp,
sl@0	397	Tcl_Obj *fileName,
sl@0	398	Tcl_LoadHandle *handlePtr,
sl@0	399	Tcl_FSUnloadFileProc **unloadProcPtr));
sl@0	400	static Tcl_Obj * TestReportLink _ANSI_ARGS_ ((Tcl_Obj *path,
sl@0	401	Tcl_Obj *to, int linkType));
sl@0	402	static CONST char** TestReportFileAttrStrings _ANSI_ARGS_ ((
sl@0	403	Tcl_Obj fileName, Tcl_Obj *objPtrRef));
sl@0	404	static int TestReportFileAttrsGet _ANSI_ARGS_ ((Tcl_Interp *interp,
sl@0	405	int index, Tcl_Obj fileName, Tcl_Obj *objPtrRef));
sl@0	406	static int TestReportFileAttrsSet _ANSI_ARGS_ ((Tcl_Interp *interp,
sl@0	407	int index, Tcl_Obj fileName, Tcl_Obj objPtr));
sl@0	408	static int TestReportUtime _ANSI_ARGS_ ((Tcl_Obj *fileName,
sl@0	409	struct utimbuf *tval));
sl@0	410	static int TestReportNormalizePath _ANSI_ARGS_ ((
sl@0	411	Tcl_Interp interp, Tcl_Obj pathPtr,
sl@0	412	int nextCheckpoint));
sl@0	413	static int TestReportInFilesystem _ANSI_ARGS_ ((Tcl_Obj pathPtr, ClientData clientDataPtr));
sl@0	414	static void TestReportFreeInternalRep _ANSI_ARGS_ ((ClientData clientData));
sl@0	415	static ClientData TestReportDupInternalRep _ANSI_ARGS_ ((ClientData clientData));
sl@0	416
sl@0	417	static int SimpleStat _ANSI_ARGS_ ((Tcl_Obj *path,
sl@0	418	Tcl_StatBuf *buf));
sl@0	419	static int SimpleAccess _ANSI_ARGS_ ((Tcl_Obj *path,
sl@0	420	int mode));
sl@0	421	static Tcl_Channel SimpleOpenFileChannel _ANSI_ARGS_ ((
sl@0	422	Tcl_Interp interp, Tcl_Obj fileName,
sl@0	423	int mode, int permissions));
sl@0	424	static Tcl_Obj* SimpleListVolumes _ANSI_ARGS_ ((void));
sl@0	425	static int SimplePathInFilesystem _ANSI_ARGS_ ((
sl@0	426	Tcl_Obj pathPtr, ClientData clientDataPtr));
sl@0	427	static Tcl_Obj* SimpleCopy _ANSI_ARGS_ ((Tcl_Obj *pathPtr));
sl@0	428	static int TestNumUtfCharsCmd _ANSI_ARGS_((ClientData clientData,
sl@0	429	Tcl_Interp *interp, int objc,
sl@0	430	Tcl_Obj *CONST objv[]));
sl@0	431
sl@0	432	static Tcl_Filesystem testReportingFilesystem = {
sl@0	433	"reporting",
sl@0	434	sizeof(Tcl_Filesystem),
sl@0	435	TCL_FILESYSTEM_VERSION_1,
sl@0	436	&TestReportInFilesystem, /* path in */
sl@0	437	&TestReportDupInternalRep,
sl@0	438	&TestReportFreeInternalRep,
sl@0	439	NULL, /* native to norm */
sl@0	440	NULL, /* convert to native */
sl@0	441	&TestReportNormalizePath,
sl@0	442	NULL, /* path type */
sl@0	443	NULL, /* separator */
sl@0	444	&TestReportStat,
sl@0	445	&TestReportAccess,
sl@0	446	&TestReportOpenFileChannel,
sl@0	447	&TestReportMatchInDirectory,
sl@0	448	&TestReportUtime,
sl@0	449	&TestReportLink,
sl@0	450	NULL /* list volumes */,
sl@0	451	&TestReportFileAttrStrings,
sl@0	452	&TestReportFileAttrsGet,
sl@0	453	&TestReportFileAttrsSet,
sl@0	454	&TestReportCreateDirectory,
sl@0	455	&TestReportRemoveDirectory,
sl@0	456	&TestReportDeleteFile,
sl@0	457	&TestReportCopyFile,
sl@0	458	&TestReportRenameFile,
sl@0	459	&TestReportCopyDirectory,
sl@0	460	&TestReportLstat,
sl@0	461	&TestReportLoadFile,
sl@0	462	NULL /* cwd */,
sl@0	463	&TestReportChdir
sl@0	464	};
sl@0	465
sl@0	466	static Tcl_Filesystem simpleFilesystem = {
sl@0	467	"simple",
sl@0	468	sizeof(Tcl_Filesystem),
sl@0	469	TCL_FILESYSTEM_VERSION_1,
sl@0	470	&SimplePathInFilesystem,
sl@0	471	NULL,
sl@0	472	NULL,
sl@0	473	/* No internal to normalized, since we don't create any
sl@0	474	* pure 'internal' Tcl_Obj path representations */
sl@0	475	NULL,
sl@0	476	/* No create native rep function, since we don't use it
sl@0	477	* or 'Tcl_FSNewNativePath' */
sl@0	478	NULL,
sl@0	479	/* Normalize path isn't needed - we assume paths only have
sl@0	480	* one representation */
sl@0	481	NULL,
sl@0	482	NULL,
sl@0	483	NULL,
sl@0	484	&SimpleStat,
sl@0	485	&SimpleAccess,
sl@0	486	&SimpleOpenFileChannel,
sl@0	487	NULL,
sl@0	488	NULL,
sl@0	489	/* We choose not to support symbolic links inside our vfs's */
sl@0	490	NULL,
sl@0	491	&SimpleListVolumes,
sl@0	492	NULL,
sl@0	493	NULL,
sl@0	494	NULL,
sl@0	495	NULL,
sl@0	496	NULL,
sl@0	497	NULL,
sl@0	498	/* No copy file - fallback will occur at Tcl level */
sl@0	499	NULL,
sl@0	500	/* No rename file - fallback will occur at Tcl level */
sl@0	501	NULL,
sl@0	502	/* No copy directory - fallback will occur at Tcl level */
sl@0	503	NULL,
sl@0	504	/* Use stat for lstat */
sl@0	505	NULL,
sl@0	506	/* No load - fallback on core implementation */
sl@0	507	NULL,
sl@0	508	/* We don't need a getcwd or chdir - fallback on Tcl's versions */
sl@0	509	NULL,
sl@0	510	NULL
sl@0	511	};
sl@0	512
sl@0	513
sl@0	514	/*
sl@0	515	* External (platform specific) initialization routine, these declarations
sl@0	516	* explicitly don't use EXTERN since this code does not get compiled
sl@0	517	* into the library:
sl@0	518	*/
sl@0	519
sl@0	520	extern int TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp));
sl@0	521	extern int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp));
sl@0	522
sl@0	523	/*
sl@0	524	*----------------------------------------------------------------------
sl@0	525	*
sl@0	526	* Tcltest_Init --
sl@0	527	*
sl@0	528	* This procedure performs application-specific initialization.
sl@0	529	* Most applications, especially those that incorporate additional
sl@0	530	* packages, will have their own version of this procedure.
sl@0	531	*
sl@0	532	* Results:
sl@0	533	* Returns a standard Tcl completion code, and leaves an error
sl@0	534	* message in the interp's result if an error occurs.
sl@0	535	*
sl@0	536	* Side effects:
sl@0	537	* Depends on the startup script.
sl@0	538	*
sl@0	539	*----------------------------------------------------------------------
sl@0	540	*/
sl@0	541
sl@0	542	int
sl@0	543	Tcltest_Init(interp)
sl@0	544	Tcl_Interp interp; / Interpreter for application. */
sl@0	545	{
sl@0	546	Tcl_ValueType t3ArgTypes[2];
sl@0	547
sl@0	548	Tcl_Obj *listPtr;
sl@0	549	Tcl_Obj **objv;
sl@0	550	int objc, index;
sl@0	551	static CONST char *specialOptions[] = {
sl@0	552	"-appinitprocerror", "-appinitprocdeleteinterp",
sl@0	553	"-appinitprocclosestderr", "-appinitprocsetrcfile", (char *) NULL
sl@0	554	};
sl@0	555
sl@0	556	#ifndef TCL_TIP268
sl@0	557	if (Tcl_PkgProvide(interp, "Tcltest", TCL_VERSION) == TCL_ERROR) {
sl@0	558	#else
sl@0	559	/* TIP #268: Full patchlevel instead of just major.minor */
sl@0	560	if (Tcl_PkgProvide(interp, "Tcltest", TCL_PATCH_LEVEL) == TCL_ERROR) {
sl@0	561	#endif
sl@0	562	return TCL_ERROR;
sl@0	563	}
sl@0	564
sl@0	565	/*
sl@0	566	* Create additional commands and math functions for testing Tcl.
sl@0	567	*/
sl@0	568
sl@0	569	Tcl_CreateCommand(interp, "gettimes", GetTimesCmd, (ClientData) 0,
sl@0	570	(Tcl_CmdDeleteProc *) NULL);
sl@0	571	Tcl_CreateCommand(interp, "noop", NoopCmd, (ClientData) 0,
sl@0	572	(Tcl_CmdDeleteProc *) NULL);
sl@0	573	Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, (ClientData) 0,
sl@0	574	(Tcl_CmdDeleteProc *) NULL);
sl@0	575	Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd,
sl@0	576	(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0	577	Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd,
sl@0	578	(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0	579	Tcl_CreateObjCommand(interp, "testsimplefilesystem", TestSimpleFilesystemObjCmd,
sl@0	580	(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0	581	Tcl_CreateObjCommand(interp, "testgetindexfromobjstruct",
sl@0	582	TestGetIndexFromObjStructObjCmd, (ClientData) 0,
sl@0	583	(Tcl_CmdDeleteProc *) NULL);
sl@0	584	Tcl_CreateCommand(interp, "testaccessproc", TestaccessprocCmd, (ClientData) 0,
sl@0	585	(Tcl_CmdDeleteProc *) NULL);
sl@0	586	Tcl_CreateCommand(interp, "testasync", TestasyncCmd, (ClientData) 0,
sl@0	587	(Tcl_CmdDeleteProc *) NULL);
sl@0	588	Tcl_CreateCommand(interp, "testchannel", TestChannelCmd,
sl@0	589	(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0	590	Tcl_CreateCommand(interp, "testchannelevent", TestChannelEventCmd,
sl@0	591	(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0	592	Tcl_CreateCommand(interp, "testcmdtoken", TestcmdtokenCmd, (ClientData) 0,
sl@0	593	(Tcl_CmdDeleteProc *) NULL);
sl@0	594	Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, (ClientData) 0,
sl@0	595	(Tcl_CmdDeleteProc *) NULL);
sl@0	596	Tcl_CreateCommand(interp, "testcmdtrace", TestcmdtraceCmd,
sl@0	597	(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0	598	Tcl_CreateCommand(interp, "testcreatecommand", TestcreatecommandCmd,
sl@0	599	(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0	600	Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, (ClientData) 0,
sl@0	601	(Tcl_CmdDeleteProc *) NULL);
sl@0	602	Tcl_CreateCommand(interp, "testdel", TestdelCmd, (ClientData) 0,
sl@0	603	(Tcl_CmdDeleteProc *) NULL);
sl@0	604	Tcl_CreateCommand(interp, "testdelassocdata", TestdelassocdataCmd,
sl@0	605	(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0	606	Tcl_DStringInit(&dstring);
sl@0	607	Tcl_CreateCommand(interp, "testdstring", TestdstringCmd, (ClientData) 0,
sl@0	608	(Tcl_CmdDeleteProc *) NULL);
sl@0	609	Tcl_CreateObjCommand(interp, "testencoding", TestencodingObjCmd, (ClientData) 0,
sl@0	610	(Tcl_CmdDeleteProc *) NULL);
sl@0	611	Tcl_CreateObjCommand(interp, "testevalex", TestevalexObjCmd,
sl@0	612	(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0	613	Tcl_CreateObjCommand(interp, "testevalobjv", TestevalobjvObjCmd,
sl@0	614	(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0	615	Tcl_CreateObjCommand( interp, "testevent", TesteventObjCmd,
sl@0	616	(ClientData) 0, (Tcl_CmdDeleteProc*) NULL );
sl@0	617	Tcl_CreateCommand(interp, "testexithandler", TestexithandlerCmd,
sl@0	618	(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0	619	Tcl_CreateCommand(interp, "testexprlong", TestexprlongCmd,
sl@0	620	(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0	621	Tcl_CreateObjCommand(interp, "testexprparser", TestexprparserObjCmd,
sl@0	622	(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0	623	Tcl_CreateCommand(interp, "testexprstring", TestexprstringCmd,
sl@0	624	(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0	625	Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, (ClientData) 0,
sl@0	626	(Tcl_CmdDeleteProc *) NULL);
sl@0	627	Tcl_CreateObjCommand(interp, "testfilelink", TestfilelinkCmd,
sl@0	628	(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0	629	Tcl_CreateObjCommand(interp, "testfile", TestfileCmd,
sl@0	630	(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0	631	Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd,
sl@0	632	(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0	633	Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd,
sl@0	634	(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0	635	Tcl_CreateObjCommand(interp, "testgetvarfullname",
sl@0	636	TestgetvarfullnameCmd, (ClientData) 0,
sl@0	637	(Tcl_CmdDeleteProc *) NULL);
sl@0	638	Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd,
sl@0	639	(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0	640	Tcl_CreateCommand(interp, "testlink", TestlinkCmd, (ClientData) 0,
sl@0	641	(Tcl_CmdDeleteProc *) NULL);
sl@0	642	Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, (ClientData) 0,
sl@0	643	(Tcl_CmdDeleteProc *) NULL);
sl@0	644	Tcl_CreateCommand(interp, "testopenfilechannelproc",
sl@0	645	TestopenfilechannelprocCmd, (ClientData) 0,
sl@0	646	(Tcl_CmdDeleteProc *) NULL);
sl@0	647	Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, (ClientData) 0,
sl@0	648	(Tcl_CmdDeleteProc *) NULL);
sl@0	649	Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd,
sl@0	650	(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0	651	Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd,
sl@0	652	(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0	653	Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameObjCmd,
sl@0	654	(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0	655	Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd,
sl@0	656	(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0	657	Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd,
sl@0	658	(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0	659	Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd,
sl@0	660	(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0	661	Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd,
sl@0	662	(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0	663	Tcl_CreateCommand(interp, "testseterr", TestsetCmd,
sl@0	664	(ClientData) TCL_LEAVE_ERR_MSG, (Tcl_CmdDeleteProc *) NULL);
sl@0	665	Tcl_CreateCommand(interp, "testseterrorcode", TestseterrorcodeCmd,
sl@0	666	(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0	667	Tcl_CreateObjCommand(interp, "testsetobjerrorcode",
sl@0	668	TestsetobjerrorcodeCmd, (ClientData) 0,
sl@0	669	(Tcl_CmdDeleteProc *) NULL);
sl@0	670	Tcl_CreateObjCommand(interp, "testnumutfchars",
sl@0	671	TestNumUtfCharsCmd, (ClientData) 0,
sl@0	672	(Tcl_CmdDeleteProc *) NULL);
sl@0	673	Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd,
sl@0	674	(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0	675	Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd,
sl@0	676	(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0	677	Tcl_CreateCommand(interp, "testtranslatefilename",
sl@0	678	TesttranslatefilenameCmd, (ClientData) 0,
sl@0	679	(Tcl_CmdDeleteProc *) NULL);
sl@0	680	Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, (ClientData) 0,
sl@0	681	(Tcl_CmdDeleteProc *) NULL);
sl@0	682	Tcl_CreateMathFunc(interp, "T1", 0, (Tcl_ValueType *) NULL, TestMathFunc,
sl@0	683	(ClientData) 123);
sl@0	684	Tcl_CreateMathFunc(interp, "T2", 0, (Tcl_ValueType *) NULL, TestMathFunc,
sl@0	685	(ClientData) 345);
sl@0	686	Tcl_CreateCommand(interp, "teststatproc", TeststatprocCmd, (ClientData) 0,
sl@0	687	(Tcl_CmdDeleteProc *) NULL);
sl@0	688	Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, (ClientData) 0,
sl@0	689	(Tcl_CmdDeleteProc *) NULL);
sl@0	690	Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd,
sl@0	691	(ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
sl@0	692	Tcl_CreateCommand(interp, "testexitmainloop", TestexitmainloopCmd,
sl@0	693	(ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
sl@0	694	t3ArgTypes[0] = TCL_EITHER;
sl@0	695	t3ArgTypes[1] = TCL_EITHER;
sl@0	696	Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2,
sl@0	697	(ClientData) 0);
sl@0	698
sl@0	699	#ifdef TCL_THREADS
sl@0	700	if (TclThread_Init(interp) != TCL_OK) {
sl@0	701	return TCL_ERROR;
sl@0	702	}
sl@0	703	#endif
sl@0	704
sl@0	705	/*
sl@0	706	* Check for special options used in ../tests/main.test
sl@0	707	*/
sl@0	708
sl@0	709	listPtr = Tcl_GetVar2Ex(interp, "argv", NULL, TCL_GLOBAL_ONLY);
sl@0	710	if (listPtr != NULL) {
sl@0	711	if (Tcl_ListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) {
sl@0	712	return TCL_ERROR;
sl@0	713	}
sl@0	714	if (objc && (Tcl_GetIndexFromObj(NULL, objv[0], specialOptions, NULL,
sl@0	715	TCL_EXACT, &index) == TCL_OK)) {
sl@0	716	switch (index) {
sl@0	717	case 0: {
sl@0	718	return TCL_ERROR;
sl@0	719	}
sl@0	720	case 1: {
sl@0	721	Tcl_DeleteInterp(interp);
sl@0	722	return TCL_ERROR;
sl@0	723	}
sl@0	724	case 2: {
sl@0	725	int mode;
sl@0	726	Tcl_UnregisterChannel(interp,
sl@0	727	Tcl_GetChannel(interp, "stderr", &mode));
sl@0	728	return TCL_ERROR;
sl@0	729	}
sl@0	730	case 3: {
sl@0	731	if (objc-1) {
sl@0	732	Tcl_SetVar2Ex(interp, "tcl_rcFileName", NULL,
sl@0	733	objv[1], TCL_GLOBAL_ONLY);
sl@0	734	}
sl@0	735	return TCL_ERROR;
sl@0	736	}
sl@0	737	}
sl@0	738	}
sl@0	739	}
sl@0	740
sl@0	741	/*
sl@0	742	* And finally add any platform specific test commands.
sl@0	743	*/
sl@0	744
sl@0	745	return TclplatformtestInit(interp);
sl@0	746	}
sl@0	747
sl@0	748	/*
sl@0	749	*----------------------------------------------------------------------
sl@0	750	*
sl@0	751	* TestasyncCmd --
sl@0	752	*
sl@0	753	* This procedure implements the "testasync" command. It is used
sl@0	754	* to test the asynchronous handler facilities of Tcl.
sl@0	755	*
sl@0	756	* Results:
sl@0	757	* A standard Tcl result.
sl@0	758	*
sl@0	759	* Side effects:
sl@0	760	* Creates, deletes, and invokes handlers.
sl@0	761	*
sl@0	762	*----------------------------------------------------------------------
sl@0	763	*/
sl@0	764
sl@0	765	/* ARGSUSED */
sl@0	766	static int
sl@0	767	TestasyncCmd(dummy, interp, argc, argv)
sl@0	768	ClientData dummy; /* Not used. */
sl@0	769	Tcl_Interp interp; / Current interpreter. */
sl@0	770	int argc; /* Number of arguments. */
sl@0	771	CONST char *argv; / Argument strings. */
sl@0	772	{
sl@0	773	TestAsyncHandler asyncPtr, prevPtr;
sl@0	774	int id, code;
sl@0	775	static int nextId = 1;
sl@0	776	char buf[TCL_INTEGER_SPACE];
sl@0	777
sl@0	778	if (argc < 2) {
sl@0	779	wrongNumArgs:
sl@0	780	Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
sl@0	781	return TCL_ERROR;
sl@0	782	}
sl@0	783	if (strcmp(argv[1], "create") == 0) {
sl@0	784	if (argc != 3) {
sl@0	785	goto wrongNumArgs;
sl@0	786	}
sl@0	787	asyncPtr = (TestAsyncHandler *) ckalloc(sizeof(TestAsyncHandler));
sl@0	788	asyncPtr->id = nextId;
sl@0	789	nextId++;
sl@0	790	asyncPtr->handler = Tcl_AsyncCreate(AsyncHandlerProc,
sl@0	791	(ClientData) asyncPtr);
sl@0	792	asyncPtr->command = (char *) ckalloc((unsigned) (strlen(argv[2]) + 1));
sl@0	793	strcpy(asyncPtr->command, argv[2]);
sl@0	794	asyncPtr->nextPtr = firstHandler;
sl@0	795	firstHandler = asyncPtr;
sl@0	796	TclFormatInt(buf, asyncPtr->id);
sl@0	797	Tcl_SetResult(interp, buf, TCL_VOLATILE);
sl@0	798	} else if (strcmp(argv[1], "delete") == 0) {
sl@0	799	if (argc == 2) {
sl@0	800	while (firstHandler != NULL) {
sl@0	801	asyncPtr = firstHandler;
sl@0	802	firstHandler = asyncPtr->nextPtr;
sl@0	803	Tcl_AsyncDelete(asyncPtr->handler);
sl@0	804	ckfree(asyncPtr->command);
sl@0	805	ckfree((char *) asyncPtr);
sl@0	806	}
sl@0	807	return TCL_OK;
sl@0	808	}
sl@0	809	if (argc != 3) {
sl@0	810	goto wrongNumArgs;
sl@0	811	}
sl@0	812	if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) {
sl@0	813	return TCL_ERROR;
sl@0	814	}
sl@0	815	for (prevPtr = NULL, asyncPtr = firstHandler; asyncPtr != NULL;
sl@0	816	prevPtr = asyncPtr, asyncPtr = asyncPtr->nextPtr) {
sl@0	817	if (asyncPtr->id != id) {
sl@0	818	continue;
sl@0	819	}
sl@0	820	if (prevPtr == NULL) {
sl@0	821	firstHandler = asyncPtr->nextPtr;
sl@0	822	} else {
sl@0	823	prevPtr->nextPtr = asyncPtr->nextPtr;
sl@0	824	}
sl@0	825	Tcl_AsyncDelete(asyncPtr->handler);
sl@0	826	ckfree(asyncPtr->command);
sl@0	827	ckfree((char *) asyncPtr);
sl@0	828	break;
sl@0	829	}
sl@0	830	} else if (strcmp(argv[1], "mark") == 0) {
sl@0	831	if (argc != 5) {
sl@0	832	goto wrongNumArgs;
sl@0	833	}
sl@0	834	if ((Tcl_GetInt(interp, argv[2], &id) != TCL_OK)
sl@0	835	\|\| (Tcl_GetInt(interp, argv[4], &code) != TCL_OK)) {
sl@0	836	return TCL_ERROR;
sl@0	837	}
sl@0	838	for (asyncPtr = firstHandler; asyncPtr != NULL;
sl@0	839	asyncPtr = asyncPtr->nextPtr) {
sl@0	840	if (asyncPtr->id == id) {
sl@0	841	Tcl_AsyncMark(asyncPtr->handler);
sl@0	842	break;
sl@0	843	}
sl@0	844	}
sl@0	845	Tcl_SetResult(interp, (char *)argv[3], TCL_VOLATILE);
sl@0	846	return code;
sl@0	847	} else {
sl@0	848	Tcl_AppendResult(interp, "bad option \"", argv[1],
sl@0	849	"\": must be create, delete, int, or mark",
sl@0	850	(char *) NULL);
sl@0	851	return TCL_ERROR;
sl@0	852	}
sl@0	853	return TCL_OK;
sl@0	854	}
sl@0	855
sl@0	856	static int
sl@0	857	AsyncHandlerProc(clientData, interp, code)
sl@0	858	ClientData clientData; /* Pointer to TestAsyncHandler structure. */
sl@0	859	Tcl_Interp interp; / Interpreter in which command was
sl@0	860	* executed, or NULL. */
sl@0	861	int code; /* Current return code from command. */
sl@0	862	{
sl@0	863	TestAsyncHandler asyncPtr = (TestAsyncHandler ) clientData;
sl@0	864	CONST char listArgv[4], cmd;
sl@0	865	char string[TCL_INTEGER_SPACE];
sl@0	866
sl@0	867	TclFormatInt(string, code);
sl@0	868	listArgv[0] = asyncPtr->command;
sl@0	869	listArgv[1] = Tcl_GetString(Tcl_GetObjResult(interp));
sl@0	870	listArgv[2] = string;
sl@0	871	listArgv[3] = NULL;
sl@0	872	cmd = Tcl_Merge(3, listArgv);
sl@0	873	if (interp != NULL) {
sl@0	874	code = Tcl_Eval(interp, cmd);
sl@0	875	} else {
sl@0	876	/*
sl@0	877	* this should not happen, but by definition of how async
sl@0	878	* handlers are invoked, it's possible. Better error
sl@0	879	* checking is needed here.
sl@0	880	*/
sl@0	881	}
sl@0	882	ckfree((char *)cmd);
sl@0	883	return code;
sl@0	884	}
sl@0	885
sl@0	886	/*
sl@0	887	*----------------------------------------------------------------------
sl@0	888	*
sl@0	889	* TestcmdinfoCmd --
sl@0	890	*
sl@0	891	* This procedure implements the "testcmdinfo" command. It is used
sl@0	892	* to test Tcl_GetCommandInfo, Tcl_SetCommandInfo, and command creation
sl@0	893	* and deletion.
sl@0	894	*
sl@0	895	* Results:
sl@0	896	* A standard Tcl result.
sl@0	897	*
sl@0	898	* Side effects:
sl@0	899	* Creates and deletes various commands and modifies their data.
sl@0	900	*
sl@0	901	*----------------------------------------------------------------------
sl@0	902	*/
sl@0	903
sl@0	904	/* ARGSUSED */
sl@0	905	static int
sl@0	906	TestcmdinfoCmd(dummy, interp, argc, argv)
sl@0	907	ClientData dummy; /* Not used. */
sl@0	908	Tcl_Interp interp; / Current interpreter. */
sl@0	909	int argc; /* Number of arguments. */
sl@0	910	CONST char *argv; / Argument strings. */
sl@0	911	{
sl@0	912	Tcl_CmdInfo info;
sl@0	913
sl@0	914	if (argc != 3) {
sl@0	915	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
sl@0	916	" option cmdName\"", (char *) NULL);
sl@0	917	return TCL_ERROR;
sl@0	918	}
sl@0	919	if (strcmp(argv[1], "create") == 0) {
sl@0	920	Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original",
sl@0	921	CmdDelProc1);
sl@0	922	} else if (strcmp(argv[1], "delete") == 0) {
sl@0	923	Tcl_DStringInit(&delString);
sl@0	924	Tcl_DeleteCommand(interp, argv[2]);
sl@0	925	Tcl_DStringResult(interp, &delString);
sl@0	926	} else if (strcmp(argv[1], "get") == 0) {
sl@0	927	if (Tcl_GetCommandInfo(interp, argv[2], &info) ==0) {
sl@0	928	Tcl_SetResult(interp, "??", TCL_STATIC);
sl@0	929	return TCL_OK;
sl@0	930	}
sl@0	931	if (info.proc == CmdProc1) {
sl@0	932	Tcl_AppendResult(interp, "CmdProc1", " ",
sl@0	933	(char ) info.clientData, (char ) NULL);
sl@0	934	} else if (info.proc == CmdProc2) {
sl@0	935	Tcl_AppendResult(interp, "CmdProc2", " ",
sl@0	936	(char ) info.clientData, (char ) NULL);
sl@0	937	} else {
sl@0	938	Tcl_AppendResult(interp, "unknown", (char *) NULL);
sl@0	939	}
sl@0	940	if (info.deleteProc == CmdDelProc1) {
sl@0	941	Tcl_AppendResult(interp, " CmdDelProc1", " ",
sl@0	942	(char ) info.deleteData, (char ) NULL);
sl@0	943	} else if (info.deleteProc == CmdDelProc2) {
sl@0	944	Tcl_AppendResult(interp, " CmdDelProc2", " ",
sl@0	945	(char ) info.deleteData, (char ) NULL);
sl@0	946	} else {
sl@0	947	Tcl_AppendResult(interp, " unknown", (char *) NULL);
sl@0	948	}
sl@0	949	Tcl_AppendResult(interp, " ", info.namespacePtr->fullName,
sl@0	950	(char *) NULL);
sl@0	951	if (info.isNativeObjectProc) {
sl@0	952	Tcl_AppendResult(interp, " nativeObjectProc", (char *) NULL);
sl@0	953	} else {
sl@0	954	Tcl_AppendResult(interp, " stringProc", (char *) NULL);
sl@0	955	}
sl@0	956	} else if (strcmp(argv[1], "modify") == 0) {
sl@0	957	info.proc = CmdProc2;
sl@0	958	info.clientData = (ClientData) "new_command_data";
sl@0	959	info.objProc = NULL;
sl@0	960	info.objClientData = (ClientData) NULL;
sl@0	961	info.deleteProc = CmdDelProc2;
sl@0	962	info.deleteData = (ClientData) "new_delete_data";
sl@0	963	if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) {
sl@0	964	Tcl_SetResult(interp, "0", TCL_STATIC);
sl@0	965	} else {
sl@0	966	Tcl_SetResult(interp, "1", TCL_STATIC);
sl@0	967	}
sl@0	968	} else {
sl@0	969	Tcl_AppendResult(interp, "bad option \"", argv[1],
sl@0	970	"\": must be create, delete, get, or modify",
sl@0	971	(char *) NULL);
sl@0	972	return TCL_ERROR;
sl@0	973	}
sl@0	974	return TCL_OK;
sl@0	975	}
sl@0	976
sl@0	977	/ARGSUSED/
sl@0	978	static int
sl@0	979	CmdProc1(clientData, interp, argc, argv)
sl@0	980	ClientData clientData; /* String to return. */
sl@0	981	Tcl_Interp interp; / Current interpreter. */
sl@0	982	int argc; /* Number of arguments. */
sl@0	983	CONST char *argv; / Argument strings. */
sl@0	984	{
sl@0	985	Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData,
sl@0	986	(char *) NULL);
sl@0	987	return TCL_OK;
sl@0	988	}
sl@0	989
sl@0	990	/ARGSUSED/
sl@0	991	static int
sl@0	992	CmdProc2(clientData, interp, argc, argv)
sl@0	993	ClientData clientData; /* String to return. */
sl@0	994	Tcl_Interp interp; / Current interpreter. */
sl@0	995	int argc; /* Number of arguments. */
sl@0	996	CONST char *argv; / Argument strings. */
sl@0	997	{
sl@0	998	Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData,
sl@0	999	(char *) NULL);
sl@0	1000	return TCL_OK;
sl@0	1001	}
sl@0	1002
sl@0	1003	static void
sl@0	1004	CmdDelProc1(clientData)
sl@0	1005	ClientData clientData; /* String to save. */
sl@0	1006	{
sl@0	1007	Tcl_DStringInit(&delString);
sl@0	1008	Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1);
sl@0	1009	Tcl_DStringAppend(&delString, (char *) clientData, -1);
sl@0	1010	}
sl@0	1011
sl@0	1012	static void
sl@0	1013	CmdDelProc2(clientData)
sl@0	1014	ClientData clientData; /* String to save. */
sl@0	1015	{
sl@0	1016	Tcl_DStringInit(&delString);
sl@0	1017	Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1);
sl@0	1018	Tcl_DStringAppend(&delString, (char *) clientData, -1);
sl@0	1019	}
sl@0	1020
sl@0	1021	/*
sl@0	1022	*----------------------------------------------------------------------
sl@0	1023	*
sl@0	1024	* TestcmdtokenCmd --
sl@0	1025	*
sl@0	1026	* This procedure implements the "testcmdtoken" command. It is used
sl@0	1027	* to test Tcl_Command tokens and procedures such as
sl@0	1028	* Tcl_GetCommandFullName.
sl@0	1029	*
sl@0	1030	* Results:
sl@0	1031	* A standard Tcl result.
sl@0	1032	*
sl@0	1033	* Side effects:
sl@0	1034	* Creates and deletes various commands and modifies their data.
sl@0	1035	*
sl@0	1036	*----------------------------------------------------------------------
sl@0	1037	*/
sl@0	1038
sl@0	1039	/* ARGSUSED */
sl@0	1040	static int
sl@0	1041	TestcmdtokenCmd(dummy, interp, argc, argv)
sl@0	1042	ClientData dummy; /* Not used. */
sl@0	1043	Tcl_Interp interp; / Current interpreter. */
sl@0	1044	int argc; /* Number of arguments. */
sl@0	1045	CONST char *argv; / Argument strings. */
sl@0	1046	{
sl@0	1047	Tcl_Command token;
sl@0	1048	int *l;
sl@0	1049	char buf[30];
sl@0	1050
sl@0	1051	if (argc != 3) {
sl@0	1052	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
sl@0	1053	" option arg\"", (char *) NULL);
sl@0	1054	return TCL_ERROR;
sl@0	1055	}
sl@0	1056	if (strcmp(argv[1], "create") == 0) {
sl@0	1057	token = Tcl_CreateCommand(interp, argv[2], CmdProc1,
sl@0	1058	(ClientData) "original", (Tcl_CmdDeleteProc *) NULL);
sl@0	1059	sprintf(buf, "%p", (VOID *)token);
sl@0	1060	Tcl_SetResult(interp, buf, TCL_VOLATILE);
sl@0	1061	} else if (strcmp(argv[1], "name") == 0) {
sl@0	1062	Tcl_Obj *objPtr;
sl@0	1063
sl@0	1064	if (sscanf(argv[2], "%p", &l) != 1) {
sl@0	1065	Tcl_AppendResult(interp, "bad command token \"", argv[2],
sl@0	1066	"\"", (char *) NULL);
sl@0	1067	return TCL_ERROR;
sl@0	1068	}
sl@0	1069
sl@0	1070	objPtr = Tcl_NewObj();
sl@0	1071	Tcl_GetCommandFullName(interp, (Tcl_Command) l, objPtr);
sl@0	1072
sl@0	1073	Tcl_AppendElement(interp,
sl@0	1074	Tcl_GetCommandName(interp, (Tcl_Command) l));
sl@0	1075	Tcl_AppendElement(interp, Tcl_GetString(objPtr));
sl@0	1076	Tcl_DecrRefCount(objPtr);
sl@0	1077	} else {
sl@0	1078	Tcl_AppendResult(interp, "bad option \"", argv[1],
sl@0	1079	"\": must be create or name", (char *) NULL);
sl@0	1080	return TCL_ERROR;
sl@0	1081	}
sl@0	1082	return TCL_OK;
sl@0	1083	}
sl@0	1084
sl@0	1085	/*
sl@0	1086	*----------------------------------------------------------------------
sl@0	1087	*
sl@0	1088	* TestcmdtraceCmd --
sl@0	1089	*
sl@0	1090	* This procedure implements the "testcmdtrace" command. It is used
sl@0	1091	* to test Tcl_CreateTrace and Tcl_DeleteTrace.
sl@0	1092	*
sl@0	1093	* Results:
sl@0	1094	* A standard Tcl result.
sl@0	1095	*
sl@0	1096	* Side effects:
sl@0	1097	* Creates and deletes a command trace, and tests the invocation of
sl@0	1098	* a procedure by the command trace.
sl@0	1099	*
sl@0	1100	*----------------------------------------------------------------------
sl@0	1101	*/
sl@0	1102
sl@0	1103	/* ARGSUSED */
sl@0	1104	static int
sl@0	1105	TestcmdtraceCmd(dummy, interp, argc, argv)
sl@0	1106	ClientData dummy; /* Not used. */
sl@0	1107	Tcl_Interp interp; / Current interpreter. */
sl@0	1108	int argc; /* Number of arguments. */
sl@0	1109	CONST char *argv; / Argument strings. */
sl@0	1110	{
sl@0	1111	Tcl_DString buffer;
sl@0	1112	int result;
sl@0	1113
sl@0	1114	if (argc != 3) {
sl@0	1115	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
sl@0	1116	" option script\"", (char *) NULL);
sl@0	1117	return TCL_ERROR;
sl@0	1118	}
sl@0	1119
sl@0	1120	if (strcmp(argv[1], "tracetest") == 0) {
sl@0	1121	Tcl_DStringInit(&buffer);
sl@0	1122	cmdTrace = Tcl_CreateTrace(interp, 50000,
sl@0	1123	(Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer);
sl@0	1124	result = Tcl_Eval(interp, argv[2]);
sl@0	1125	if (result == TCL_OK) {
sl@0	1126	Tcl_ResetResult(interp);
sl@0	1127	Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
sl@0	1128	}
sl@0	1129	Tcl_DeleteTrace(interp, cmdTrace);
sl@0	1130	Tcl_DStringFree(&buffer);
sl@0	1131	} else if (strcmp(argv[1], "deletetest") == 0) {
sl@0	1132	/*
sl@0	1133	* Create a command trace then eval a script to check whether it is
sl@0	1134	* called. Note that this trace procedure removes itself as a
sl@0	1135	* further check of the robustness of the trace proc calling code in
sl@0	1136	* TclExecuteByteCode.
sl@0	1137	*/
sl@0	1138
sl@0	1139	cmdTrace = Tcl_CreateTrace(interp, 50000,
sl@0	1140	(Tcl_CmdTraceProc *) CmdTraceDeleteProc, (ClientData) NULL);
sl@0	1141	Tcl_Eval(interp, argv[2]);
sl@0	1142	} else if (strcmp(argv[1], "leveltest") == 0) {
sl@0	1143	Interp iPtr = (Interp ) interp;
sl@0	1144	Tcl_DStringInit(&buffer);
sl@0	1145	cmdTrace = Tcl_CreateTrace(interp, iPtr->numLevels + 4,
sl@0	1146	(Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer);
sl@0	1147	result = Tcl_Eval(interp, argv[2]);
sl@0	1148	if (result == TCL_OK) {
sl@0	1149	Tcl_ResetResult(interp);
sl@0	1150	Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
sl@0	1151	}
sl@0	1152	Tcl_DeleteTrace(interp, cmdTrace);
sl@0	1153	Tcl_DStringFree(&buffer);
sl@0	1154	} else if ( strcmp(argv[1], "resulttest" ) == 0 ) {
sl@0	1155	/* Create an object-based trace, then eval a script. This is used
sl@0	1156	* to test return codes other than TCL_OK from the trace engine.
sl@0	1157	*/
sl@0	1158	static int deleteCalled;
sl@0	1159	deleteCalled = 0;
sl@0	1160	cmdTrace = Tcl_CreateObjTrace( interp, 50000,
sl@0	1161	TCL_ALLOW_INLINE_COMPILATION,
sl@0	1162	ObjTraceProc,
sl@0	1163	(ClientData) &deleteCalled,
sl@0	1164	ObjTraceDeleteProc );
sl@0	1165	result = Tcl_Eval( interp, argv[ 2 ] );
sl@0	1166	Tcl_DeleteTrace( interp, cmdTrace );
sl@0	1167	if ( !deleteCalled ) {
sl@0	1168	Tcl_SetResult( interp, "Delete wasn't called", TCL_STATIC );
sl@0	1169	return TCL_ERROR;
sl@0	1170	} else {
sl@0	1171	return result;
sl@0	1172	}
sl@0	1173
sl@0	1174	} else {
sl@0	1175	Tcl_AppendResult(interp, "bad option \"", argv[1],
sl@0	1176	"\": must be tracetest, deletetest or resulttest",
sl@0	1177	(char *) NULL);
sl@0	1178	return TCL_ERROR;
sl@0	1179	}
sl@0	1180	return TCL_OK;
sl@0	1181	}
sl@0	1182
sl@0	1183	static void
sl@0	1184	CmdTraceProc(clientData, interp, level, command, cmdProc, cmdClientData,
sl@0	1185	argc, argv)
sl@0	1186	ClientData clientData; /* Pointer to buffer in which the
sl@0	1187	* command and arguments are appended.
sl@0	1188	* Accumulates test result. */
sl@0	1189	Tcl_Interp interp; / Current interpreter. */
sl@0	1190	int level; /* Current trace level. */
sl@0	1191	char command; / The command being traced (after
sl@0	1192	* substitutions). */
sl@0	1193	Tcl_CmdProc cmdProc; / Points to command's command procedure. */
sl@0	1194	ClientData cmdClientData; /* Client data associated with command
sl@0	1195	* procedure. */
sl@0	1196	int argc; /* Number of arguments. */
sl@0	1197	char *argv; / Argument strings. */
sl@0	1198	{
sl@0	1199	Tcl_DString bufPtr = (Tcl_DString ) clientData;
sl@0	1200	int i;
sl@0	1201
sl@0	1202	Tcl_DStringAppendElement(bufPtr, command);
sl@0	1203
sl@0	1204	Tcl_DStringStartSublist(bufPtr);
sl@0	1205	for (i = 0; i < argc; i++) {
sl@0	1206	Tcl_DStringAppendElement(bufPtr, argv[i]);
sl@0	1207	}
sl@0	1208	Tcl_DStringEndSublist(bufPtr);
sl@0	1209	}
sl@0	1210
sl@0	1211	static void
sl@0	1212	CmdTraceDeleteProc(clientData, interp, level, command, cmdProc,
sl@0	1213	cmdClientData, argc, argv)
sl@0	1214	ClientData clientData; /* Unused. */
sl@0	1215	Tcl_Interp interp; / Current interpreter. */
sl@0	1216	int level; /* Current trace level. */
sl@0	1217	char command; / The command being traced (after
sl@0	1218	* substitutions). */
sl@0	1219	Tcl_CmdProc cmdProc; / Points to command's command procedure. */
sl@0	1220	ClientData cmdClientData; /* Client data associated with command
sl@0	1221	* procedure. */
sl@0	1222	int argc; /* Number of arguments. */
sl@0	1223	char *argv; / Argument strings. */
sl@0	1224	{
sl@0	1225	/*
sl@0	1226	* Remove ourselves to test whether calling Tcl_DeleteTrace within
sl@0	1227	* a trace callback causes the for loop in TclExecuteByteCode that
sl@0	1228	* calls traces to reference freed memory.
sl@0	1229	*/
sl@0	1230
sl@0	1231	Tcl_DeleteTrace(interp, cmdTrace);
sl@0	1232	}
sl@0	1233
sl@0	1234	static int
sl@0	1235	ObjTraceProc( clientData, interp, level, command, token, objc, objv )
sl@0	1236	ClientData clientData; /* unused */
sl@0	1237	Tcl_Interp* interp; /* Tcl interpreter */
sl@0	1238	int level; /* Execution level */
sl@0	1239	CONST char* command; /* Command being executed */
sl@0	1240	Tcl_Command token; /* Command information */
sl@0	1241	int objc; /* Parameter count */
sl@0	1242	Tcl_Obj CONST objv[]; / Parameter list */
sl@0	1243	{
sl@0	1244	CONST char* word = Tcl_GetString( objv[ 0 ] );
sl@0	1245	if ( !strcmp( word, "Error" ) ) {
sl@0	1246	Tcl_SetObjResult( interp, Tcl_NewStringObj( command, -1 ) );
sl@0	1247	return TCL_ERROR;
sl@0	1248	} else if ( !strcmp( word, "Break" ) ) {
sl@0	1249	return TCL_BREAK;
sl@0	1250	} else if ( !strcmp( word, "Continue" ) ) {
sl@0	1251	return TCL_CONTINUE;
sl@0	1252	} else if ( !strcmp( word, "Return" ) ) {
sl@0	1253	return TCL_RETURN;
sl@0	1254	} else if ( !strcmp( word, "OtherStatus" ) ) {
sl@0	1255	return 6;
sl@0	1256	} else {
sl@0	1257	return TCL_OK;
sl@0	1258	}
sl@0	1259	}
sl@0	1260
sl@0	1261	static void
sl@0	1262	ObjTraceDeleteProc( clientData )
sl@0	1263	ClientData clientData;
sl@0	1264	{
sl@0	1265	int * intPtr = (int *) clientData;
sl@0	1266	intPtr = 1; / Record that the trace was deleted */
sl@0	1267	}
sl@0	1268
sl@0	1269	/*
sl@0	1270	*----------------------------------------------------------------------
sl@0	1271	*
sl@0	1272	* TestcreatecommandCmd --
sl@0	1273	*
sl@0	1274	* This procedure implements the "testcreatecommand" command. It is
sl@0	1275	* used to test that the Tcl_CreateCommand creates a new command in
sl@0	1276	* the namespace specified as part of its name, if any. It also
sl@0	1277	* checks that the namespace code ignore single ":"s in the middle
sl@0	1278	* or end of a command name.
sl@0	1279	*
sl@0	1280	* Results:
sl@0	1281	* A standard Tcl result.
sl@0	1282	*
sl@0	1283	* Side effects:
sl@0	1284	* Creates and deletes two commands ("test_ns_basic::createdcommand"
sl@0	1285	* and "value:at:").
sl@0	1286	*
sl@0	1287	*----------------------------------------------------------------------
sl@0	1288	*/
sl@0	1289
sl@0	1290	static int
sl@0	1291	TestcreatecommandCmd(dummy, interp, argc, argv)
sl@0	1292	ClientData dummy; /* Not used. */
sl@0	1293	Tcl_Interp interp; / Current interpreter. */
sl@0	1294	int argc; /* Number of arguments. */
sl@0	1295	CONST char *argv; / Argument strings. */
sl@0	1296	{
sl@0	1297	if (argc != 2) {
sl@0	1298	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
sl@0	1299	" option\"", (char *) NULL);
sl@0	1300	return TCL_ERROR;
sl@0	1301	}
sl@0	1302	if (strcmp(argv[1], "create") == 0) {
sl@0	1303	Tcl_CreateCommand(interp, "test_ns_basic::createdcommand",
sl@0	1304	CreatedCommandProc, (ClientData) NULL,
sl@0	1305	(Tcl_CmdDeleteProc *) NULL);
sl@0	1306	} else if (strcmp(argv[1], "delete") == 0) {
sl@0	1307	Tcl_DeleteCommand(interp, "test_ns_basic::createdcommand");
sl@0	1308	} else if (strcmp(argv[1], "create2") == 0) {
sl@0	1309	Tcl_CreateCommand(interp, "value:at:",
sl@0	1310	CreatedCommandProc2, (ClientData) NULL,
sl@0	1311	(Tcl_CmdDeleteProc *) NULL);
sl@0	1312	} else if (strcmp(argv[1], "delete2") == 0) {
sl@0	1313	Tcl_DeleteCommand(interp, "value:at:");
sl@0	1314	} else {
sl@0	1315	Tcl_AppendResult(interp, "bad option \"", argv[1],
sl@0	1316	"\": must be create, delete, create2, or delete2",
sl@0	1317	(char *) NULL);
sl@0	1318	return TCL_ERROR;
sl@0	1319	}
sl@0	1320	return TCL_OK;
sl@0	1321	}
sl@0	1322
sl@0	1323	static int
sl@0	1324	CreatedCommandProc(clientData, interp, argc, argv)
sl@0	1325	ClientData clientData; /* String to return. */
sl@0	1326	Tcl_Interp interp; / Current interpreter. */
sl@0	1327	int argc; /* Number of arguments. */
sl@0	1328	CONST char *argv; / Argument strings. */
sl@0	1329	{
sl@0	1330	Tcl_CmdInfo info;
sl@0	1331	int found;
sl@0	1332
sl@0	1333	found = Tcl_GetCommandInfo(interp, "test_ns_basic::createdcommand",
sl@0	1334	&info);
sl@0	1335	if (!found) {
sl@0	1336	Tcl_AppendResult(interp, "CreatedCommandProc could not get command info for test_ns_basic::createdcommand",
sl@0	1337	(char *) NULL);
sl@0	1338	return TCL_ERROR;
sl@0	1339	}
sl@0	1340	Tcl_AppendResult(interp, "CreatedCommandProc in ",
sl@0	1341	info.namespacePtr->fullName, (char *) NULL);
sl@0	1342	return TCL_OK;
sl@0	1343	}
sl@0	1344
sl@0	1345	static int
sl@0	1346	CreatedCommandProc2(clientData, interp, argc, argv)
sl@0	1347	ClientData clientData; /* String to return. */
sl@0	1348	Tcl_Interp interp; / Current interpreter. */
sl@0	1349	int argc; /* Number of arguments. */
sl@0	1350	CONST char *argv; / Argument strings. */
sl@0	1351	{
sl@0	1352	Tcl_CmdInfo info;
sl@0	1353	int found;
sl@0	1354
sl@0	1355	found = Tcl_GetCommandInfo(interp, "value:at:", &info);
sl@0	1356	if (!found) {
sl@0	1357	Tcl_AppendResult(interp, "CreatedCommandProc2 could not get command info for test_ns_basic::createdcommand",
sl@0	1358	(char *) NULL);
sl@0	1359	return TCL_ERROR;
sl@0	1360	}
sl@0	1361	Tcl_AppendResult(interp, "CreatedCommandProc2 in ",
sl@0	1362	info.namespacePtr->fullName, (char *) NULL);
sl@0	1363	return TCL_OK;
sl@0	1364	}
sl@0	1365
sl@0	1366	/*
sl@0	1367	*----------------------------------------------------------------------
sl@0	1368	*
sl@0	1369	* TestdcallCmd --
sl@0	1370	*
sl@0	1371	* This procedure implements the "testdcall" command. It is used
sl@0	1372	* to test Tcl_CallWhenDeleted.
sl@0	1373	*
sl@0	1374	* Results:
sl@0	1375	* A standard Tcl result.
sl@0	1376	*
sl@0	1377	* Side effects:
sl@0	1378	* Creates and deletes interpreters.
sl@0	1379	*
sl@0	1380	*----------------------------------------------------------------------
sl@0	1381	*/
sl@0	1382
sl@0	1383	/* ARGSUSED */
sl@0	1384	static int
sl@0	1385	TestdcallCmd(dummy, interp, argc, argv)
sl@0	1386	ClientData dummy; /* Not used. */
sl@0	1387	Tcl_Interp interp; / Current interpreter. */
sl@0	1388	int argc; /* Number of arguments. */
sl@0	1389	CONST char *argv; / Argument strings. */
sl@0	1390	{
sl@0	1391	int i, id;
sl@0	1392
sl@0	1393	delInterp = Tcl_CreateInterp();
sl@0	1394	Tcl_DStringInit(&delString);
sl@0	1395	for (i = 1; i < argc; i++) {
sl@0	1396	if (Tcl_GetInt(interp, argv[i], &id) != TCL_OK) {
sl@0	1397	return TCL_ERROR;
sl@0	1398	}
sl@0	1399	if (id < 0) {
sl@0	1400	Tcl_DontCallWhenDeleted(delInterp, DelCallbackProc,
sl@0	1401	(ClientData) (-id));
sl@0	1402	} else {
sl@0	1403	Tcl_CallWhenDeleted(delInterp, DelCallbackProc,
sl@0	1404	(ClientData) id);
sl@0	1405	}
sl@0	1406	}
sl@0	1407	Tcl_DeleteInterp(delInterp);
sl@0	1408	Tcl_DStringResult(interp, &delString);
sl@0	1409	return TCL_OK;
sl@0	1410	}
sl@0	1411
sl@0	1412	/*
sl@0	1413	* The deletion callback used by TestdcallCmd:
sl@0	1414	*/
sl@0	1415
sl@0	1416	static void
sl@0	1417	DelCallbackProc(clientData, interp)
sl@0	1418	ClientData clientData; /* Numerical value to append to
sl@0	1419	* delString. */
sl@0	1420	Tcl_Interp interp; / Interpreter being deleted. */
sl@0	1421	{
sl@0	1422	int id = (int) clientData;
sl@0	1423	char buffer[TCL_INTEGER_SPACE];
sl@0	1424
sl@0	1425	TclFormatInt(buffer, id);
sl@0	1426	Tcl_DStringAppendElement(&delString, buffer);
sl@0	1427	if (interp != delInterp) {
sl@0	1428	Tcl_DStringAppendElement(&delString, "bogus interpreter argument!");
sl@0	1429	}
sl@0	1430	}
sl@0	1431
sl@0	1432	/*
sl@0	1433	*----------------------------------------------------------------------
sl@0	1434	*
sl@0	1435	* TestdelCmd --
sl@0	1436	*
sl@0	1437	* This procedure implements the "testdcall" command. It is used
sl@0	1438	* to test Tcl_CallWhenDeleted.
sl@0	1439	*
sl@0	1440	* Results:
sl@0	1441	* A standard Tcl result.
sl@0	1442	*
sl@0	1443	* Side effects:
sl@0	1444	* Creates and deletes interpreters.
sl@0	1445	*
sl@0	1446	*----------------------------------------------------------------------
sl@0	1447	*/
sl@0	1448
sl@0	1449	/* ARGSUSED */
sl@0	1450	static int
sl@0	1451	TestdelCmd(dummy, interp, argc, argv)
sl@0	1452	ClientData dummy; /* Not used. */
sl@0	1453	Tcl_Interp interp; / Current interpreter. */
sl@0	1454	int argc; /* Number of arguments. */
sl@0	1455	CONST char *argv; / Argument strings. */
sl@0	1456	{
sl@0	1457	DelCmd *dPtr;
sl@0	1458	Tcl_Interp *slave;
sl@0	1459
sl@0	1460	if (argc != 4) {
sl@0	1461	Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
sl@0	1462	return TCL_ERROR;
sl@0	1463	}
sl@0	1464
sl@0	1465	slave = Tcl_GetSlave(interp, argv[1]);
sl@0	1466	if (slave == NULL) {
sl@0	1467	return TCL_ERROR;
sl@0	1468	}
sl@0	1469
sl@0	1470	dPtr = (DelCmd *) ckalloc(sizeof(DelCmd));
sl@0	1471	dPtr->interp = interp;
sl@0	1472	dPtr->deleteCmd = (char *) ckalloc((unsigned) (strlen(argv[3]) + 1));
sl@0	1473	strcpy(dPtr->deleteCmd, argv[3]);
sl@0	1474
sl@0	1475	Tcl_CreateCommand(slave, argv[2], DelCmdProc, (ClientData) dPtr,
sl@0	1476	DelDeleteProc);
sl@0	1477	return TCL_OK;
sl@0	1478	}
sl@0	1479
sl@0	1480	static int
sl@0	1481	DelCmdProc(clientData, interp, argc, argv)
sl@0	1482	ClientData clientData; /* String result to return. */
sl@0	1483	Tcl_Interp interp; / Current interpreter. */
sl@0	1484	int argc; /* Number of arguments. */
sl@0	1485	CONST char *argv; / Argument strings. */
sl@0	1486	{
sl@0	1487	DelCmd dPtr = (DelCmd ) clientData;
sl@0	1488
sl@0	1489	Tcl_AppendResult(interp, dPtr->deleteCmd, (char *) NULL);
sl@0	1490	ckfree(dPtr->deleteCmd);
sl@0	1491	ckfree((char *) dPtr);
sl@0	1492	return TCL_OK;
sl@0	1493	}
sl@0	1494
sl@0	1495	static void
sl@0	1496	DelDeleteProc(clientData)
sl@0	1497	ClientData clientData; /* String command to evaluate. */
sl@0	1498	{
sl@0	1499	DelCmd dPtr = (DelCmd ) clientData;
sl@0	1500
sl@0	1501	Tcl_Eval(dPtr->interp, dPtr->deleteCmd);
sl@0	1502	Tcl_ResetResult(dPtr->interp);
sl@0	1503	ckfree(dPtr->deleteCmd);
sl@0	1504	ckfree((char *) dPtr);
sl@0	1505	}
sl@0	1506
sl@0	1507	/*
sl@0	1508	*----------------------------------------------------------------------
sl@0	1509	*
sl@0	1510	* TestdelassocdataCmd --
sl@0	1511	*
sl@0	1512	* This procedure implements the "testdelassocdata" command. It is used
sl@0	1513	* to test Tcl_DeleteAssocData.
sl@0	1514	*
sl@0	1515	* Results:
sl@0	1516	* A standard Tcl result.
sl@0	1517	*
sl@0	1518	* Side effects:
sl@0	1519	* Deletes an association between a key and associated data from an
sl@0	1520	* interpreter.
sl@0	1521	*
sl@0	1522	*----------------------------------------------------------------------
sl@0	1523	*/
sl@0	1524
sl@0	1525	static int
sl@0	1526	TestdelassocdataCmd(clientData, interp, argc, argv)
sl@0	1527	ClientData clientData; /* Not used. */
sl@0	1528	Tcl_Interp interp; / Current interpreter. */
sl@0	1529	int argc; /* Number of arguments. */
sl@0	1530	CONST char *argv; / Argument strings. */
sl@0	1531	{
sl@0	1532	if (argc != 2) {
sl@0	1533	Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
sl@0	1534	" data_key\"", (char *) NULL);
sl@0	1535	return TCL_ERROR;
sl@0	1536	}
sl@0	1537	Tcl_DeleteAssocData(interp, argv[1]);
sl@0	1538	return TCL_OK;
sl@0	1539	}
sl@0	1540
sl@0	1541	/*
sl@0	1542	*----------------------------------------------------------------------
sl@0	1543	*
sl@0	1544	* TestdstringCmd --
sl@0	1545	*
sl@0	1546	* This procedure implements the "testdstring" command. It is used
sl@0	1547	* to test the dynamic string facilities of Tcl.
sl@0	1548	*
sl@0	1549	* Results:
sl@0	1550	* A standard Tcl result.
sl@0	1551	*
sl@0	1552	* Side effects:
sl@0	1553	* Creates, deletes, and invokes handlers.
sl@0	1554	*
sl@0	1555	*----------------------------------------------------------------------
sl@0	1556	*/
sl@0	1557
sl@0	1558	/* ARGSUSED */
sl@0	1559	static int
sl@0	1560	TestdstringCmd(dummy, interp, argc, argv)
sl@0	1561	ClientData dummy; /* Not used. */
sl@0	1562	Tcl_Interp interp; / Current interpreter. */
sl@0	1563	int argc; /* Number of arguments. */
sl@0	1564	CONST char *argv; / Argument strings. */
sl@0	1565	{
sl@0	1566	int count;
sl@0	1567
sl@0	1568	if (argc < 2) {
sl@0	1569	wrongNumArgs:
sl@0	1570	Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
sl@0	1571	return TCL_ERROR;
sl@0	1572	}
sl@0	1573	if (strcmp(argv[1], "append") == 0) {
sl@0	1574	if (argc != 4) {
sl@0	1575	goto wrongNumArgs;
sl@0	1576	}
sl@0	1577	if (Tcl_GetInt(interp, argv[3], &count) != TCL_OK) {
sl@0	1578	return TCL_ERROR;
sl@0	1579	}
sl@0	1580	Tcl_DStringAppend(&dstring, argv[2], count);
sl@0	1581	} else if (strcmp(argv[1], "element") == 0) {
sl@0	1582	if (argc != 3) {
sl@0	1583	goto wrongNumArgs;
sl@0	1584	}
sl@0	1585	Tcl_DStringAppendElement(&dstring, argv[2]);
sl@0	1586	} else if (strcmp(argv[1], "end") == 0) {
sl@0	1587	if (argc != 2) {
sl@0	1588	goto wrongNumArgs;
sl@0	1589	}
sl@0	1590	Tcl_DStringEndSublist(&dstring);
sl@0	1591	} else if (strcmp(argv[1], "free") == 0) {
sl@0	1592	if (argc != 2) {
sl@0	1593	goto wrongNumArgs;
sl@0	1594	}
sl@0	1595	Tcl_DStringFree(&dstring);
sl@0	1596	} else if (strcmp(argv[1], "get") == 0) {
sl@0	1597	if (argc != 2) {
sl@0	1598	goto wrongNumArgs;
sl@0	1599	}
sl@0	1600	Tcl_SetResult(interp, Tcl_DStringValue(&dstring), TCL_VOLATILE);
sl@0	1601	} else if (strcmp(argv[1], "gresult") == 0) {
sl@0	1602	if (argc != 3) {
sl@0	1603	goto wrongNumArgs;
sl@0	1604	}
sl@0	1605	if (strcmp(argv[2], "staticsmall") == 0) {
sl@0	1606	Tcl_SetResult(interp, "short", TCL_STATIC);
sl@0	1607	} else if (strcmp(argv[2], "staticlarge") == 0) {
sl@0	1608	Tcl_SetResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", TCL_STATIC);
sl@0	1609	} else if (strcmp(argv[2], "free") == 0) {
sl@0	1610	Tcl_SetResult(interp, (char *) ckalloc(100), TCL_DYNAMIC);
sl@0	1611	strcpy(interp->result, "This is a malloc-ed string");
sl@0	1612	} else if (strcmp(argv[2], "special") == 0) {
sl@0	1613	interp->result = (char *) ckalloc(100);
sl@0	1614	interp->result += 4;
sl@0	1615	interp->freeProc = SpecialFree;
sl@0	1616	strcpy(interp->result, "This is a specially-allocated string");
sl@0	1617	} else {
sl@0	1618	Tcl_AppendResult(interp, "bad gresult option \"", argv[2],
sl@0	1619	"\": must be staticsmall, staticlarge, free, or special",
sl@0	1620	(char *) NULL);
sl@0	1621	return TCL_ERROR;
sl@0	1622	}
sl@0	1623	Tcl_DStringGetResult(interp, &dstring);
sl@0	1624	} else if (strcmp(argv[1], "length") == 0) {
sl@0	1625	char buf[TCL_INTEGER_SPACE];
sl@0	1626
sl@0	1627	if (argc != 2) {
sl@0	1628	goto wrongNumArgs;
sl@0	1629	}
sl@0	1630	TclFormatInt(buf, Tcl_DStringLength(&dstring));
sl@0	1631	Tcl_SetResult(interp, buf, TCL_VOLATILE);
sl@0	1632	} else if (strcmp(argv[1], "result") == 0) {
sl@0	1633	if (argc != 2) {
sl@0	1634	goto wrongNumArgs;
sl@0	1635	}
sl@0	1636	Tcl_DStringResult(interp, &dstring);
sl@0	1637	} else if (strcmp(argv[1], "trunc") == 0) {
sl@0	1638	if (argc != 3) {
sl@0	1639	goto wrongNumArgs;
sl@0	1640	}
sl@0	1641	if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) {
sl@0	1642	return TCL_ERROR;
sl@0	1643	}
sl@0	1644	Tcl_DStringTrunc(&dstring, count);
sl@0	1645	} else if (strcmp(argv[1], "start") == 0) {
sl@0	1646	if (argc != 2) {
sl@0	1647	goto wrongNumArgs;
sl@0	1648	}
sl@0	1649	Tcl_DStringStartSublist(&dstring);
sl@0	1650	} else {
sl@0	1651	Tcl_AppendResult(interp, "bad option \"", argv[1],
sl@0	1652	"\": must be append, element, end, free, get, length, ",
sl@0	1653	"result, trunc, or start", (char *) NULL);
sl@0	1654	return TCL_ERROR;
sl@0	1655	}
sl@0	1656	return TCL_OK;
sl@0	1657	}
sl@0	1658
sl@0	1659	/*
sl@0	1660	* The procedure below is used as a special freeProc to test how well
sl@0	1661	* Tcl_DStringGetResult handles freeProc's other than free.
sl@0	1662	*/
sl@0	1663
sl@0	1664	static void SpecialFree(blockPtr)
sl@0	1665	char blockPtr; / Block to free. */
sl@0	1666	{
sl@0	1667	ckfree(blockPtr - 4);
sl@0	1668	}
sl@0	1669
sl@0	1670	/*
sl@0	1671	*----------------------------------------------------------------------
sl@0	1672	*
sl@0	1673	* TestencodingCmd --
sl@0	1674	*
sl@0	1675	* This procedure implements the "testencoding" command. It is used
sl@0	1676	* to test the encoding package.
sl@0	1677	*
sl@0	1678	* Results:
sl@0	1679	* A standard Tcl result.
sl@0	1680	*
sl@0	1681	* Side effects:
sl@0	1682	* Load encodings.
sl@0	1683	*
sl@0	1684	*----------------------------------------------------------------------
sl@0	1685	*/
sl@0	1686
sl@0	1687	/* ARGSUSED */
sl@0	1688	static int
sl@0	1689	TestencodingObjCmd(dummy, interp, objc, objv)
sl@0	1690	ClientData dummy; /* Not used. */
sl@0	1691	Tcl_Interp interp; / Current interpreter. */
sl@0	1692	int objc; /* Number of arguments. */
sl@0	1693	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	1694	{
sl@0	1695	Tcl_Encoding encoding;
sl@0	1696	int index, length;
sl@0	1697	char *string;
sl@0	1698	TclEncoding *encodingPtr;
sl@0	1699	static CONST char *optionStrings[] = {
sl@0	1700	"create", "delete", "path",
sl@0	1701	NULL
sl@0	1702	};
sl@0	1703	enum options {
sl@0	1704	ENC_CREATE, ENC_DELETE, ENC_PATH
sl@0	1705	};
sl@0	1706
sl@0	1707	if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
sl@0	1708	&index) != TCL_OK) {
sl@0	1709	return TCL_ERROR;
sl@0	1710	}
sl@0	1711
sl@0	1712	switch ((enum options) index) {
sl@0	1713	case ENC_CREATE: {
sl@0	1714	Tcl_EncodingType type;
sl@0	1715
sl@0	1716	if (objc != 5) {
sl@0	1717	return TCL_ERROR;
sl@0	1718	}
sl@0	1719	encodingPtr = (TclEncoding *) ckalloc(sizeof(TclEncoding));
sl@0	1720	encodingPtr->interp = interp;
sl@0	1721
sl@0	1722	string = Tcl_GetStringFromObj(objv[3], &length);
sl@0	1723	encodingPtr->toUtfCmd = (char *) ckalloc((unsigned) (length + 1));
sl@0	1724	memcpy(encodingPtr->toUtfCmd, string, (unsigned) length + 1);
sl@0	1725
sl@0	1726	string = Tcl_GetStringFromObj(objv[4], &length);
sl@0	1727	encodingPtr->fromUtfCmd = (char *) ckalloc((unsigned) (length + 1));
sl@0	1728	memcpy(encodingPtr->fromUtfCmd, string, (unsigned) (length + 1));
sl@0	1729
sl@0	1730	string = Tcl_GetStringFromObj(objv[2], &length);
sl@0	1731
sl@0	1732	type.encodingName = string;
sl@0	1733	type.toUtfProc = EncodingToUtfProc;
sl@0	1734	type.fromUtfProc = EncodingFromUtfProc;
sl@0	1735	type.freeProc = EncodingFreeProc;
sl@0	1736	type.clientData = (ClientData) encodingPtr;
sl@0	1737	type.nullSize = 1;
sl@0	1738
sl@0	1739	Tcl_CreateEncoding(&type);
sl@0	1740	break;
sl@0	1741	}
sl@0	1742	case ENC_DELETE: {
sl@0	1743	if (objc != 3) {
sl@0	1744	return TCL_ERROR;
sl@0	1745	}
sl@0	1746	encoding = Tcl_GetEncoding(NULL, Tcl_GetString(objv[2]));
sl@0	1747	Tcl_FreeEncoding(encoding);
sl@0	1748	Tcl_FreeEncoding(encoding);
sl@0	1749	break;
sl@0	1750	}
sl@0	1751	case ENC_PATH: {
sl@0	1752	if (objc == 2) {
sl@0	1753	Tcl_SetObjResult(interp, TclGetLibraryPath());
sl@0	1754	} else {
sl@0	1755	TclSetLibraryPath(objv[2]);
sl@0	1756	}
sl@0	1757	break;
sl@0	1758	}
sl@0	1759	}
sl@0	1760	return TCL_OK;
sl@0	1761	}
sl@0	1762	static int
sl@0	1763	EncodingToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
sl@0	1764	srcReadPtr, dstWrotePtr, dstCharsPtr)
sl@0	1765	ClientData clientData; /* TclEncoding structure. */
sl@0	1766	CONST char src; / Source string in specified encoding. */
sl@0	1767	int srcLen; /* Source string length in bytes. */
sl@0	1768	int flags; /* Conversion control flags. */
sl@0	1769	Tcl_EncodingState statePtr;/ Current state. */
sl@0	1770	char dst; / Output buffer. */
sl@0	1771	int dstLen; /* The maximum length of output buffer. */
sl@0	1772	int srcReadPtr; / Filled with number of bytes read. */
sl@0	1773	int dstWrotePtr; / Filled with number of bytes stored. */
sl@0	1774	int dstCharsPtr; / Filled with number of chars stored. */
sl@0	1775	{
sl@0	1776	int len;
sl@0	1777	TclEncoding *encodingPtr;
sl@0	1778
sl@0	1779	encodingPtr = (TclEncoding *) clientData;
sl@0	1780	Tcl_GlobalEval(encodingPtr->interp, encodingPtr->toUtfCmd);
sl@0	1781
sl@0	1782	len = strlen(Tcl_GetStringResult(encodingPtr->interp));
sl@0	1783	if (len > dstLen) {
sl@0	1784	len = dstLen;
sl@0	1785	}
sl@0	1786	memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), (unsigned) len);
sl@0	1787	Tcl_ResetResult(encodingPtr->interp);
sl@0	1788
sl@0	1789	*srcReadPtr = srcLen;
sl@0	1790	*dstWrotePtr = len;
sl@0	1791	*dstCharsPtr = len;
sl@0	1792	return TCL_OK;
sl@0	1793	}
sl@0	1794	static int
sl@0	1795	EncodingFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
sl@0	1796	srcReadPtr, dstWrotePtr, dstCharsPtr)
sl@0	1797	ClientData clientData; /* TclEncoding structure. */
sl@0	1798	CONST char src; / Source string in specified encoding. */
sl@0	1799	int srcLen; /* Source string length in bytes. */
sl@0	1800	int flags; /* Conversion control flags. */
sl@0	1801	Tcl_EncodingState statePtr;/ Current state. */
sl@0	1802	char dst; / Output buffer. */
sl@0	1803	int dstLen; /* The maximum length of output buffer. */
sl@0	1804	int srcReadPtr; / Filled with number of bytes read. */
sl@0	1805	int dstWrotePtr; / Filled with number of bytes stored. */
sl@0	1806	int dstCharsPtr; / Filled with number of chars stored. */
sl@0	1807	{
sl@0	1808	int len;
sl@0	1809	TclEncoding *encodingPtr;
sl@0	1810
sl@0	1811	encodingPtr = (TclEncoding *) clientData;
sl@0	1812	Tcl_GlobalEval(encodingPtr->interp, encodingPtr->fromUtfCmd);
sl@0	1813
sl@0	1814	len = strlen(Tcl_GetStringResult(encodingPtr->interp));
sl@0	1815	if (len > dstLen) {
sl@0	1816	len = dstLen;
sl@0	1817	}
sl@0	1818	memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), (unsigned) len);
sl@0	1819	Tcl_ResetResult(encodingPtr->interp);
sl@0	1820
sl@0	1821	*srcReadPtr = srcLen;
sl@0	1822	*dstWrotePtr = len;
sl@0	1823	*dstCharsPtr = len;
sl@0	1824	return TCL_OK;
sl@0	1825	}
sl@0	1826	static void
sl@0	1827	EncodingFreeProc(clientData)
sl@0	1828	ClientData clientData; /* ClientData associated with type. */
sl@0	1829	{
sl@0	1830	TclEncoding *encodingPtr;
sl@0	1831
sl@0	1832	encodingPtr = (TclEncoding *) clientData;
sl@0	1833	ckfree((char *) encodingPtr->toUtfCmd);
sl@0	1834	ckfree((char *) encodingPtr->fromUtfCmd);
sl@0	1835	ckfree((char *) encodingPtr);
sl@0	1836	}
sl@0	1837
sl@0	1838	/*
sl@0	1839	*----------------------------------------------------------------------
sl@0	1840	*
sl@0	1841	* TestevalexObjCmd --
sl@0	1842	*
sl@0	1843	* This procedure implements the "testevalex" command. It is
sl@0	1844	* used to test Tcl_EvalEx.
sl@0	1845	*
sl@0	1846	* Results:
sl@0	1847	* A standard Tcl result.
sl@0	1848	*
sl@0	1849	* Side effects:
sl@0	1850	* None.
sl@0	1851	*
sl@0	1852	*----------------------------------------------------------------------
sl@0	1853	*/
sl@0	1854
sl@0	1855	static int
sl@0	1856	TestevalexObjCmd(dummy, interp, objc, objv)
sl@0	1857	ClientData dummy; /* Not used. */
sl@0	1858	Tcl_Interp interp; / Current interpreter. */
sl@0	1859	int objc; /* Number of arguments. */
sl@0	1860	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	1861	{
sl@0	1862	Interp iPtr = (Interp ) interp;
sl@0	1863	int code, oldFlags, length, flags;
sl@0	1864	char *string;
sl@0	1865
sl@0	1866	if (objc == 1) {
sl@0	1867	/*
sl@0	1868	* The command was invoked with no arguments, so just toggle
sl@0	1869	* the flag that determines whether we use Tcl_EvalEx.
sl@0	1870	*/
sl@0	1871
sl@0	1872	if (iPtr->flags & USE_EVAL_DIRECT) {
sl@0	1873	iPtr->flags &= ~USE_EVAL_DIRECT;
sl@0	1874	Tcl_SetResult(interp, "disabling direct evaluation", TCL_STATIC);
sl@0	1875	} else {
sl@0	1876	iPtr->flags \|= USE_EVAL_DIRECT;
sl@0	1877	Tcl_SetResult(interp, "enabling direct evaluation", TCL_STATIC);
sl@0	1878	}
sl@0	1879	return TCL_OK;
sl@0	1880	}
sl@0	1881
sl@0	1882	flags = 0;
sl@0	1883	if (objc == 3) {
sl@0	1884	string = Tcl_GetStringFromObj(objv[2], &length);
sl@0	1885	if (strcmp(string, "global") != 0) {
sl@0	1886	Tcl_AppendResult(interp, "bad value \"", string,
sl@0	1887	"\": must be global", (char *) NULL);
sl@0	1888	return TCL_ERROR;
sl@0	1889	}
sl@0	1890	flags = TCL_EVAL_GLOBAL;
sl@0	1891	} else if (objc != 2) {
sl@0	1892	Tcl_WrongNumArgs(interp, 1, objv, "script ?global?");
sl@0	1893	return TCL_ERROR;
sl@0	1894	}
sl@0	1895	Tcl_SetResult(interp, "xxx", TCL_STATIC);
sl@0	1896
sl@0	1897	/*
sl@0	1898	* Note, we have to set the USE_EVAL_DIRECT flag in the interpreter
sl@0	1899	* in addition to calling Tcl_EvalEx. This is needed so that even nested
sl@0	1900	* commands are evaluated directly.
sl@0	1901	*/
sl@0	1902
sl@0	1903	oldFlags = iPtr->flags;
sl@0	1904	iPtr->flags \|= USE_EVAL_DIRECT;
sl@0	1905	string = Tcl_GetStringFromObj(objv[1], &length);
sl@0	1906	code = Tcl_EvalEx(interp, string, length, flags);
sl@0	1907	iPtr->flags = (iPtr->flags & ~USE_EVAL_DIRECT)
sl@0	1908	\| (oldFlags & USE_EVAL_DIRECT);
sl@0	1909	return code;
sl@0	1910	}
sl@0	1911
sl@0	1912	/*
sl@0	1913	*----------------------------------------------------------------------
sl@0	1914	*
sl@0	1915	* TestevalobjvObjCmd --
sl@0	1916	*
sl@0	1917	* This procedure implements the "testevalobjv" command. It is
sl@0	1918	* used to test Tcl_EvalObjv.
sl@0	1919	*
sl@0	1920	* Results:
sl@0	1921	* A standard Tcl result.
sl@0	1922	*
sl@0	1923	* Side effects:
sl@0	1924	* None.
sl@0	1925	*
sl@0	1926	*----------------------------------------------------------------------
sl@0	1927	*/
sl@0	1928
sl@0	1929	static int
sl@0	1930	TestevalobjvObjCmd(dummy, interp, objc, objv)
sl@0	1931	ClientData dummy; /* Not used. */
sl@0	1932	Tcl_Interp interp; / Current interpreter. */
sl@0	1933	int objc; /* Number of arguments. */
sl@0	1934	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	1935	{
sl@0	1936	int evalGlobal;
sl@0	1937
sl@0	1938	if (objc < 3) {
sl@0	1939	Tcl_WrongNumArgs(interp, 1, objv, "global word ?word ...?");
sl@0	1940	return TCL_ERROR;
sl@0	1941	}
sl@0	1942	if (Tcl_GetIntFromObj(interp, objv[1], &evalGlobal) != TCL_OK) {
sl@0	1943	return TCL_ERROR;
sl@0	1944	}
sl@0	1945	return Tcl_EvalObjv(interp, objc-2, objv+2,
sl@0	1946	(evalGlobal) ? TCL_EVAL_GLOBAL : 0);
sl@0	1947	}
sl@0	1948
sl@0	1949	/*
sl@0	1950	*----------------------------------------------------------------------
sl@0	1951	*
sl@0	1952	* TesteventObjCmd --
sl@0	1953	*
sl@0	1954	* This procedure implements a 'testevent' command. The command
sl@0	1955	* is used to test event queue management.
sl@0	1956	*
sl@0	1957	* The command takes two forms:
sl@0	1958	* - testevent queue name position script
sl@0	1959	* Queues an event at the given position in the queue, and
sl@0	1960	* associates a given name with it (the same name may be
sl@0	1961	* associated with multiple events). When the event comes
sl@0	1962	* to the head of the queue, executes the given script at
sl@0	1963	* global level in the current interp. The position may be
sl@0	1964	* one of 'head', 'tail' or 'mark'.
sl@0	1965	* - testevent delete name
sl@0	1966	* Deletes any events associated with the given name from
sl@0	1967	* the queue.
sl@0	1968	*
sl@0	1969	* Return value:
sl@0	1970	* Returns a standard Tcl result.
sl@0	1971	*
sl@0	1972	* Side effects:
sl@0	1973	* Manipulates the event queue as directed.
sl@0	1974	*
sl@0	1975	*----------------------------------------------------------------------
sl@0	1976	*/
sl@0	1977
sl@0	1978	static int
sl@0	1979	TesteventObjCmd( ClientData unused, /* Not used */
sl@0	1980	Tcl_Interp* interp, /* Tcl interpreter */
sl@0	1981	int objc, /* Parameter count */
sl@0	1982	Tcl_Obj CONST objv[] ) / Parameter vector */
sl@0	1983	{
sl@0	1984
sl@0	1985	static CONST char* subcommands[] = { /* Possible subcommands */
sl@0	1986	"queue",
sl@0	1987	"delete",
sl@0	1988	NULL
sl@0	1989	};
sl@0	1990	int subCmdIndex; /* Index of the chosen subcommand */
sl@0	1991	static CONST char* positions[] = { /* Possible queue positions */
sl@0	1992	"head",
sl@0	1993	"tail",
sl@0	1994	"mark",
sl@0	1995	NULL
sl@0	1996	};
sl@0	1997	int posIndex; /* Index of the chosen position */
sl@0	1998	static CONST Tcl_QueuePosition posNum[] = {
sl@0	1999	/* Interpretation of the chosen position */
sl@0	2000	TCL_QUEUE_HEAD,
sl@0	2001	TCL_QUEUE_TAIL,
sl@0	2002	TCL_QUEUE_MARK
sl@0	2003	};
sl@0	2004	TestEvent* ev; /* Event to be queued */
sl@0	2005
sl@0	2006	if ( objc < 2 ) {
sl@0	2007	Tcl_WrongNumArgs( interp, 1, objv, "subcommand ?args?" );
sl@0	2008	return TCL_ERROR;
sl@0	2009	}
sl@0	2010	if ( Tcl_GetIndexFromObj( interp, objv[1], subcommands, "subcommand",
sl@0	2011	TCL_EXACT, &subCmdIndex ) != TCL_OK ) {
sl@0	2012	return TCL_ERROR;
sl@0	2013	}
sl@0	2014	switch ( subCmdIndex ) {
sl@0	2015	case 0: /* queue */
sl@0	2016	if ( objc != 5 ) {
sl@0	2017	Tcl_WrongNumArgs( interp, 2, objv, "name position script" );
sl@0	2018	return TCL_ERROR;
sl@0	2019	}
sl@0	2020	if ( Tcl_GetIndexFromObj( interp, objv[3], positions,
sl@0	2021	"position specifier", TCL_EXACT,
sl@0	2022	&posIndex ) != TCL_OK ) {
sl@0	2023	return TCL_ERROR;
sl@0	2024	}
sl@0	2025	ev = (TestEvent*) ckalloc( sizeof( TestEvent ) );
sl@0	2026	ev->header.proc = TesteventProc;
sl@0	2027	ev->header.nextPtr = NULL;
sl@0	2028	ev->interp = interp;
sl@0	2029	ev->command = objv[ 4 ];
sl@0	2030	Tcl_IncrRefCount( ev->command );
sl@0	2031	ev->tag = objv[ 2 ];
sl@0	2032	Tcl_IncrRefCount( ev->tag );
sl@0	2033	Tcl_QueueEvent( (Tcl_Event*) ev, posNum[ posIndex ] );
sl@0	2034	break;
sl@0	2035
sl@0	2036	case 1: /* delete */
sl@0	2037	if ( objc != 3 ) {
sl@0	2038	Tcl_WrongNumArgs( interp, 2, objv, "name" );
sl@0	2039	return TCL_ERROR;
sl@0	2040	}
sl@0	2041	Tcl_DeleteEvents( TesteventDeleteProc, objv[ 2 ] );
sl@0	2042	break;
sl@0	2043	}
sl@0	2044
sl@0	2045	return TCL_OK;
sl@0	2046
sl@0	2047	}
sl@0	2048
sl@0	2049	/*
sl@0	2050	*----------------------------------------------------------------------
sl@0	2051	*
sl@0	2052	* TesteventProc --
sl@0	2053	*
sl@0	2054	* Delivers a test event to the Tcl interpreter as part of event
sl@0	2055	* queue testing.
sl@0	2056	*
sl@0	2057	* Results:
sl@0	2058	* Returns 1 if the event has been serviced, 0 otherwise.
sl@0	2059	*
sl@0	2060	* Side effects:
sl@0	2061	* Evaluates the event's callback script, so has whatever
sl@0	2062	* side effects the callback has. The return value of the
sl@0	2063	* callback script becomes the return value of this function.
sl@0	2064	* If the callback script reports an error, it is reported as
sl@0	2065	* a background error.
sl@0	2066	*
sl@0	2067	*----------------------------------------------------------------------
sl@0	2068	*/
sl@0	2069
sl@0	2070	static int
sl@0	2071	TesteventProc( Tcl_Event* event, /* Event to deliver */
sl@0	2072	int flags ) /* Current flags for Tcl_ServiceEvent */
sl@0	2073	{
sl@0	2074	TestEvent * ev = (TestEvent *) event;
sl@0	2075	Tcl_Interp* interp = ev->interp;
sl@0	2076	Tcl_Obj* command = ev->command;
sl@0	2077	int result = Tcl_EvalObjEx( interp, command,
sl@0	2078	TCL_EVAL_GLOBAL \| TCL_EVAL_DIRECT );
sl@0	2079	int retval;
sl@0	2080	if ( result != TCL_OK ) {
sl@0	2081	Tcl_AddErrorInfo( interp,
sl@0	2082	" (command bound to \"testevent\" callback)" );
sl@0	2083	Tcl_BackgroundError( interp );
sl@0	2084	return 1; /* Avoid looping on errors */
sl@0	2085	}
sl@0	2086	if ( Tcl_GetBooleanFromObj( interp,
sl@0	2087	Tcl_GetObjResult( interp ),
sl@0	2088	&retval ) != TCL_OK ) {
sl@0	2089	Tcl_AddErrorInfo( interp,
sl@0	2090	" (return value from \"testevent\" callback)" );
sl@0	2091	Tcl_BackgroundError( interp );
sl@0	2092	return 1;
sl@0	2093	}
sl@0	2094	if ( retval ) {
sl@0	2095	Tcl_DecrRefCount( ev->tag );
sl@0	2096	Tcl_DecrRefCount( ev->command );
sl@0	2097	}
sl@0	2098
sl@0	2099	return retval;
sl@0	2100	}
sl@0	2101
sl@0	2102	/*
sl@0	2103	*----------------------------------------------------------------------
sl@0	2104	*
sl@0	2105	* TesteventDeleteProc --
sl@0	2106	*
sl@0	2107	* Removes some set of events from the queue.
sl@0	2108	*
sl@0	2109	* This procedure is used as part of testing event queue management.
sl@0	2110	*
sl@0	2111	* Results:
sl@0	2112	* Returns 1 if a given event should be deleted, 0 otherwise.
sl@0	2113	*
sl@0	2114	* Side effects:
sl@0	2115	* None.
sl@0	2116	*
sl@0	2117	*----------------------------------------------------------------------
sl@0	2118	*/
sl@0	2119
sl@0	2120	static int
sl@0	2121	TesteventDeleteProc( Tcl_Event* event, /* Event to examine */
sl@0	2122	ClientData clientData ) /* Tcl_Obj containing the name
sl@0	2123	* of the event(s) to remove */
sl@0	2124	{
sl@0	2125	TestEvent* ev; /* Event to examine */
sl@0	2126	char* evNameStr;
sl@0	2127	Tcl_Obj* targetName; /* Name of the event(s) to delete */
sl@0	2128	char* targetNameStr;
sl@0	2129
sl@0	2130	if ( event->proc != TesteventProc ) {
sl@0	2131	return 0;
sl@0	2132	}
sl@0	2133	targetName = (Tcl_Obj*) clientData;
sl@0	2134	targetNameStr = (char*) Tcl_GetStringFromObj( targetName, NULL );
sl@0	2135	ev = (TestEvent*) event;
sl@0	2136	evNameStr = Tcl_GetStringFromObj( ev->tag, NULL );
sl@0	2137	if ( strcmp( evNameStr, targetNameStr ) == 0 ) {
sl@0	2138	Tcl_DecrRefCount( ev->tag );
sl@0	2139	Tcl_DecrRefCount( ev->command );
sl@0	2140	return 1;
sl@0	2141	} else {
sl@0	2142	return 0;
sl@0	2143	}
sl@0	2144	}
sl@0	2145
sl@0	2146	/*
sl@0	2147	*----------------------------------------------------------------------
sl@0	2148	*
sl@0	2149	* TestexithandlerCmd --
sl@0	2150	*
sl@0	2151	* This procedure implements the "testexithandler" command. It is
sl@0	2152	* used to test Tcl_CreateExitHandler and Tcl_DeleteExitHandler.
sl@0	2153	*
sl@0	2154	* Results:
sl@0	2155	* A standard Tcl result.
sl@0	2156	*
sl@0	2157	* Side effects:
sl@0	2158	* None.
sl@0	2159	*
sl@0	2160	*----------------------------------------------------------------------
sl@0	2161	*/
sl@0	2162
sl@0	2163	static int
sl@0	2164	TestexithandlerCmd(clientData, interp, argc, argv)
sl@0	2165	ClientData clientData; /* Not used. */
sl@0	2166	Tcl_Interp interp; / Current interpreter. */
sl@0	2167	int argc; /* Number of arguments. */
sl@0	2168	CONST char *argv; / Argument strings. */
sl@0	2169	{
sl@0	2170	int value;
sl@0	2171
sl@0	2172	if (argc != 3) {
sl@0	2173	Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
sl@0	2174	" create\|delete value\"", (char *) NULL);
sl@0	2175	return TCL_ERROR;
sl@0	2176	}
sl@0	2177	if (Tcl_GetInt(interp, argv[2], &value) != TCL_OK) {
sl@0	2178	return TCL_ERROR;
sl@0	2179	}
sl@0	2180	if (strcmp(argv[1], "create") == 0) {
sl@0	2181	Tcl_CreateExitHandler((value & 1) ? ExitProcOdd : ExitProcEven,
sl@0	2182	(ClientData) value);
sl@0	2183	} else if (strcmp(argv[1], "delete") == 0) {
sl@0	2184	Tcl_DeleteExitHandler((value & 1) ? ExitProcOdd : ExitProcEven,
sl@0	2185	(ClientData) value);
sl@0	2186	} else {
sl@0	2187	Tcl_AppendResult(interp, "bad option \"", argv[1],
sl@0	2188	"\": must be create or delete", (char *) NULL);
sl@0	2189	return TCL_ERROR;
sl@0	2190	}
sl@0	2191	return TCL_OK;
sl@0	2192	}
sl@0	2193
sl@0	2194	static void
sl@0	2195	ExitProcOdd(clientData)
sl@0	2196	ClientData clientData; /* Integer value to print. */
sl@0	2197	{
sl@0	2198	char buf[16 + TCL_INTEGER_SPACE];
sl@0	2199
sl@0	2200	sprintf(buf, "odd %d\n", (int) clientData);
sl@0	2201	write(1, buf, strlen(buf));
sl@0	2202	}
sl@0	2203
sl@0	2204	static void
sl@0	2205	ExitProcEven(clientData)
sl@0	2206	ClientData clientData; /* Integer value to print. */
sl@0	2207	{
sl@0	2208	char buf[16 + TCL_INTEGER_SPACE];
sl@0	2209
sl@0	2210	sprintf(buf, "even %d\n", (int) clientData);
sl@0	2211	write(1, buf, strlen(buf));
sl@0	2212	}
sl@0	2213
sl@0	2214	/*
sl@0	2215	*----------------------------------------------------------------------
sl@0	2216	*
sl@0	2217	* TestexprlongCmd --
sl@0	2218	*
sl@0	2219	* This procedure verifies that Tcl_ExprLong does not modify the
sl@0	2220	* interpreter result if there is no error.
sl@0	2221	*
sl@0	2222	* Results:
sl@0	2223	* A standard Tcl result.
sl@0	2224	*
sl@0	2225	* Side effects:
sl@0	2226	* None.
sl@0	2227	*
sl@0	2228	*----------------------------------------------------------------------
sl@0	2229	*/
sl@0	2230
sl@0	2231	static int
sl@0	2232	TestexprlongCmd(clientData, interp, argc, argv)
sl@0	2233	ClientData clientData; /* Not used. */
sl@0	2234	Tcl_Interp interp; / Current interpreter. */
sl@0	2235	int argc; /* Number of arguments. */
sl@0	2236	CONST char *argv; / Argument strings. */
sl@0	2237	{
sl@0	2238	long exprResult;
sl@0	2239	char buf[4 + TCL_INTEGER_SPACE];
sl@0	2240	int result;
sl@0	2241
sl@0	2242	Tcl_SetResult(interp, "This is a result", TCL_STATIC);
sl@0	2243	result = Tcl_ExprLong(interp, "4+1", &exprResult);
sl@0	2244	if (result != TCL_OK) {
sl@0	2245	return result;
sl@0	2246	}
sl@0	2247	sprintf(buf, ": %ld", exprResult);
sl@0	2248	Tcl_AppendResult(interp, buf, NULL);
sl@0	2249	return TCL_OK;
sl@0	2250	}
sl@0	2251
sl@0	2252	/*
sl@0	2253	*----------------------------------------------------------------------
sl@0	2254	*
sl@0	2255	* TestexprstringCmd --
sl@0	2256	*
sl@0	2257	* This procedure tests the basic operation of Tcl_ExprString.
sl@0	2258	*
sl@0	2259	* Results:
sl@0	2260	* A standard Tcl result.
sl@0	2261	*
sl@0	2262	* Side effects:
sl@0	2263	* None.
sl@0	2264	*
sl@0	2265	*----------------------------------------------------------------------
sl@0	2266	*/
sl@0	2267
sl@0	2268	static int
sl@0	2269	TestexprstringCmd(clientData, interp, argc, argv)
sl@0	2270	ClientData clientData; /* Not used. */
sl@0	2271	Tcl_Interp interp; / Current interpreter. */
sl@0	2272	int argc; /* Number of arguments. */
sl@0	2273	CONST char *argv; / Argument strings. */
sl@0	2274	{
sl@0	2275	if (argc != 2) {
sl@0	2276	Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
sl@0	2277	" expression\"", (char *) NULL);
sl@0	2278	return TCL_ERROR;
sl@0	2279	}
sl@0	2280	return Tcl_ExprString(interp, argv[1]);
sl@0	2281	}
sl@0	2282
sl@0	2283	/*
sl@0	2284	*----------------------------------------------------------------------
sl@0	2285	*
sl@0	2286	* TestfilelinkCmd --
sl@0	2287	*
sl@0	2288	* This procedure implements the "testfilelink" command. It is used
sl@0	2289	* to test the effects of creating and manipulating filesystem links
sl@0	2290	* in Tcl.
sl@0	2291	*
sl@0	2292	* Results:
sl@0	2293	* A standard Tcl result.
sl@0	2294	*
sl@0	2295	* Side effects:
sl@0	2296	* May create a link on disk.
sl@0	2297	*
sl@0	2298	*----------------------------------------------------------------------
sl@0	2299	*/
sl@0	2300
sl@0	2301	static int
sl@0	2302	TestfilelinkCmd(clientData, interp, objc, objv)
sl@0	2303	ClientData clientData; /* Not used. */
sl@0	2304	Tcl_Interp interp; / Current interpreter. */
sl@0	2305	int objc; /* Number of arguments. */
sl@0	2306	Tcl_Obj CONST objv[]; / The argument objects. */
sl@0	2307	{
sl@0	2308	Tcl_Obj *contents;
sl@0	2309
sl@0	2310	if (objc < 2 \|\| objc > 3) {
sl@0	2311	Tcl_WrongNumArgs(interp, 1, objv, "source ?target?");
sl@0	2312	return TCL_ERROR;
sl@0	2313	}
sl@0	2314
sl@0	2315	if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {
sl@0	2316	return TCL_ERROR;
sl@0	2317	}
sl@0	2318
sl@0	2319	if (objc == 3) {
sl@0	2320	/* Create link from source to target */
sl@0	2321	contents = Tcl_FSLink(objv[1], objv[2],
sl@0	2322	TCL_CREATE_SYMBOLIC_LINK\|TCL_CREATE_HARD_LINK);
sl@0	2323	if (contents == NULL) {
sl@0	2324	Tcl_AppendResult(interp, "could not create link from \"",
sl@0	2325	Tcl_GetString(objv[1]), "\" to \"",
sl@0	2326	Tcl_GetString(objv[2]), "\": ",
sl@0	2327	Tcl_PosixError(interp), (char *) NULL);
sl@0	2328	return TCL_ERROR;
sl@0	2329	}
sl@0	2330	} else {
sl@0	2331	/* Read link */
sl@0	2332	contents = Tcl_FSLink(objv[1], NULL, 0);
sl@0	2333	if (contents == NULL) {
sl@0	2334	Tcl_AppendResult(interp, "could not read link \"",
sl@0	2335	Tcl_GetString(objv[1]), "\": ",
sl@0	2336	Tcl_PosixError(interp), (char *) NULL);
sl@0	2337	return TCL_ERROR;
sl@0	2338	}
sl@0	2339	}
sl@0	2340	Tcl_SetObjResult(interp, contents);
sl@0	2341	if (objc == 2) {
sl@0	2342	/*
sl@0	2343	* If we are creating a link, this will actually just
sl@0	2344	* be objv[3], and we don't own it
sl@0	2345	*/
sl@0	2346	Tcl_DecrRefCount(contents);
sl@0	2347	}
sl@0	2348	return TCL_OK;
sl@0	2349	}
sl@0	2350
sl@0	2351	/*
sl@0	2352	*----------------------------------------------------------------------
sl@0	2353	*
sl@0	2354	* TestgetassocdataCmd --
sl@0	2355	*
sl@0	2356	* This procedure implements the "testgetassocdata" command. It is
sl@0	2357	* used to test Tcl_GetAssocData.
sl@0	2358	*
sl@0	2359	* Results:
sl@0	2360	* A standard Tcl result.
sl@0	2361	*
sl@0	2362	* Side effects:
sl@0	2363	* None.
sl@0	2364	*
sl@0	2365	*----------------------------------------------------------------------
sl@0	2366	*/
sl@0	2367
sl@0	2368	static int
sl@0	2369	TestgetassocdataCmd(clientData, interp, argc, argv)
sl@0	2370	ClientData clientData; /* Not used. */
sl@0	2371	Tcl_Interp interp; / Current interpreter. */
sl@0	2372	int argc; /* Number of arguments. */
sl@0	2373	CONST char *argv; / Argument strings. */
sl@0	2374	{
sl@0	2375	char *res;
sl@0	2376
sl@0	2377	if (argc != 2) {
sl@0	2378	Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
sl@0	2379	" data_key\"", (char *) NULL);
sl@0	2380	return TCL_ERROR;
sl@0	2381	}
sl@0	2382	res = (char *) Tcl_GetAssocData(interp, argv[1], NULL);
sl@0	2383	if (res != NULL) {
sl@0	2384	Tcl_AppendResult(interp, res, NULL);
sl@0	2385	}
sl@0	2386	return TCL_OK;
sl@0	2387	}
sl@0	2388
sl@0	2389	/*
sl@0	2390	*----------------------------------------------------------------------
sl@0	2391	*
sl@0	2392	* TestgetplatformCmd --
sl@0	2393	*
sl@0	2394	* This procedure implements the "testgetplatform" command. It is
sl@0	2395	* used to retrievel the value of the tclPlatform global variable.
sl@0	2396	*
sl@0	2397	* Results:
sl@0	2398	* A standard Tcl result.
sl@0	2399	*
sl@0	2400	* Side effects:
sl@0	2401	* None.
sl@0	2402	*
sl@0	2403	*----------------------------------------------------------------------
sl@0	2404	*/
sl@0	2405
sl@0	2406	static int
sl@0	2407	TestgetplatformCmd(clientData, interp, argc, argv)
sl@0	2408	ClientData clientData; /* Not used. */
sl@0	2409	Tcl_Interp interp; / Current interpreter. */
sl@0	2410	int argc; /* Number of arguments. */
sl@0	2411	CONST char *argv; / Argument strings. */
sl@0	2412	{
sl@0	2413	static CONST char *platformStrings[] = { "unix", "mac", "windows" };
sl@0	2414	TclPlatformType *platform;
sl@0	2415
sl@0	2416	#ifdef __WIN32__
sl@0	2417	platform = TclWinGetPlatform();
sl@0	2418	#else
sl@0	2419	platform = &tclPlatform;
sl@0	2420	#endif
sl@0	2421
sl@0	2422	if (argc != 1) {
sl@0	2423	Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
sl@0	2424	(char *) NULL);
sl@0	2425	return TCL_ERROR;
sl@0	2426	}
sl@0	2427
sl@0	2428	Tcl_AppendResult(interp, platformStrings[*platform], NULL);
sl@0	2429	return TCL_OK;
sl@0	2430	}
sl@0	2431
sl@0	2432	/*
sl@0	2433	*----------------------------------------------------------------------
sl@0	2434	*
sl@0	2435	* TestinterpdeleteCmd --
sl@0	2436	*
sl@0	2437	* This procedure tests the code in tclInterp.c that deals with
sl@0	2438	* interpreter deletion. It deletes a user-specified interpreter
sl@0	2439	* from the hierarchy, and subsequent code checks integrity.
sl@0	2440	*
sl@0	2441	* Results:
sl@0	2442	* A standard Tcl result.
sl@0	2443	*
sl@0	2444	* Side effects:
sl@0	2445	* Deletes one or more interpreters.
sl@0	2446	*
sl@0	2447	*----------------------------------------------------------------------
sl@0	2448	*/
sl@0	2449
sl@0	2450	/* ARGSUSED */
sl@0	2451	static int
sl@0	2452	TestinterpdeleteCmd(dummy, interp, argc, argv)
sl@0	2453	ClientData dummy; /* Not used. */
sl@0	2454	Tcl_Interp interp; / Current interpreter. */
sl@0	2455	int argc; /* Number of arguments. */
sl@0	2456	CONST char *argv; / Argument strings. */
sl@0	2457	{
sl@0	2458	Tcl_Interp *slaveToDelete;
sl@0	2459
sl@0	2460	if (argc != 2) {
sl@0	2461	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
sl@0	2462	" path\"", (char *) NULL);
sl@0	2463	return TCL_ERROR;
sl@0	2464	}
sl@0	2465	slaveToDelete = Tcl_GetSlave(interp, argv[1]);
sl@0	2466	if (slaveToDelete == (Tcl_Interp *) NULL) {
sl@0	2467	return TCL_ERROR;
sl@0	2468	}
sl@0	2469	Tcl_DeleteInterp(slaveToDelete);
sl@0	2470	return TCL_OK;
sl@0	2471	}
sl@0	2472
sl@0	2473	/*
sl@0	2474	*----------------------------------------------------------------------
sl@0	2475	*
sl@0	2476	* TestlinkCmd --
sl@0	2477	*
sl@0	2478	* This procedure implements the "testlink" command. It is used
sl@0	2479	* to test Tcl_LinkVar and related library procedures.
sl@0	2480	*
sl@0	2481	* Results:
sl@0	2482	* A standard Tcl result.
sl@0	2483	*
sl@0	2484	* Side effects:
sl@0	2485	* Creates and deletes various variable links, plus returns
sl@0	2486	* values of the linked variables.
sl@0	2487	*
sl@0	2488	*----------------------------------------------------------------------
sl@0	2489	*/
sl@0	2490
sl@0	2491	/* ARGSUSED */
sl@0	2492	static int
sl@0	2493	TestlinkCmd(dummy, interp, argc, argv)
sl@0	2494	ClientData dummy; /* Not used. */
sl@0	2495	Tcl_Interp interp; / Current interpreter. */
sl@0	2496	int argc; /* Number of arguments. */
sl@0	2497	CONST char *argv; / Argument strings. */
sl@0	2498	{
sl@0	2499	static int intVar = 43;
sl@0	2500	static int boolVar = 4;
sl@0	2501	static double realVar = 1.23;
sl@0	2502	static Tcl_WideInt wideVar = Tcl_LongAsWide(79);
sl@0	2503	static char *stringVar = NULL;
sl@0	2504	static int created = 0;
sl@0	2505	char buffer[2*TCL_DOUBLE_SPACE];
sl@0	2506	int writable, flag;
sl@0	2507	Tcl_Obj *tmp;
sl@0	2508
sl@0	2509	if (argc < 2) {
sl@0	2510	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
sl@0	2511	" option ?arg arg arg arg arg?\"", (char *) NULL);
sl@0	2512	return TCL_ERROR;
sl@0	2513	}
sl@0	2514	if (strcmp(argv[1], "create") == 0) {
sl@0	2515	if (argc != 7) {
sl@0	2516	Tcl_AppendResult(interp, "wrong # args: should be \"",
sl@0	2517	argv[0], " ", argv[1],
sl@0	2518	" intRO realRO boolRO stringRO wideRO\"", (char *) NULL);
sl@0	2519	return TCL_ERROR;
sl@0	2520	}
sl@0	2521	if (created) {
sl@0	2522	Tcl_UnlinkVar(interp, "int");
sl@0	2523	Tcl_UnlinkVar(interp, "real");
sl@0	2524	Tcl_UnlinkVar(interp, "bool");
sl@0	2525	Tcl_UnlinkVar(interp, "string");
sl@0	2526	Tcl_UnlinkVar(interp, "wide");
sl@0	2527	}
sl@0	2528	created = 1;
sl@0	2529	if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) {
sl@0	2530	return TCL_ERROR;
sl@0	2531	}
sl@0	2532	flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
sl@0	2533	if (Tcl_LinkVar(interp, "int", (char *) &intVar,
sl@0	2534	TCL_LINK_INT \| flag) != TCL_OK) {
sl@0	2535	return TCL_ERROR;
sl@0	2536	}
sl@0	2537	if (Tcl_GetBoolean(interp, argv[3], &writable) != TCL_OK) {
sl@0	2538	return TCL_ERROR;
sl@0	2539	}
sl@0	2540	flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
sl@0	2541	if (Tcl_LinkVar(interp, "real", (char *) &realVar,
sl@0	2542	TCL_LINK_DOUBLE \| flag) != TCL_OK) {
sl@0	2543	return TCL_ERROR;
sl@0	2544	}
sl@0	2545	if (Tcl_GetBoolean(interp, argv[4], &writable) != TCL_OK) {
sl@0	2546	return TCL_ERROR;
sl@0	2547	}
sl@0	2548	flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
sl@0	2549	if (Tcl_LinkVar(interp, "bool", (char *) &boolVar,
sl@0	2550	TCL_LINK_BOOLEAN \| flag) != TCL_OK) {
sl@0	2551	return TCL_ERROR;
sl@0	2552	}
sl@0	2553	if (Tcl_GetBoolean(interp, argv[5], &writable) != TCL_OK) {
sl@0	2554	return TCL_ERROR;
sl@0	2555	}
sl@0	2556	flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
sl@0	2557	if (Tcl_LinkVar(interp, "string", (char *) &stringVar,
sl@0	2558	TCL_LINK_STRING \| flag) != TCL_OK) {
sl@0	2559	return TCL_ERROR;
sl@0	2560	}
sl@0	2561	if (Tcl_GetBoolean(interp, argv[6], &writable) != TCL_OK) {
sl@0	2562	return TCL_ERROR;
sl@0	2563	}
sl@0	2564	flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
sl@0	2565	if (Tcl_LinkVar(interp, "wide", (char *) &wideVar,
sl@0	2566	TCL_LINK_WIDE_INT \| flag) != TCL_OK) {
sl@0	2567	return TCL_ERROR;
sl@0	2568	}
sl@0	2569	} else if (strcmp(argv[1], "delete") == 0) {
sl@0	2570	Tcl_UnlinkVar(interp, "int");
sl@0	2571	Tcl_UnlinkVar(interp, "real");
sl@0	2572	Tcl_UnlinkVar(interp, "bool");
sl@0	2573	Tcl_UnlinkVar(interp, "string");
sl@0	2574	Tcl_UnlinkVar(interp, "wide");
sl@0	2575	created = 0;
sl@0	2576	} else if (strcmp(argv[1], "get") == 0) {
sl@0	2577	TclFormatInt(buffer, intVar);
sl@0	2578	Tcl_AppendElement(interp, buffer);
sl@0	2579	Tcl_PrintDouble((Tcl_Interp *) NULL, realVar, buffer);
sl@0	2580	Tcl_AppendElement(interp, buffer);
sl@0	2581	TclFormatInt(buffer, boolVar);
sl@0	2582	Tcl_AppendElement(interp, buffer);
sl@0	2583	Tcl_AppendElement(interp, (stringVar == NULL) ? "-" : stringVar);
sl@0	2584	/*
sl@0	2585	* Wide ints only have an object-based interface.
sl@0	2586	*/
sl@0	2587	tmp = Tcl_NewWideIntObj(wideVar);
sl@0	2588	Tcl_AppendElement(interp, Tcl_GetString(tmp));
sl@0	2589	Tcl_DecrRefCount(tmp);
sl@0	2590	} else if (strcmp(argv[1], "set") == 0) {
sl@0	2591	if (argc != 7) {
sl@0	2592	Tcl_AppendResult(interp, "wrong # args: should be \"",
sl@0	2593	argv[0], " ", argv[1],
sl@0	2594	" intValue realValue boolValue stringValue wideValue\"",
sl@0	2595	(char *) NULL);
sl@0	2596	return TCL_ERROR;
sl@0	2597	}
sl@0	2598	if (argv[2][0] != 0) {
sl@0	2599	if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) {
sl@0	2600	return TCL_ERROR;
sl@0	2601	}
sl@0	2602	}
sl@0	2603	if (argv[3][0] != 0) {
sl@0	2604	if (Tcl_GetDouble(interp, argv[3], &realVar) != TCL_OK) {
sl@0	2605	return TCL_ERROR;
sl@0	2606	}
sl@0	2607	}
sl@0	2608	if (argv[4][0] != 0) {
sl@0	2609	if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) {
sl@0	2610	return TCL_ERROR;
sl@0	2611	}
sl@0	2612	}
sl@0	2613	if (argv[5][0] != 0) {
sl@0	2614	if (stringVar != NULL) {
sl@0	2615	ckfree(stringVar);
sl@0	2616	}
sl@0	2617	if (strcmp(argv[5], "-") == 0) {
sl@0	2618	stringVar = NULL;
sl@0	2619	} else {
sl@0	2620	stringVar = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1));
sl@0	2621	strcpy(stringVar, argv[5]);
sl@0	2622	}
sl@0	2623	}
sl@0	2624	if (argv[6][0] != 0) {
sl@0	2625	tmp = Tcl_NewStringObj(argv[6], -1);
sl@0	2626	if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {
sl@0	2627	Tcl_DecrRefCount(tmp);
sl@0	2628	return TCL_ERROR;
sl@0	2629	}
sl@0	2630	Tcl_DecrRefCount(tmp);
sl@0	2631	}
sl@0	2632	} else if (strcmp(argv[1], "update") == 0) {
sl@0	2633	if (argc != 7) {
sl@0	2634	Tcl_AppendResult(interp, "wrong # args: should be \"",
sl@0	2635	argv[0], " ", argv[1],
sl@0	2636	"intValue realValue boolValue stringValue wideValue\"",
sl@0	2637	(char *) NULL);
sl@0	2638	return TCL_ERROR;
sl@0	2639	}
sl@0	2640	if (argv[2][0] != 0) {
sl@0	2641	if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) {
sl@0	2642	return TCL_ERROR;
sl@0	2643	}
sl@0	2644	Tcl_UpdateLinkedVar(interp, "int");
sl@0	2645	}
sl@0	2646	if (argv[3][0] != 0) {
sl@0	2647	if (Tcl_GetDouble(interp, argv[3], &realVar) != TCL_OK) {
sl@0	2648	return TCL_ERROR;
sl@0	2649	}
sl@0	2650	Tcl_UpdateLinkedVar(interp, "real");
sl@0	2651	}
sl@0	2652	if (argv[4][0] != 0) {
sl@0	2653	if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) {
sl@0	2654	return TCL_ERROR;
sl@0	2655	}
sl@0	2656	Tcl_UpdateLinkedVar(interp, "bool");
sl@0	2657	}
sl@0	2658	if (argv[5][0] != 0) {
sl@0	2659	if (stringVar != NULL) {
sl@0	2660	ckfree(stringVar);
sl@0	2661	}
sl@0	2662	if (strcmp(argv[5], "-") == 0) {
sl@0	2663	stringVar = NULL;
sl@0	2664	} else {
sl@0	2665	stringVar = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1));
sl@0	2666	strcpy(stringVar, argv[5]);
sl@0	2667	}
sl@0	2668	Tcl_UpdateLinkedVar(interp, "string");
sl@0	2669	}
sl@0	2670	if (argv[6][0] != 0) {
sl@0	2671	tmp = Tcl_NewStringObj(argv[6], -1);
sl@0	2672	if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {
sl@0	2673	Tcl_DecrRefCount(tmp);
sl@0	2674	return TCL_ERROR;
sl@0	2675	}
sl@0	2676	Tcl_DecrRefCount(tmp);
sl@0	2677	Tcl_UpdateLinkedVar(interp, "wide");
sl@0	2678	}
sl@0	2679	} else {
sl@0	2680	Tcl_AppendResult(interp, "bad option \"", argv[1],
sl@0	2681	"\": should be create, delete, get, set, or update",
sl@0	2682	(char *) NULL);
sl@0	2683	return TCL_ERROR;
sl@0	2684	}
sl@0	2685	return TCL_OK;
sl@0	2686	}
sl@0	2687
sl@0	2688	/*
sl@0	2689	*----------------------------------------------------------------------
sl@0	2690	*
sl@0	2691	* TestlocaleCmd --
sl@0	2692	*
sl@0	2693	* This procedure implements the "testlocale" command. It is used
sl@0	2694	* to test the effects of setting different locales in Tcl.
sl@0	2695	*
sl@0	2696	* Results:
sl@0	2697	* A standard Tcl result.
sl@0	2698	*
sl@0	2699	* Side effects:
sl@0	2700	* Modifies the current C locale.
sl@0	2701	*
sl@0	2702	*----------------------------------------------------------------------
sl@0	2703	*/
sl@0	2704
sl@0	2705	static int
sl@0	2706	TestlocaleCmd(clientData, interp, objc, objv)
sl@0	2707	ClientData clientData; /* Not used. */
sl@0	2708	Tcl_Interp interp; / Current interpreter. */
sl@0	2709	int objc; /* Number of arguments. */
sl@0	2710	Tcl_Obj CONST objv[]; / The argument objects. */
sl@0	2711	{
sl@0	2712	int index;
sl@0	2713	char *locale;
sl@0	2714
sl@0	2715	static CONST char *optionStrings[] = {
sl@0	2716	"ctype", "numeric", "time", "collate", "monetary",
sl@0	2717	"all", NULL
sl@0	2718	};
sl@0	2719	static int lcTypes[] = {
sl@0	2720	LC_CTYPE, LC_NUMERIC, LC_TIME, LC_COLLATE, LC_MONETARY,
sl@0	2721	LC_ALL
sl@0	2722	};
sl@0	2723
sl@0	2724	/*
sl@0	2725	* LC_CTYPE, etc. correspond to the indices for the strings.
sl@0	2726	*/
sl@0	2727
sl@0	2728	if (objc < 2 \|\| objc > 3) {
sl@0	2729	Tcl_WrongNumArgs(interp, 1, objv, "category ?locale?");
sl@0	2730	return TCL_ERROR;
sl@0	2731	}
sl@0	2732
sl@0	2733	if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
sl@0	2734	&index) != TCL_OK) {
sl@0	2735	return TCL_ERROR;
sl@0	2736	}
sl@0	2737
sl@0	2738	if (objc == 3) {
sl@0	2739	locale = Tcl_GetString(objv[2]);
sl@0	2740	} else {
sl@0	2741	locale = NULL;
sl@0	2742	}
sl@0	2743	locale = setlocale(lcTypes[index], locale);
sl@0	2744	if (locale) {
sl@0	2745	Tcl_SetStringObj(Tcl_GetObjResult(interp), locale, -1);
sl@0	2746	}
sl@0	2747	return TCL_OK;
sl@0	2748	}
sl@0	2749
sl@0	2750	/*
sl@0	2751	*----------------------------------------------------------------------
sl@0	2752	*
sl@0	2753	* TestMathFunc --
sl@0	2754	*
sl@0	2755	* This is a user-defined math procedure to test out math procedures
sl@0	2756	* with no arguments.
sl@0	2757	*
sl@0	2758	* Results:
sl@0	2759	* A normal Tcl completion code.
sl@0	2760	*
sl@0	2761	* Side effects:
sl@0	2762	* None.
sl@0	2763	*
sl@0	2764	*----------------------------------------------------------------------
sl@0	2765	*/
sl@0	2766
sl@0	2767	/* ARGSUSED */
sl@0	2768	static int
sl@0	2769	TestMathFunc(clientData, interp, args, resultPtr)
sl@0	2770	ClientData clientData; /* Integer value to return. */
sl@0	2771	Tcl_Interp interp; / Not used. */
sl@0	2772	Tcl_Value args; / Not used. */
sl@0	2773	Tcl_Value resultPtr; / Where to store result. */
sl@0	2774	{
sl@0	2775	resultPtr->type = TCL_INT;
sl@0	2776	resultPtr->intValue = (int) clientData;
sl@0	2777	return TCL_OK;
sl@0	2778	}
sl@0	2779
sl@0	2780	/*
sl@0	2781	*----------------------------------------------------------------------
sl@0	2782	*
sl@0	2783	* TestMathFunc2 --
sl@0	2784	*
sl@0	2785	* This is a user-defined math procedure to test out math procedures
sl@0	2786	* that do have arguments, in this case 2.
sl@0	2787	*
sl@0	2788	* Results:
sl@0	2789	* A normal Tcl completion code.
sl@0	2790	*
sl@0	2791	* Side effects:
sl@0	2792	* None.
sl@0	2793	*
sl@0	2794	*----------------------------------------------------------------------
sl@0	2795	*/
sl@0	2796
sl@0	2797	/* ARGSUSED */
sl@0	2798	static int
sl@0	2799	TestMathFunc2(clientData, interp, args, resultPtr)
sl@0	2800	ClientData clientData; /* Integer value to return. */
sl@0	2801	Tcl_Interp interp; / Used to report errors. */
sl@0	2802	Tcl_Value args; / Points to an array of two
sl@0	2803	* Tcl_Value structs for the
sl@0	2804	* two arguments. */
sl@0	2805	Tcl_Value resultPtr; / Where to store the result. */
sl@0	2806	{
sl@0	2807	int result = TCL_OK;
sl@0	2808
sl@0	2809	/*
sl@0	2810	* Return the maximum of the two arguments with the correct type.
sl@0	2811	*/
sl@0	2812
sl@0	2813	if (args[0].type == TCL_INT) {
sl@0	2814	int i0 = args[0].intValue;
sl@0	2815
sl@0	2816	if (args[1].type == TCL_INT) {
sl@0	2817	int i1 = args[1].intValue;
sl@0	2818
sl@0	2819	resultPtr->type = TCL_INT;
sl@0	2820	resultPtr->intValue = ((i0 > i1)? i0 : i1);
sl@0	2821	} else if (args[1].type == TCL_DOUBLE) {
sl@0	2822	double d0 = i0;
sl@0	2823	double d1 = args[1].doubleValue;
sl@0	2824
sl@0	2825	resultPtr->type = TCL_DOUBLE;
sl@0	2826	resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
sl@0	2827	} else if (args[1].type == TCL_WIDE_INT) {
sl@0	2828	Tcl_WideInt w0 = Tcl_LongAsWide(i0);
sl@0	2829	Tcl_WideInt w1 = args[1].wideValue;
sl@0	2830
sl@0	2831	resultPtr->type = TCL_WIDE_INT;
sl@0	2832	resultPtr->wideValue = ((w0 > w1)? w0 : w1);
sl@0	2833	} else {
sl@0	2834	Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC);
sl@0	2835	result = TCL_ERROR;
sl@0	2836	}
sl@0	2837	} else if (args[0].type == TCL_DOUBLE) {
sl@0	2838	double d0 = args[0].doubleValue;
sl@0	2839
sl@0	2840	if (args[1].type == TCL_INT) {
sl@0	2841	double d1 = args[1].intValue;
sl@0	2842
sl@0	2843	resultPtr->type = TCL_DOUBLE;
sl@0	2844	resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
sl@0	2845	} else if (args[1].type == TCL_DOUBLE) {
sl@0	2846	double d1 = args[1].doubleValue;
sl@0	2847
sl@0	2848	resultPtr->type = TCL_DOUBLE;
sl@0	2849	resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
sl@0	2850	} else if (args[1].type == TCL_WIDE_INT) {
sl@0	2851	double d1 = Tcl_WideAsDouble(args[1].wideValue);
sl@0	2852
sl@0	2853	resultPtr->type = TCL_DOUBLE;
sl@0	2854	resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
sl@0	2855	} else {
sl@0	2856	Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC);
sl@0	2857	result = TCL_ERROR;
sl@0	2858	}
sl@0	2859	} else if (args[0].type == TCL_WIDE_INT) {
sl@0	2860	Tcl_WideInt w0 = args[0].wideValue;
sl@0	2861
sl@0	2862	if (args[1].type == TCL_INT) {
sl@0	2863	Tcl_WideInt w1 = Tcl_LongAsWide(args[1].intValue);
sl@0	2864
sl@0	2865	resultPtr->type = TCL_WIDE_INT;
sl@0	2866	resultPtr->wideValue = ((w0 > w1)? w0 : w1);
sl@0	2867	} else if (args[1].type == TCL_DOUBLE) {
sl@0	2868	double d0 = Tcl_WideAsDouble(w0);
sl@0	2869	double d1 = args[1].doubleValue;
sl@0	2870
sl@0	2871	resultPtr->type = TCL_DOUBLE;
sl@0	2872	resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
sl@0	2873	} else if (args[1].type == TCL_WIDE_INT) {
sl@0	2874	Tcl_WideInt w1 = args[1].wideValue;
sl@0	2875
sl@0	2876	resultPtr->type = TCL_WIDE_INT;
sl@0	2877	resultPtr->wideValue = ((w0 > w1)? w0 : w1);
sl@0	2878	} else {
sl@0	2879	Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC);
sl@0	2880	result = TCL_ERROR;
sl@0	2881	}
sl@0	2882	} else {
sl@0	2883	Tcl_SetResult(interp, "T3: wrong type for arg 1", TCL_STATIC);
sl@0	2884	result = TCL_ERROR;
sl@0	2885	}
sl@0	2886	return result;
sl@0	2887	}
sl@0	2888
sl@0	2889	/*
sl@0	2890	*----------------------------------------------------------------------
sl@0	2891	*
sl@0	2892	* CleanupTestSetassocdataTests --
sl@0	2893	*
sl@0	2894	* This function is called when an interpreter is deleted to clean
sl@0	2895	* up any data left over from running the testsetassocdata command.
sl@0	2896	*
sl@0	2897	* Results:
sl@0	2898	* None.
sl@0	2899	*
sl@0	2900	* Side effects:
sl@0	2901	* Releases storage.
sl@0	2902	*
sl@0	2903	*----------------------------------------------------------------------
sl@0	2904	*/
sl@0	2905	/* ARGSUSED */
sl@0	2906	static void
sl@0	2907	CleanupTestSetassocdataTests(clientData, interp)
sl@0	2908	ClientData clientData; /* Data to be released. */
sl@0	2909	Tcl_Interp interp; / Interpreter being deleted. */
sl@0	2910	{
sl@0	2911	ckfree((char *) clientData);
sl@0	2912	}
sl@0	2913
sl@0	2914	/*
sl@0	2915	*----------------------------------------------------------------------
sl@0	2916	*
sl@0	2917	* TestparserObjCmd --
sl@0	2918	*
sl@0	2919	* This procedure implements the "testparser" command. It is
sl@0	2920	* used for testing the new Tcl script parser in Tcl 8.1.
sl@0	2921	*
sl@0	2922	* Results:
sl@0	2923	* A standard Tcl result.
sl@0	2924	*
sl@0	2925	* Side effects:
sl@0	2926	* None.
sl@0	2927	*
sl@0	2928	*----------------------------------------------------------------------
sl@0	2929	*/
sl@0	2930
sl@0	2931	static int
sl@0	2932	TestparserObjCmd(clientData, interp, objc, objv)
sl@0	2933	ClientData clientData; /* Not used. */
sl@0	2934	Tcl_Interp interp; / Current interpreter. */
sl@0	2935	int objc; /* Number of arguments. */
sl@0	2936	Tcl_Obj CONST objv[]; / The argument objects. */
sl@0	2937	{
sl@0	2938	char *script;
sl@0	2939	int length, dummy;
sl@0	2940	Tcl_Parse parse;
sl@0	2941
sl@0	2942	if (objc != 3) {
sl@0	2943	Tcl_WrongNumArgs(interp, 1, objv, "script length");
sl@0	2944	return TCL_ERROR;
sl@0	2945	}
sl@0	2946	script = Tcl_GetStringFromObj(objv[1], &dummy);
sl@0	2947	if (Tcl_GetIntFromObj(interp, objv[2], &length)) {
sl@0	2948	return TCL_ERROR;
sl@0	2949	}
sl@0	2950	if (length == 0) {
sl@0	2951	length = dummy;
sl@0	2952	}
sl@0	2953	if (Tcl_ParseCommand(interp, script, length, 0, &parse) != TCL_OK) {
sl@0	2954	Tcl_AddErrorInfo(interp, "\n (remainder of script: \"");
sl@0	2955	Tcl_AddErrorInfo(interp, parse.term);
sl@0	2956	Tcl_AddErrorInfo(interp, "\")");
sl@0	2957	return TCL_ERROR;
sl@0	2958	}
sl@0	2959
sl@0	2960	/*
sl@0	2961	* The parse completed successfully. Just print out the contents
sl@0	2962	* of the parse structure into the interpreter's result.
sl@0	2963	*/
sl@0	2964
sl@0	2965	PrintParse(interp, &parse);
sl@0	2966	Tcl_FreeParse(&parse);
sl@0	2967	return TCL_OK;
sl@0	2968	}
sl@0	2969
sl@0	2970	/*
sl@0	2971	*----------------------------------------------------------------------
sl@0	2972	*
sl@0	2973	* TestexprparserObjCmd --
sl@0	2974	*
sl@0	2975	* This procedure implements the "testexprparser" command. It is
sl@0	2976	* used for testing the new Tcl expression parser in Tcl 8.1.
sl@0	2977	*
sl@0	2978	* Results:
sl@0	2979	* A standard Tcl result.
sl@0	2980	*
sl@0	2981	* Side effects:
sl@0	2982	* None.
sl@0	2983	*
sl@0	2984	*----------------------------------------------------------------------
sl@0	2985	*/
sl@0	2986
sl@0	2987	static int
sl@0	2988	TestexprparserObjCmd(clientData, interp, objc, objv)
sl@0	2989	ClientData clientData; /* Not used. */
sl@0	2990	Tcl_Interp interp; / Current interpreter. */
sl@0	2991	int objc; /* Number of arguments. */
sl@0	2992	Tcl_Obj CONST objv[]; / The argument objects. */
sl@0	2993	{
sl@0	2994	char *script;
sl@0	2995	int length, dummy;
sl@0	2996	Tcl_Parse parse;
sl@0	2997
sl@0	2998	if (objc != 3) {
sl@0	2999	Tcl_WrongNumArgs(interp, 1, objv, "expr length");
sl@0	3000	return TCL_ERROR;
sl@0	3001	}
sl@0	3002	script = Tcl_GetStringFromObj(objv[1], &dummy);
sl@0	3003	if (Tcl_GetIntFromObj(interp, objv[2], &length)) {
sl@0	3004	return TCL_ERROR;
sl@0	3005	}
sl@0	3006	if (length == 0) {
sl@0	3007	length = dummy;
sl@0	3008	}
sl@0	3009	if (Tcl_ParseExpr(interp, script, length, &parse) != TCL_OK) {
sl@0	3010	Tcl_AddErrorInfo(interp, "\n (remainder of expr: \"");
sl@0	3011	Tcl_AddErrorInfo(interp, parse.term);
sl@0	3012	Tcl_AddErrorInfo(interp, "\")");
sl@0	3013	return TCL_ERROR;
sl@0	3014	}
sl@0	3015
sl@0	3016	/*
sl@0	3017	* The parse completed successfully. Just print out the contents
sl@0	3018	* of the parse structure into the interpreter's result.
sl@0	3019	*/
sl@0	3020
sl@0	3021	PrintParse(interp, &parse);
sl@0	3022	Tcl_FreeParse(&parse);
sl@0	3023	return TCL_OK;
sl@0	3024	}
sl@0	3025
sl@0	3026	/*
sl@0	3027	*----------------------------------------------------------------------
sl@0	3028	*
sl@0	3029	* PrintParse --
sl@0	3030	*
sl@0	3031	* This procedure prints out the contents of a Tcl_Parse structure
sl@0	3032	* in the result of an interpreter.
sl@0	3033	*
sl@0	3034	* Results:
sl@0	3035	* Interp's result is set to a prettily formatted version of the
sl@0	3036	* contents of parsePtr.
sl@0	3037	*
sl@0	3038	* Side effects:
sl@0	3039	* None.
sl@0	3040	*
sl@0	3041	*----------------------------------------------------------------------
sl@0	3042	*/
sl@0	3043
sl@0	3044	static void
sl@0	3045	PrintParse(interp, parsePtr)
sl@0	3046	Tcl_Interp interp; / Interpreter whose result is to be set to
sl@0	3047	* the contents of a parse structure. */
sl@0	3048	Tcl_Parse parsePtr; / Parse structure to print out. */
sl@0	3049	{
sl@0	3050	Tcl_Obj *objPtr;
sl@0	3051	char *typeString;
sl@0	3052	Tcl_Token *tokenPtr;
sl@0	3053	int i;
sl@0	3054
sl@0	3055	objPtr = Tcl_GetObjResult(interp);
sl@0	3056	if (parsePtr->commentSize > 0) {
sl@0	3057	Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
sl@0	3058	Tcl_NewStringObj(parsePtr->commentStart,
sl@0	3059	parsePtr->commentSize));
sl@0	3060	} else {
sl@0	3061	Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
sl@0	3062	Tcl_NewStringObj("-", 1));
sl@0	3063	}
sl@0	3064	Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
sl@0	3065	Tcl_NewStringObj(parsePtr->commandStart, parsePtr->commandSize));
sl@0	3066	Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
sl@0	3067	Tcl_NewIntObj(parsePtr->numWords));
sl@0	3068	for (i = 0; i < parsePtr->numTokens; i++) {
sl@0	3069	tokenPtr = &parsePtr->tokenPtr[i];
sl@0	3070	switch (tokenPtr->type) {
sl@0	3071	case TCL_TOKEN_WORD:
sl@0	3072	typeString = "word";
sl@0	3073	break;
sl@0	3074	case TCL_TOKEN_SIMPLE_WORD:
sl@0	3075	typeString = "simple";
sl@0	3076	break;
sl@0	3077	case TCL_TOKEN_TEXT:
sl@0	3078	typeString = "text";
sl@0	3079	break;
sl@0	3080	case TCL_TOKEN_BS:
sl@0	3081	typeString = "backslash";
sl@0	3082	break;
sl@0	3083	case TCL_TOKEN_COMMAND:
sl@0	3084	typeString = "command";
sl@0	3085	break;
sl@0	3086	case TCL_TOKEN_VARIABLE:
sl@0	3087	typeString = "variable";
sl@0	3088	break;
sl@0	3089	case TCL_TOKEN_SUB_EXPR:
sl@0	3090	typeString = "subexpr";
sl@0	3091	break;
sl@0	3092	case TCL_TOKEN_OPERATOR:
sl@0	3093	typeString = "operator";
sl@0	3094	break;
sl@0	3095	default:
sl@0	3096	typeString = "??";
sl@0	3097	break;
sl@0	3098	}
sl@0	3099	Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
sl@0	3100	Tcl_NewStringObj(typeString, -1));
sl@0	3101	Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
sl@0	3102	Tcl_NewStringObj(tokenPtr->start, tokenPtr->size));
sl@0	3103	Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
sl@0	3104	Tcl_NewIntObj(tokenPtr->numComponents));
sl@0	3105	}
sl@0	3106	Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
sl@0	3107	Tcl_NewStringObj(parsePtr->commandStart + parsePtr->commandSize,
sl@0	3108	-1));
sl@0	3109	}
sl@0	3110
sl@0	3111	/*
sl@0	3112	*----------------------------------------------------------------------
sl@0	3113	*
sl@0	3114	* TestparsevarObjCmd --
sl@0	3115	*
sl@0	3116	* This procedure implements the "testparsevar" command. It is
sl@0	3117	* used for testing Tcl_ParseVar.
sl@0	3118	*
sl@0	3119	* Results:
sl@0	3120	* A standard Tcl result.
sl@0	3121	*
sl@0	3122	* Side effects:
sl@0	3123	* None.
sl@0	3124	*
sl@0	3125	*----------------------------------------------------------------------
sl@0	3126	*/
sl@0	3127
sl@0	3128	static int
sl@0	3129	TestparsevarObjCmd(clientData, interp, objc, objv)
sl@0	3130	ClientData clientData; /* Not used. */
sl@0	3131	Tcl_Interp interp; / Current interpreter. */
sl@0	3132	int objc; /* Number of arguments. */
sl@0	3133	Tcl_Obj CONST objv[]; / The argument objects. */
sl@0	3134	{
sl@0	3135	CONST char *value;
sl@0	3136	CONST char name, termPtr;
sl@0	3137
sl@0	3138	if (objc != 2) {
sl@0	3139	Tcl_WrongNumArgs(interp, 1, objv, "varName");
sl@0	3140	return TCL_ERROR;
sl@0	3141	}
sl@0	3142	name = Tcl_GetString(objv[1]);
sl@0	3143	value = Tcl_ParseVar(interp, name, &termPtr);
sl@0	3144	if (value == NULL) {
sl@0	3145	return TCL_ERROR;
sl@0	3146	}
sl@0	3147
sl@0	3148	Tcl_AppendElement(interp, value);
sl@0	3149	Tcl_AppendElement(interp, termPtr);
sl@0	3150	return TCL_OK;
sl@0	3151	}
sl@0	3152
sl@0	3153	/*
sl@0	3154	*----------------------------------------------------------------------
sl@0	3155	*
sl@0	3156	* TestparsevarnameObjCmd --
sl@0	3157	*
sl@0	3158	* This procedure implements the "testparsevarname" command. It is
sl@0	3159	* used for testing the new Tcl script parser in Tcl 8.1.
sl@0	3160	*
sl@0	3161	* Results:
sl@0	3162	* A standard Tcl result.
sl@0	3163	*
sl@0	3164	* Side effects:
sl@0	3165	* None.
sl@0	3166	*
sl@0	3167	*----------------------------------------------------------------------
sl@0	3168	*/
sl@0	3169
sl@0	3170	static int
sl@0	3171	TestparsevarnameObjCmd(clientData, interp, objc, objv)
sl@0	3172	ClientData clientData; /* Not used. */
sl@0	3173	Tcl_Interp interp; / Current interpreter. */
sl@0	3174	int objc; /* Number of arguments. */
sl@0	3175	Tcl_Obj CONST objv[]; / The argument objects. */
sl@0	3176	{
sl@0	3177	char *script;
sl@0	3178	int append, length, dummy;
sl@0	3179	Tcl_Parse parse;
sl@0	3180
sl@0	3181	if (objc != 4) {
sl@0	3182	Tcl_WrongNumArgs(interp, 1, objv, "script length append");
sl@0	3183	return TCL_ERROR;
sl@0	3184	}
sl@0	3185	script = Tcl_GetStringFromObj(objv[1], &dummy);
sl@0	3186	if (Tcl_GetIntFromObj(interp, objv[2], &length)) {
sl@0	3187	return TCL_ERROR;
sl@0	3188	}
sl@0	3189	if (length == 0) {
sl@0	3190	length = dummy;
sl@0	3191	}
sl@0	3192	if (Tcl_GetIntFromObj(interp, objv[3], &append)) {
sl@0	3193	return TCL_ERROR;
sl@0	3194	}
sl@0	3195	if (Tcl_ParseVarName(interp, script, length, &parse, append) != TCL_OK) {
sl@0	3196	Tcl_AddErrorInfo(interp, "\n (remainder of script: \"");
sl@0	3197	Tcl_AddErrorInfo(interp, parse.term);
sl@0	3198	Tcl_AddErrorInfo(interp, "\")");
sl@0	3199	return TCL_ERROR;
sl@0	3200	}
sl@0	3201
sl@0	3202	/*
sl@0	3203	* The parse completed successfully. Just print out the contents
sl@0	3204	* of the parse structure into the interpreter's result.
sl@0	3205	*/
sl@0	3206
sl@0	3207	parse.commentSize = 0;
sl@0	3208	parse.commandStart = script + parse.tokenPtr->size;
sl@0	3209	parse.commandSize = 0;
sl@0	3210	PrintParse(interp, &parse);
sl@0	3211	Tcl_FreeParse(&parse);
sl@0	3212	return TCL_OK;
sl@0	3213	}
sl@0	3214
sl@0	3215	/*
sl@0	3216	*----------------------------------------------------------------------
sl@0	3217	*
sl@0	3218	* TestregexpObjCmd --
sl@0	3219	*
sl@0	3220	* This procedure implements the "testregexp" command. It is
sl@0	3221	* used to give a direct interface for regexp flags. It's identical
sl@0	3222	* to Tcl_RegexpObjCmd except for the -xflags option, and the
sl@0	3223	* consequences thereof (including the REG_EXPECT kludge).
sl@0	3224	*
sl@0	3225	* Results:
sl@0	3226	* A standard Tcl result.
sl@0	3227	*
sl@0	3228	* Side effects:
sl@0	3229	* See the user documentation.
sl@0	3230	*
sl@0	3231	*----------------------------------------------------------------------
sl@0	3232	*/
sl@0	3233
sl@0	3234	/* ARGSUSED */
sl@0	3235	static int
sl@0	3236	TestregexpObjCmd(dummy, interp, objc, objv)
sl@0	3237	ClientData dummy; /* Not used. */
sl@0	3238	Tcl_Interp interp; / Current interpreter. */
sl@0	3239	int objc; /* Number of arguments. */
sl@0	3240	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	3241	{
sl@0	3242	int i, ii, indices, stringLength, match, about;
sl@0	3243	int hasxflags, cflags, eflags;
sl@0	3244	Tcl_RegExp regExpr;
sl@0	3245	char *string;
sl@0	3246	Tcl_Obj *objPtr;
sl@0	3247	Tcl_RegExpInfo info;
sl@0	3248	static CONST char *options[] = {
sl@0	3249	"-indices", "-nocase", "-about", "-expanded",
sl@0	3250	"-line", "-linestop", "-lineanchor",
sl@0	3251	"-xflags",
sl@0	3252	"--", (char *) NULL
sl@0	3253	};
sl@0	3254	enum options {
sl@0	3255	REGEXP_INDICES, REGEXP_NOCASE, REGEXP_ABOUT, REGEXP_EXPANDED,
sl@0	3256	REGEXP_MULTI, REGEXP_NOCROSS, REGEXP_NEWL,
sl@0	3257	REGEXP_XFLAGS,
sl@0	3258	REGEXP_LAST
sl@0	3259	};
sl@0	3260
sl@0	3261	indices = 0;
sl@0	3262	about = 0;
sl@0	3263	cflags = REG_ADVANCED;
sl@0	3264	eflags = 0;
sl@0	3265	hasxflags = 0;
sl@0	3266
sl@0	3267	for (i = 1; i < objc; i++) {
sl@0	3268	char *name;
sl@0	3269	int index;
sl@0	3270
sl@0	3271	name = Tcl_GetString(objv[i]);
sl@0	3272	if (name[0] != '-') {
sl@0	3273	break;
sl@0	3274	}
sl@0	3275	if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT,
sl@0	3276	&index) != TCL_OK) {
sl@0	3277	return TCL_ERROR;
sl@0	3278	}
sl@0	3279	switch ((enum options) index) {
sl@0	3280	case REGEXP_INDICES: {
sl@0	3281	indices = 1;
sl@0	3282	break;
sl@0	3283	}
sl@0	3284	case REGEXP_NOCASE: {
sl@0	3285	cflags \|= REG_ICASE;
sl@0	3286	break;
sl@0	3287	}
sl@0	3288	case REGEXP_ABOUT: {
sl@0	3289	about = 1;
sl@0	3290	break;
sl@0	3291	}
sl@0	3292	case REGEXP_EXPANDED: {
sl@0	3293	cflags \|= REG_EXPANDED;
sl@0	3294	break;
sl@0	3295	}
sl@0	3296	case REGEXP_MULTI: {
sl@0	3297	cflags \|= REG_NEWLINE;
sl@0	3298	break;
sl@0	3299	}
sl@0	3300	case REGEXP_NOCROSS: {
sl@0	3301	cflags \|= REG_NLSTOP;
sl@0	3302	break;
sl@0	3303	}
sl@0	3304	case REGEXP_NEWL: {
sl@0	3305	cflags \|= REG_NLANCH;
sl@0	3306	break;
sl@0	3307	}
sl@0	3308	case REGEXP_XFLAGS: {
sl@0	3309	hasxflags = 1;
sl@0	3310	break;
sl@0	3311	}
sl@0	3312	case REGEXP_LAST: {
sl@0	3313	i++;
sl@0	3314	goto endOfForLoop;
sl@0	3315	}
sl@0	3316	}
sl@0	3317	}
sl@0	3318
sl@0	3319	endOfForLoop:
sl@0	3320	if (objc - i < hasxflags + 2 - about) {
sl@0	3321	Tcl_WrongNumArgs(interp, 1, objv,
sl@0	3322	"?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?");
sl@0	3323	return TCL_ERROR;
sl@0	3324	}
sl@0	3325	objc -= i;
sl@0	3326	objv += i;
sl@0	3327
sl@0	3328	if (hasxflags) {
sl@0	3329	string = Tcl_GetStringFromObj(objv[0], &stringLength);
sl@0	3330	TestregexpXflags(string, stringLength, &cflags, &eflags);
sl@0	3331	objc--;
sl@0	3332	objv++;
sl@0	3333	}
sl@0	3334
sl@0	3335	regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
sl@0	3336	if (regExpr == NULL) {
sl@0	3337	return TCL_ERROR;
sl@0	3338	}
sl@0	3339	objPtr = objv[1];
sl@0	3340
sl@0	3341	if (about) {
sl@0	3342	if (TclRegAbout(interp, regExpr) < 0) {
sl@0	3343	return TCL_ERROR;
sl@0	3344	}
sl@0	3345	return TCL_OK;
sl@0	3346	}
sl@0	3347
sl@0	3348	match = Tcl_RegExpExecObj(interp, regExpr, objPtr, 0 /* offset */,
sl@0	3349	objc-2 /* nmatches */, eflags);
sl@0	3350
sl@0	3351	if (match < 0) {
sl@0	3352	return TCL_ERROR;
sl@0	3353	}
sl@0	3354	if (match == 0) {
sl@0	3355	/*
sl@0	3356	* Set the interpreter's object result to an integer object w/
sl@0	3357	* value 0.
sl@0	3358	*/
sl@0	3359
sl@0	3360	Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
sl@0	3361	if (objc > 2 && (cflags&REG_EXPECT) && indices) {
sl@0	3362	char *varName;
sl@0	3363	CONST char *value;
sl@0	3364	int start, end;
sl@0	3365	char resinfo[TCL_INTEGER_SPACE * 2];
sl@0	3366
sl@0	3367	varName = Tcl_GetString(objv[2]);
sl@0	3368	TclRegExpRangeUniChar(regExpr, -1, &start, &end);
sl@0	3369	sprintf(resinfo, "%d %d", start, end-1);
sl@0	3370	value = Tcl_SetVar(interp, varName, resinfo, 0);
sl@0	3371	if (value == NULL) {
sl@0	3372	Tcl_AppendResult(interp, "couldn't set variable \"",
sl@0	3373	varName, "\"", (char *) NULL);
sl@0	3374	return TCL_ERROR;
sl@0	3375	}
sl@0	3376	} else if (cflags & TCL_REG_CANMATCH) {
sl@0	3377	char *varName;
sl@0	3378	CONST char *value;
sl@0	3379	char resinfo[TCL_INTEGER_SPACE * 2];
sl@0	3380
sl@0	3381	Tcl_RegExpGetInfo(regExpr, &info);
sl@0	3382	varName = Tcl_GetString(objv[2]);
sl@0	3383	sprintf(resinfo, "%ld", info.extendStart);
sl@0	3384	value = Tcl_SetVar(interp, varName, resinfo, 0);
sl@0	3385	if (value == NULL) {
sl@0	3386	Tcl_AppendResult(interp, "couldn't set variable \"",
sl@0	3387	varName, "\"", (char *) NULL);
sl@0	3388	return TCL_ERROR;
sl@0	3389	}
sl@0	3390	}
sl@0	3391	return TCL_OK;
sl@0	3392	}
sl@0	3393
sl@0	3394	/*
sl@0	3395	* If additional variable names have been specified, return
sl@0	3396	* index information in those variables.
sl@0	3397	*/
sl@0	3398
sl@0	3399	objc -= 2;
sl@0	3400	objv += 2;
sl@0	3401
sl@0	3402	Tcl_RegExpGetInfo(regExpr, &info);
sl@0	3403	for (i = 0; i < objc; i++) {
sl@0	3404	int start, end;
sl@0	3405	Tcl_Obj newPtr, varPtr, *valuePtr;
sl@0	3406
sl@0	3407	varPtr = objv[i];
sl@0	3408	ii = ((cflags&REG_EXPECT) && i == objc-1) ? -1 : i;
sl@0	3409	if (indices) {
sl@0	3410	Tcl_Obj *objs[2];
sl@0	3411
sl@0	3412	if (ii == -1) {
sl@0	3413	TclRegExpRangeUniChar(regExpr, ii, &start, &end);
sl@0	3414	} else if (ii > info.nsubs) {
sl@0	3415	start = -1;
sl@0	3416	end = -1;
sl@0	3417	} else {
sl@0	3418	start = info.matches[ii].start;
sl@0	3419	end = info.matches[ii].end;
sl@0	3420	}
sl@0	3421
sl@0	3422	/*
sl@0	3423	* Adjust index so it refers to the last character in the
sl@0	3424	* match instead of the first character after the match.
sl@0	3425	*/
sl@0	3426
sl@0	3427	if (end >= 0) {
sl@0	3428	end--;
sl@0	3429	}
sl@0	3430
sl@0	3431	objs[0] = Tcl_NewLongObj(start);
sl@0	3432	objs[1] = Tcl_NewLongObj(end);
sl@0	3433
sl@0	3434	newPtr = Tcl_NewListObj(2, objs);
sl@0	3435	} else {
sl@0	3436	if (ii == -1) {
sl@0	3437	TclRegExpRangeUniChar(regExpr, ii, &start, &end);
sl@0	3438	newPtr = Tcl_GetRange(objPtr, start, end);
sl@0	3439	} else if (ii > info.nsubs) {
sl@0	3440	newPtr = Tcl_NewObj();
sl@0	3441	} else {
sl@0	3442	newPtr = Tcl_GetRange(objPtr, info.matches[ii].start,
sl@0	3443	info.matches[ii].end - 1);
sl@0	3444	}
sl@0	3445	}
sl@0	3446	Tcl_IncrRefCount(newPtr);
sl@0	3447	valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, 0);
sl@0	3448	Tcl_DecrRefCount(newPtr);
sl@0	3449	if (valuePtr == NULL) {
sl@0	3450	Tcl_AppendResult(interp, "couldn't set variable \"",
sl@0	3451	Tcl_GetString(varPtr), "\"", (char *) NULL);
sl@0	3452	return TCL_ERROR;
sl@0	3453	}
sl@0	3454	}
sl@0	3455
sl@0	3456	/*
sl@0	3457	* Set the interpreter's object result to an integer object w/ value 1.
sl@0	3458	*/
sl@0	3459
sl@0	3460	Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
sl@0	3461	return TCL_OK;
sl@0	3462	}
sl@0	3463
sl@0	3464	/*
sl@0	3465	*---------------------------------------------------------------------------
sl@0	3466	*
sl@0	3467	* TestregexpXflags --
sl@0	3468	*
sl@0	3469	* Parse a string of extended regexp flag letters, for testing.
sl@0	3470	*
sl@0	3471	* Results:
sl@0	3472	* No return value (you're on your own for errors here).
sl@0	3473	*
sl@0	3474	* Side effects:
sl@0	3475	* Modifies cflagsPtr, a regcomp flags word, and eflagsPtr, a
sl@0	3476	* regexec flags word, as appropriate.
sl@0	3477	*
sl@0	3478	*----------------------------------------------------------------------
sl@0	3479	*/
sl@0	3480
sl@0	3481	static void
sl@0	3482	TestregexpXflags(string, length, cflagsPtr, eflagsPtr)
sl@0	3483	char string; / The string of flags. */
sl@0	3484	int length; /* The length of the string in bytes. */
sl@0	3485	int cflagsPtr; / compile flags word */
sl@0	3486	int eflagsPtr; / exec flags word */
sl@0	3487	{
sl@0	3488	int i;
sl@0	3489	int cflags;
sl@0	3490	int eflags;
sl@0	3491
sl@0	3492	cflags = *cflagsPtr;
sl@0	3493	eflags = *eflagsPtr;
sl@0	3494	for (i = 0; i < length; i++) {
sl@0	3495	switch (string[i]) {
sl@0	3496	case 'a': {
sl@0	3497	cflags \|= REG_ADVF;
sl@0	3498	break;
sl@0	3499	}
sl@0	3500	case 'b': {
sl@0	3501	cflags &= ~REG_ADVANCED;
sl@0	3502	break;
sl@0	3503	}
sl@0	3504	case 'c': {
sl@0	3505	cflags \|= TCL_REG_CANMATCH;
sl@0	3506	break;
sl@0	3507	}
sl@0	3508	case 'e': {
sl@0	3509	cflags &= ~REG_ADVANCED;
sl@0	3510	cflags \|= REG_EXTENDED;
sl@0	3511	break;
sl@0	3512	}
sl@0	3513	case 'q': {
sl@0	3514	cflags &= ~REG_ADVANCED;
sl@0	3515	cflags \|= REG_QUOTE;
sl@0	3516	break;
sl@0	3517	}
sl@0	3518	case 'o': { /* o for opaque */
sl@0	3519	cflags \|= REG_NOSUB;
sl@0	3520	break;
sl@0	3521	}
sl@0	3522	case 's': { /* s for start */
sl@0	3523	cflags \|= REG_BOSONLY;
sl@0	3524	break;
sl@0	3525	}
sl@0	3526	case '+': {
sl@0	3527	cflags \|= REG_FAKE;
sl@0	3528	break;
sl@0	3529	}
sl@0	3530	case ',': {
sl@0	3531	cflags \|= REG_PROGRESS;
sl@0	3532	break;
sl@0	3533	}
sl@0	3534	case '.': {
sl@0	3535	cflags \|= REG_DUMP;
sl@0	3536	break;
sl@0	3537	}
sl@0	3538	case ':': {
sl@0	3539	eflags \|= REG_MTRACE;
sl@0	3540	break;
sl@0	3541	}
sl@0	3542	case ';': {
sl@0	3543	eflags \|= REG_FTRACE;
sl@0	3544	break;
sl@0	3545	}
sl@0	3546	case '^': {
sl@0	3547	eflags \|= REG_NOTBOL;
sl@0	3548	break;
sl@0	3549	}
sl@0	3550	case '$': {
sl@0	3551	eflags \|= REG_NOTEOL;
sl@0	3552	break;
sl@0	3553	}
sl@0	3554	case 't': {
sl@0	3555	cflags \|= REG_EXPECT;
sl@0	3556	break;
sl@0	3557	}
sl@0	3558	case '%': {
sl@0	3559	eflags \|= REG_SMALL;
sl@0	3560	break;
sl@0	3561	}
sl@0	3562	}
sl@0	3563	}
sl@0	3564
sl@0	3565	*cflagsPtr = cflags;
sl@0	3566	*eflagsPtr = eflags;
sl@0	3567	}
sl@0	3568
sl@0	3569	/*
sl@0	3570	*----------------------------------------------------------------------
sl@0	3571	*
sl@0	3572	* TestsetassocdataCmd --
sl@0	3573	*
sl@0	3574	* This procedure implements the "testsetassocdata" command. It is used
sl@0	3575	* to test Tcl_SetAssocData.
sl@0	3576	*
sl@0	3577	* Results:
sl@0	3578	* A standard Tcl result.
sl@0	3579	*
sl@0	3580	* Side effects:
sl@0	3581	* Modifies or creates an association between a key and associated
sl@0	3582	* data for this interpreter.
sl@0	3583	*
sl@0	3584	*----------------------------------------------------------------------
sl@0	3585	*/
sl@0	3586
sl@0	3587	static int
sl@0	3588	TestsetassocdataCmd(clientData, interp, argc, argv)
sl@0	3589	ClientData clientData; /* Not used. */
sl@0	3590	Tcl_Interp interp; / Current interpreter. */
sl@0	3591	int argc; /* Number of arguments. */
sl@0	3592	CONST char *argv; / Argument strings. */
sl@0	3593	{
sl@0	3594	char *buf;
sl@0	3595	char *oldData;
sl@0	3596	Tcl_InterpDeleteProc *procPtr;
sl@0	3597
sl@0	3598	if (argc != 3) {
sl@0	3599	Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
sl@0	3600	" data_key data_item\"", (char *) NULL);
sl@0	3601	return TCL_ERROR;
sl@0	3602	}
sl@0	3603
sl@0	3604	buf = ckalloc((unsigned) strlen(argv[2]) + 1);
sl@0	3605	strcpy(buf, argv[2]);
sl@0	3606
sl@0	3607	/*
sl@0	3608	* If we previously associated a malloced value with the variable,
sl@0	3609	* free it before associating a new value.
sl@0	3610	*/
sl@0	3611
sl@0	3612	oldData = (char *) Tcl_GetAssocData(interp, argv[1], &procPtr);
sl@0	3613	if ((oldData != NULL) && (procPtr == CleanupTestSetassocdataTests)) {
sl@0	3614	ckfree(oldData);
sl@0	3615	}
sl@0	3616
sl@0	3617	Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests,
sl@0	3618	(ClientData) buf);
sl@0	3619	return TCL_OK;
sl@0	3620	}
sl@0	3621
sl@0	3622	/*
sl@0	3623	*----------------------------------------------------------------------
sl@0	3624	*
sl@0	3625	* TestsetplatformCmd --
sl@0	3626	*
sl@0	3627	* This procedure implements the "testsetplatform" command. It is
sl@0	3628	* used to change the tclPlatform global variable so all file
sl@0	3629	* name conversions can be tested on a single platform.
sl@0	3630	*
sl@0	3631	* Results:
sl@0	3632	* A standard Tcl result.
sl@0	3633	*
sl@0	3634	* Side effects:
sl@0	3635	* Sets the tclPlatform global variable.
sl@0	3636	*
sl@0	3637	*----------------------------------------------------------------------
sl@0	3638	*/
sl@0	3639
sl@0	3640	static int
sl@0	3641	TestsetplatformCmd(clientData, interp, argc, argv)
sl@0	3642	ClientData clientData; /* Not used. */
sl@0	3643	Tcl_Interp interp; / Current interpreter. */
sl@0	3644	int argc; /* Number of arguments. */
sl@0	3645	CONST char *argv; / Argument strings. */
sl@0	3646	{
sl@0	3647	size_t length;
sl@0	3648	TclPlatformType *platform;
sl@0	3649
sl@0	3650	#ifdef __WIN32__
sl@0	3651	platform = TclWinGetPlatform();
sl@0	3652	#else
sl@0	3653	platform = &tclPlatform;
sl@0	3654	#endif
sl@0	3655
sl@0	3656	if (argc != 2) {
sl@0	3657	Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
sl@0	3658	" platform\"", (char *) NULL);
sl@0	3659	return TCL_ERROR;
sl@0	3660	}
sl@0	3661
sl@0	3662	length = strlen(argv[1]);
sl@0	3663	if (strncmp(argv[1], "unix", length) == 0) {
sl@0	3664	*platform = TCL_PLATFORM_UNIX;
sl@0	3665	} else if (strncmp(argv[1], "mac", length) == 0) {
sl@0	3666	*platform = TCL_PLATFORM_MAC;
sl@0	3667	} else if (strncmp(argv[1], "windows", length) == 0) {
sl@0	3668	*platform = TCL_PLATFORM_WINDOWS;
sl@0	3669	} else {
sl@0	3670	Tcl_AppendResult(interp, "unsupported platform: should be one of ",
sl@0	3671	"unix, mac, or windows", (char *) NULL);
sl@0	3672	return TCL_ERROR;
sl@0	3673	}
sl@0	3674	return TCL_OK;
sl@0	3675	}
sl@0	3676
sl@0	3677	/*
sl@0	3678	*----------------------------------------------------------------------
sl@0	3679	*
sl@0	3680	* TeststaticpkgCmd --
sl@0	3681	*
sl@0	3682	* This procedure implements the "teststaticpkg" command.
sl@0	3683	* It is used to test the procedure Tcl_StaticPackage.
sl@0	3684	*
sl@0	3685	* Results:
sl@0	3686	* A standard Tcl result.
sl@0	3687	*
sl@0	3688	* Side effects:
sl@0	3689	* When the packge given by argv[1] is loaded into an interpeter,
sl@0	3690	* variable "x" in that interpreter is set to "loaded".
sl@0	3691	*
sl@0	3692	*----------------------------------------------------------------------
sl@0	3693	*/
sl@0	3694
sl@0	3695	static int
sl@0	3696	TeststaticpkgCmd(dummy, interp, argc, argv)
sl@0	3697	ClientData dummy; /* Not used. */
sl@0	3698	Tcl_Interp interp; / Current interpreter. */
sl@0	3699	int argc; /* Number of arguments. */
sl@0	3700	CONST char *argv; / Argument strings. */
sl@0	3701	{
sl@0	3702	int safe, loaded;
sl@0	3703
sl@0	3704	if (argc != 4) {
sl@0	3705	Tcl_AppendResult(interp, "wrong # arguments: should be \"",
sl@0	3706	argv[0], " pkgName safe loaded\"", (char *) NULL);
sl@0	3707	return TCL_ERROR;
sl@0	3708	}
sl@0	3709	if (Tcl_GetInt(interp, argv[2], &safe) != TCL_OK) {
sl@0	3710	return TCL_ERROR;
sl@0	3711	}
sl@0	3712	if (Tcl_GetInt(interp, argv[3], &loaded) != TCL_OK) {
sl@0	3713	return TCL_ERROR;
sl@0	3714	}
sl@0	3715	Tcl_StaticPackage((loaded) ? interp : NULL, argv[1], StaticInitProc,
sl@0	3716	(safe) ? StaticInitProc : NULL);
sl@0	3717	return TCL_OK;
sl@0	3718	}
sl@0	3719
sl@0	3720	static int
sl@0	3721	StaticInitProc(interp)
sl@0	3722	Tcl_Interp interp; / Interpreter in which package
sl@0	3723	* is supposedly being loaded. */
sl@0	3724	{
sl@0	3725	Tcl_SetVar(interp, "x", "loaded", TCL_GLOBAL_ONLY);
sl@0	3726	return TCL_OK;
sl@0	3727	}
sl@0	3728
sl@0	3729	/*
sl@0	3730	*----------------------------------------------------------------------
sl@0	3731	*
sl@0	3732	* TesttranslatefilenameCmd --
sl@0	3733	*
sl@0	3734	* This procedure implements the "testtranslatefilename" command.
sl@0	3735	* It is used to test the Tcl_TranslateFileName command.
sl@0	3736	*
sl@0	3737	* Results:
sl@0	3738	* A standard Tcl result.
sl@0	3739	*
sl@0	3740	* Side effects:
sl@0	3741	* None.
sl@0	3742	*
sl@0	3743	*----------------------------------------------------------------------
sl@0	3744	*/
sl@0	3745
sl@0	3746	static int
sl@0	3747	TesttranslatefilenameCmd(dummy, interp, argc, argv)
sl@0	3748	ClientData dummy; /* Not used. */
sl@0	3749	Tcl_Interp interp; / Current interpreter. */
sl@0	3750	int argc; /* Number of arguments. */
sl@0	3751	CONST char *argv; / Argument strings. */
sl@0	3752	{
sl@0	3753	Tcl_DString buffer;
sl@0	3754	CONST char *result;
sl@0	3755
sl@0	3756	if (argc != 2) {
sl@0	3757	Tcl_AppendResult(interp, "wrong # arguments: should be \"",
sl@0	3758	argv[0], " path\"", (char *) NULL);
sl@0	3759	return TCL_ERROR;
sl@0	3760	}
sl@0	3761	result = Tcl_TranslateFileName(interp, argv[1], &buffer);
sl@0	3762	if (result == NULL) {
sl@0	3763	return TCL_ERROR;
sl@0	3764	}
sl@0	3765	Tcl_AppendResult(interp, result, NULL);
sl@0	3766	Tcl_DStringFree(&buffer);
sl@0	3767	return TCL_OK;
sl@0	3768	}
sl@0	3769
sl@0	3770	/*
sl@0	3771	*----------------------------------------------------------------------
sl@0	3772	*
sl@0	3773	* TestupvarCmd --
sl@0	3774	*
sl@0	3775	* This procedure implements the "testupvar2" command. It is used
sl@0	3776	* to test Tcl_UpVar and Tcl_UpVar2.
sl@0	3777	*
sl@0	3778	* Results:
sl@0	3779	* A standard Tcl result.
sl@0	3780	*
sl@0	3781	* Side effects:
sl@0	3782	* Creates or modifies an "upvar" reference.
sl@0	3783	*
sl@0	3784	*----------------------------------------------------------------------
sl@0	3785	*/
sl@0	3786
sl@0	3787	/* ARGSUSED */
sl@0	3788	static int
sl@0	3789	TestupvarCmd(dummy, interp, argc, argv)
sl@0	3790	ClientData dummy; /* Not used. */
sl@0	3791	Tcl_Interp interp; / Current interpreter. */
sl@0	3792	int argc; /* Number of arguments. */
sl@0	3793	CONST char *argv; / Argument strings. */
sl@0	3794	{
sl@0	3795	int flags = 0;
sl@0	3796
sl@0	3797	if ((argc != 5) && (argc != 6)) {
sl@0	3798	Tcl_AppendResult(interp, "wrong # arguments: should be \"",
sl@0	3799	argv[0], " level name ?name2? dest global\"", (char *) NULL);
sl@0	3800	return TCL_ERROR;
sl@0	3801	}
sl@0	3802
sl@0	3803	if (argc == 5) {
sl@0	3804	if (strcmp(argv[4], "global") == 0) {
sl@0	3805	flags = TCL_GLOBAL_ONLY;
sl@0	3806	} else if (strcmp(argv[4], "namespace") == 0) {
sl@0	3807	flags = TCL_NAMESPACE_ONLY;
sl@0	3808	}
sl@0	3809	return Tcl_UpVar(interp, argv[1], argv[2], argv[3], flags);
sl@0	3810	} else {
sl@0	3811	if (strcmp(argv[5], "global") == 0) {
sl@0	3812	flags = TCL_GLOBAL_ONLY;
sl@0	3813	} else if (strcmp(argv[5], "namespace") == 0) {
sl@0	3814	flags = TCL_NAMESPACE_ONLY;
sl@0	3815	}
sl@0	3816	return Tcl_UpVar2(interp, argv[1], argv[2],
sl@0	3817	(argv[3][0] == 0) ? (char *) NULL : argv[3], argv[4],
sl@0	3818	flags);
sl@0	3819	}
sl@0	3820	}
sl@0	3821
sl@0	3822	/*
sl@0	3823	*----------------------------------------------------------------------
sl@0	3824	*
sl@0	3825	* TestseterrorcodeCmd --
sl@0	3826	*
sl@0	3827	* This procedure implements the "testseterrorcodeCmd".
sl@0	3828	* This tests up to five elements passed to the
sl@0	3829	* Tcl_SetErrorCode command.
sl@0	3830	*
sl@0	3831	* Results:
sl@0	3832	* A standard Tcl result. Always returns TCL_ERROR so that
sl@0	3833	* the error code can be tested.
sl@0	3834	*
sl@0	3835	* Side effects:
sl@0	3836	* None.
sl@0	3837	*
sl@0	3838	*----------------------------------------------------------------------
sl@0	3839	*/
sl@0	3840
sl@0	3841	/* ARGSUSED */
sl@0	3842	static int
sl@0	3843	TestseterrorcodeCmd(dummy, interp, argc, argv)
sl@0	3844	ClientData dummy; /* Not used. */
sl@0	3845	Tcl_Interp interp; / Current interpreter. */
sl@0	3846	int argc; /* Number of arguments. */
sl@0	3847	CONST char *argv; / Argument strings. */
sl@0	3848	{
sl@0	3849	if (argc > 6) {
sl@0	3850	Tcl_SetResult(interp, "too many args", TCL_STATIC);
sl@0	3851	return TCL_ERROR;
sl@0	3852	}
sl@0	3853	Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4],
sl@0	3854	argv[5], NULL);
sl@0	3855	return TCL_ERROR;
sl@0	3856	}
sl@0	3857
sl@0	3858	/*
sl@0	3859	*----------------------------------------------------------------------
sl@0	3860	*
sl@0	3861	* TestsetobjerrorcodeCmd --
sl@0	3862	*
sl@0	3863	* This procedure implements the "testsetobjerrorcodeCmd".
sl@0	3864	* This tests the Tcl_SetObjErrorCode function.
sl@0	3865	*
sl@0	3866	* Results:
sl@0	3867	* A standard Tcl result. Always returns TCL_ERROR so that
sl@0	3868	* the error code can be tested.
sl@0	3869	*
sl@0	3870	* Side effects:
sl@0	3871	* None.
sl@0	3872	*
sl@0	3873	*----------------------------------------------------------------------
sl@0	3874	*/
sl@0	3875
sl@0	3876	/* ARGSUSED */
sl@0	3877	static int
sl@0	3878	TestsetobjerrorcodeCmd(dummy, interp, objc, objv)
sl@0	3879	ClientData dummy; /* Not used. */
sl@0	3880	Tcl_Interp interp; / Current interpreter. */
sl@0	3881	int objc; /* Number of arguments. */
sl@0	3882	Tcl_Obj CONST objv[]; / The argument objects. */
sl@0	3883	{
sl@0	3884	Tcl_Obj *listObjPtr;
sl@0	3885
sl@0	3886	if (objc > 1) {
sl@0	3887	listObjPtr = Tcl_ConcatObj(objc - 1, objv + 1);
sl@0	3888	} else {
sl@0	3889	listObjPtr = Tcl_NewObj();
sl@0	3890	}
sl@0	3891	Tcl_IncrRefCount(listObjPtr);
sl@0	3892	Tcl_SetObjErrorCode(interp, listObjPtr);
sl@0	3893	Tcl_DecrRefCount(listObjPtr);
sl@0	3894	return TCL_ERROR;
sl@0	3895	}
sl@0	3896
sl@0	3897	/*
sl@0	3898	*----------------------------------------------------------------------
sl@0	3899	*
sl@0	3900	* TestfeventCmd --
sl@0	3901	*
sl@0	3902	* This procedure implements the "testfevent" command. It is
sl@0	3903	* used for testing the "fileevent" command.
sl@0	3904	*
sl@0	3905	* Results:
sl@0	3906	* A standard Tcl result.
sl@0	3907	*
sl@0	3908	* Side effects:
sl@0	3909	* Creates and deletes interpreters.
sl@0	3910	*
sl@0	3911	*----------------------------------------------------------------------
sl@0	3912	*/
sl@0	3913
sl@0	3914	/* ARGSUSED */
sl@0	3915	static int
sl@0	3916	TestfeventCmd(clientData, interp, argc, argv)
sl@0	3917	ClientData clientData; /* Not used. */
sl@0	3918	Tcl_Interp interp; / Current interpreter. */
sl@0	3919	int argc; /* Number of arguments. */
sl@0	3920	CONST char *argv; / Argument strings. */
sl@0	3921	{
sl@0	3922	static Tcl_Interp *interp2 = NULL;
sl@0	3923	int code;
sl@0	3924	Tcl_Channel chan;
sl@0	3925
sl@0	3926	if (argc < 2) {
sl@0	3927	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
sl@0	3928	" option ?arg arg ...?", (char *) NULL);
sl@0	3929	return TCL_ERROR;
sl@0	3930	}
sl@0	3931	if (strcmp(argv[1], "cmd") == 0) {
sl@0	3932	if (argc != 3) {
sl@0	3933	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
sl@0	3934	" cmd script", (char *) NULL);
sl@0	3935	return TCL_ERROR;
sl@0	3936	}
sl@0	3937	if (interp2 != (Tcl_Interp *) NULL) {
sl@0	3938	code = Tcl_GlobalEval(interp2, argv[2]);
sl@0	3939	Tcl_SetObjResult(interp, Tcl_GetObjResult(interp2));
sl@0	3940	return code;
sl@0	3941	} else {
sl@0	3942	Tcl_AppendResult(interp,
sl@0	3943	"called \"testfevent code\" before \"testfevent create\"",
sl@0	3944	(char *) NULL);
sl@0	3945	return TCL_ERROR;
sl@0	3946	}
sl@0	3947	} else if (strcmp(argv[1], "create") == 0) {
sl@0	3948	if (interp2 != NULL) {
sl@0	3949	Tcl_DeleteInterp(interp2);
sl@0	3950	}
sl@0	3951	interp2 = Tcl_CreateInterp();
sl@0	3952	return Tcl_Init(interp2);
sl@0	3953	} else if (strcmp(argv[1], "delete") == 0) {
sl@0	3954	if (interp2 != NULL) {
sl@0	3955	Tcl_DeleteInterp(interp2);
sl@0	3956	}
sl@0	3957	interp2 = NULL;
sl@0	3958	} else if (strcmp(argv[1], "share") == 0) {
sl@0	3959	if (interp2 != NULL) {
sl@0	3960	chan = Tcl_GetChannel(interp, argv[2], NULL);
sl@0	3961	if (chan == (Tcl_Channel) NULL) {
sl@0	3962	return TCL_ERROR;
sl@0	3963	}
sl@0	3964	Tcl_RegisterChannel(interp2, chan);
sl@0	3965	}
sl@0	3966	}
sl@0	3967
sl@0	3968	return TCL_OK;
sl@0	3969	}
sl@0	3970
sl@0	3971	/*
sl@0	3972	*----------------------------------------------------------------------
sl@0	3973	*
sl@0	3974	* TestpanicCmd --
sl@0	3975	*
sl@0	3976	* Calls the panic routine.
sl@0	3977	*
sl@0	3978	* Results:
sl@0	3979	* Always returns TCL_OK.
sl@0	3980	*
sl@0	3981	* Side effects:
sl@0	3982	* May exit application.
sl@0	3983	*
sl@0	3984	*----------------------------------------------------------------------
sl@0	3985	*/
sl@0	3986
sl@0	3987	static int
sl@0	3988	TestpanicCmd(dummy, interp, argc, argv)
sl@0	3989	ClientData dummy; /* Not used. */
sl@0	3990	Tcl_Interp interp; / Current interpreter. */
sl@0	3991	int argc; /* Number of arguments. */
sl@0	3992	CONST char *argv; / Argument strings. */
sl@0	3993	{
sl@0	3994	CONST char *argString;
sl@0	3995
sl@0	3996	/*
sl@0	3997	* Put the arguments into a var args structure
sl@0	3998	* Append all of the arguments together separated by spaces
sl@0	3999	*/
sl@0	4000
sl@0	4001	argString = Tcl_Merge(argc-1, argv+1);
sl@0	4002	panic(argString);
sl@0	4003	ckfree((char *)argString);
sl@0	4004
sl@0	4005	return TCL_OK;
sl@0	4006	}
sl@0	4007
sl@0	4008	static int
sl@0	4009	TestfileCmd(dummy, interp, argc, argv)
sl@0	4010	ClientData dummy; /* Not used. */
sl@0	4011	Tcl_Interp interp; / Current interpreter. */
sl@0	4012	int argc; /* Number of arguments. */
sl@0	4013	Tcl_Obj CONST argv[]; / The argument objects. */
sl@0	4014	{
sl@0	4015	int force, i, j, result;
sl@0	4016	Tcl_Obj *error = NULL;
sl@0	4017	char *subcmd;
sl@0	4018
sl@0	4019	if (argc < 3) {
sl@0	4020	return TCL_ERROR;
sl@0	4021	}
sl@0	4022
sl@0	4023	force = 0;
sl@0	4024	i = 2;
sl@0	4025	if (strcmp(Tcl_GetString(argv[2]), "-force") == 0) {
sl@0	4026	force = 1;
sl@0	4027	i = 3;
sl@0	4028	}
sl@0	4029
sl@0	4030	if (argc - i > 2) {
sl@0	4031	return TCL_ERROR;
sl@0	4032	}
sl@0	4033
sl@0	4034	for (j = i; j < argc; j++) {
sl@0	4035	if (Tcl_FSGetNormalizedPath(interp, argv[j]) == NULL) {
sl@0	4036	return TCL_ERROR;
sl@0	4037	}
sl@0	4038	}
sl@0	4039
sl@0	4040	subcmd = Tcl_GetString(argv[1]);
sl@0	4041
sl@0	4042	if (strcmp(subcmd, "mv") == 0) {
sl@0	4043	result = TclpObjRenameFile(argv[i], argv[i + 1]);
sl@0	4044	} else if (strcmp(subcmd, "cp") == 0) {
sl@0	4045	result = TclpObjCopyFile(argv[i], argv[i + 1]);
sl@0	4046	} else if (strcmp(subcmd, "rm") == 0) {
sl@0	4047	result = TclpObjDeleteFile(argv[i]);
sl@0	4048	} else if (strcmp(subcmd, "mkdir") == 0) {
sl@0	4049	result = TclpObjCreateDirectory(argv[i]);
sl@0	4050	} else if (strcmp(subcmd, "cpdir") == 0) {
sl@0	4051	result = TclpObjCopyDirectory(argv[i], argv[i + 1], &error);
sl@0	4052	} else if (strcmp(subcmd, "rmdir") == 0) {
sl@0	4053	result = TclpObjRemoveDirectory(argv[i], force, &error);
sl@0	4054	} else {
sl@0	4055	result = TCL_ERROR;
sl@0	4056	goto end;
sl@0	4057	}
sl@0	4058
sl@0	4059	if (result != TCL_OK) {
sl@0	4060	if (error != NULL) {
sl@0	4061	if (Tcl_GetString(error)[0] != '\0') {
sl@0	4062	Tcl_AppendResult(interp, Tcl_GetString(error), " ", NULL);
sl@0	4063	}
sl@0	4064	Tcl_DecrRefCount(error);
sl@0	4065	}
sl@0	4066	Tcl_AppendResult(interp, Tcl_ErrnoId(), (char *) NULL);
sl@0	4067	}
sl@0	4068
sl@0	4069	end:
sl@0	4070
sl@0	4071	return result;
sl@0	4072	}
sl@0	4073
sl@0	4074	/*
sl@0	4075	*----------------------------------------------------------------------
sl@0	4076	*
sl@0	4077	* TestgetvarfullnameCmd --
sl@0	4078	*
sl@0	4079	* Implements the "testgetvarfullname" cmd that is used when testing
sl@0	4080	* the Tcl_GetVariableFullName procedure.
sl@0	4081	*
sl@0	4082	* Results:
sl@0	4083	* A standard Tcl result.
sl@0	4084	*
sl@0	4085	* Side effects:
sl@0	4086	* None.
sl@0	4087	*
sl@0	4088	*----------------------------------------------------------------------
sl@0	4089	*/
sl@0	4090
sl@0	4091	static int
sl@0	4092	TestgetvarfullnameCmd(dummy, interp, objc, objv)
sl@0	4093	ClientData dummy; /* Not used. */
sl@0	4094	Tcl_Interp interp; / Current interpreter. */
sl@0	4095	int objc; /* Number of arguments. */
sl@0	4096	Tcl_Obj CONST objv[]; / The argument objects. */
sl@0	4097	{
sl@0	4098	char name, arg;
sl@0	4099	int flags = 0;
sl@0	4100	Tcl_Namespace *namespacePtr;
sl@0	4101	Tcl_CallFrame frame;
sl@0	4102	Tcl_Var variable;
sl@0	4103	int result;
sl@0	4104
sl@0	4105	if (objc != 3) {
sl@0	4106	Tcl_WrongNumArgs(interp, 1, objv, "name scope");
sl@0	4107	return TCL_ERROR;
sl@0	4108	}
sl@0	4109
sl@0	4110	name = Tcl_GetString(objv[1]);
sl@0	4111
sl@0	4112	arg = Tcl_GetString(objv[2]);
sl@0	4113	if (strcmp(arg, "global") == 0) {
sl@0	4114	flags = TCL_GLOBAL_ONLY;
sl@0	4115	} else if (strcmp(arg, "namespace") == 0) {
sl@0	4116	flags = TCL_NAMESPACE_ONLY;
sl@0	4117	}
sl@0	4118
sl@0	4119	/*
sl@0	4120	* This command, like any other created with Tcl_Create[Obj]Command,
sl@0	4121	* runs in the global namespace. As a "namespace-aware" command that
sl@0	4122	* needs to run in a particular namespace, it must activate that
sl@0	4123	* namespace itself.
sl@0	4124	*/
sl@0	4125
sl@0	4126	if (flags == TCL_NAMESPACE_ONLY) {
sl@0	4127	namespacePtr = Tcl_FindNamespace(interp, "::test_ns_var",
sl@0	4128	(Tcl_Namespace *) NULL, TCL_LEAVE_ERR_MSG);
sl@0	4129	if (namespacePtr == NULL) {
sl@0	4130	return TCL_ERROR;
sl@0	4131	}
sl@0	4132	result = Tcl_PushCallFrame(interp, &frame, namespacePtr,
sl@0	4133	/isProcCallFrame/ 0);
sl@0	4134	if (result != TCL_OK) {
sl@0	4135	return result;
sl@0	4136	}
sl@0	4137	}
sl@0	4138
sl@0	4139	variable = Tcl_FindNamespaceVar(interp, name, (Tcl_Namespace *) NULL,
sl@0	4140	(flags \| TCL_LEAVE_ERR_MSG));
sl@0	4141
sl@0	4142	if (flags == TCL_NAMESPACE_ONLY) {
sl@0	4143	Tcl_PopCallFrame(interp);
sl@0	4144	}
sl@0	4145	if (variable == (Tcl_Var) NULL) {
sl@0	4146	return TCL_ERROR;
sl@0	4147	}
sl@0	4148	Tcl_GetVariableFullName(interp, variable, Tcl_GetObjResult(interp));
sl@0	4149	return TCL_OK;
sl@0	4150	}
sl@0	4151
sl@0	4152	/*
sl@0	4153	*----------------------------------------------------------------------
sl@0	4154	*
sl@0	4155	* GetTimesCmd --
sl@0	4156	*
sl@0	4157	* This procedure implements the "gettimes" command. It is
sl@0	4158	* used for computing the time needed for various basic operations
sl@0	4159	* such as reading variables, allocating memory, sprintf, converting
sl@0	4160	* variables, etc.
sl@0	4161	*
sl@0	4162	* Results:
sl@0	4163	* A standard Tcl result.
sl@0	4164	*
sl@0	4165	* Side effects:
sl@0	4166	* Allocates and frees memory, sets a variable "a" in the interpreter.
sl@0	4167	*
sl@0	4168	*----------------------------------------------------------------------
sl@0	4169	*/
sl@0	4170
sl@0	4171	static int
sl@0	4172	GetTimesCmd(unused, interp, argc, argv)
sl@0	4173	ClientData unused; /* Unused. */
sl@0	4174	Tcl_Interp interp; / The current interpreter. */
sl@0	4175	int argc; /* The number of arguments. */
sl@0	4176	CONST char *argv; / The argument strings. */
sl@0	4177	{
sl@0	4178	Interp iPtr = (Interp ) interp;
sl@0	4179	int i, n;
sl@0	4180	double timePer;
sl@0	4181	Tcl_Time start, stop;
sl@0	4182	Tcl_Obj *objPtr;
sl@0	4183	Tcl_Obj **objv;
sl@0	4184	CONST char *s;
sl@0	4185	char newString[TCL_INTEGER_SPACE];
sl@0	4186
sl@0	4187	/* alloc & free 100000 times */
sl@0	4188	fprintf(stderr, "alloc & free 100000 6 word items\n");
sl@0	4189	Tcl_GetTime(&start);
sl@0	4190	for (i = 0; i < 100000; i++) {
sl@0	4191	objPtr = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj));
sl@0	4192	ckfree((char *) objPtr);
sl@0	4193	}
sl@0	4194	Tcl_GetTime(&stop);
sl@0	4195	timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
sl@0	4196	fprintf(stderr, " %.3f usec per alloc+free\n", timePer/100000);
sl@0	4197
sl@0	4198	/* alloc 5000 times */
sl@0	4199	fprintf(stderr, "alloc 5000 6 word items\n");
sl@0	4200	objv = (Tcl_Obj *) ckalloc(5000 sizeof(Tcl_Obj *));
sl@0	4201	Tcl_GetTime(&start);
sl@0	4202	for (i = 0; i < 5000; i++) {
sl@0	4203	objv[i] = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj));
sl@0	4204	}
sl@0	4205	Tcl_GetTime(&stop);
sl@0	4206	timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
sl@0	4207	fprintf(stderr, " %.3f usec per alloc\n", timePer/5000);
sl@0	4208
sl@0	4209	/* free 5000 times */
sl@0	4210	fprintf(stderr, "free 5000 6 word items\n");
sl@0	4211	Tcl_GetTime(&start);
sl@0	4212	for (i = 0; i < 5000; i++) {
sl@0	4213	ckfree((char *) objv[i]);
sl@0	4214	}
sl@0	4215	Tcl_GetTime(&stop);
sl@0	4216	timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
sl@0	4217	fprintf(stderr, " %.3f usec per free\n", timePer/5000);
sl@0	4218
sl@0	4219	/* Tcl_NewObj 5000 times */
sl@0	4220	fprintf(stderr, "Tcl_NewObj 5000 times\n");
sl@0	4221	Tcl_GetTime(&start);
sl@0	4222	for (i = 0; i < 5000; i++) {
sl@0	4223	objv[i] = Tcl_NewObj();
sl@0	4224	}
sl@0	4225	Tcl_GetTime(&stop);
sl@0	4226	timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
sl@0	4227	fprintf(stderr, " %.3f usec per Tcl_NewObj\n", timePer/5000);
sl@0	4228
sl@0	4229	/* Tcl_DecrRefCount 5000 times */
sl@0	4230	fprintf(stderr, "Tcl_DecrRefCount 5000 times\n");
sl@0	4231	Tcl_GetTime(&start);
sl@0	4232	for (i = 0; i < 5000; i++) {
sl@0	4233	objPtr = objv[i];
sl@0	4234	Tcl_DecrRefCount(objPtr);
sl@0	4235	}
sl@0	4236	Tcl_GetTime(&stop);
sl@0	4237	timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
sl@0	4238	fprintf(stderr, " %.3f usec per Tcl_DecrRefCount\n", timePer/5000);
sl@0	4239	ckfree((char *) objv);
sl@0	4240
sl@0	4241	/* TclGetString 100000 times */
sl@0	4242	fprintf(stderr, "TclGetStringFromObj of \"12345\" 100000 times\n");
sl@0	4243	objPtr = Tcl_NewStringObj("12345", -1);
sl@0	4244	Tcl_GetTime(&start);
sl@0	4245	for (i = 0; i < 100000; i++) {
sl@0	4246	(void) TclGetString(objPtr);
sl@0	4247	}
sl@0	4248	Tcl_GetTime(&stop);
sl@0	4249	timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
sl@0	4250	fprintf(stderr, " %.3f usec per TclGetStringFromObj of \"12345\"\n",
sl@0	4251	timePer/100000);
sl@0	4252
sl@0	4253	/* Tcl_GetIntFromObj 100000 times */
sl@0	4254	fprintf(stderr, "Tcl_GetIntFromObj of \"12345\" 100000 times\n");
sl@0	4255	Tcl_GetTime(&start);
sl@0	4256	for (i = 0; i < 100000; i++) {
sl@0	4257	if (Tcl_GetIntFromObj(interp, objPtr, &n) != TCL_OK) {
sl@0	4258	return TCL_ERROR;
sl@0	4259	}
sl@0	4260	}
sl@0	4261	Tcl_GetTime(&stop);
sl@0	4262	timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
sl@0	4263	fprintf(stderr, " %.3f usec per Tcl_GetIntFromObj of \"12345\"\n",
sl@0	4264	timePer/100000);
sl@0	4265	Tcl_DecrRefCount(objPtr);
sl@0	4266
sl@0	4267	/* Tcl_GetInt 100000 times */
sl@0	4268	fprintf(stderr, "Tcl_GetInt of \"12345\" 100000 times\n");
sl@0	4269	Tcl_GetTime(&start);
sl@0	4270	for (i = 0; i < 100000; i++) {
sl@0	4271	if (Tcl_GetInt(interp, "12345", &n) != TCL_OK) {
sl@0	4272	return TCL_ERROR;
sl@0	4273	}
sl@0	4274	}
sl@0	4275	Tcl_GetTime(&stop);
sl@0	4276	timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
sl@0	4277	fprintf(stderr, " %.3f usec per Tcl_GetInt of \"12345\"\n",
sl@0	4278	timePer/100000);
sl@0	4279
sl@0	4280	/* sprintf 100000 times */
sl@0	4281	fprintf(stderr, "sprintf of 12345 100000 times\n");
sl@0	4282	Tcl_GetTime(&start);
sl@0	4283	for (i = 0; i < 100000; i++) {
sl@0	4284	sprintf(newString, "%d", 12345);
sl@0	4285	}
sl@0	4286	Tcl_GetTime(&stop);
sl@0	4287	timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
sl@0	4288	fprintf(stderr, " %.3f usec per sprintf of 12345\n",
sl@0	4289	timePer/100000);
sl@0	4290
sl@0	4291	/* hashtable lookup 100000 times */
sl@0	4292	fprintf(stderr, "hashtable lookup of \"gettimes\" 100000 times\n");
sl@0	4293	Tcl_GetTime(&start);
sl@0	4294	for (i = 0; i < 100000; i++) {
sl@0	4295	(void) Tcl_FindHashEntry(&iPtr->globalNsPtr->cmdTable, "gettimes");
sl@0	4296	}
sl@0	4297	Tcl_GetTime(&stop);
sl@0	4298	timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
sl@0	4299	fprintf(stderr, " %.3f usec per hashtable lookup of \"gettimes\"\n",
sl@0	4300	timePer/100000);
sl@0	4301
sl@0	4302	/* Tcl_SetVar 100000 times */
sl@0	4303	fprintf(stderr, "Tcl_SetVar of \"12345\" 100000 times\n");
sl@0	4304	Tcl_GetTime(&start);
sl@0	4305	for (i = 0; i < 100000; i++) {
sl@0	4306	s = Tcl_SetVar(interp, "a", "12345", TCL_LEAVE_ERR_MSG);
sl@0	4307	if (s == NULL) {
sl@0	4308	return TCL_ERROR;
sl@0	4309	}
sl@0	4310	}
sl@0	4311	Tcl_GetTime(&stop);
sl@0	4312	timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
sl@0	4313	fprintf(stderr, " %.3f usec per Tcl_SetVar of a to \"12345\"\n",
sl@0	4314	timePer/100000);
sl@0	4315
sl@0	4316	/* Tcl_GetVar 100000 times */
sl@0	4317	fprintf(stderr, "Tcl_GetVar of a==\"12345\" 100000 times\n");
sl@0	4318	Tcl_GetTime(&start);
sl@0	4319	for (i = 0; i < 100000; i++) {
sl@0	4320	s = Tcl_GetVar(interp, "a", TCL_LEAVE_ERR_MSG);
sl@0	4321	if (s == NULL) {
sl@0	4322	return TCL_ERROR;
sl@0	4323	}
sl@0	4324	}
sl@0	4325	Tcl_GetTime(&stop);
sl@0	4326	timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
sl@0	4327	fprintf(stderr, " %.3f usec per Tcl_GetVar of a==\"12345\"\n",
sl@0	4328	timePer/100000);
sl@0	4329
sl@0	4330	Tcl_ResetResult(interp);
sl@0	4331	return TCL_OK;
sl@0	4332	}
sl@0	4333
sl@0	4334	/*
sl@0	4335	*----------------------------------------------------------------------
sl@0	4336	*
sl@0	4337	* NoopCmd --
sl@0	4338	*
sl@0	4339	* This procedure is just used to time the overhead involved in
sl@0	4340	* parsing and invoking a command.
sl@0	4341	*
sl@0	4342	* Results:
sl@0	4343	* None.
sl@0	4344	*
sl@0	4345	* Side effects:
sl@0	4346	* None.
sl@0	4347	*
sl@0	4348	*----------------------------------------------------------------------
sl@0	4349	*/
sl@0	4350
sl@0	4351	static int
sl@0	4352	NoopCmd(unused, interp, argc, argv)
sl@0	4353	ClientData unused; /* Unused. */
sl@0	4354	Tcl_Interp interp; / The current interpreter. */
sl@0	4355	int argc; /* The number of arguments. */
sl@0	4356	CONST char *argv; / The argument strings. */
sl@0	4357	{
sl@0	4358	return TCL_OK;
sl@0	4359	}
sl@0	4360
sl@0	4361	/*
sl@0	4362	*----------------------------------------------------------------------
sl@0	4363	*
sl@0	4364	* NoopObjCmd --
sl@0	4365	*
sl@0	4366	* This object-based procedure is just used to time the overhead
sl@0	4367	* involved in parsing and invoking a command.
sl@0	4368	*
sl@0	4369	* Results:
sl@0	4370	* Returns the TCL_OK result code.
sl@0	4371	*
sl@0	4372	* Side effects:
sl@0	4373	* None.
sl@0	4374	*
sl@0	4375	*----------------------------------------------------------------------
sl@0	4376	*/
sl@0	4377
sl@0	4378	static int
sl@0	4379	NoopObjCmd(unused, interp, objc, objv)
sl@0	4380	ClientData unused; /* Not used. */
sl@0	4381	Tcl_Interp interp; / Current interpreter. */
sl@0	4382	int objc; /* Number of arguments. */
sl@0	4383	Tcl_Obj CONST objv[]; / The argument objects. */
sl@0	4384	{
sl@0	4385	return TCL_OK;
sl@0	4386	}
sl@0	4387
sl@0	4388	/*
sl@0	4389	*----------------------------------------------------------------------
sl@0	4390	*
sl@0	4391	* TestsetCmd --
sl@0	4392	*
sl@0	4393	* Implements the "testset{err,noerr}" cmds that are used when testing
sl@0	4394	* Tcl_Set/GetVar C Api with/without TCL_LEAVE_ERR_MSG flag
sl@0	4395	*
sl@0	4396	* Results:
sl@0	4397	* A standard Tcl result.
sl@0	4398	*
sl@0	4399	* Side effects:
sl@0	4400	* Variables may be set.
sl@0	4401	*
sl@0	4402	*----------------------------------------------------------------------
sl@0	4403	*/
sl@0	4404
sl@0	4405	/* ARGSUSED */
sl@0	4406	static int
sl@0	4407	TestsetCmd(data, interp, argc, argv)
sl@0	4408	ClientData data; /* Additional flags for Get/SetVar2. */
sl@0	4409	register Tcl_Interp interp; / Current interpreter. */
sl@0	4410	int argc; /* Number of arguments. */
sl@0	4411	CONST char *argv; / Argument strings. */
sl@0	4412	{
sl@0	4413	int flags = (int) data;
sl@0	4414	CONST char *value;
sl@0	4415
sl@0	4416	if (argc == 2) {
sl@0	4417	Tcl_SetResult(interp, "before get", TCL_STATIC);
sl@0	4418	value = Tcl_GetVar2(interp, argv[1], (char *) NULL, flags);
sl@0	4419	if (value == NULL) {
sl@0	4420	return TCL_ERROR;
sl@0	4421	}
sl@0	4422	Tcl_AppendElement(interp, value);
sl@0	4423	return TCL_OK;
sl@0	4424	} else if (argc == 3) {
sl@0	4425	Tcl_SetResult(interp, "before set", TCL_STATIC);
sl@0	4426	value = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2], flags);
sl@0	4427	if (value == NULL) {
sl@0	4428	return TCL_ERROR;
sl@0	4429	}
sl@0	4430	Tcl_AppendElement(interp, value);
sl@0	4431	return TCL_OK;
sl@0	4432	} else {
sl@0	4433	Tcl_AppendResult(interp, "wrong # args: should be \"",
sl@0	4434	argv[0], " varName ?newValue?\"", (char *) NULL);
sl@0	4435	return TCL_ERROR;
sl@0	4436	}
sl@0	4437	}
sl@0	4438
sl@0	4439	/*
sl@0	4440	*----------------------------------------------------------------------
sl@0	4441	*
sl@0	4442	* TestsaveresultCmd --
sl@0	4443	*
sl@0	4444	* Implements the "testsaveresult" cmd that is used when testing
sl@0	4445	* the Tcl_SaveResult, Tcl_RestoreResult, and
sl@0	4446	* Tcl_DiscardResult interfaces.
sl@0	4447	*
sl@0	4448	* Results:
sl@0	4449	* A standard Tcl result.
sl@0	4450	*
sl@0	4451	* Side effects:
sl@0	4452	* None.
sl@0	4453	*
sl@0	4454	*----------------------------------------------------------------------
sl@0	4455	*/
sl@0	4456
sl@0	4457	/* ARGSUSED */
sl@0	4458	static int
sl@0	4459	TestsaveresultCmd(dummy, interp, objc, objv)
sl@0	4460	ClientData dummy; /* Not used. */
sl@0	4461	register Tcl_Interp interp; / Current interpreter. */
sl@0	4462	int objc; /* Number of arguments. */
sl@0	4463	Tcl_Obj CONST objv[]; / The argument objects. */
sl@0	4464	{
sl@0	4465	int discard, result, index;
sl@0	4466	Tcl_SavedResult state;
sl@0	4467	Tcl_Obj *objPtr;
sl@0	4468	static CONST char *optionStrings[] = {
sl@0	4469	"append", "dynamic", "free", "object", "small", NULL
sl@0	4470	};
sl@0	4471	enum options {
sl@0	4472	RESULT_APPEND, RESULT_DYNAMIC, RESULT_FREE, RESULT_OBJECT, RESULT_SMALL
sl@0	4473	};
sl@0	4474
sl@0	4475	/*
sl@0	4476	* Parse arguments
sl@0	4477	*/
sl@0	4478
sl@0	4479	if (objc != 4) {
sl@0	4480	Tcl_WrongNumArgs(interp, 1, objv, "type script discard");
sl@0	4481	return TCL_ERROR;
sl@0	4482	}
sl@0	4483	if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
sl@0	4484	&index) != TCL_OK) {
sl@0	4485	return TCL_ERROR;
sl@0	4486	}
sl@0	4487	if (Tcl_GetBooleanFromObj(interp, objv[3], &discard) != TCL_OK) {
sl@0	4488	return TCL_ERROR;
sl@0	4489	}
sl@0	4490
sl@0	4491	objPtr = NULL; /* Lint. */
sl@0	4492	switch ((enum options) index) {
sl@0	4493	case RESULT_SMALL:
sl@0	4494	Tcl_SetResult(interp, "small result", TCL_VOLATILE);
sl@0	4495	break;
sl@0	4496	case RESULT_APPEND:
sl@0	4497	Tcl_AppendResult(interp, "append result", NULL);
sl@0	4498	break;
sl@0	4499	case RESULT_FREE: {
sl@0	4500	char *buf = ckalloc(200);
sl@0	4501	strcpy(buf, "free result");
sl@0	4502	Tcl_SetResult(interp, buf, TCL_DYNAMIC);
sl@0	4503	break;
sl@0	4504	}
sl@0	4505	case RESULT_DYNAMIC:
sl@0	4506	Tcl_SetResult(interp, "dynamic result", TestsaveresultFree);
sl@0	4507	break;
sl@0	4508	case RESULT_OBJECT:
sl@0	4509	objPtr = Tcl_NewStringObj("object result", -1);
sl@0	4510	Tcl_SetObjResult(interp, objPtr);
sl@0	4511	break;
sl@0	4512	}
sl@0	4513
sl@0	4514	freeCount = 0;
sl@0	4515	Tcl_SaveResult(interp, &state);
sl@0	4516
sl@0	4517	if (((enum options) index) == RESULT_OBJECT) {
sl@0	4518	result = Tcl_EvalObjEx(interp, objv[2], 0);
sl@0	4519	} else {
sl@0	4520	result = Tcl_Eval(interp, Tcl_GetString(objv[2]));
sl@0	4521	}
sl@0	4522
sl@0	4523	if (discard) {
sl@0	4524	Tcl_DiscardResult(&state);
sl@0	4525	} else {
sl@0	4526	Tcl_RestoreResult(interp, &state);
sl@0	4527	result = TCL_OK;
sl@0	4528	}
sl@0	4529
sl@0	4530	switch ((enum options) index) {
sl@0	4531	case RESULT_DYNAMIC: {
sl@0	4532	int present = interp->freeProc == TestsaveresultFree;
sl@0	4533	int called = freeCount;
sl@0	4534	Tcl_AppendElement(interp, called ? "called" : "notCalled");
sl@0	4535	Tcl_AppendElement(interp, present ? "present" : "missing");
sl@0	4536	break;
sl@0	4537	}
sl@0	4538	case RESULT_OBJECT:
sl@0	4539	Tcl_AppendElement(interp, Tcl_GetObjResult(interp) == objPtr
sl@0	4540	? "same" : "different");
sl@0	4541	break;
sl@0	4542	default:
sl@0	4543	break;
sl@0	4544	}
sl@0	4545	return result;
sl@0	4546	}
sl@0	4547
sl@0	4548	/*
sl@0	4549	*----------------------------------------------------------------------
sl@0	4550	*
sl@0	4551	* TestsaveresultFree --
sl@0	4552	*
sl@0	4553	* Special purpose freeProc used by TestsaveresultCmd.
sl@0	4554	*
sl@0	4555	* Results:
sl@0	4556	* None.
sl@0	4557	*
sl@0	4558	* Side effects:
sl@0	4559	* Increments the freeCount.
sl@0	4560	*
sl@0	4561	*----------------------------------------------------------------------
sl@0	4562	*/
sl@0	4563
sl@0	4564	static void
sl@0	4565	TestsaveresultFree(blockPtr)
sl@0	4566	char *blockPtr;
sl@0	4567	{
sl@0	4568	freeCount++;
sl@0	4569	}
sl@0	4570
sl@0	4571	/*
sl@0	4572	*----------------------------------------------------------------------
sl@0	4573	*
sl@0	4574	* TeststatprocCmd --
sl@0	4575	*
sl@0	4576	* Implements the "testTclStatProc" cmd that is used to test the
sl@0	4577	* 'TclStatInsertProc' & 'TclStatDeleteProc' C Apis.
sl@0	4578	*
sl@0	4579	* Results:
sl@0	4580	* A standard Tcl result.
sl@0	4581	*
sl@0	4582	* Side effects:
sl@0	4583	* None.
sl@0	4584	*
sl@0	4585	*----------------------------------------------------------------------
sl@0	4586	*/
sl@0	4587
sl@0	4588	static int
sl@0	4589	TeststatprocCmd (dummy, interp, argc, argv)
sl@0	4590	ClientData dummy; /* Not used. */
sl@0	4591	register Tcl_Interp interp; / Current interpreter. */
sl@0	4592	int argc; /* Number of arguments. */
sl@0	4593	CONST char *argv; / Argument strings. */
sl@0	4594	{
sl@0	4595	TclStatProc_ *proc;
sl@0	4596	int retVal;
sl@0	4597
sl@0	4598	if (argc != 3) {
sl@0	4599	Tcl_AppendResult(interp, "wrong # args: should be \"",
sl@0	4600	argv[0], " option arg\"", (char *) NULL);
sl@0	4601	return TCL_ERROR;
sl@0	4602	}
sl@0	4603
sl@0	4604	if (strcmp(argv[2], "TclpStat") == 0) {
sl@0	4605	proc = PretendTclpStat;
sl@0	4606	} else if (strcmp(argv[2], "TestStatProc1") == 0) {
sl@0	4607	proc = TestStatProc1;
sl@0	4608	} else if (strcmp(argv[2], "TestStatProc2") == 0) {
sl@0	4609	proc = TestStatProc2;
sl@0	4610	} else if (strcmp(argv[2], "TestStatProc3") == 0) {
sl@0	4611	proc = TestStatProc3;
sl@0	4612	} else {
sl@0	4613	Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ",
sl@0	4614	"must be TclpStat, ",
sl@0	4615	"TestStatProc1, TestStatProc2, or TestStatProc3",
sl@0	4616	(char *) NULL);
sl@0	4617	return TCL_ERROR;
sl@0	4618	}
sl@0	4619
sl@0	4620	if (strcmp(argv[1], "insert") == 0) {
sl@0	4621	if (proc == PretendTclpStat) {
sl@0	4622	Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ",
sl@0	4623	"must be ",
sl@0	4624	"TestStatProc1, TestStatProc2, or TestStatProc3",
sl@0	4625	(char *) NULL);
sl@0	4626	return TCL_ERROR;
sl@0	4627	}
sl@0	4628	retVal = TclStatInsertProc(proc);
sl@0	4629	} else if (strcmp(argv[1], "delete") == 0) {
sl@0	4630	retVal = TclStatDeleteProc(proc);
sl@0	4631	} else {
sl@0	4632	Tcl_AppendResult(interp, "bad option \"", argv[1], "\": ",
sl@0	4633	"must be insert or delete", (char *) NULL);
sl@0	4634	return TCL_ERROR;
sl@0	4635	}
sl@0	4636
sl@0	4637	if (retVal == TCL_ERROR) {
sl@0	4638	Tcl_AppendResult(interp, "\"", argv[2], "\": ",
sl@0	4639	"could not be ", argv[1], "ed", (char *) NULL);
sl@0	4640	}
sl@0	4641
sl@0	4642	return retVal;
sl@0	4643	}
sl@0	4644
sl@0	4645	static int PretendTclpStat(path, buf)
sl@0	4646	CONST char *path;
sl@0	4647	struct stat *buf;
sl@0	4648	{
sl@0	4649	int ret;
sl@0	4650	Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1);
sl@0	4651	#ifdef TCL_WIDE_INT_IS_LONG
sl@0	4652	Tcl_IncrRefCount(pathPtr);
sl@0	4653	ret = TclpObjStat(pathPtr, buf);
sl@0	4654	Tcl_DecrRefCount(pathPtr);
sl@0	4655	return ret;
sl@0	4656	#else /* TCL_WIDE_INT_IS_LONG */
sl@0	4657	Tcl_StatBuf realBuf;
sl@0	4658	Tcl_IncrRefCount(pathPtr);
sl@0	4659	ret = TclpObjStat(pathPtr, &realBuf);
sl@0	4660	Tcl_DecrRefCount(pathPtr);
sl@0	4661	if (ret != -1) {
sl@0	4662	# define OUT_OF_RANGE(x) \
sl@0	4663	(((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) \|\| \
sl@0	4664	((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX))
sl@0	4665	#if defined(__GNUC__) && __GNUC__ >= 2
sl@0	4666	/*
sl@0	4667	* Workaround gcc warning of "comparison is always false due to limited range of
sl@0	4668	* data type" in this macro by checking max type size, and when necessary ANDing
sl@0	4669	* with the complement of ULONG_MAX instead of the comparison:
sl@0	4670	*/
sl@0	4671	# define OUT_OF_URANGE(x) \
sl@0	4672	((((Tcl_WideUInt)(~ (__typeof__(x)) 0)) > (Tcl_WideUInt)ULONG_MAX) && \
sl@0	4673	(((Tcl_WideUInt)(x)) & ~(Tcl_WideUInt)ULONG_MAX))
sl@0	4674	#else
sl@0	4675	# define OUT_OF_URANGE(x) \
sl@0	4676	(((Tcl_WideUInt)(x)) > (Tcl_WideUInt)ULONG_MAX)
sl@0	4677	#endif
sl@0	4678
sl@0	4679	/*
sl@0	4680	* Perform the result-buffer overflow check manually.
sl@0	4681	*
sl@0	4682	* Note that ino_t/ino64_t is unsigned...
sl@0	4683	*/
sl@0	4684
sl@0	4685	if (OUT_OF_URANGE(realBuf.st_ino) \|\| OUT_OF_RANGE(realBuf.st_size)
sl@0	4686	# ifdef HAVE_ST_BLOCKS
sl@0	4687	\|\| OUT_OF_RANGE(realBuf.st_blocks)
sl@0	4688	# endif
sl@0	4689	) {
sl@0	4690	# ifdef EOVERFLOW
sl@0	4691	errno = EOVERFLOW;
sl@0	4692	# else
sl@0	4693	# ifdef EFBIG
sl@0	4694	errno = EFBIG;
sl@0	4695	# else
sl@0	4696	# error "what error should be returned for a value out of range?"
sl@0	4697	# endif
sl@0	4698	# endif
sl@0	4699	return -1;
sl@0	4700	}
sl@0	4701
sl@0	4702	# undef OUT_OF_RANGE
sl@0	4703	# undef OUT_OF_URANGE
sl@0	4704
sl@0	4705	/*
sl@0	4706	* Copy across all supported fields, with possible type
sl@0	4707	* coercions on those fields that change between the normal
sl@0	4708	* and lf64 versions of the stat structure (on Solaris at
sl@0	4709	* least.) This is slow when the structure sizes coincide,
sl@0	4710	* but that's what you get for mixing interfaces...
sl@0	4711	*/
sl@0	4712
sl@0	4713	buf->st_mode = realBuf.st_mode;
sl@0	4714	buf->st_ino = (ino_t) realBuf.st_ino;
sl@0	4715	buf->st_dev = realBuf.st_dev;
sl@0	4716	buf->st_rdev = realBuf.st_rdev;
sl@0	4717	buf->st_nlink = realBuf.st_nlink;
sl@0	4718	buf->st_uid = realBuf.st_uid;
sl@0	4719	buf->st_gid = realBuf.st_gid;
sl@0	4720	buf->st_size = (off_t) realBuf.st_size;
sl@0	4721	buf->st_atime = realBuf.st_atime;
sl@0	4722	buf->st_mtime = realBuf.st_mtime;
sl@0	4723	buf->st_ctime = realBuf.st_ctime;
sl@0	4724	# ifdef HAVE_ST_BLOCKS
sl@0	4725	buf->st_blksize = realBuf.st_blksize;
sl@0	4726	buf->st_blocks = (blkcnt_t) realBuf.st_blocks;
sl@0	4727	# endif
sl@0	4728	}
sl@0	4729	return ret;
sl@0	4730	#endif /* TCL_WIDE_INT_IS_LONG */
sl@0	4731	}
sl@0	4732
sl@0	4733	/* Be careful in the compares in these tests, since the Macintosh puts a
sl@0	4734	* leading : in the beginning of non-absolute paths before passing them
sl@0	4735	* into the file command procedures.
sl@0	4736	*/
sl@0	4737
sl@0	4738	static int
sl@0	4739	TestStatProc1(path, buf)
sl@0	4740	CONST char *path;
sl@0	4741	struct stat *buf;
sl@0	4742	{
sl@0	4743	memset(buf, 0, sizeof(struct stat));
sl@0	4744	buf->st_size = 1234;
sl@0	4745	return ((strstr(path, "testStat1%.fil") == NULL) ? -1 : 0);
sl@0	4746	}
sl@0	4747
sl@0	4748
sl@0	4749	static int
sl@0	4750	TestStatProc2(path, buf)
sl@0	4751	CONST char *path;
sl@0	4752	struct stat *buf;
sl@0	4753	{
sl@0	4754	memset(buf, 0, sizeof(struct stat));
sl@0	4755	buf->st_size = 2345;
sl@0	4756	return ((strstr(path, "testStat2%.fil") == NULL) ? -1 : 0);
sl@0	4757	}
sl@0	4758
sl@0	4759
sl@0	4760	static int
sl@0	4761	TestStatProc3(path, buf)
sl@0	4762	CONST char *path;
sl@0	4763	struct stat *buf;
sl@0	4764	{
sl@0	4765	memset(buf, 0, sizeof(struct stat));
sl@0	4766	buf->st_size = 3456;
sl@0	4767	return ((strstr(path, "testStat3%.fil") == NULL) ? -1 : 0);
sl@0	4768	}
sl@0	4769
sl@0	4770	/*
sl@0	4771	*----------------------------------------------------------------------
sl@0	4772	*
sl@0	4773	* TestmainthreadCmd --
sl@0	4774	*
sl@0	4775	* Implements the "testmainthread" cmd that is used to test the
sl@0	4776	* 'Tcl_GetCurrentThread' API.
sl@0	4777	*
sl@0	4778	* Results:
sl@0	4779	* A standard Tcl result.
sl@0	4780	*
sl@0	4781	* Side effects:
sl@0	4782	* None.
sl@0	4783	*
sl@0	4784	*----------------------------------------------------------------------
sl@0	4785	*/
sl@0	4786
sl@0	4787	static int
sl@0	4788	TestmainthreadCmd (dummy, interp, argc, argv)
sl@0	4789	ClientData dummy; /* Not used. */
sl@0	4790	register Tcl_Interp interp; / Current interpreter. */
sl@0	4791	int argc; /* Number of arguments. */
sl@0	4792	CONST char *argv; / Argument strings. */
sl@0	4793	{
sl@0	4794	if (argc == 1) {
sl@0	4795	Tcl_Obj *idObj = Tcl_NewLongObj((long)Tcl_GetCurrentThread());
sl@0	4796	Tcl_SetObjResult(interp, idObj);
sl@0	4797	return TCL_OK;
sl@0	4798	} else {
sl@0	4799	Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
sl@0	4800	return TCL_ERROR;
sl@0	4801	}
sl@0	4802	}
sl@0	4803
sl@0	4804	/*
sl@0	4805	*----------------------------------------------------------------------
sl@0	4806	*
sl@0	4807	* MainLoop --
sl@0	4808	*
sl@0	4809	* A main loop set by TestsetmainloopCmd below.
sl@0	4810	*
sl@0	4811	* Results:
sl@0	4812	* None.
sl@0	4813	*
sl@0	4814	* Side effects:
sl@0	4815	* Event handlers could do anything.
sl@0	4816	*
sl@0	4817	*----------------------------------------------------------------------
sl@0	4818	*/
sl@0	4819
sl@0	4820	static void
sl@0	4821	MainLoop(void)
sl@0	4822	{
sl@0	4823	while (!exitMainLoop) {
sl@0	4824	Tcl_DoOneEvent(0);
sl@0	4825	}
sl@0	4826	fprintf(stdout,"Exit MainLoop\n");
sl@0	4827	fflush(stdout);
sl@0	4828	}
sl@0	4829
sl@0	4830	/*
sl@0	4831	*----------------------------------------------------------------------
sl@0	4832	*
sl@0	4833	* TestsetmainloopCmd --
sl@0	4834	*
sl@0	4835	* Implements the "testsetmainloop" cmd that is used to test the
sl@0	4836	* 'Tcl_SetMainLoop' API.
sl@0	4837	*
sl@0	4838	* Results:
sl@0	4839	* A standard Tcl result.
sl@0	4840	*
sl@0	4841	* Side effects:
sl@0	4842	* None.
sl@0	4843	*
sl@0	4844	*----------------------------------------------------------------------
sl@0	4845	*/
sl@0	4846
sl@0	4847	static int
sl@0	4848	TestsetmainloopCmd (dummy, interp, argc, argv)
sl@0	4849	ClientData dummy; /* Not used. */
sl@0	4850	register Tcl_Interp interp; / Current interpreter. */
sl@0	4851	int argc; /* Number of arguments. */
sl@0	4852	CONST char *argv; / Argument strings. */
sl@0	4853	{
sl@0	4854	exitMainLoop = 0;
sl@0	4855	Tcl_SetMainLoop(MainLoop);
sl@0	4856	return TCL_OK;
sl@0	4857	}
sl@0	4858
sl@0	4859	/*
sl@0	4860	*----------------------------------------------------------------------
sl@0	4861	*
sl@0	4862	* TestexitmainloopCmd --
sl@0	4863	*
sl@0	4864	* Implements the "testexitmainloop" cmd that is used to test the
sl@0	4865	* 'Tcl_SetMainLoop' API.
sl@0	4866	*
sl@0	4867	* Results:
sl@0	4868	* A standard Tcl result.
sl@0	4869	*
sl@0	4870	* Side effects:
sl@0	4871	* None.
sl@0	4872	*
sl@0	4873	*----------------------------------------------------------------------
sl@0	4874	*/
sl@0	4875
sl@0	4876	static int
sl@0	4877	TestexitmainloopCmd (dummy, interp, argc, argv)
sl@0	4878	ClientData dummy; /* Not used. */
sl@0	4879	register Tcl_Interp interp; / Current interpreter. */
sl@0	4880	int argc; /* Number of arguments. */
sl@0	4881	CONST char *argv; / Argument strings. */
sl@0	4882	{
sl@0	4883	exitMainLoop = 1;
sl@0	4884	return TCL_OK;
sl@0	4885	}
sl@0	4886
sl@0	4887	/*
sl@0	4888	*----------------------------------------------------------------------
sl@0	4889	*
sl@0	4890	* TestaccessprocCmd --
sl@0	4891	*
sl@0	4892	* Implements the "testTclAccessProc" cmd that is used to test the
sl@0	4893	* 'TclAccessInsertProc' & 'TclAccessDeleteProc' C Apis.
sl@0	4894	*
sl@0	4895	* Results:
sl@0	4896	* A standard Tcl result.
sl@0	4897	*
sl@0	4898	* Side effects:
sl@0	4899	* None.
sl@0	4900	*
sl@0	4901	*----------------------------------------------------------------------
sl@0	4902	*/
sl@0	4903
sl@0	4904	static int
sl@0	4905	TestaccessprocCmd (dummy, interp, argc, argv)
sl@0	4906	ClientData dummy; /* Not used. */
sl@0	4907	register Tcl_Interp interp; / Current interpreter. */
sl@0	4908	int argc; /* Number of arguments. */
sl@0	4909	CONST char *argv; / Argument strings. */
sl@0	4910	{
sl@0	4911	TclAccessProc_ *proc;
sl@0	4912	int retVal;
sl@0	4913
sl@0	4914	if (argc != 3) {
sl@0	4915	Tcl_AppendResult(interp, "wrong # args: should be \"",
sl@0	4916	argv[0], " option arg\"", (char *) NULL);
sl@0	4917	return TCL_ERROR;
sl@0	4918	}
sl@0	4919
sl@0	4920	if (strcmp(argv[2], "TclpAccess") == 0) {
sl@0	4921	proc = PretendTclpAccess;
sl@0	4922	} else if (strcmp(argv[2], "TestAccessProc1") == 0) {
sl@0	4923	proc = TestAccessProc1;
sl@0	4924	} else if (strcmp(argv[2], "TestAccessProc2") == 0) {
sl@0	4925	proc = TestAccessProc2;
sl@0	4926	} else if (strcmp(argv[2], "TestAccessProc3") == 0) {
sl@0	4927	proc = TestAccessProc3;
sl@0	4928	} else {
sl@0	4929	Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ",
sl@0	4930	"must be TclpAccess, ",
sl@0	4931	"TestAccessProc1, TestAccessProc2, or TestAccessProc3",
sl@0	4932	(char *) NULL);
sl@0	4933	return TCL_ERROR;
sl@0	4934	}
sl@0	4935
sl@0	4936	if (strcmp(argv[1], "insert") == 0) {
sl@0	4937	if (proc == PretendTclpAccess) {
sl@0	4938	Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ",
sl@0	4939	"must be ",
sl@0	4940	"TestAccessProc1, TestAccessProc2, or TestAccessProc3",
sl@0	4941	(char *) NULL);
sl@0	4942	return TCL_ERROR;
sl@0	4943	}
sl@0	4944	retVal = TclAccessInsertProc(proc);
sl@0	4945	} else if (strcmp(argv[1], "delete") == 0) {
sl@0	4946	retVal = TclAccessDeleteProc(proc);
sl@0	4947	} else {
sl@0	4948	Tcl_AppendResult(interp, "bad option \"", argv[1], "\": ",
sl@0	4949	"must be insert or delete", (char *) NULL);
sl@0	4950	return TCL_ERROR;
sl@0	4951	}
sl@0	4952
sl@0	4953	if (retVal == TCL_ERROR) {
sl@0	4954	Tcl_AppendResult(interp, "\"", argv[2], "\": ",
sl@0	4955	"could not be ", argv[1], "ed", (char *) NULL);
sl@0	4956	}
sl@0	4957
sl@0	4958	return retVal;
sl@0	4959	}
sl@0	4960
sl@0	4961	static int PretendTclpAccess(path, mode)
sl@0	4962	CONST char *path;
sl@0	4963	int mode;
sl@0	4964	{
sl@0	4965	int ret;
sl@0	4966	Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1);
sl@0	4967	Tcl_IncrRefCount(pathPtr);
sl@0	4968	ret = TclpObjAccess(pathPtr, mode);
sl@0	4969	Tcl_DecrRefCount(pathPtr);
sl@0	4970	return ret;
sl@0	4971	}
sl@0	4972
sl@0	4973	static int
sl@0	4974	TestAccessProc1(path, mode)
sl@0	4975	CONST char *path;
sl@0	4976	int mode;
sl@0	4977	{
sl@0	4978	return ((strstr(path, "testAccess1%.fil") == NULL) ? -1 : 0);
sl@0	4979	}
sl@0	4980
sl@0	4981
sl@0	4982	static int
sl@0	4983	TestAccessProc2(path, mode)
sl@0	4984	CONST char *path;
sl@0	4985	int mode;
sl@0	4986	{
sl@0	4987	return ((strstr(path, "testAccess2%.fil") == NULL) ? -1 : 0);
sl@0	4988	}
sl@0	4989
sl@0	4990
sl@0	4991	static int
sl@0	4992	TestAccessProc3(path, mode)
sl@0	4993	CONST char *path;
sl@0	4994	int mode;
sl@0	4995	{
sl@0	4996	return ((strstr(path, "testAccess3%.fil") == NULL) ? -1 : 0);
sl@0	4997	}
sl@0	4998
sl@0	4999	/*
sl@0	5000	*----------------------------------------------------------------------
sl@0	5001	*
sl@0	5002	* TestopenfilechannelprocCmd --
sl@0	5003	*
sl@0	5004	* Implements the "testTclOpenFileChannelProc" cmd that is used to test the
sl@0	5005	* 'TclOpenFileChannelInsertProc' & 'TclOpenFileChannelDeleteProc' C Apis.
sl@0	5006	*
sl@0	5007	* Results:
sl@0	5008	* A standard Tcl result.
sl@0	5009	*
sl@0	5010	* Side effects:
sl@0	5011	* None.
sl@0	5012	*
sl@0	5013	*----------------------------------------------------------------------
sl@0	5014	*/
sl@0	5015
sl@0	5016	static int
sl@0	5017	TestopenfilechannelprocCmd (dummy, interp, argc, argv)
sl@0	5018	ClientData dummy; /* Not used. */
sl@0	5019	register Tcl_Interp interp; / Current interpreter. */
sl@0	5020	int argc; /* Number of arguments. */
sl@0	5021	CONST char *argv; / Argument strings. */
sl@0	5022	{
sl@0	5023	TclOpenFileChannelProc_ *proc;
sl@0	5024	int retVal;
sl@0	5025
sl@0	5026	if (argc != 3) {
sl@0	5027	Tcl_AppendResult(interp, "wrong # args: should be \"",
sl@0	5028	argv[0], " option arg\"", (char *) NULL);
sl@0	5029	return TCL_ERROR;
sl@0	5030	}
sl@0	5031
sl@0	5032	if (strcmp(argv[2], "TclpOpenFileChannel") == 0) {
sl@0	5033	proc = PretendTclpOpenFileChannel;
sl@0	5034	} else if (strcmp(argv[2], "TestOpenFileChannelProc1") == 0) {
sl@0	5035	proc = TestOpenFileChannelProc1;
sl@0	5036	} else if (strcmp(argv[2], "TestOpenFileChannelProc2") == 0) {
sl@0	5037	proc = TestOpenFileChannelProc2;
sl@0	5038	} else if (strcmp(argv[2], "TestOpenFileChannelProc3") == 0) {
sl@0	5039	proc = TestOpenFileChannelProc3;
sl@0	5040	} else {
sl@0	5041	Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ",
sl@0	5042	"must be TclpOpenFileChannel, ",
sl@0	5043	"TestOpenFileChannelProc1, TestOpenFileChannelProc2, or ",
sl@0	5044	"TestOpenFileChannelProc3",
sl@0	5045	(char *) NULL);
sl@0	5046	return TCL_ERROR;
sl@0	5047	}
sl@0	5048
sl@0	5049	if (strcmp(argv[1], "insert") == 0) {
sl@0	5050	if (proc == PretendTclpOpenFileChannel) {
sl@0	5051	Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ",
sl@0	5052	"must be ",
sl@0	5053	"TestOpenFileChannelProc1, TestOpenFileChannelProc2, or ",
sl@0	5054	"TestOpenFileChannelProc3",
sl@0	5055	(char *) NULL);
sl@0	5056	return TCL_ERROR;
sl@0	5057	}
sl@0	5058	retVal = TclOpenFileChannelInsertProc(proc);
sl@0	5059	} else if (strcmp(argv[1], "delete") == 0) {
sl@0	5060	retVal = TclOpenFileChannelDeleteProc(proc);
sl@0	5061	} else {
sl@0	5062	Tcl_AppendResult(interp, "bad option \"", argv[1], "\": ",
sl@0	5063	"must be insert or delete", (char *) NULL);
sl@0	5064	return TCL_ERROR;
sl@0	5065	}
sl@0	5066
sl@0	5067	if (retVal == TCL_ERROR) {
sl@0	5068	Tcl_AppendResult(interp, "\"", argv[2], "\": ",
sl@0	5069	"could not be ", argv[1], "ed", (char *) NULL);
sl@0	5070	}
sl@0	5071
sl@0	5072	return retVal;
sl@0	5073	}
sl@0	5074
sl@0	5075	static Tcl_Channel
sl@0	5076	PretendTclpOpenFileChannel(interp, fileName, modeString, permissions)
sl@0	5077	Tcl_Interp interp; / Interpreter for error reporting;
sl@0	5078	* can be NULL. */
sl@0	5079	CONST char fileName; / Name of file to open. */
sl@0	5080	CONST char modeString; / A list of POSIX open modes or
sl@0	5081	* a string such as "rw". */
sl@0	5082	int permissions; /* If the open involves creating a
sl@0	5083	* file, with what modes to create
sl@0	5084	* it? */
sl@0	5085	{
sl@0	5086	Tcl_Channel ret;
sl@0	5087	int mode, seekFlag;
sl@0	5088	Tcl_Obj *pathPtr;
sl@0	5089	mode = TclGetOpenMode(interp, modeString, &seekFlag);
sl@0	5090	if (mode == -1) {
sl@0	5091	return NULL;
sl@0	5092	}
sl@0	5093	pathPtr = Tcl_NewStringObj(fileName, -1);
sl@0	5094	Tcl_IncrRefCount(pathPtr);
sl@0	5095	ret = TclpOpenFileChannel(interp, pathPtr, mode, permissions);
sl@0	5096	Tcl_DecrRefCount(pathPtr);
sl@0	5097	if (ret != NULL) {
sl@0	5098	if (seekFlag) {
sl@0	5099	if (Tcl_Seek(ret, (Tcl_WideInt)0, SEEK_END) < (Tcl_WideInt)0) {
sl@0	5100	if (interp != (Tcl_Interp *) NULL) {
sl@0	5101	Tcl_AppendResult(interp,
sl@0	5102	"could not seek to end of file while opening \"",
sl@0	5103	fileName, "\": ",
sl@0	5104	Tcl_PosixError(interp), (char *) NULL);
sl@0	5105	}
sl@0	5106	Tcl_Close(NULL, ret);
sl@0	5107	return NULL;
sl@0	5108	}
sl@0	5109	}
sl@0	5110	}
sl@0	5111	return ret;
sl@0	5112	}
sl@0	5113
sl@0	5114	static Tcl_Channel
sl@0	5115	TestOpenFileChannelProc1(interp, fileName, modeString, permissions)
sl@0	5116	Tcl_Interp interp; / Interpreter for error reporting;
sl@0	5117	* can be NULL. */
sl@0	5118	CONST char fileName; / Name of file to open. */
sl@0	5119	CONST char modeString; / A list of POSIX open modes or
sl@0	5120	* a string such as "rw". */
sl@0	5121	int permissions; /* If the open involves creating a
sl@0	5122	* file, with what modes to create
sl@0	5123	* it? */
sl@0	5124	{
sl@0	5125	CONST char *expectname="testOpenFileChannel1%.fil";
sl@0	5126	Tcl_DString ds;
sl@0	5127
sl@0	5128	Tcl_DStringInit(&ds);
sl@0	5129	Tcl_JoinPath(1, &expectname, &ds);
sl@0	5130
sl@0	5131	if (!strcmp(Tcl_DStringValue(&ds), fileName)) {
sl@0	5132	Tcl_DStringFree(&ds);
sl@0	5133	return (PretendTclpOpenFileChannel(interp, "__testOpenFileChannel1%__.fil",
sl@0	5134	modeString, permissions));
sl@0	5135	} else {
sl@0	5136	Tcl_DStringFree(&ds);
sl@0	5137	return (NULL);
sl@0	5138	}
sl@0	5139	}
sl@0	5140
sl@0	5141
sl@0	5142	static Tcl_Channel
sl@0	5143	TestOpenFileChannelProc2(interp, fileName, modeString, permissions)
sl@0	5144	Tcl_Interp interp; / Interpreter for error reporting;
sl@0	5145	* can be NULL. */
sl@0	5146	CONST char fileName; / Name of file to open. */
sl@0	5147	CONST char modeString; / A list of POSIX open modes or
sl@0	5148	* a string such as "rw". */
sl@0	5149	int permissions; /* If the open involves creating a
sl@0	5150	* file, with what modes to create
sl@0	5151	* it? */
sl@0	5152	{
sl@0	5153	CONST char *expectname="testOpenFileChannel2%.fil";
sl@0	5154	Tcl_DString ds;
sl@0	5155
sl@0	5156	Tcl_DStringInit(&ds);
sl@0	5157	Tcl_JoinPath(1, &expectname, &ds);
sl@0	5158
sl@0	5159	if (!strcmp(Tcl_DStringValue(&ds), fileName)) {
sl@0	5160	Tcl_DStringFree(&ds);
sl@0	5161	return (PretendTclpOpenFileChannel(interp, "__testOpenFileChannel2%__.fil",
sl@0	5162	modeString, permissions));
sl@0	5163	} else {
sl@0	5164	Tcl_DStringFree(&ds);
sl@0	5165	return (NULL);
sl@0	5166	}
sl@0	5167	}
sl@0	5168
sl@0	5169
sl@0	5170	static Tcl_Channel
sl@0	5171	TestOpenFileChannelProc3(interp, fileName, modeString, permissions)
sl@0	5172	Tcl_Interp interp; / Interpreter for error reporting;
sl@0	5173	* can be NULL. */
sl@0	5174	CONST char fileName; / Name of file to open. */
sl@0	5175	CONST char modeString; / A list of POSIX open modes or
sl@0	5176	* a string such as "rw". */
sl@0	5177	int permissions; /* If the open involves creating a
sl@0	5178	* file, with what modes to create
sl@0	5179	* it? */
sl@0	5180	{
sl@0	5181	CONST char *expectname="testOpenFileChannel3%.fil";
sl@0	5182	Tcl_DString ds;
sl@0	5183
sl@0	5184	Tcl_DStringInit(&ds);
sl@0	5185	Tcl_JoinPath(1, &expectname, &ds);
sl@0	5186
sl@0	5187	if (!strcmp(Tcl_DStringValue(&ds), fileName)) {
sl@0	5188	Tcl_DStringFree(&ds);
sl@0	5189	return (PretendTclpOpenFileChannel(interp, "__testOpenFileChannel3%__.fil",
sl@0	5190	modeString, permissions));
sl@0	5191	} else {
sl@0	5192	Tcl_DStringFree(&ds);
sl@0	5193	return (NULL);
sl@0	5194	}
sl@0	5195	}
sl@0	5196
sl@0	5197	/*
sl@0	5198	*----------------------------------------------------------------------
sl@0	5199	*
sl@0	5200	* TestChannelCmd --
sl@0	5201	*
sl@0	5202	* Implements the Tcl "testchannel" debugging command and its
sl@0	5203	* subcommands. This is part of the testing environment.
sl@0	5204	*
sl@0	5205	* Results:
sl@0	5206	* A standard Tcl result.
sl@0	5207	*
sl@0	5208	* Side effects:
sl@0	5209	* None.
sl@0	5210	*
sl@0	5211	*----------------------------------------------------------------------
sl@0	5212	*/
sl@0	5213
sl@0	5214	/* ARGSUSED */
sl@0	5215	static int
sl@0	5216	TestChannelCmd(clientData, interp, argc, argv)
sl@0	5217	ClientData clientData; /* Not used. */
sl@0	5218	Tcl_Interp interp; / Interpreter for result. */
sl@0	5219	int argc; /* Count of additional args. */
sl@0	5220	CONST char *argv; / Additional arg strings. */
sl@0	5221	{
sl@0	5222	CONST char cmdName; / Sub command. */
sl@0	5223	Tcl_HashTable hTblPtr; / Hash table of channels. */
sl@0	5224	Tcl_HashSearch hSearch; /* Search variable. */
sl@0	5225	Tcl_HashEntry hPtr; / Search variable. */
sl@0	5226	Channel chanPtr; / The actual channel. */
sl@0	5227	ChannelState statePtr; / state info for channel */
sl@0	5228	Tcl_Channel chan; /* The opaque type. */
sl@0	5229	size_t len; /* Length of subcommand string. */
sl@0	5230	int IOQueued; /* How much IO is queued inside channel? */
sl@0	5231	ChannelBuffer bufPtr; / For iterating over queued IO. */
sl@0	5232	char buf[TCL_INTEGER_SPACE];/* For sprintf. */
sl@0	5233	int mode; /* rw mode of the channel */
sl@0	5234
sl@0	5235	if (argc < 2) {
sl@0	5236	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
sl@0	5237	" subcommand ?additional args..?\"", (char *) NULL);
sl@0	5238	return TCL_ERROR;
sl@0	5239	}
sl@0	5240	cmdName = argv[1];
sl@0	5241	len = strlen(cmdName);
sl@0	5242
sl@0	5243	chanPtr = (Channel *) NULL;
sl@0	5244
sl@0	5245	if (argc > 2) {
sl@0	5246	chan = Tcl_GetChannel(interp, argv[2], &mode);
sl@0	5247	if (chan == (Tcl_Channel) NULL) {
sl@0	5248	return TCL_ERROR;
sl@0	5249	}
sl@0	5250	chanPtr = (Channel *) chan;
sl@0	5251	statePtr = chanPtr->state;
sl@0	5252	chanPtr = statePtr->topChanPtr;
sl@0	5253	chan = (Tcl_Channel) chanPtr;
sl@0	5254	} else {
sl@0	5255	/* lint */
sl@0	5256	statePtr = NULL;
sl@0	5257	chan = NULL;
sl@0	5258	}
sl@0	5259
sl@0	5260	if ((cmdName[0] == 'c') && (strncmp(cmdName, "cut", len) == 0)) {
sl@0	5261	if (argc != 3) {
sl@0	5262	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
sl@0	5263	" cut channelName\"", (char *) NULL);
sl@0	5264	return TCL_ERROR;
sl@0	5265	}
sl@0	5266	Tcl_CutChannel(chan);
sl@0	5267	return TCL_OK;
sl@0	5268	}
sl@0	5269
sl@0	5270	if ((cmdName[0] == 'c') &&
sl@0	5271	(strncmp(cmdName, "clearchannelhandlers", len) == 0)) {
sl@0	5272	if (argc != 3) {
sl@0	5273	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
sl@0	5274	" clearchannelhandlers channelName\"", (char *) NULL);
sl@0	5275	return TCL_ERROR;
sl@0	5276	}
sl@0	5277	Tcl_ClearChannelHandlers(chan);
sl@0	5278	return TCL_OK;
sl@0	5279	}
sl@0	5280
sl@0	5281	if ((cmdName[0] == 'i') && (strncmp(cmdName, "info", len) == 0)) {
sl@0	5282	if (argc != 3) {
sl@0	5283	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
sl@0	5284	" info channelName\"", (char *) NULL);
sl@0	5285	return TCL_ERROR;
sl@0	5286	}
sl@0	5287	Tcl_AppendElement(interp, argv[2]);
sl@0	5288	Tcl_AppendElement(interp, Tcl_ChannelName(chanPtr->typePtr));
sl@0	5289	if (statePtr->flags & TCL_READABLE) {
sl@0	5290	Tcl_AppendElement(interp, "read");
sl@0	5291	} else {
sl@0	5292	Tcl_AppendElement(interp, "");
sl@0	5293	}
sl@0	5294	if (statePtr->flags & TCL_WRITABLE) {
sl@0	5295	Tcl_AppendElement(interp, "write");
sl@0	5296	} else {
sl@0	5297	Tcl_AppendElement(interp, "");
sl@0	5298	}
sl@0	5299	if (statePtr->flags & CHANNEL_NONBLOCKING) {
sl@0	5300	Tcl_AppendElement(interp, "nonblocking");
sl@0	5301	} else {
sl@0	5302	Tcl_AppendElement(interp, "blocking");
sl@0	5303	}
sl@0	5304	if (statePtr->flags & CHANNEL_LINEBUFFERED) {
sl@0	5305	Tcl_AppendElement(interp, "line");
sl@0	5306	} else if (statePtr->flags & CHANNEL_UNBUFFERED) {
sl@0	5307	Tcl_AppendElement(interp, "none");
sl@0	5308	} else {
sl@0	5309	Tcl_AppendElement(interp, "full");
sl@0	5310	}
sl@0	5311	if (statePtr->flags & BG_FLUSH_SCHEDULED) {
sl@0	5312	Tcl_AppendElement(interp, "async_flush");
sl@0	5313	} else {
sl@0	5314	Tcl_AppendElement(interp, "");
sl@0	5315	}
sl@0	5316	if (statePtr->flags & CHANNEL_EOF) {
sl@0	5317	Tcl_AppendElement(interp, "eof");
sl@0	5318	} else {
sl@0	5319	Tcl_AppendElement(interp, "");
sl@0	5320	}
sl@0	5321	if (statePtr->flags & CHANNEL_BLOCKED) {
sl@0	5322	Tcl_AppendElement(interp, "blocked");
sl@0	5323	} else {
sl@0	5324	Tcl_AppendElement(interp, "unblocked");
sl@0	5325	}
sl@0	5326	if (statePtr->inputTranslation == TCL_TRANSLATE_AUTO) {
sl@0	5327	Tcl_AppendElement(interp, "auto");
sl@0	5328	if (statePtr->flags & INPUT_SAW_CR) {
sl@0	5329	Tcl_AppendElement(interp, "saw_cr");
sl@0	5330	} else {
sl@0	5331	Tcl_AppendElement(interp, "");
sl@0	5332	}
sl@0	5333	} else if (statePtr->inputTranslation == TCL_TRANSLATE_LF) {
sl@0	5334	Tcl_AppendElement(interp, "lf");
sl@0	5335	Tcl_AppendElement(interp, "");
sl@0	5336	} else if (statePtr->inputTranslation == TCL_TRANSLATE_CR) {
sl@0	5337	Tcl_AppendElement(interp, "cr");
sl@0	5338	Tcl_AppendElement(interp, "");
sl@0	5339	} else if (statePtr->inputTranslation == TCL_TRANSLATE_CRLF) {
sl@0	5340	Tcl_AppendElement(interp, "crlf");
sl@0	5341	if (statePtr->flags & INPUT_SAW_CR) {
sl@0	5342	Tcl_AppendElement(interp, "queued_cr");
sl@0	5343	} else {
sl@0	5344	Tcl_AppendElement(interp, "");
sl@0	5345	}
sl@0	5346	}
sl@0	5347	if (statePtr->outputTranslation == TCL_TRANSLATE_AUTO) {
sl@0	5348	Tcl_AppendElement(interp, "auto");
sl@0	5349	} else if (statePtr->outputTranslation == TCL_TRANSLATE_LF) {
sl@0	5350	Tcl_AppendElement(interp, "lf");
sl@0	5351	} else if (statePtr->outputTranslation == TCL_TRANSLATE_CR) {
sl@0	5352	Tcl_AppendElement(interp, "cr");
sl@0	5353	} else if (statePtr->outputTranslation == TCL_TRANSLATE_CRLF) {
sl@0	5354	Tcl_AppendElement(interp, "crlf");
sl@0	5355	}
sl@0	5356	for (IOQueued = 0, bufPtr = statePtr->inQueueHead;
sl@0	5357	bufPtr != (ChannelBuffer *) NULL;
sl@0	5358	bufPtr = bufPtr->nextPtr) {
sl@0	5359	IOQueued += bufPtr->nextAdded - bufPtr->nextRemoved;
sl@0	5360	}
sl@0	5361	TclFormatInt(buf, IOQueued);
sl@0	5362	Tcl_AppendElement(interp, buf);
sl@0	5363
sl@0	5364	IOQueued = 0;
sl@0	5365	if (statePtr->curOutPtr != (ChannelBuffer *) NULL) {
sl@0	5366	IOQueued = statePtr->curOutPtr->nextAdded -
sl@0	5367	statePtr->curOutPtr->nextRemoved;
sl@0	5368	}
sl@0	5369	for (bufPtr = statePtr->outQueueHead;
sl@0	5370	bufPtr != (ChannelBuffer *) NULL;
sl@0	5371	bufPtr = bufPtr->nextPtr) {
sl@0	5372	IOQueued += (bufPtr->nextAdded - bufPtr->nextRemoved);
sl@0	5373	}
sl@0	5374	TclFormatInt(buf, IOQueued);
sl@0	5375	Tcl_AppendElement(interp, buf);
sl@0	5376
sl@0	5377	TclFormatInt(buf, (int)Tcl_Tell((Tcl_Channel) chanPtr));
sl@0	5378	Tcl_AppendElement(interp, buf);
sl@0	5379
sl@0	5380	TclFormatInt(buf, statePtr->refCount);
sl@0	5381	Tcl_AppendElement(interp, buf);
sl@0	5382
sl@0	5383	return TCL_OK;
sl@0	5384	}
sl@0	5385
sl@0	5386	if ((cmdName[0] == 'i') &&
sl@0	5387	(strncmp(cmdName, "inputbuffered", len) == 0)) {
sl@0	5388	if (argc != 3) {
sl@0	5389	Tcl_AppendResult(interp, "channel name required",
sl@0	5390	(char *) NULL);
sl@0	5391	return TCL_ERROR;
sl@0	5392	}
sl@0	5393
sl@0	5394	for (IOQueued = 0, bufPtr = statePtr->inQueueHead;
sl@0	5395	bufPtr != (ChannelBuffer *) NULL;
sl@0	5396	bufPtr = bufPtr->nextPtr) {
sl@0	5397	IOQueued += bufPtr->nextAdded - bufPtr->nextRemoved;
sl@0	5398	}
sl@0	5399	TclFormatInt(buf, IOQueued);
sl@0	5400	Tcl_AppendResult(interp, buf, (char *) NULL);
sl@0	5401	return TCL_OK;
sl@0	5402	}
sl@0	5403
sl@0	5404	if ((cmdName[0] == 'i') && (strncmp(cmdName, "isshared", len) == 0)) {
sl@0	5405	if (argc != 3) {
sl@0	5406	Tcl_AppendResult(interp, "channel name required", (char *) NULL);
sl@0	5407	return TCL_ERROR;
sl@0	5408	}
sl@0	5409
sl@0	5410	TclFormatInt(buf, Tcl_IsChannelShared(chan));
sl@0	5411	Tcl_AppendResult(interp, buf, (char *) NULL);
sl@0	5412	return TCL_OK;
sl@0	5413	}
sl@0	5414
sl@0	5415	if ((cmdName[0] == 'i') && (strncmp(cmdName, "isstandard", len) == 0)) {
sl@0	5416	if (argc != 3) {
sl@0	5417	Tcl_AppendResult(interp, "channel name required", (char *) NULL);
sl@0	5418	return TCL_ERROR;
sl@0	5419	}
sl@0	5420
sl@0	5421	TclFormatInt(buf, Tcl_IsStandardChannel(chan));
sl@0	5422	Tcl_AppendResult(interp, buf, (char *) NULL);
sl@0	5423	return TCL_OK;
sl@0	5424	}
sl@0	5425
sl@0	5426	if ((cmdName[0] == 'm') && (strncmp(cmdName, "mode", len) == 0)) {
sl@0	5427	if (argc != 3) {
sl@0	5428	Tcl_AppendResult(interp, "channel name required",
sl@0	5429	(char *) NULL);
sl@0	5430	return TCL_ERROR;
sl@0	5431	}
sl@0	5432
sl@0	5433	if (statePtr->flags & TCL_READABLE) {
sl@0	5434	Tcl_AppendElement(interp, "read");
sl@0	5435	} else {
sl@0	5436	Tcl_AppendElement(interp, "");
sl@0	5437	}
sl@0	5438	if (statePtr->flags & TCL_WRITABLE) {
sl@0	5439	Tcl_AppendElement(interp, "write");
sl@0	5440	} else {
sl@0	5441	Tcl_AppendElement(interp, "");
sl@0	5442	}
sl@0	5443	return TCL_OK;
sl@0	5444	}
sl@0	5445
sl@0	5446	if ((cmdName[0] == 'm') && (strncmp(cmdName, "mthread", len) == 0)) {
sl@0	5447	if (argc != 3) {
sl@0	5448	Tcl_AppendResult(interp, "channel name required",
sl@0	5449	(char *) NULL);
sl@0	5450	return TCL_ERROR;
sl@0	5451	}
sl@0	5452
sl@0	5453	TclFormatInt(buf, (long) Tcl_GetChannelThread(chan));
sl@0	5454	Tcl_AppendResult(interp, buf, (char *) NULL);
sl@0	5455	return TCL_OK;
sl@0	5456	}
sl@0	5457
sl@0	5458	if ((cmdName[0] == 'n') && (strncmp(cmdName, "name", len) == 0)) {
sl@0	5459	if (argc != 3) {
sl@0	5460	Tcl_AppendResult(interp, "channel name required",
sl@0	5461	(char *) NULL);
sl@0	5462	return TCL_ERROR;
sl@0	5463	}
sl@0	5464	Tcl_AppendResult(interp, statePtr->channelName, (char *) NULL);
sl@0	5465	return TCL_OK;
sl@0	5466	}
sl@0	5467
sl@0	5468	if ((cmdName[0] == 'o') && (strncmp(cmdName, "open", len) == 0)) {
sl@0	5469	hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
sl@0	5470	if (hTblPtr == (Tcl_HashTable *) NULL) {
sl@0	5471	return TCL_OK;
sl@0	5472	}
sl@0	5473	for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
sl@0	5474	hPtr != (Tcl_HashEntry *) NULL;
sl@0	5475	hPtr = Tcl_NextHashEntry(&hSearch)) {
sl@0	5476	Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr));
sl@0	5477	}
sl@0	5478	return TCL_OK;
sl@0	5479	}
sl@0	5480
sl@0	5481	if ((cmdName[0] == 'o') &&
sl@0	5482	(strncmp(cmdName, "outputbuffered", len) == 0)) {
sl@0	5483	if (argc != 3) {
sl@0	5484	Tcl_AppendResult(interp, "channel name required",
sl@0	5485	(char *) NULL);
sl@0	5486	return TCL_ERROR;
sl@0	5487	}
sl@0	5488
sl@0	5489	IOQueued = 0;
sl@0	5490	if (statePtr->curOutPtr != (ChannelBuffer *) NULL) {
sl@0	5491	IOQueued = statePtr->curOutPtr->nextAdded -
sl@0	5492	statePtr->curOutPtr->nextRemoved;
sl@0	5493	}
sl@0	5494	for (bufPtr = statePtr->outQueueHead;
sl@0	5495	bufPtr != (ChannelBuffer *) NULL;
sl@0	5496	bufPtr = bufPtr->nextPtr) {
sl@0	5497	IOQueued += (bufPtr->nextAdded - bufPtr->nextRemoved);
sl@0	5498	}
sl@0	5499	TclFormatInt(buf, IOQueued);
sl@0	5500	Tcl_AppendResult(interp, buf, (char *) NULL);
sl@0	5501	return TCL_OK;
sl@0	5502	}
sl@0	5503
sl@0	5504	if ((cmdName[0] == 'q') &&
sl@0	5505	(strncmp(cmdName, "queuedcr", len) == 0)) {
sl@0	5506	if (argc != 3) {
sl@0	5507	Tcl_AppendResult(interp, "channel name required",
sl@0	5508	(char *) NULL);
sl@0	5509	return TCL_ERROR;
sl@0	5510	}
sl@0	5511
sl@0	5512	Tcl_AppendResult(interp,
sl@0	5513	(statePtr->flags & INPUT_SAW_CR) ? "1" : "0",
sl@0	5514	(char *) NULL);
sl@0	5515	return TCL_OK;
sl@0	5516	}
sl@0	5517
sl@0	5518	if ((cmdName[0] == 'r') && (strncmp(cmdName, "readable", len) == 0)) {
sl@0	5519	hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
sl@0	5520	if (hTblPtr == (Tcl_HashTable *) NULL) {
sl@0	5521	return TCL_OK;
sl@0	5522	}
sl@0	5523	for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
sl@0	5524	hPtr != (Tcl_HashEntry *) NULL;
sl@0	5525	hPtr = Tcl_NextHashEntry(&hSearch)) {
sl@0	5526	chanPtr = (Channel *) Tcl_GetHashValue(hPtr);
sl@0	5527	statePtr = chanPtr->state;
sl@0	5528	if (statePtr->flags & TCL_READABLE) {
sl@0	5529	Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr));
sl@0	5530	}
sl@0	5531	}
sl@0	5532	return TCL_OK;
sl@0	5533	}
sl@0	5534
sl@0	5535	if ((cmdName[0] == 'r') && (strncmp(cmdName, "refcount", len) == 0)) {
sl@0	5536	if (argc != 3) {
sl@0	5537	Tcl_AppendResult(interp, "channel name required",
sl@0	5538	(char *) NULL);
sl@0	5539	return TCL_ERROR;
sl@0	5540	}
sl@0	5541
sl@0	5542	TclFormatInt(buf, statePtr->refCount);
sl@0	5543	Tcl_AppendResult(interp, buf, (char *) NULL);
sl@0	5544	return TCL_OK;
sl@0	5545	}
sl@0	5546
sl@0	5547	if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) {
sl@0	5548	if (argc != 3) {
sl@0	5549	Tcl_AppendResult(interp, "channel name required", (char *) NULL);
sl@0	5550	return TCL_ERROR;
sl@0	5551	}
sl@0	5552
sl@0	5553	Tcl_SpliceChannel(chan);
sl@0	5554	return TCL_OK;
sl@0	5555	}
sl@0	5556
sl@0	5557	if ((cmdName[0] == 't') && (strncmp(cmdName, "type", len) == 0)) {
sl@0	5558	if (argc != 3) {
sl@0	5559	Tcl_AppendResult(interp, "channel name required",
sl@0	5560	(char *) NULL);
sl@0	5561	return TCL_ERROR;
sl@0	5562	}
sl@0	5563	Tcl_AppendResult(interp, Tcl_ChannelName(chanPtr->typePtr),
sl@0	5564	(char *) NULL);
sl@0	5565	return TCL_OK;
sl@0	5566	}
sl@0	5567
sl@0	5568	if ((cmdName[0] == 'w') && (strncmp(cmdName, "writable", len) == 0)) {
sl@0	5569	hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
sl@0	5570	if (hTblPtr == (Tcl_HashTable *) NULL) {
sl@0	5571	return TCL_OK;
sl@0	5572	}
sl@0	5573	for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
sl@0	5574	hPtr != (Tcl_HashEntry *) NULL;
sl@0	5575	hPtr = Tcl_NextHashEntry(&hSearch)) {
sl@0	5576	chanPtr = (Channel *) Tcl_GetHashValue(hPtr);
sl@0	5577	statePtr = chanPtr->state;
sl@0	5578	if (statePtr->flags & TCL_WRITABLE) {
sl@0	5579	Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr));
sl@0	5580	}
sl@0	5581	}
sl@0	5582	return TCL_OK;
sl@0	5583	}
sl@0	5584
sl@0	5585	if ((cmdName[0] == 't') && (strncmp(cmdName, "transform", len) == 0)) {
sl@0	5586	/*
sl@0	5587	* Syntax: transform channel -command command
sl@0	5588	*/
sl@0	5589
sl@0	5590	if (argc != 5) {
sl@0	5591	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
sl@0	5592	" transform channelId -command cmd\"", (char *) NULL);
sl@0	5593	return TCL_ERROR;
sl@0	5594	}
sl@0	5595	if (strcmp(argv[3], "-command") != 0) {
sl@0	5596	Tcl_AppendResult(interp, "bad argument \"", argv[3],
sl@0	5597	"\": should be \"-command\"", (char *) NULL);
sl@0	5598	return TCL_ERROR;
sl@0	5599	}
sl@0	5600
sl@0	5601	return TclChannelTransform(interp, chan,
sl@0	5602	Tcl_NewStringObj(argv[4], -1));
sl@0	5603	}
sl@0	5604
sl@0	5605	if ((cmdName[0] == 'u') && (strncmp(cmdName, "unstack", len) == 0)) {
sl@0	5606	/*
sl@0	5607	* Syntax: unstack channel
sl@0	5608	*/
sl@0	5609
sl@0	5610	if (argc != 3) {
sl@0	5611	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
sl@0	5612	" unstack channel\"", (char *) NULL);
sl@0	5613	return TCL_ERROR;
sl@0	5614	}
sl@0	5615	return Tcl_UnstackChannel(interp, chan);
sl@0	5616	}
sl@0	5617
sl@0	5618	Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be ",
sl@0	5619	"cut, clearchannelhandlers, info, isshared, mode, open, "
sl@0	5620	"readable, splice, writable, transform, unstack",
sl@0	5621	(char *) NULL);
sl@0	5622	return TCL_ERROR;
sl@0	5623	}
sl@0	5624
sl@0	5625	/*
sl@0	5626	*----------------------------------------------------------------------
sl@0	5627	*
sl@0	5628	* TestChannelEventCmd --
sl@0	5629	*
sl@0	5630	* This procedure implements the "testchannelevent" command. It is
sl@0	5631	* used to test the Tcl channel event mechanism.
sl@0	5632	*
sl@0	5633	* Results:
sl@0	5634	* A standard Tcl result.
sl@0	5635	*
sl@0	5636	* Side effects:
sl@0	5637	* Creates, deletes and returns channel event handlers.
sl@0	5638	*
sl@0	5639	*----------------------------------------------------------------------
sl@0	5640	*/
sl@0	5641
sl@0	5642	/* ARGSUSED */
sl@0	5643	static int
sl@0	5644	TestChannelEventCmd(dummy, interp, argc, argv)
sl@0	5645	ClientData dummy; /* Not used. */
sl@0	5646	Tcl_Interp interp; / Current interpreter. */
sl@0	5647	int argc; /* Number of arguments. */
sl@0	5648	CONST char *argv; / Argument strings. */
sl@0	5649	{
sl@0	5650	Tcl_Obj *resultListPtr;
sl@0	5651	Channel *chanPtr;
sl@0	5652	ChannelState statePtr; / state info for channel */
sl@0	5653	EventScriptRecord esPtr, prevEsPtr, *nextEsPtr;
sl@0	5654	CONST char *cmd;
sl@0	5655	int index, i, mask, len;
sl@0	5656
sl@0	5657	if ((argc < 3) \|\| (argc > 5)) {
sl@0	5658	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
sl@0	5659	" channelName cmd ?arg1? ?arg2?\"", (char *) NULL);
sl@0	5660	return TCL_ERROR;
sl@0	5661	}
sl@0	5662	chanPtr = (Channel *) Tcl_GetChannel(interp, argv[1], NULL);
sl@0	5663	if (chanPtr == (Channel *) NULL) {
sl@0	5664	return TCL_ERROR;
sl@0	5665	}
sl@0	5666	statePtr = chanPtr->state;
sl@0	5667
sl@0	5668	cmd = argv[2];
sl@0	5669	len = strlen(cmd);
sl@0	5670	if ((cmd[0] == 'a') && (strncmp(cmd, "add", (unsigned) len) == 0)) {
sl@0	5671	if (argc != 5) {
sl@0	5672	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
sl@0	5673	" channelName add eventSpec script\"", (char *) NULL);
sl@0	5674	return TCL_ERROR;
sl@0	5675	}
sl@0	5676	if (strcmp(argv[3], "readable") == 0) {
sl@0	5677	mask = TCL_READABLE;
sl@0	5678	} else if (strcmp(argv[3], "writable") == 0) {
sl@0	5679	mask = TCL_WRITABLE;
sl@0	5680	} else if (strcmp(argv[3], "none") == 0) {
sl@0	5681	mask = 0;
sl@0	5682	} else {
sl@0	5683	Tcl_AppendResult(interp, "bad event name \"", argv[3],
sl@0	5684	"\": must be readable, writable, or none", (char *) NULL);
sl@0	5685	return TCL_ERROR;
sl@0	5686	}
sl@0	5687
sl@0	5688	esPtr = (EventScriptRecord *) ckalloc((unsigned)
sl@0	5689	sizeof(EventScriptRecord));
sl@0	5690	esPtr->nextPtr = statePtr->scriptRecordPtr;
sl@0	5691	statePtr->scriptRecordPtr = esPtr;
sl@0	5692
sl@0	5693	esPtr->chanPtr = chanPtr;
sl@0	5694	esPtr->interp = interp;
sl@0	5695	esPtr->mask = mask;
sl@0	5696	esPtr->scriptPtr = Tcl_NewStringObj(argv[4], -1);
sl@0	5697	Tcl_IncrRefCount(esPtr->scriptPtr);
sl@0	5698
sl@0	5699	Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
sl@0	5700	TclChannelEventScriptInvoker, (ClientData) esPtr);
sl@0	5701
sl@0	5702	return TCL_OK;
sl@0	5703	}
sl@0	5704
sl@0	5705	if ((cmd[0] == 'd') && (strncmp(cmd, "delete", (unsigned) len) == 0)) {
sl@0	5706	if (argc != 4) {
sl@0	5707	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
sl@0	5708	" channelName delete index\"", (char *) NULL);
sl@0	5709	return TCL_ERROR;
sl@0	5710	}
sl@0	5711	if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) {
sl@0	5712	return TCL_ERROR;
sl@0	5713	}
sl@0	5714	if (index < 0) {
sl@0	5715	Tcl_AppendResult(interp, "bad event index: ", argv[3],
sl@0	5716	": must be nonnegative", (char *) NULL);
sl@0	5717	return TCL_ERROR;
sl@0	5718	}
sl@0	5719	for (i = 0, esPtr = statePtr->scriptRecordPtr;
sl@0	5720	(i < index) && (esPtr != (EventScriptRecord *) NULL);
sl@0	5721	i++, esPtr = esPtr->nextPtr) {
sl@0	5722	/* Empty loop body. */
sl@0	5723	}
sl@0	5724	if (esPtr == (EventScriptRecord *) NULL) {
sl@0	5725	Tcl_AppendResult(interp, "bad event index ", argv[3],
sl@0	5726	": out of range", (char *) NULL);
sl@0	5727	return TCL_ERROR;
sl@0	5728	}
sl@0	5729	if (esPtr == statePtr->scriptRecordPtr) {
sl@0	5730	statePtr->scriptRecordPtr = esPtr->nextPtr;
sl@0	5731	} else {
sl@0	5732	for (prevEsPtr = statePtr->scriptRecordPtr;
sl@0	5733	(prevEsPtr != (EventScriptRecord *) NULL) &&
sl@0	5734	(prevEsPtr->nextPtr != esPtr);
sl@0	5735	prevEsPtr = prevEsPtr->nextPtr) {
sl@0	5736	/* Empty loop body. */
sl@0	5737	}
sl@0	5738	if (prevEsPtr == (EventScriptRecord *) NULL) {
sl@0	5739	panic("TestChannelEventCmd: damaged event script list");
sl@0	5740	}
sl@0	5741	prevEsPtr->nextPtr = esPtr->nextPtr;
sl@0	5742	}
sl@0	5743	Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
sl@0	5744	TclChannelEventScriptInvoker, (ClientData) esPtr);
sl@0	5745	Tcl_DecrRefCount(esPtr->scriptPtr);
sl@0	5746	ckfree((char *) esPtr);
sl@0	5747
sl@0	5748	return TCL_OK;
sl@0	5749	}
sl@0	5750
sl@0	5751	if ((cmd[0] == 'l') && (strncmp(cmd, "list", (unsigned) len) == 0)) {
sl@0	5752	if (argc != 3) {
sl@0	5753	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
sl@0	5754	" channelName list\"", (char *) NULL);
sl@0	5755	return TCL_ERROR;
sl@0	5756	}
sl@0	5757	resultListPtr = Tcl_GetObjResult(interp);
sl@0	5758	for (esPtr = statePtr->scriptRecordPtr;
sl@0	5759	esPtr != (EventScriptRecord *) NULL;
sl@0	5760	esPtr = esPtr->nextPtr) {
sl@0	5761	if (esPtr->mask) {
sl@0	5762	Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
sl@0	5763	(esPtr->mask == TCL_READABLE) ? "readable" : "writable", -1));
sl@0	5764	} else {
sl@0	5765	Tcl_ListObjAppendElement(interp, resultListPtr,
sl@0	5766	Tcl_NewStringObj("none", -1));
sl@0	5767	}
sl@0	5768	Tcl_ListObjAppendElement(interp, resultListPtr, esPtr->scriptPtr);
sl@0	5769	}
sl@0	5770	Tcl_SetObjResult(interp, resultListPtr);
sl@0	5771	return TCL_OK;
sl@0	5772	}
sl@0	5773
sl@0	5774	if ((cmd[0] == 'r') && (strncmp(cmd, "removeall", (unsigned) len) == 0)) {
sl@0	5775	if (argc != 3) {
sl@0	5776	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
sl@0	5777	" channelName removeall\"", (char *) NULL);
sl@0	5778	return TCL_ERROR;
sl@0	5779	}
sl@0	5780	for (esPtr = statePtr->scriptRecordPtr;
sl@0	5781	esPtr != (EventScriptRecord *) NULL;
sl@0	5782	esPtr = nextEsPtr) {
sl@0	5783	nextEsPtr = esPtr->nextPtr;
sl@0	5784	Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
sl@0	5785	TclChannelEventScriptInvoker, (ClientData) esPtr);
sl@0	5786	Tcl_DecrRefCount(esPtr->scriptPtr);
sl@0	5787	ckfree((char *) esPtr);
sl@0	5788	}
sl@0	5789	statePtr->scriptRecordPtr = (EventScriptRecord *) NULL;
sl@0	5790	return TCL_OK;
sl@0	5791	}
sl@0	5792
sl@0	5793	if ((cmd[0] == 's') && (strncmp(cmd, "set", (unsigned) len) == 0)) {
sl@0	5794	if (argc != 5) {
sl@0	5795	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
sl@0	5796	" channelName delete index event\"", (char *) NULL);
sl@0	5797	return TCL_ERROR;
sl@0	5798	}
sl@0	5799	if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) {
sl@0	5800	return TCL_ERROR;
sl@0	5801	}
sl@0	5802	if (index < 0) {
sl@0	5803	Tcl_AppendResult(interp, "bad event index: ", argv[3],
sl@0	5804	": must be nonnegative", (char *) NULL);
sl@0	5805	return TCL_ERROR;
sl@0	5806	}
sl@0	5807	for (i = 0, esPtr = statePtr->scriptRecordPtr;
sl@0	5808	(i < index) && (esPtr != (EventScriptRecord *) NULL);
sl@0	5809	i++, esPtr = esPtr->nextPtr) {
sl@0	5810	/* Empty loop body. */
sl@0	5811	}
sl@0	5812	if (esPtr == (EventScriptRecord *) NULL) {
sl@0	5813	Tcl_AppendResult(interp, "bad event index ", argv[3],
sl@0	5814	": out of range", (char *) NULL);
sl@0	5815	return TCL_ERROR;
sl@0	5816	}
sl@0	5817
sl@0	5818	if (strcmp(argv[4], "readable") == 0) {
sl@0	5819	mask = TCL_READABLE;
sl@0	5820	} else if (strcmp(argv[4], "writable") == 0) {
sl@0	5821	mask = TCL_WRITABLE;
sl@0	5822	} else if (strcmp(argv[4], "none") == 0) {
sl@0	5823	mask = 0;
sl@0	5824	} else {
sl@0	5825	Tcl_AppendResult(interp, "bad event name \"", argv[4],
sl@0	5826	"\": must be readable, writable, or none", (char *) NULL);
sl@0	5827	return TCL_ERROR;
sl@0	5828	}
sl@0	5829	esPtr->mask = mask;
sl@0	5830	Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
sl@0	5831	TclChannelEventScriptInvoker, (ClientData) esPtr);
sl@0	5832	return TCL_OK;
sl@0	5833	}
sl@0	5834	Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of ",
sl@0	5835	"add, delete, list, set, or removeall", (char *) NULL);
sl@0	5836	return TCL_ERROR;
sl@0	5837	}
sl@0	5838
sl@0	5839	/*
sl@0	5840	*----------------------------------------------------------------------
sl@0	5841	*
sl@0	5842	* TestWrongNumArgsObjCmd --
sl@0	5843	*
sl@0	5844	* Test the Tcl_WrongNumArgs function.
sl@0	5845	*
sl@0	5846	* Results:
sl@0	5847	* Standard Tcl result.
sl@0	5848	*
sl@0	5849	* Side effects:
sl@0	5850	* Sets interpreter result.
sl@0	5851	*
sl@0	5852	*----------------------------------------------------------------------
sl@0	5853	*/
sl@0	5854
sl@0	5855	static int
sl@0	5856	TestWrongNumArgsObjCmd(dummy, interp, objc, objv)
sl@0	5857	ClientData dummy; /* Not used. */
sl@0	5858	Tcl_Interp interp; / Current interpreter. */
sl@0	5859	int objc; /* Number of arguments. */
sl@0	5860	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	5861	{
sl@0	5862	int i, length;
sl@0	5863	char *msg;
sl@0	5864
sl@0	5865	if (objc < 3) {
sl@0	5866	/*
sl@0	5867	* Don't use Tcl_WrongNumArgs here, as that is the function
sl@0	5868	* we want to test!
sl@0	5869	*/
sl@0	5870	Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC);
sl@0	5871	return TCL_ERROR;
sl@0	5872	}
sl@0	5873
sl@0	5874	if (Tcl_GetIntFromObj(interp, objv[1], &i) != TCL_OK) {
sl@0	5875	return TCL_ERROR;
sl@0	5876	}
sl@0	5877
sl@0	5878	msg = Tcl_GetStringFromObj(objv[2], &length);
sl@0	5879	if (length == 0) {
sl@0	5880	msg = NULL;
sl@0	5881	}
sl@0	5882
sl@0	5883	if (i > objc - 3) {
sl@0	5884	/*
sl@0	5885	* Asked for more arguments than were given.
sl@0	5886	*/
sl@0	5887	Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC);
sl@0	5888	return TCL_ERROR;
sl@0	5889	}
sl@0	5890
sl@0	5891	Tcl_WrongNumArgs(interp, i, &(objv[3]), msg);
sl@0	5892	return TCL_OK;
sl@0	5893	}
sl@0	5894
sl@0	5895	/*
sl@0	5896	*----------------------------------------------------------------------
sl@0	5897	*
sl@0	5898	* TestGetIndexFromObjStructObjCmd --
sl@0	5899	*
sl@0	5900	* Test the Tcl_GetIndexFromObjStruct function.
sl@0	5901	*
sl@0	5902	* Results:
sl@0	5903	* Standard Tcl result.
sl@0	5904	*
sl@0	5905	* Side effects:
sl@0	5906	* Sets interpreter result.
sl@0	5907	*
sl@0	5908	*----------------------------------------------------------------------
sl@0	5909	*/
sl@0	5910
sl@0	5911	static int
sl@0	5912	TestGetIndexFromObjStructObjCmd(dummy, interp, objc, objv)
sl@0	5913	ClientData dummy; /* Not used. */
sl@0	5914	Tcl_Interp interp; / Current interpreter. */
sl@0	5915	int objc; /* Number of arguments. */
sl@0	5916	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	5917	{
sl@0	5918	char *ary[] = {
sl@0	5919	"a", "b", "c", "d", "e", "f", (char )NULL,(char )NULL
sl@0	5920	};
sl@0	5921	int idx,target;
sl@0	5922
sl@0	5923	if (objc != 3) {
sl@0	5924	Tcl_WrongNumArgs(interp, 1, objv, "argument targetvalue");
sl@0	5925	return TCL_ERROR;
sl@0	5926	}
sl@0	5927	if (Tcl_GetIndexFromObjStruct(interp, objv[1], ary, 2sizeof(char ),
sl@0	5928	"dummy", 0, &idx) != TCL_OK) {
sl@0	5929	return TCL_ERROR;
sl@0	5930	}
sl@0	5931	if (Tcl_GetIntFromObj(interp, objv[2], &target) != TCL_OK) {
sl@0	5932	return TCL_ERROR;
sl@0	5933	}
sl@0	5934	if (idx != target) {
sl@0	5935	char buffer[64];
sl@0	5936	sprintf(buffer, "%d", idx);
sl@0	5937	Tcl_AppendResult(interp, "index value comparison failed: got ",
sl@0	5938	buffer, NULL);
sl@0	5939	sprintf(buffer, "%d", target);
sl@0	5940	Tcl_AppendResult(interp, " when ", buffer, " expected", NULL);
sl@0	5941	return TCL_ERROR;
sl@0	5942	}
sl@0	5943	Tcl_WrongNumArgs(interp, 3, objv, NULL);
sl@0	5944	return TCL_OK;
sl@0	5945	}
sl@0	5946
sl@0	5947	/*
sl@0	5948	*----------------------------------------------------------------------
sl@0	5949	*
sl@0	5950	* TestFilesystemObjCmd --
sl@0	5951	*
sl@0	5952	* This procedure implements the "testfilesystem" command. It is
sl@0	5953	* used to test Tcl_FSRegister, Tcl_FSUnregister, and can be used
sl@0	5954	* to test that the pluggable filesystem works.
sl@0	5955	*
sl@0	5956	* Results:
sl@0	5957	* A standard Tcl result.
sl@0	5958	*
sl@0	5959	* Side effects:
sl@0	5960	* Inserts or removes a filesystem from Tcl's stack.
sl@0	5961	*
sl@0	5962	*----------------------------------------------------------------------
sl@0	5963	*/
sl@0	5964
sl@0	5965	static int
sl@0	5966	TestFilesystemObjCmd(dummy, interp, objc, objv)
sl@0	5967	ClientData dummy;
sl@0	5968	Tcl_Interp *interp;
sl@0	5969	int objc;
sl@0	5970	Tcl_Obj *CONST objv[];
sl@0	5971	{
sl@0	5972	int res, boolVal;
sl@0	5973	char *msg;
sl@0	5974
sl@0	5975	if (objc != 2) {
sl@0	5976	Tcl_WrongNumArgs(interp, 1, objv, "boolean");
sl@0	5977	return TCL_ERROR;
sl@0	5978	}
sl@0	5979	if (Tcl_GetBooleanFromObj(interp, objv[1], &boolVal) != TCL_OK) {
sl@0	5980	return TCL_ERROR;
sl@0	5981	}
sl@0	5982	if (boolVal) {
sl@0	5983	res = Tcl_FSRegister((ClientData)interp, &testReportingFilesystem);
sl@0	5984	msg = (res == TCL_OK) ? "registered" : "failed";
sl@0	5985	} else {
sl@0	5986	res = Tcl_FSUnregister(&testReportingFilesystem);
sl@0	5987	msg = (res == TCL_OK) ? "unregistered" : "failed";
sl@0	5988	}
sl@0	5989	Tcl_SetResult(interp, msg, TCL_VOLATILE);
sl@0	5990	return res;
sl@0	5991	}
sl@0	5992
sl@0	5993	static int
sl@0	5994	TestReportInFilesystem(Tcl_Obj pathPtr, ClientData clientDataPtr)
sl@0	5995	{
sl@0	5996	static Tcl_Obj* lastPathPtr = NULL;
sl@0	5997
sl@0	5998	if (pathPtr == lastPathPtr) {
sl@0	5999	/* Reject all files second time around */
sl@0	6000	return -1;
sl@0	6001	} else {
sl@0	6002	Tcl_Obj * newPathPtr;
sl@0	6003	/* Try to claim all files first time around */
sl@0	6004
sl@0	6005	newPathPtr = Tcl_DuplicateObj(pathPtr);
sl@0	6006	lastPathPtr = newPathPtr;
sl@0	6007	Tcl_IncrRefCount(newPathPtr);
sl@0	6008	if (Tcl_FSGetFileSystemForPath(newPathPtr) == NULL) {
sl@0	6009	/* Nothing claimed it. Therefore we don't either */
sl@0	6010	Tcl_DecrRefCount(newPathPtr);
sl@0	6011	lastPathPtr = NULL;
sl@0	6012	return -1;
sl@0	6013	} else {
sl@0	6014	lastPathPtr = NULL;
sl@0	6015	*clientDataPtr = (ClientData) newPathPtr;
sl@0	6016	return TCL_OK;
sl@0	6017	}
sl@0	6018	}
sl@0	6019	}
sl@0	6020
sl@0	6021	/*
sl@0	6022	* Simple helper function to extract the native vfs representation of a
sl@0	6023	* path object, or NULL if no such representation exists.
sl@0	6024	*/
sl@0	6025	static Tcl_Obj*
sl@0	6026	TestReportGetNativePath(Tcl_Obj* pathObjPtr) {
sl@0	6027	return (Tcl_Obj*) Tcl_FSGetInternalRep(pathObjPtr, &testReportingFilesystem);
sl@0	6028	}
sl@0	6029
sl@0	6030	static void
sl@0	6031	TestReportFreeInternalRep(ClientData clientData) {
sl@0	6032	Tcl_Obj nativeRep = (Tcl_Obj)clientData;
sl@0	6033	if (nativeRep != NULL) {
sl@0	6034	/* Free the path */
sl@0	6035	Tcl_DecrRefCount(nativeRep);
sl@0	6036	}
sl@0	6037	}
sl@0	6038
sl@0	6039	static ClientData
sl@0	6040	TestReportDupInternalRep(ClientData clientData) {
sl@0	6041	Tcl_Obj original = (Tcl_Obj)clientData;
sl@0	6042	Tcl_IncrRefCount(original);
sl@0	6043	return clientData;
sl@0	6044	}
sl@0	6045
sl@0	6046	static void
sl@0	6047	TestReport(cmd, path, arg2)
sl@0	6048	CONST char* cmd;
sl@0	6049	Tcl_Obj* path;
sl@0	6050	Tcl_Obj* arg2;
sl@0	6051	{
sl@0	6052	Tcl_Interp* interp = (Tcl_Interp*) Tcl_FSData(&testReportingFilesystem);
sl@0	6053	if (interp == NULL) {
sl@0	6054	/* This is bad, but not much we can do about it */
sl@0	6055	} else {
sl@0	6056	/*
sl@0	6057	* No idea why I decided to program this up using the
sl@0	6058	* old string-based API, but there you go. We should
sl@0	6059	* convert it to objects.
sl@0	6060	*/
sl@0	6061	Tcl_SavedResult savedResult;
sl@0	6062	Tcl_DString ds;
sl@0	6063	Tcl_DStringInit(&ds);
sl@0	6064	Tcl_DStringAppend(&ds, "lappend filesystemReport ",-1);
sl@0	6065	Tcl_DStringStartSublist(&ds);
sl@0	6066	Tcl_DStringAppendElement(&ds, cmd);
sl@0	6067	if (path != NULL) {
sl@0	6068	Tcl_DStringAppendElement(&ds, Tcl_GetString(path));
sl@0	6069	}
sl@0	6070	if (arg2 != NULL) {
sl@0	6071	Tcl_DStringAppendElement(&ds, Tcl_GetString(arg2));
sl@0	6072	}
sl@0	6073	Tcl_DStringEndSublist(&ds);
sl@0	6074	Tcl_SaveResult(interp, &savedResult);
sl@0	6075	Tcl_Eval(interp, Tcl_DStringValue(&ds));
sl@0	6076	Tcl_DStringFree(&ds);
sl@0	6077	Tcl_RestoreResult(interp, &savedResult);
sl@0	6078	}
sl@0	6079	}
sl@0	6080
sl@0	6081	static int
sl@0	6082	TestReportStat(path, buf)
sl@0	6083	Tcl_Obj path; / Path of file to stat (in current CP). */
sl@0	6084	Tcl_StatBuf buf; / Filled with results of stat call. */
sl@0	6085	{
sl@0	6086	TestReport("stat",path, NULL);
sl@0	6087	return Tcl_FSStat(TestReportGetNativePath(path),buf);
sl@0	6088	}
sl@0	6089	static int
sl@0	6090	TestReportLstat(path, buf)
sl@0	6091	Tcl_Obj path; / Path of file to stat (in current CP). */
sl@0	6092	Tcl_StatBuf buf; / Filled with results of stat call. */
sl@0	6093	{
sl@0	6094	TestReport("lstat",path, NULL);
sl@0	6095	return Tcl_FSLstat(TestReportGetNativePath(path),buf);
sl@0	6096	}
sl@0	6097	static int
sl@0	6098	TestReportAccess(path, mode)
sl@0	6099	Tcl_Obj path; / Path of file to access (in current CP). */
sl@0	6100	int mode; /* Permission setting. */
sl@0	6101	{
sl@0	6102	TestReport("access",path,NULL);
sl@0	6103	return Tcl_FSAccess(TestReportGetNativePath(path),mode);
sl@0	6104	}
sl@0	6105	static Tcl_Channel
sl@0	6106	TestReportOpenFileChannel(interp, fileName, mode, permissions)
sl@0	6107	Tcl_Interp interp; / Interpreter for error reporting;
sl@0	6108	* can be NULL. */
sl@0	6109	Tcl_Obj fileName; / Name of file to open. */
sl@0	6110	int mode; /* POSIX open mode. */
sl@0	6111	int permissions; /* If the open involves creating a
sl@0	6112	* file, with what modes to create
sl@0	6113	* it? */
sl@0	6114	{
sl@0	6115	TestReport("open",fileName, NULL);
sl@0	6116	return TclpOpenFileChannel(interp, TestReportGetNativePath(fileName),
sl@0	6117	mode, permissions);
sl@0	6118	}
sl@0	6119
sl@0	6120	static int
sl@0	6121	TestReportMatchInDirectory(interp, resultPtr, dirPtr, pattern, types)
sl@0	6122	Tcl_Interp interp; / Interpreter to receive results. */
sl@0	6123	Tcl_Obj resultPtr; / Object to lappend results. */
sl@0	6124	Tcl_Obj dirPtr; / Contains path to directory to search. */
sl@0	6125	CONST char pattern; / Pattern to match against. */
sl@0	6126	Tcl_GlobTypeData types; / Object containing list of acceptable types.
sl@0	6127	* May be NULL. */
sl@0	6128	{
sl@0	6129	if (types != NULL && types->type & TCL_GLOB_TYPE_MOUNT) {
sl@0	6130	TestReport("matchmounts",dirPtr, NULL);
sl@0	6131	return TCL_OK;
sl@0	6132	} else {
sl@0	6133	TestReport("matchindirectory",dirPtr, NULL);
sl@0	6134	return Tcl_FSMatchInDirectory(interp, resultPtr,
sl@0	6135	TestReportGetNativePath(dirPtr), pattern,
sl@0	6136	types);
sl@0	6137	}
sl@0	6138	}
sl@0	6139	static int
sl@0	6140	TestReportChdir(dirName)
sl@0	6141	Tcl_Obj *dirName;
sl@0	6142	{
sl@0	6143	TestReport("chdir",dirName,NULL);
sl@0	6144	return Tcl_FSChdir(TestReportGetNativePath(dirName));
sl@0	6145	}
sl@0	6146	static int
sl@0	6147	TestReportLoadFile(interp, fileName,
sl@0	6148	handlePtr, unloadProcPtr)
sl@0	6149	Tcl_Interp interp; / Used for error reporting. */
sl@0	6150	Tcl_Obj fileName; / Name of the file containing the desired
sl@0	6151	* code. */
sl@0	6152	Tcl_LoadHandle handlePtr; / Filled with token for dynamically loaded
sl@0	6153	* file which will be passed back to
sl@0	6154	* (unloadProcPtr)() to unload the file. /
sl@0	6155	Tcl_FSUnloadFileProc **unloadProcPtr;
sl@0	6156	/* Filled with address of Tcl_FSUnloadFileProc
sl@0	6157	* function which should be used for
sl@0	6158	* this file. */
sl@0	6159	{
sl@0	6160	TestReport("loadfile",fileName,NULL);
sl@0	6161	return Tcl_FSLoadFile(interp, TestReportGetNativePath(fileName), NULL, NULL,
sl@0	6162	NULL, NULL, handlePtr, unloadProcPtr);
sl@0	6163	}
sl@0	6164	static Tcl_Obj *
sl@0	6165	TestReportLink(path, to, linkType)
sl@0	6166	Tcl_Obj path; / Path of file to readlink or link */
sl@0	6167	Tcl_Obj to; / Path of file to link to, or NULL */
sl@0	6168	int linkType;
sl@0	6169	{
sl@0	6170	TestReport("link",path,to);
sl@0	6171	return Tcl_FSLink(TestReportGetNativePath(path), to, linkType);
sl@0	6172	}
sl@0	6173	static int
sl@0	6174	TestReportRenameFile(src, dst)
sl@0	6175	Tcl_Obj src; / Pathname of file or dir to be renamed
sl@0	6176	* (UTF-8). */
sl@0	6177	Tcl_Obj dst; / New pathname of file or directory
sl@0	6178	* (UTF-8). */
sl@0	6179	{
sl@0	6180	TestReport("renamefile",src,dst);
sl@0	6181	return Tcl_FSRenameFile(TestReportGetNativePath(src),
sl@0	6182	TestReportGetNativePath(dst));
sl@0	6183	}
sl@0	6184	static int
sl@0	6185	TestReportCopyFile(src, dst)
sl@0	6186	Tcl_Obj src; / Pathname of file to be copied (UTF-8). */
sl@0	6187	Tcl_Obj dst; / Pathname of file to copy to (UTF-8). */
sl@0	6188	{
sl@0	6189	TestReport("copyfile",src,dst);
sl@0	6190	return Tcl_FSCopyFile(TestReportGetNativePath(src),
sl@0	6191	TestReportGetNativePath(dst));
sl@0	6192	}
sl@0	6193	static int
sl@0	6194	TestReportDeleteFile(path)
sl@0	6195	Tcl_Obj path; / Pathname of file to be removed (UTF-8). */
sl@0	6196	{
sl@0	6197	TestReport("deletefile",path,NULL);
sl@0	6198	return Tcl_FSDeleteFile(TestReportGetNativePath(path));
sl@0	6199	}
sl@0	6200	static int
sl@0	6201	TestReportCreateDirectory(path)
sl@0	6202	Tcl_Obj path; / Pathname of directory to create (UTF-8). */
sl@0	6203	{
sl@0	6204	TestReport("createdirectory",path,NULL);
sl@0	6205	return Tcl_FSCreateDirectory(TestReportGetNativePath(path));
sl@0	6206	}
sl@0	6207	static int
sl@0	6208	TestReportCopyDirectory(src, dst, errorPtr)
sl@0	6209	Tcl_Obj src; / Pathname of directory to be copied
sl@0	6210	* (UTF-8). */
sl@0	6211	Tcl_Obj dst; / Pathname of target directory (UTF-8). */
sl@0	6212	Tcl_Obj *errorPtr; / If non-NULL, to be filled with UTF-8 name
sl@0	6213	* of file causing error. */
sl@0	6214	{
sl@0	6215	TestReport("copydirectory",src,dst);
sl@0	6216	return Tcl_FSCopyDirectory(TestReportGetNativePath(src),
sl@0	6217	TestReportGetNativePath(dst), errorPtr);
sl@0	6218	}
sl@0	6219	static int
sl@0	6220	TestReportRemoveDirectory(path, recursive, errorPtr)
sl@0	6221	Tcl_Obj path; / Pathname of directory to be removed
sl@0	6222	* (UTF-8). */
sl@0	6223	int recursive; /* If non-zero, removes directories that
sl@0	6224	* are nonempty. Otherwise, will only remove
sl@0	6225	* empty directories. */
sl@0	6226	Tcl_Obj *errorPtr; / If non-NULL, to be filled with UTF-8 name
sl@0	6227	* of file causing error. */
sl@0	6228	{
sl@0	6229	TestReport("removedirectory",path,NULL);
sl@0	6230	return Tcl_FSRemoveDirectory(TestReportGetNativePath(path), recursive,
sl@0	6231	errorPtr);
sl@0	6232	}
sl@0	6233	static CONST char**
sl@0	6234	TestReportFileAttrStrings(fileName, objPtrRef)
sl@0	6235	Tcl_Obj* fileName;
sl@0	6236	Tcl_Obj** objPtrRef;
sl@0	6237	{
sl@0	6238	TestReport("fileattributestrings",fileName,NULL);
sl@0	6239	return Tcl_FSFileAttrStrings(TestReportGetNativePath(fileName), objPtrRef);
sl@0	6240	}
sl@0	6241	static int
sl@0	6242	TestReportFileAttrsGet(interp, index, fileName, objPtrRef)
sl@0	6243	Tcl_Interp interp; / The interpreter for error reporting. */
sl@0	6244	int index; /* index of the attribute command. */
sl@0	6245	Tcl_Obj fileName; / filename we are operating on. */
sl@0	6246	Tcl_Obj *objPtrRef; / for output. */
sl@0	6247	{
sl@0	6248	TestReport("fileattributesget",fileName,NULL);
sl@0	6249	return Tcl_FSFileAttrsGet(interp, index,
sl@0	6250	TestReportGetNativePath(fileName), objPtrRef);
sl@0	6251	}
sl@0	6252	static int
sl@0	6253	TestReportFileAttrsSet(interp, index, fileName, objPtr)
sl@0	6254	Tcl_Interp interp; / The interpreter for error reporting. */
sl@0	6255	int index; /* index of the attribute command. */
sl@0	6256	Tcl_Obj fileName; / filename we are operating on. */
sl@0	6257	Tcl_Obj objPtr; / for input. */
sl@0	6258	{
sl@0	6259	TestReport("fileattributesset",fileName,objPtr);
sl@0	6260	return Tcl_FSFileAttrsSet(interp, index,
sl@0	6261	TestReportGetNativePath(fileName), objPtr);
sl@0	6262	}
sl@0	6263	static int
sl@0	6264	TestReportUtime (fileName, tval)
sl@0	6265	Tcl_Obj* fileName;
sl@0	6266	struct utimbuf *tval;
sl@0	6267	{
sl@0	6268	TestReport("utime",fileName,NULL);
sl@0	6269	return Tcl_FSUtime(TestReportGetNativePath(fileName), tval);
sl@0	6270	}
sl@0	6271	static int
sl@0	6272	TestReportNormalizePath(interp, pathPtr, nextCheckpoint)
sl@0	6273	Tcl_Interp *interp;
sl@0	6274	Tcl_Obj *pathPtr;
sl@0	6275	int nextCheckpoint;
sl@0	6276	{
sl@0	6277	TestReport("normalizepath",pathPtr,NULL);
sl@0	6278	return nextCheckpoint;
sl@0	6279	}
sl@0	6280
sl@0	6281	static int
sl@0	6282	SimplePathInFilesystem(Tcl_Obj pathPtr, ClientData clientDataPtr) {
sl@0	6283	CONST char *str = Tcl_GetString(pathPtr);
sl@0	6284	if (strncmp(str,"simplefs:/",10)) {
sl@0	6285	return -1;
sl@0	6286	}
sl@0	6287	return TCL_OK;
sl@0	6288	}
sl@0	6289
sl@0	6290	/*
sl@0	6291	* Since TclCopyChannel insists on an interpreter, we use this
sl@0	6292	* to simplify our test scripts. Would be better if it could
sl@0	6293	* copy without an interp
sl@0	6294	*/
sl@0	6295	static Tcl_Interp *simpleInterpPtr = NULL;
sl@0	6296	/* We use this to ensure we clean up after ourselves */
sl@0	6297	static Tcl_Obj *tempFile = NULL;
sl@0	6298
sl@0	6299	/*
sl@0	6300	* This is a very 'hacky' filesystem which is used just to
sl@0	6301	* test two important features of the vfs code: (1) that
sl@0	6302	* you can load a shared library from a vfs, (2) that when
sl@0	6303	* copying files from one fs to another, the 'mtime' is
sl@0	6304	* preserved.
sl@0	6305	*
sl@0	6306	* It treats any file in 'simplefs:/' as a file, and
sl@0	6307	* artificially creates a real file on the fly which it uses
sl@0	6308	* to extract information from. The real file it uses is
sl@0	6309	* whatever follows the trailing '/' (e.g. 'foo' in 'simplefs:/foo'),
sl@0	6310	* and that file is assumed to exist in the native pwd, and is
sl@0	6311	* copied over to the native temporary directory where it is
sl@0	6312	* accessed.
sl@0	6313	*
sl@0	6314	* Please do not consider this filesystem a model of how
sl@0	6315	* things are to be done. It is quite the opposite! But, it
sl@0	6316	* does allow us to test two important features.
sl@0	6317	*
sl@0	6318	* Finally: this fs can only be used from one interpreter.
sl@0	6319	*/
sl@0	6320	static int
sl@0	6321	TestSimpleFilesystemObjCmd(dummy, interp, objc, objv)
sl@0	6322	ClientData dummy;
sl@0	6323	Tcl_Interp *interp;
sl@0	6324	int objc;
sl@0	6325	Tcl_Obj *CONST objv[];
sl@0	6326	{
sl@0	6327	int res, boolVal;
sl@0	6328	char *msg;
sl@0	6329
sl@0	6330	if (objc != 2) {
sl@0	6331	Tcl_WrongNumArgs(interp, 1, objv, "boolean");
sl@0	6332	return TCL_ERROR;
sl@0	6333	}
sl@0	6334	if (Tcl_GetBooleanFromObj(interp, objv[1], &boolVal) != TCL_OK) {
sl@0	6335	return TCL_ERROR;
sl@0	6336	}
sl@0	6337	if (boolVal) {
sl@0	6338	res = Tcl_FSRegister((ClientData)interp, &simpleFilesystem);
sl@0	6339	msg = (res == TCL_OK) ? "registered" : "failed";
sl@0	6340	simpleInterpPtr = interp;
sl@0	6341	} else {
sl@0	6342	if (tempFile != NULL) {
sl@0	6343	Tcl_FSDeleteFile(tempFile);
sl@0	6344	Tcl_DecrRefCount(tempFile);
sl@0	6345	tempFile = NULL;
sl@0	6346	}
sl@0	6347	res = Tcl_FSUnregister(&simpleFilesystem);
sl@0	6348	msg = (res == TCL_OK) ? "unregistered" : "failed";
sl@0	6349	simpleInterpPtr = NULL;
sl@0	6350	}
sl@0	6351	Tcl_SetResult(interp, msg, TCL_VOLATILE);
sl@0	6352	return res;
sl@0	6353	}
sl@0	6354
sl@0	6355	/*
sl@0	6356	* Treats a file name 'simplefs:/foo' by copying the file 'foo'
sl@0	6357	* in the current (native) directory to a temporary native file,
sl@0	6358	* and then returns that native file.
sl@0	6359	*/
sl@0	6360	static Tcl_Obj*
sl@0	6361	SimpleCopy(pathPtr)
sl@0	6362	Tcl_Obj pathPtr; / Name of file to copy. */
sl@0	6363	{
sl@0	6364	int res;
sl@0	6365	CONST char *str;
sl@0	6366	Tcl_Obj *origPtr;
sl@0	6367	Tcl_Obj *tempPtr;
sl@0	6368
sl@0	6369	tempPtr = TclpTempFileName();
sl@0	6370	Tcl_IncrRefCount(tempPtr);
sl@0	6371
sl@0	6372	/*
sl@0	6373	* We assume the same name in the current directory is ok.
sl@0	6374	*/
sl@0	6375	str = Tcl_GetString(pathPtr);
sl@0	6376	origPtr = Tcl_NewStringObj(str+10,-1);
sl@0	6377	Tcl_IncrRefCount(origPtr);
sl@0	6378
sl@0	6379	res = TclCrossFilesystemCopy(simpleInterpPtr, origPtr, tempPtr);
sl@0	6380	Tcl_DecrRefCount(origPtr);
sl@0	6381
sl@0	6382	if (res != TCL_OK) {
sl@0	6383	Tcl_FSDeleteFile(tempPtr);
sl@0	6384	Tcl_DecrRefCount(tempPtr);
sl@0	6385	return NULL;
sl@0	6386	}
sl@0	6387	return tempPtr;
sl@0	6388	}
sl@0	6389
sl@0	6390	static Tcl_Channel
sl@0	6391	SimpleOpenFileChannel(interp, pathPtr, mode, permissions)
sl@0	6392	Tcl_Interp interp; / Interpreter for error reporting;
sl@0	6393	* can be NULL. */
sl@0	6394	Tcl_Obj pathPtr; / Name of file to open. */
sl@0	6395	int mode; /* POSIX open mode. */
sl@0	6396	int permissions; /* If the open involves creating a
sl@0	6397	* file, with what modes to create
sl@0	6398	* it? */
sl@0	6399	{
sl@0	6400	Tcl_Obj *tempPtr;
sl@0	6401	Tcl_Channel chan;
sl@0	6402
sl@0	6403	if ((mode != 0) && !(mode & O_RDONLY)) {
sl@0	6404	Tcl_AppendResult(interp, "read-only",
sl@0	6405	(char *) NULL);
sl@0	6406	return NULL;
sl@0	6407	}
sl@0	6408
sl@0	6409	tempPtr = SimpleCopy(pathPtr);
sl@0	6410
sl@0	6411	if (tempPtr == NULL) {
sl@0	6412	return NULL;
sl@0	6413	}
sl@0	6414
sl@0	6415	chan = Tcl_FSOpenFileChannel(interp, tempPtr, "r", permissions);
sl@0	6416
sl@0	6417	if (tempFile != NULL) {
sl@0	6418	Tcl_FSDeleteFile(tempFile);
sl@0	6419	Tcl_DecrRefCount(tempFile);
sl@0	6420	tempFile = NULL;
sl@0	6421	}
sl@0	6422	/*
sl@0	6423	* Store file pointer in this global variable so we can delete
sl@0	6424	* it later
sl@0	6425	*/
sl@0	6426	tempFile = tempPtr;
sl@0	6427	return chan;
sl@0	6428	}
sl@0	6429
sl@0	6430	static int
sl@0	6431	SimpleAccess(pathPtr, mode)
sl@0	6432	Tcl_Obj pathPtr; / Path of file to access (in current CP). */
sl@0	6433	int mode; /* Permission setting. */
sl@0	6434	{
sl@0	6435	/* All files exist */
sl@0	6436	return TCL_OK;
sl@0	6437	}
sl@0	6438
sl@0	6439	static int
sl@0	6440	SimpleStat(pathPtr, bufPtr)
sl@0	6441	Tcl_Obj pathPtr; / Path of file to stat (in current CP). */
sl@0	6442	Tcl_StatBuf bufPtr; / Filled with results of stat call. */
sl@0	6443	{
sl@0	6444	Tcl_Obj *tempPtr = SimpleCopy(pathPtr);
sl@0	6445	if (tempPtr == NULL) {
sl@0	6446	/* We just pretend the file exists anyway */
sl@0	6447	return TCL_OK;
sl@0	6448	} else {
sl@0	6449	int res = Tcl_FSStat(tempPtr, bufPtr);
sl@0	6450	Tcl_FSDeleteFile(tempPtr);
sl@0	6451	Tcl_DecrRefCount(tempPtr);
sl@0	6452	return res;
sl@0	6453	}
sl@0	6454	}
sl@0	6455
sl@0	6456	static Tcl_Obj*
sl@0	6457	SimpleListVolumes(void)
sl@0	6458	{
sl@0	6459	/* Add one new volume */
sl@0	6460	Tcl_Obj *retVal;
sl@0	6461
sl@0	6462	retVal = Tcl_NewStringObj("simplefs:/",-1);
sl@0	6463	Tcl_IncrRefCount(retVal);
sl@0	6464	return retVal;
sl@0	6465	}
sl@0	6466
sl@0	6467	/*
sl@0	6468	* Used to check correct string-length determining in Tcl_NumUtfChars
sl@0	6469	*/
sl@0	6470	static int
sl@0	6471	TestNumUtfCharsCmd(clientData, interp, objc, objv)
sl@0	6472	ClientData clientData;
sl@0	6473	Tcl_Interp *interp;
sl@0	6474	int objc;
sl@0	6475	Tcl_Obj *CONST objv[];
sl@0	6476	{
sl@0	6477	if (objc > 1) {
sl@0	6478	int len = -1;
sl@0	6479	if (objc > 2) {
sl@0	6480	(void) Tcl_GetStringFromObj(objv[1], &len);
sl@0	6481	}
sl@0	6482	len = Tcl_NumUtfChars(Tcl_GetString(objv[1]), len);
sl@0	6483	Tcl_SetObjResult(interp, Tcl_NewIntObj(len));
sl@0	6484	}
sl@0	6485	return TCL_OK;
sl@0	6486	}

author	sl
	Tue, 10 Jun 2014 14:32:02 +0200
changeset 1	260cb5ec6c19
permissions	-rw-r--r--