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