MercurialSymaptic / file revision
summary | shortlog | changelog | graph | tags | bookmarks | branches | files | changeset | file | latest | revisions | annotate | diff | raw | help
os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclTest.c
author sl
Tue, 10 Jun 2014 14:32:02 +0200
changeset 1 260cb5ec6c19
permissions -rw-r--r--
Update contrib. 
     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  * Portions Copyright (c) 2007 Nokia Corporation and/or its subsidiaries. All rights reserved.   

    14  *

    15  * See the file "license.terms" for information on usage and redistribution

    16  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.

    17  *

    18  * RCS: @(#) $Id: tclTest.c,v 1.62.2.13 2006/09/22 01:26:23 andreas_kupries Exp $

    19  */

    20 #ifndef __SYMBIAN32__  

    21 #define TCL_TEST

    22 #endif

    23 #include "tclInt.h"

    24 #include "tclPort.h"

    25 #if defined(__SYMBIAN32__) 

    26 #include "tclSymbianGlobals.h"

    27 #endif 

    28 

    29 /*

    30  * Required for Testregexp*Cmd

    31  */

    32 #include "tclRegexp.h"

    33 

    34 /*

    35  * Required for TestlocaleCmd

    36  */

    37 #include <locale.h>

    38 

    39 /*

    40  * Required for the TestChannelCmd and TestChannelEventCmd

    41  */

    42 #include "tclIO.h"

    43 

    44 /*

    45  * Declare external functions used in Windows tests.

    46  */

    47 

    48 /*

    49  * Dynamic string shared by TestdcallCmd and DelCallbackProc;  used

    50  * to collect the results of the various deletion callbacks.

    51  */

    52 

    53 static Tcl_DString delString;

    54 static Tcl_Interp *delInterp;

    55 

    56 /*

    57  * One of the following structures exists for each asynchronous

    58  * handler created by the "testasync" command".

    59  */

    60 

    61 typedef struct TestAsyncHandler {

    62     int id;				/* Identifier for this handler. */

    63     Tcl_AsyncHandler handler;		/* Tcl's token for the handler. */

    64     char *command;			/* Command to invoke when the

    65 					 * handler is invoked. */

    66     struct TestAsyncHandler *nextPtr;	/* Next is list of handlers. */

    67 } TestAsyncHandler;

    68 

    69 static TestAsyncHandler *firstHandler = NULL;

    70 

    71 /*

    72  * The dynamic string below is used by the "testdstring" command

    73  * to test the dynamic string facilities.

    74  */

    75 

    76 static Tcl_DString dstring;

    77 

    78 /*

    79  * The command trace below is used by the "testcmdtraceCmd" command

    80  * to test the command tracing facilities.

    81  */

    82 

    83 static Tcl_Trace cmdTrace;

    84 

    85 /*

    86  * One of the following structures exists for each command created

    87  * by TestdelCmd:

    88  */

    89 

    90 typedef struct DelCmd {

    91     Tcl_Interp *interp;		/* Interpreter in which command exists. */

    92     char *deleteCmd;		/* Script to execute when command is

    93 				 * deleted.  Malloc'ed. */

    94 } DelCmd;

    95 

    96 /*

    97  * The following is used to keep track of an encoding that invokes a Tcl

    98  * command. 

    99  */

   100 

   101 typedef struct TclEncoding {

   102     Tcl_Interp *interp;

   103     char *toUtfCmd;

   104     char *fromUtfCmd;

   105 } TclEncoding;

   106 

   107 /*

   108  * The counter below is used to determine if the TestsaveresultFree

   109  * routine was called for a result.

   110  */

   111 

   112 static int freeCount;

   113 

   114 /*

   115  * Boolean flag used by the "testsetmainloop" and "testexitmainloop"

   116  * commands.

   117  */

   118 static int exitMainLoop = 0;

   119 

   120 /*

   121  * Event structure used in testing the event queue management procedures.

   122  */

   123 typedef struct TestEvent {

   124     Tcl_Event header;		/* Header common to all events */

   125     Tcl_Interp* interp;		/* Interpreter that will handle the event */

   126     Tcl_Obj* command;		/* Command to evaluate when the event occurs */

   127     Tcl_Obj* tag;		/* Tag for this event used to delete it */

   128 } TestEvent;

   129 

   130 /*

   131  * Forward declarations for procedures defined later in this file:

   132  */

   133 

   134 int			Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp));

   135 static int		AsyncHandlerProc _ANSI_ARGS_((ClientData clientData,

   136 			    Tcl_Interp *interp, int code));

   137 static void		CleanupTestSetassocdataTests _ANSI_ARGS_((

   138 			    ClientData clientData, Tcl_Interp *interp));

   139 static void		CmdDelProc1 _ANSI_ARGS_((ClientData clientData));

   140 static void		CmdDelProc2 _ANSI_ARGS_((ClientData clientData));

   141 static int		CmdProc1 _ANSI_ARGS_((ClientData clientData,

   142 			    Tcl_Interp *interp, int argc, CONST char **argv));

   143 static int		CmdProc2 _ANSI_ARGS_((ClientData clientData,

   144 			    Tcl_Interp *interp, int argc, CONST char **argv));

   145 static void		CmdTraceDeleteProc _ANSI_ARGS_((

   146 			    ClientData clientData, Tcl_Interp *interp,

   147 			    int level, char *command, Tcl_CmdProc *cmdProc,

   148 			    ClientData cmdClientData, int argc,

   149 			    char **argv));

   150 static void		CmdTraceProc _ANSI_ARGS_((ClientData clientData,

   151 			    Tcl_Interp *interp, int level, char *command,

   152 			    Tcl_CmdProc *cmdProc, ClientData cmdClientData,

   153                             int argc, char **argv));

   154 static int		CreatedCommandProc _ANSI_ARGS_((

   155 			    ClientData clientData, Tcl_Interp *interp,

   156 			    int argc, CONST char **argv));

   157 static int		CreatedCommandProc2 _ANSI_ARGS_((

   158 			    ClientData clientData, Tcl_Interp *interp,

   159 			    int argc, CONST char **argv));

   160 static void		DelCallbackProc _ANSI_ARGS_((ClientData clientData,

   161 			    Tcl_Interp *interp));

   162 static int		DelCmdProc _ANSI_ARGS_((ClientData clientData,

   163 			    Tcl_Interp *interp, int argc, CONST char **argv));

   164 static void		DelDeleteProc _ANSI_ARGS_((ClientData clientData));

   165 static void		EncodingFreeProc _ANSI_ARGS_((ClientData clientData));

   166 static int		EncodingToUtfProc _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));

   171 static int		EncodingFromUtfProc _ANSI_ARGS_((ClientData clientData,

   172 			    CONST char *src, int srcLen, int flags,

   173 			    Tcl_EncodingState *statePtr, char *dst,

   174 			    int dstLen, int *srcReadPtr, int *dstWrotePtr,

   175 			    int *dstCharsPtr));

   176 static void		ExitProcEven _ANSI_ARGS_((ClientData clientData));

   177 static void		ExitProcOdd _ANSI_ARGS_((ClientData clientData));

   178 static int              GetTimesCmd _ANSI_ARGS_((ClientData clientData,

   179                             Tcl_Interp *interp, int argc, CONST char **argv));

   180 static void		MainLoop _ANSI_ARGS_((void));

   181 static int              NoopCmd _ANSI_ARGS_((ClientData clientData,

   182                             Tcl_Interp *interp, int argc, CONST char **argv));

   183 static int              NoopObjCmd _ANSI_ARGS_((ClientData clientData,

   184                             Tcl_Interp *interp, int objc,

   185 			    Tcl_Obj *CONST objv[]));

   186 static int		ObjTraceProc _ANSI_ARGS_(( ClientData clientData,

   187 						   Tcl_Interp* interp,

   188 						   int level,

   189 						   CONST char* command,

   190 						   Tcl_Command commandToken,

   191 						   int objc,

   192 						   Tcl_Obj *CONST objv[] ));

   193 static void		ObjTraceDeleteProc _ANSI_ARGS_(( ClientData ));

   194 static void		PrintParse _ANSI_ARGS_((Tcl_Interp *interp,

   195 						Tcl_Parse *parsePtr));

   196 static void		SpecialFree _ANSI_ARGS_((char *blockPtr));

   197 static int		StaticInitProc _ANSI_ARGS_((Tcl_Interp *interp));

   198 static int		TestaccessprocCmd _ANSI_ARGS_((ClientData dummy,

   199 			    Tcl_Interp *interp, int argc, CONST char **argv));

   200 static int		PretendTclpAccess _ANSI_ARGS_((CONST char *path,

   201 			   int mode));

   202 static int		TestAccessProc1 _ANSI_ARGS_((CONST char *path,

   203 			   int mode));

   204 static int		TestAccessProc2 _ANSI_ARGS_((CONST char *path,

   205 			   int mode));

   206 static int		TestAccessProc3 _ANSI_ARGS_((CONST char *path,

   207 			   int mode));

   208 static int		TestasyncCmd _ANSI_ARGS_((ClientData dummy,

   209 			    Tcl_Interp *interp, int argc, CONST char **argv));

   210 static int		TestcmdinfoCmd _ANSI_ARGS_((ClientData dummy,

   211 			    Tcl_Interp *interp, int argc, CONST char **argv));

   212 static int		TestcmdtokenCmd _ANSI_ARGS_((ClientData dummy,

   213 			    Tcl_Interp *interp, int argc, CONST char **argv));

   214 static int		TestcmdtraceCmd _ANSI_ARGS_((ClientData dummy,

   215 			    Tcl_Interp *interp, int argc, CONST char **argv));

   216 static int		TestcreatecommandCmd _ANSI_ARGS_((ClientData dummy,

   217 			    Tcl_Interp *interp, int argc, CONST char **argv));

   218 static int		TestdcallCmd _ANSI_ARGS_((ClientData dummy,

   219 			    Tcl_Interp *interp, int argc, CONST char **argv));

   220 static int		TestdelCmd _ANSI_ARGS_((ClientData dummy,

   221 			    Tcl_Interp *interp, int argc, CONST char **argv));

   222 static int		TestdelassocdataCmd _ANSI_ARGS_((ClientData dummy,

   223 			    Tcl_Interp *interp, int argc, CONST char **argv));

   224 static int		TestdstringCmd _ANSI_ARGS_((ClientData dummy,

   225 			    Tcl_Interp *interp, int argc, CONST char **argv));

   226 static int		TestencodingObjCmd _ANSI_ARGS_((ClientData dummy,

   227 			    Tcl_Interp *interp, int objc, 

   228 			    Tcl_Obj *CONST objv[]));

   229 static int		TestevalexObjCmd _ANSI_ARGS_((ClientData dummy,

   230 			    Tcl_Interp *interp, int objc, 

   231 			    Tcl_Obj *CONST objv[]));

   232 static int		TestevalobjvObjCmd _ANSI_ARGS_((ClientData dummy,

   233 			    Tcl_Interp *interp, int objc, 

   234 			    Tcl_Obj *CONST objv[]));

   235 static int		TesteventObjCmd _ANSI_ARGS_((ClientData unused,

   236 						     Tcl_Interp* interp,

   237 						     int argc,

   238 						     Tcl_Obj *CONST objv[]));

   239 static int		TesteventProc _ANSI_ARGS_((Tcl_Event* event,

   240 						   int flags));

   241 static int		TesteventDeleteProc _ANSI_ARGS_((

   242 			    Tcl_Event* event,

   243 			    ClientData clientData));

   244 static int		TestexithandlerCmd _ANSI_ARGS_((ClientData dummy,

   245 			    Tcl_Interp *interp, int argc, CONST char **argv));

   246 static int		TestexprlongCmd _ANSI_ARGS_((ClientData dummy,

   247 			    Tcl_Interp *interp, int argc, CONST char **argv));

   248 static int		TestexprparserObjCmd _ANSI_ARGS_((ClientData dummy,

   249 			    Tcl_Interp *interp, int objc,

   250 			    Tcl_Obj *CONST objv[]));

   251 static int		TestexprstringCmd _ANSI_ARGS_((ClientData dummy,

   252 			    Tcl_Interp *interp, int argc, CONST char **argv));

   253 static int		TestfileCmd _ANSI_ARGS_((ClientData dummy,

   254 			    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));

   255 static int		TestfilelinkCmd _ANSI_ARGS_((ClientData dummy,

   256 			    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));

   257 static int		TestfeventCmd _ANSI_ARGS_((ClientData dummy,

   258 			    Tcl_Interp *interp, int argc, CONST char **argv));

   259 static int		TestgetassocdataCmd _ANSI_ARGS_((ClientData dummy,

   260 			    Tcl_Interp *interp, int argc, CONST char **argv));

   261 static int		TestgetplatformCmd _ANSI_ARGS_((ClientData dummy,

   262 			    Tcl_Interp *interp, int argc, CONST char **argv));

   263 static int		TestgetvarfullnameCmd _ANSI_ARGS_((

   264 			    ClientData dummy, Tcl_Interp *interp,

   265 			    int objc, Tcl_Obj *CONST objv[]));

   266 static int		TestinterpdeleteCmd _ANSI_ARGS_((ClientData dummy,

   267 		            Tcl_Interp *interp, int argc, CONST char **argv));

   268 static int		TestlinkCmd _ANSI_ARGS_((ClientData dummy,

   269 			    Tcl_Interp *interp, int argc, CONST char **argv));

   270 static int		TestlocaleCmd _ANSI_ARGS_((ClientData dummy,

   271 			    Tcl_Interp *interp, int objc,

   272 			    Tcl_Obj *CONST objv[]));

   273 static int		TestMathFunc _ANSI_ARGS_((ClientData clientData,

   274 			    Tcl_Interp *interp, Tcl_Value *args,

   275 			    Tcl_Value *resultPtr));

   276 static int		TestMathFunc2 _ANSI_ARGS_((ClientData clientData,

   277 			    Tcl_Interp *interp, Tcl_Value *args,

   278 			    Tcl_Value *resultPtr));

   279 static int		TestmainthreadCmd _ANSI_ARGS_((ClientData dummy,

   280 			    Tcl_Interp *interp, int argc, CONST char **argv));

   281 static int		TestsetmainloopCmd _ANSI_ARGS_((ClientData dummy,

   282 			    Tcl_Interp *interp, int argc, CONST char **argv));

   283 static int		TestexitmainloopCmd _ANSI_ARGS_((ClientData dummy,

   284 			    Tcl_Interp *interp, int argc, CONST char **argv));

   285 static Tcl_Channel	PretendTclpOpenFileChannel _ANSI_ARGS_((

   286 			    Tcl_Interp *interp, CONST char *fileName,

   287 			    CONST char *modeString, int permissions));

   288 static Tcl_Channel	TestOpenFileChannelProc1 _ANSI_ARGS_((

   289 			    Tcl_Interp *interp, CONST char *fileName,

   290 			    CONST char *modeString, int permissions));

   291 static Tcl_Channel	TestOpenFileChannelProc2 _ANSI_ARGS_((

   292 			    Tcl_Interp *interp, CONST char *fileName,

   293 			    CONST char *modeString, int permissions));

   294 static Tcl_Channel	TestOpenFileChannelProc3 _ANSI_ARGS_((

   295 			    Tcl_Interp *interp, CONST char *fileName,

   296 			    CONST char *modeString, int permissions));

   297 static int		TestpanicCmd _ANSI_ARGS_((ClientData dummy,

   298 			    Tcl_Interp *interp, int argc, CONST char **argv));

   299 static int		TestparserObjCmd _ANSI_ARGS_((ClientData dummy,

   300 			    Tcl_Interp *interp, int objc,

   301 			    Tcl_Obj *CONST objv[]));

   302 static int		TestparsevarObjCmd _ANSI_ARGS_((ClientData dummy,

   303 			    Tcl_Interp *interp, int objc,

   304 			    Tcl_Obj *CONST objv[]));

   305 static int		TestparsevarnameObjCmd _ANSI_ARGS_((ClientData dummy,

   306 			    Tcl_Interp *interp, int objc,

   307 			    Tcl_Obj *CONST objv[]));

   308 static int		TestregexpObjCmd _ANSI_ARGS_((ClientData dummy,

   309 			    Tcl_Interp *interp, int objc,

   310 			    Tcl_Obj *CONST objv[]));

   311 static void		TestregexpXflags _ANSI_ARGS_((char *string,

   312 			    int length, int *cflagsPtr, int *eflagsPtr));

   313 static int		TestsaveresultCmd _ANSI_ARGS_((ClientData dummy,

   314 			    Tcl_Interp *interp, int objc,

   315 			    Tcl_Obj *CONST objv[]));

   316 static void		TestsaveresultFree _ANSI_ARGS_((char *blockPtr));

   317 static int		TestsetassocdataCmd _ANSI_ARGS_((ClientData dummy,

   318 			    Tcl_Interp *interp, int argc, CONST char **argv));

   319 static int		TestsetCmd _ANSI_ARGS_((ClientData dummy,

   320 			    Tcl_Interp *interp, int argc, CONST char **argv));

   321 static int		TestseterrorcodeCmd _ANSI_ARGS_((ClientData dummy,

   322 			    Tcl_Interp *interp, int argc, CONST char **argv));

   323 static int		TestsetobjerrorcodeCmd _ANSI_ARGS_((

   324 			    ClientData dummy, Tcl_Interp *interp,

   325 			    int objc, Tcl_Obj *CONST objv[]));

   326 static int		TestopenfilechannelprocCmd _ANSI_ARGS_((

   327 			    ClientData dummy, Tcl_Interp *interp, int argc,

   328 			    CONST char **argv));

   329 static int		TestsetplatformCmd _ANSI_ARGS_((ClientData dummy,

   330 			    Tcl_Interp *interp, int argc, CONST char **argv));

   331 static int		TeststaticpkgCmd _ANSI_ARGS_((ClientData dummy,

   332 			    Tcl_Interp *interp, int argc, CONST char **argv));

   333 static int		PretendTclpStat _ANSI_ARGS_((CONST char *path,

   334 			    struct stat *buf));

   335 static int		TestStatProc1 _ANSI_ARGS_((CONST char *path,

   336 			    struct stat *buf));

   337 static int		TestStatProc2 _ANSI_ARGS_((CONST char *path,

   338 			    struct stat *buf));

   339 static int		TestStatProc3 _ANSI_ARGS_((CONST char *path,

   340 			    struct stat *buf));

   341 static int		TeststatprocCmd _ANSI_ARGS_((ClientData dummy,

   342 			    Tcl_Interp *interp, int argc, CONST char **argv));

   343 static int		TesttranslatefilenameCmd _ANSI_ARGS_((ClientData dummy,

   344 			    Tcl_Interp *interp, int argc, CONST char **argv));

   345 static int		TestupvarCmd _ANSI_ARGS_((ClientData dummy,

   346 			    Tcl_Interp *interp, int argc, CONST char **argv));

   347 static int              TestWrongNumArgsObjCmd _ANSI_ARGS_((

   348 			    ClientData clientData, Tcl_Interp *interp,

   349 			    int objc, Tcl_Obj *CONST objv[]));

   350 static int              TestGetIndexFromObjStructObjCmd _ANSI_ARGS_((

   351 			    ClientData clientData, Tcl_Interp *interp,

   352 			    int objc, Tcl_Obj *CONST objv[]));

   353 static int		TestChannelCmd _ANSI_ARGS_((ClientData clientData,

   354 			    Tcl_Interp *interp, int argc, CONST char **argv));

   355 static int		TestChannelEventCmd _ANSI_ARGS_((ClientData clientData,

   356 			    Tcl_Interp *interp, int argc, CONST char **argv));

   357 /* Filesystem testing */

   358 

   359 static int		TestFilesystemObjCmd _ANSI_ARGS_((ClientData dummy,

   360 			    Tcl_Interp *interp, int objc, 

   361 			    Tcl_Obj *CONST objv[]));

   362 static int		TestSimpleFilesystemObjCmd _ANSI_ARGS_((

   363 			    ClientData dummy, Tcl_Interp *interp, int objc, 

   364 			    Tcl_Obj *CONST objv[]));

   365 

   366 static void             TestReport _ANSI_ARGS_ ((CONST char* cmd, Tcl_Obj* arg1, 

   367 			    Tcl_Obj* arg2));

   368 

   369 static Tcl_Obj*         TestReportGetNativePath _ANSI_ARGS_ ((

   370 			    Tcl_Obj* pathObjPtr));

   371 

   372 static int		TestReportStat _ANSI_ARGS_ ((Tcl_Obj *path,

   373 			    Tcl_StatBuf *buf));

   374 static int		TestReportAccess _ANSI_ARGS_ ((Tcl_Obj *path,

   375 			    int mode));

   376 static Tcl_Channel	TestReportOpenFileChannel _ANSI_ARGS_ ((

   377 			    Tcl_Interp *interp, Tcl_Obj *fileName,

   378 			    int mode, int permissions));

   379 static int		TestReportMatchInDirectory _ANSI_ARGS_ ((

   380 			    Tcl_Interp *interp, Tcl_Obj *resultPtr,

   381 			    Tcl_Obj *dirPtr, CONST char *pattern,

   382 			    Tcl_GlobTypeData *types));

   383 static int		TestReportChdir _ANSI_ARGS_ ((Tcl_Obj *dirName));

   384 static int		TestReportLstat _ANSI_ARGS_ ((Tcl_Obj *path,

   385 			    Tcl_StatBuf *buf));

   386 static int		TestReportCopyFile _ANSI_ARGS_ ((Tcl_Obj *src,

   387 			    Tcl_Obj *dst));

   388 static int		TestReportDeleteFile _ANSI_ARGS_ ((Tcl_Obj *path));

   389 static int		TestReportRenameFile _ANSI_ARGS_ ((Tcl_Obj *src,

   390 			    Tcl_Obj *dst));

   391 static int		TestReportCreateDirectory _ANSI_ARGS_ ((Tcl_Obj *path));

   392 static int		TestReportCopyDirectory _ANSI_ARGS_ ((Tcl_Obj *src,

   393 			    Tcl_Obj *dst, Tcl_Obj **errorPtr));

   394 static int		TestReportRemoveDirectory _ANSI_ARGS_ ((Tcl_Obj *path,

   395 			    int recursive, Tcl_Obj **errorPtr));

   396 static int		TestReportLoadFile _ANSI_ARGS_ ((Tcl_Interp *interp,

   397 			    Tcl_Obj *fileName, 

   398 			    Tcl_LoadHandle *handlePtr,

   399 			    Tcl_FSUnloadFileProc **unloadProcPtr));

   400 static Tcl_Obj *	TestReportLink _ANSI_ARGS_ ((Tcl_Obj *path,

   401 			    Tcl_Obj *to, int linkType));

   402 static CONST char**	TestReportFileAttrStrings _ANSI_ARGS_ ((

   403 			    Tcl_Obj *fileName, Tcl_Obj **objPtrRef));

   404 static int		TestReportFileAttrsGet _ANSI_ARGS_ ((Tcl_Interp *interp,

   405 			    int index, Tcl_Obj *fileName, Tcl_Obj **objPtrRef));

   406 static int		TestReportFileAttrsSet _ANSI_ARGS_ ((Tcl_Interp *interp,

   407 			    int index, Tcl_Obj *fileName, Tcl_Obj *objPtr));

   408 static int		TestReportUtime _ANSI_ARGS_ ((Tcl_Obj *fileName,

   409 			    struct utimbuf *tval));

   410 static int		TestReportNormalizePath _ANSI_ARGS_ ((

   411 			    Tcl_Interp *interp, Tcl_Obj *pathPtr,

   412 			    int nextCheckpoint));

   413 static int		TestReportInFilesystem _ANSI_ARGS_ ((Tcl_Obj *pathPtr, ClientData *clientDataPtr));

   414 static void		TestReportFreeInternalRep _ANSI_ARGS_ ((ClientData clientData));

   415 static ClientData	TestReportDupInternalRep _ANSI_ARGS_ ((ClientData clientData));

   416 

   417 static int		SimpleStat _ANSI_ARGS_ ((Tcl_Obj *path,

   418 			    Tcl_StatBuf *buf));

   419 static int		SimpleAccess _ANSI_ARGS_ ((Tcl_Obj *path,

   420 			    int mode));

   421 static Tcl_Channel	SimpleOpenFileChannel _ANSI_ARGS_ ((

   422 			    Tcl_Interp *interp, Tcl_Obj *fileName,

   423 			    int mode, int permissions));

   424 static Tcl_Obj*         SimpleListVolumes _ANSI_ARGS_ ((void));

   425 static int              SimplePathInFilesystem _ANSI_ARGS_ ((

   426 			    Tcl_Obj *pathPtr, ClientData *clientDataPtr));

   427 static Tcl_Obj*         SimpleCopy _ANSI_ARGS_ ((Tcl_Obj *pathPtr));

   428 static int              TestNumUtfCharsCmd _ANSI_ARGS_((ClientData clientData,

   429                             Tcl_Interp *interp, int objc,

   430 			    Tcl_Obj *CONST objv[]));

   431 

   432 static Tcl_Filesystem testReportingFilesystem = {

   433     "reporting",

   434     sizeof(Tcl_Filesystem),

   435     TCL_FILESYSTEM_VERSION_1,

   436     &TestReportInFilesystem, /* path in */

   437     &TestReportDupInternalRep,

   438     &TestReportFreeInternalRep,

   439     NULL, /* native to norm */

   440     NULL, /* convert to native */

   441     &TestReportNormalizePath,

   442     NULL, /* path type */

   443     NULL, /* separator */

   444     &TestReportStat,

   445     &TestReportAccess,

   446     &TestReportOpenFileChannel,

   447     &TestReportMatchInDirectory,

   448     &TestReportUtime,

   449     &TestReportLink,

   450     NULL /* list volumes */,

   451     &TestReportFileAttrStrings,

   452     &TestReportFileAttrsGet,

   453     &TestReportFileAttrsSet,

   454     &TestReportCreateDirectory,

   455     &TestReportRemoveDirectory, 

   456     &TestReportDeleteFile,

   457     &TestReportCopyFile,

   458     &TestReportRenameFile,

   459     &TestReportCopyDirectory, 

   460     &TestReportLstat,

   461     &TestReportLoadFile,

   462     NULL /* cwd */,

   463     &TestReportChdir

   464 };

   465 

   466 static Tcl_Filesystem simpleFilesystem = {

   467     "simple",

   468     sizeof(Tcl_Filesystem),

   469     TCL_FILESYSTEM_VERSION_1,

   470     &SimplePathInFilesystem,

   471     NULL,

   472     NULL,

   473     /* No internal to normalized, since we don't create any

   474      * pure 'internal' Tcl_Obj path representations */

   475     NULL,

   476     /* No create native rep function, since we don't use it

   477      * or 'Tcl_FSNewNativePath' */

   478     NULL,

   479     /* Normalize path isn't needed - we assume paths only have

   480      * one representation */

   481     NULL,

   482     NULL,

   483     NULL,

   484     &SimpleStat,

   485     &SimpleAccess,

   486     &SimpleOpenFileChannel,

   487     NULL,

   488     NULL,

   489     /* We choose not to support symbolic links inside our vfs's */

   490     NULL,

   491     &SimpleListVolumes,

   492     NULL,

   493     NULL,

   494     NULL,

   495     NULL,

   496     NULL, 

   497     NULL,

   498     /* No copy file - fallback will occur at Tcl level */

   499     NULL,

   500     /* No rename file - fallback will occur at Tcl level */

   501     NULL,

   502     /* No copy directory - fallback will occur at Tcl level */

   503     NULL, 

   504     /* Use stat for lstat */

   505     NULL,

   506     /* No load - fallback on core implementation */

   507     NULL,

   508     /* We don't need a getcwd or chdir - fallback on Tcl's versions */

   509     NULL,

   510     NULL

   511 };

   512 

   513 

   514 /*

   515  * External (platform specific) initialization routine, these declarations

   516  * explicitly don't use EXTERN since this code does not get compiled

   517  * into the library:

   518  */

   519 

   520 extern int		TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp));

   521 extern int		TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp));

   522 

   523 /*

   524  *----------------------------------------------------------------------

   525  *

   526  * Tcltest_Init --

   527  *

   528  *	This procedure performs application-specific initialization.

   529  *	Most applications, especially those that incorporate additional

   530  *	packages, will have their own version of this procedure.

   531  *

   532  * Results:

   533  *	Returns a standard Tcl completion code, and leaves an error

   534  *	message in the interp's result if an error occurs.

   535  *

   536  * Side effects:

   537  *	Depends on the startup script.

   538  *

   539  *----------------------------------------------------------------------

   540  */

   541 

   542 int

   543 Tcltest_Init(interp)

   544     Tcl_Interp *interp;		/* Interpreter for application. */

   545 {

   546     Tcl_ValueType t3ArgTypes[2];

   547 

   548     Tcl_Obj *listPtr;

   549     Tcl_Obj **objv;

   550     int objc, index;

   551     static CONST char *specialOptions[] = {

   552 	"-appinitprocerror", "-appinitprocdeleteinterp",

   553 	"-appinitprocclosestderr", "-appinitprocsetrcfile", (char *) NULL

   554     };

   555 

   556 #ifndef TCL_TIP268

   557     if (Tcl_PkgProvide(interp, "Tcltest", TCL_VERSION) == TCL_ERROR) {

   558 #else

   559     /* TIP #268: Full patchlevel instead of just major.minor */

   560     if (Tcl_PkgProvide(interp, "Tcltest", TCL_PATCH_LEVEL) == TCL_ERROR) {

   561 #endif

   562         return TCL_ERROR;

   563     }

   564 

   565     /*

   566      * Create additional commands and math functions for testing Tcl.

   567      */

   568 

   569     Tcl_CreateCommand(interp, "gettimes", GetTimesCmd, (ClientData) 0,

   570 	    (Tcl_CmdDeleteProc *) NULL);

   571     Tcl_CreateCommand(interp, "noop", NoopCmd, (ClientData) 0,

   572 	    (Tcl_CmdDeleteProc *) NULL);

   573     Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, (ClientData) 0,

   574 	    (Tcl_CmdDeleteProc *) NULL);

   575     Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd,

   576 	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

   577     Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd, 

   578 	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

   579     Tcl_CreateObjCommand(interp, "testsimplefilesystem", TestSimpleFilesystemObjCmd, 

   580 	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

   581     Tcl_CreateObjCommand(interp, "testgetindexfromobjstruct",

   582 			 TestGetIndexFromObjStructObjCmd, (ClientData) 0,

   583 			 (Tcl_CmdDeleteProc *) NULL);

   584     Tcl_CreateCommand(interp, "testaccessproc", TestaccessprocCmd, (ClientData) 0,

   585 	    (Tcl_CmdDeleteProc *) NULL);

   586     Tcl_CreateCommand(interp, "testasync", TestasyncCmd, (ClientData) 0,

   587 	    (Tcl_CmdDeleteProc *) NULL);

   588     Tcl_CreateCommand(interp, "testchannel", TestChannelCmd,

   589             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

   590     Tcl_CreateCommand(interp, "testchannelevent", TestChannelEventCmd,

   591             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

   592     Tcl_CreateCommand(interp, "testcmdtoken", TestcmdtokenCmd, (ClientData) 0,

   593 	    (Tcl_CmdDeleteProc *) NULL);

   594     Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, (ClientData) 0,

   595 	    (Tcl_CmdDeleteProc *) NULL);

   596     Tcl_CreateCommand(interp, "testcmdtrace", TestcmdtraceCmd,

   597 	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

   598     Tcl_CreateCommand(interp, "testcreatecommand", TestcreatecommandCmd,

   599 	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

   600     Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, (ClientData) 0,

   601 	    (Tcl_CmdDeleteProc *) NULL);

   602     Tcl_CreateCommand(interp, "testdel", TestdelCmd, (ClientData) 0,

   603 	    (Tcl_CmdDeleteProc *) NULL);

   604     Tcl_CreateCommand(interp, "testdelassocdata", TestdelassocdataCmd,

   605             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

   606     Tcl_DStringInit(&dstring);

   607     Tcl_CreateCommand(interp, "testdstring", TestdstringCmd, (ClientData) 0,

   608 	    (Tcl_CmdDeleteProc *) NULL);

   609     Tcl_CreateObjCommand(interp, "testencoding", TestencodingObjCmd, (ClientData) 0,

   610 	    (Tcl_CmdDeleteProc *) NULL);

   611     Tcl_CreateObjCommand(interp, "testevalex", TestevalexObjCmd,

   612 	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

   613     Tcl_CreateObjCommand(interp, "testevalobjv", TestevalobjvObjCmd,

   614 	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

   615     Tcl_CreateObjCommand( interp, "testevent", TesteventObjCmd,

   616 			  (ClientData) 0, (Tcl_CmdDeleteProc*) NULL );

   617     Tcl_CreateCommand(interp, "testexithandler", TestexithandlerCmd,

   618             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

   619     Tcl_CreateCommand(interp, "testexprlong", TestexprlongCmd,

   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 */

   766 static int

   767 TestasyncCmd(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 

   856 static int

   857 AsyncHandlerProc(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 */

   905 static int

   906 TestcmdinfoCmd(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*/

   978 static int

   979 CmdProc1(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*/

   991 static int

   992 CmdProc2(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 

  1003 static void

  1004 CmdDelProc1(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 

  1012 static void

  1013 CmdDelProc2(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 */

  1040 static int

  1041 TestcmdtokenCmd(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 */

  1104 static int

  1105 TestcmdtraceCmd(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 	

  1174     } else {

  1175 	Tcl_AppendResult(interp, "bad option \"", argv[1],

  1176 			 "\": must be tracetest, deletetest or resulttest",

  1177 			 (char *) NULL);

  1178 	return TCL_ERROR;

  1179     }

  1180     return TCL_OK;

  1181 }

  1182 

  1183 static void

  1184 CmdTraceProc(clientData, interp, level, command, cmdProc, cmdClientData,

  1185         argc, argv)

  1186     ClientData clientData;	/* Pointer to buffer in which the

  1187 				 * command and arguments are appended.

  1188 				 * Accumulates test result. */

  1189     Tcl_Interp *interp;		/* Current interpreter. */

  1190     int level;			/* Current trace level. */

  1191     char *command;		/* The command being traced (after

  1192 				 * substitutions). */

  1193     Tcl_CmdProc *cmdProc;	/* Points to command's command procedure. */

  1194     ClientData cmdClientData;	/* Client data associated with command

  1195 				 * procedure. */

  1196     int argc;			/* Number of arguments. */

  1197     char **argv;		/* Argument strings. */

  1198 {

  1199     Tcl_DString *bufPtr = (Tcl_DString *) clientData;

  1200     int i;

  1201 

  1202     Tcl_DStringAppendElement(bufPtr, command);

  1203 

  1204     Tcl_DStringStartSublist(bufPtr);

  1205     for (i = 0;  i < argc;  i++) {

  1206 	Tcl_DStringAppendElement(bufPtr, argv[i]);

  1207     }

  1208     Tcl_DStringEndSublist(bufPtr);

  1209 }

  1210 

  1211 static void

  1212 CmdTraceDeleteProc(clientData, interp, level, command, cmdProc,

  1213 	cmdClientData, argc, argv)

  1214     ClientData clientData;	/* Unused. */

  1215     Tcl_Interp *interp;		/* Current interpreter. */

  1216     int level;			/* Current trace level. */

  1217     char *command;		/* The command being traced (after

  1218 				 * substitutions). */

  1219     Tcl_CmdProc *cmdProc;	/* Points to command's command procedure. */

  1220     ClientData cmdClientData;	/* Client data associated with command

  1221 				 * procedure. */

  1222     int argc;			/* Number of arguments. */

  1223     char **argv;		/* Argument strings. */

  1224 {

  1225     /*

  1226      * Remove ourselves to test whether calling Tcl_DeleteTrace within

  1227      * a trace callback causes the for loop in TclExecuteByteCode that

  1228      * calls traces to reference freed memory.

  1229      */

  1230     

  1231     Tcl_DeleteTrace(interp, cmdTrace);

  1232 }

  1233 

  1234 static int

  1235 ObjTraceProc( clientData, interp, level, command, token, objc, objv )

  1236     ClientData clientData;	/* unused */

  1237     Tcl_Interp* interp;		/* Tcl interpreter */

  1238     int level;			/* Execution level */

  1239     CONST char* command;	/* Command being executed */

  1240     Tcl_Command token;		/* Command information */

  1241     int objc;			/* Parameter count */

  1242     Tcl_Obj *CONST objv[];	/* Parameter list */

  1243 {

  1244     CONST char* word = Tcl_GetString( objv[ 0 ] );

  1245     if ( !strcmp( word, "Error" ) ) {

  1246 	Tcl_SetObjResult( interp, Tcl_NewStringObj( command, -1 ) );

  1247 	return TCL_ERROR;

  1248     } else if ( !strcmp( word, "Break" ) ) {

  1249 	return TCL_BREAK;

  1250     } else if ( !strcmp( word, "Continue" ) ) {

  1251 	return TCL_CONTINUE;

  1252     } else if ( !strcmp( word, "Return" ) ) {

  1253 	return TCL_RETURN;

  1254     } else if ( !strcmp( word, "OtherStatus" ) ) {

  1255 	return 6;

  1256     } else {

  1257 	return TCL_OK;

  1258     }

  1259 }

  1260 

  1261 static void

  1262 ObjTraceDeleteProc( clientData )

  1263     ClientData clientData;

  1264 {

  1265     int * intPtr = (int *) clientData;

  1266     *intPtr = 1;		/* Record that the trace was deleted */

  1267 }

  1268 

  1269 /*

  1270  *----------------------------------------------------------------------

  1271  *

  1272  * TestcreatecommandCmd --

  1273  *

  1274  *	This procedure implements the "testcreatecommand" command. It is

  1275  *	used to test that the Tcl_CreateCommand creates a new command in

  1276  *	the namespace specified as part of its name, if any. It also

  1277  *	checks that the namespace code ignore single ":"s in the middle

  1278  *	or end of a command name.

  1279  *

  1280  * Results:

  1281  *	A standard Tcl result.

  1282  *

  1283  * Side effects:

  1284  *	Creates and deletes two commands ("test_ns_basic::createdcommand"

  1285  *	and "value:at:").

  1286  *

  1287  *----------------------------------------------------------------------

  1288  */

  1289 

  1290 static int

  1291 TestcreatecommandCmd(dummy, interp, argc, argv)

  1292     ClientData dummy;			/* Not used. */

  1293     Tcl_Interp *interp;			/* Current interpreter. */

  1294     int argc;				/* Number of arguments. */

  1295     CONST char **argv;			/* Argument strings. */

  1296 {

  1297     if (argc != 2) {

  1298 	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

  1299 		" option\"", (char *) NULL);

  1300 	return TCL_ERROR;

  1301     }

  1302     if (strcmp(argv[1], "create") == 0) {

  1303 	Tcl_CreateCommand(interp, "test_ns_basic::createdcommand",

  1304 		CreatedCommandProc, (ClientData) NULL,

  1305 		(Tcl_CmdDeleteProc *) NULL);

  1306     } else if (strcmp(argv[1], "delete") == 0) {

  1307 	Tcl_DeleteCommand(interp, "test_ns_basic::createdcommand");

  1308     } else if (strcmp(argv[1], "create2") == 0) {

  1309 	Tcl_CreateCommand(interp, "value:at:",

  1310 		CreatedCommandProc2, (ClientData) NULL,

  1311 		(Tcl_CmdDeleteProc *) NULL);

  1312     } else if (strcmp(argv[1], "delete2") == 0) {

  1313 	Tcl_DeleteCommand(interp, "value:at:");

  1314     } else {

  1315 	Tcl_AppendResult(interp, "bad option \"", argv[1],

  1316 		"\": must be create, delete, create2, or delete2",

  1317 		(char *) NULL);

  1318 	return TCL_ERROR;

  1319     }

  1320     return TCL_OK;

  1321 }

  1322 

  1323 static int

  1324 CreatedCommandProc(clientData, interp, argc, argv)

  1325     ClientData clientData;		/* String to return. */

  1326     Tcl_Interp *interp;			/* Current interpreter. */

  1327     int argc;				/* Number of arguments. */

  1328     CONST char **argv;			/* Argument strings. */

  1329 {

  1330     Tcl_CmdInfo info;

  1331     int found;

  1332 

  1333     found = Tcl_GetCommandInfo(interp, "test_ns_basic::createdcommand",

  1334 	    &info);

  1335     if (!found) {

  1336 	Tcl_AppendResult(interp, "CreatedCommandProc could not get command info for test_ns_basic::createdcommand",

  1337 	        (char *) NULL);

  1338 	return TCL_ERROR;

  1339     }

  1340     Tcl_AppendResult(interp, "CreatedCommandProc in ",

  1341 	    info.namespacePtr->fullName, (char *) NULL);

  1342     return TCL_OK;

  1343 }

  1344 

  1345 static int

  1346 CreatedCommandProc2(clientData, interp, argc, argv)

  1347     ClientData clientData;		/* String to return. */

  1348     Tcl_Interp *interp;			/* Current interpreter. */

  1349     int argc;				/* Number of arguments. */

  1350     CONST char **argv;			/* Argument strings. */

  1351 {

  1352     Tcl_CmdInfo info;

  1353     int found;

  1354 

  1355     found = Tcl_GetCommandInfo(interp, "value:at:", &info);

  1356     if (!found) {

  1357 	Tcl_AppendResult(interp, "CreatedCommandProc2 could not get command info for test_ns_basic::createdcommand",

  1358 	        (char *) NULL);

  1359 	return TCL_ERROR;

  1360     }

  1361     Tcl_AppendResult(interp, "CreatedCommandProc2 in ",

  1362 	    info.namespacePtr->fullName, (char *) NULL);

  1363     return TCL_OK;

  1364 }

  1365 

  1366 /*

  1367  *----------------------------------------------------------------------

  1368  *

  1369  * TestdcallCmd --

  1370  *

  1371  *	This procedure implements the "testdcall" command.  It is used

  1372  *	to test Tcl_CallWhenDeleted.

  1373  *

  1374  * Results:

  1375  *	A standard Tcl result.

  1376  *

  1377  * Side effects:

  1378  *	Creates and deletes interpreters.

  1379  *

  1380  *----------------------------------------------------------------------

  1381  */

  1382 

  1383 	/* ARGSUSED */

  1384 static int

  1385 TestdcallCmd(dummy, interp, argc, argv)

  1386     ClientData dummy;			/* Not used. */

  1387     Tcl_Interp *interp;			/* Current interpreter. */

  1388     int argc;				/* Number of arguments. */

  1389     CONST char **argv;			/* Argument strings. */

  1390 {

  1391     int i, id;

  1392 

  1393     delInterp = Tcl_CreateInterp();

  1394     Tcl_DStringInit(&delString);

  1395     for (i = 1; i < argc; i++) {

  1396 	if (Tcl_GetInt(interp, argv[i], &id) != TCL_OK) {

  1397 	    return TCL_ERROR;

  1398 	}

  1399 	if (id < 0) {

  1400 	    Tcl_DontCallWhenDeleted(delInterp, DelCallbackProc,

  1401 		    (ClientData) (-id));

  1402 	} else {

  1403 	    Tcl_CallWhenDeleted(delInterp, DelCallbackProc,

  1404 		    (ClientData) id);

  1405 	}

  1406     }

  1407     Tcl_DeleteInterp(delInterp);

  1408     Tcl_DStringResult(interp, &delString);

  1409     return TCL_OK;

  1410 }

  1411 

  1412 /*

  1413  * The deletion callback used by TestdcallCmd:

  1414  */

  1415 

  1416 static void

  1417 DelCallbackProc(clientData, interp)

  1418     ClientData clientData;		/* Numerical value to append to

  1419 					 * delString. */

  1420     Tcl_Interp *interp;			/* Interpreter being deleted. */

  1421 {

  1422     int id = (int) clientData;

  1423     char buffer[TCL_INTEGER_SPACE];

  1424 

  1425     TclFormatInt(buffer, id);

  1426     Tcl_DStringAppendElement(&delString, buffer);

  1427     if (interp != delInterp) {

  1428 	Tcl_DStringAppendElement(&delString, "bogus interpreter argument!");

  1429     }

  1430 }

  1431 

  1432 /*

  1433  *----------------------------------------------------------------------

  1434  *

  1435  * TestdelCmd --

  1436  *

  1437  *	This procedure implements the "testdcall" command.  It is used

  1438  *	to test Tcl_CallWhenDeleted.

  1439  *

  1440  * Results:

  1441  *	A standard Tcl result.

  1442  *

  1443  * Side effects:

  1444  *	Creates and deletes interpreters.

  1445  *

  1446  *----------------------------------------------------------------------

  1447  */

  1448 

  1449 	/* ARGSUSED */

  1450 static int

  1451 TestdelCmd(dummy, interp, argc, argv)

  1452     ClientData dummy;			/* Not used. */

  1453     Tcl_Interp *interp;			/* Current interpreter. */

  1454     int argc;				/* Number of arguments. */

  1455     CONST char **argv;			/* Argument strings. */

  1456 {

  1457     DelCmd *dPtr;

  1458     Tcl_Interp *slave;

  1459 

  1460     if (argc != 4) {

  1461 	Tcl_SetResult(interp, "wrong # args", TCL_STATIC);

  1462 	return TCL_ERROR;

  1463     }

  1464 

  1465     slave = Tcl_GetSlave(interp, argv[1]);

  1466     if (slave == NULL) {

  1467 	return TCL_ERROR;

  1468     }

  1469 

  1470     dPtr = (DelCmd *) ckalloc(sizeof(DelCmd));

  1471     dPtr->interp = interp;

  1472     dPtr->deleteCmd = (char *) ckalloc((unsigned) (strlen(argv[3]) + 1));

  1473     strcpy(dPtr->deleteCmd, argv[3]);

  1474 

  1475     Tcl_CreateCommand(slave, argv[2], DelCmdProc, (ClientData) dPtr,

  1476 	    DelDeleteProc);

  1477     return TCL_OK;

  1478 }

  1479 

  1480 static int

  1481 DelCmdProc(clientData, interp, argc, argv)

  1482     ClientData clientData;		/* String result to return. */

  1483     Tcl_Interp *interp;			/* Current interpreter. */

  1484     int argc;				/* Number of arguments. */

  1485     CONST char **argv;			/* Argument strings. */

  1486 {

  1487     DelCmd *dPtr = (DelCmd *) clientData;

  1488 

  1489     Tcl_AppendResult(interp, dPtr->deleteCmd, (char *) NULL);

  1490     ckfree(dPtr->deleteCmd);

  1491     ckfree((char *) dPtr);

  1492     return TCL_OK;

  1493 }

  1494 

  1495 static void

  1496 DelDeleteProc(clientData)

  1497     ClientData clientData;		/* String command to evaluate. */

  1498 {

  1499     DelCmd *dPtr = (DelCmd *) clientData;

  1500 

  1501     Tcl_Eval(dPtr->interp, dPtr->deleteCmd);

  1502     Tcl_ResetResult(dPtr->interp);

  1503     ckfree(dPtr->deleteCmd);

  1504     ckfree((char *) dPtr);

  1505 }

  1506 

  1507 /*

  1508  *----------------------------------------------------------------------

  1509  *

  1510  * TestdelassocdataCmd --

  1511  *

  1512  *	This procedure implements the "testdelassocdata" command. It is used

  1513  *	to test Tcl_DeleteAssocData.

  1514  *

  1515  * Results:

  1516  *	A standard Tcl result.

  1517  *

  1518  * Side effects:

  1519  *	Deletes an association between a key and associated data from an

  1520  *	interpreter.

  1521  *

  1522  *----------------------------------------------------------------------

  1523  */

  1524 

  1525 static int

  1526 TestdelassocdataCmd(clientData, interp, argc, argv)

  1527     ClientData clientData;		/* Not used. */

  1528     Tcl_Interp *interp;			/* Current interpreter. */

  1529     int argc;				/* Number of arguments. */

  1530     CONST char **argv;			/* Argument strings. */

  1531 {

  1532     if (argc != 2) {

  1533         Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],

  1534                 " data_key\"", (char *) NULL);

  1535         return TCL_ERROR;

  1536     }

  1537     Tcl_DeleteAssocData(interp, argv[1]);

  1538     return TCL_OK;

  1539 }

  1540 

  1541 /*

  1542  *----------------------------------------------------------------------

  1543  *

  1544  * TestdstringCmd --

  1545  *

  1546  *	This procedure implements the "testdstring" command.  It is used

  1547  *	to test the dynamic string facilities of Tcl.

  1548  *

  1549  * Results:

  1550  *	A standard Tcl result.

  1551  *

  1552  * Side effects:

  1553  *	Creates, deletes, and invokes handlers.

  1554  *

  1555  *----------------------------------------------------------------------

  1556  */

  1557 

  1558 	/* ARGSUSED */

  1559 static int

  1560 TestdstringCmd(dummy, interp, argc, argv)

  1561     ClientData dummy;			/* Not used. */

  1562     Tcl_Interp *interp;			/* Current interpreter. */

  1563     int argc;				/* Number of arguments. */

  1564     CONST char **argv;			/* Argument strings. */

  1565 {

  1566     int count;

  1567 

  1568     if (argc < 2) {

  1569 	wrongNumArgs:

  1570 	Tcl_SetResult(interp, "wrong # args", TCL_STATIC);

  1571 	return TCL_ERROR;

  1572     }

  1573     if (strcmp(argv[1], "append") == 0) {

  1574 	if (argc != 4) {

  1575 	    goto wrongNumArgs;

  1576 	}

  1577 	if (Tcl_GetInt(interp, argv[3], &count) != TCL_OK) {

  1578 	    return TCL_ERROR;

  1579 	}

  1580 	Tcl_DStringAppend(&dstring, argv[2], count);

  1581     } else if (strcmp(argv[1], "element") == 0) {

  1582 	if (argc != 3) {

  1583 	    goto wrongNumArgs;

  1584 	}

  1585 	Tcl_DStringAppendElement(&dstring, argv[2]);

  1586     } else if (strcmp(argv[1], "end") == 0) {

  1587 	if (argc != 2) {

  1588 	    goto wrongNumArgs;

  1589 	}

  1590 	Tcl_DStringEndSublist(&dstring);

  1591     } else if (strcmp(argv[1], "free") == 0) {

  1592 	if (argc != 2) {

  1593 	    goto wrongNumArgs;

  1594 	}

  1595 	Tcl_DStringFree(&dstring);

  1596     } else if (strcmp(argv[1], "get") == 0) {

  1597 	if (argc != 2) {

  1598 	    goto wrongNumArgs;

  1599 	}

  1600 	Tcl_SetResult(interp, Tcl_DStringValue(&dstring), TCL_VOLATILE);

  1601     } else if (strcmp(argv[1], "gresult") == 0) {

  1602 	if (argc != 3) {

  1603 	    goto wrongNumArgs;

  1604 	}

  1605 	if (strcmp(argv[2], "staticsmall") == 0) {

  1606 	    Tcl_SetResult(interp, "short", TCL_STATIC);

  1607 	} else if (strcmp(argv[2], "staticlarge") == 0) {

  1608 	    Tcl_SetResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", TCL_STATIC);

  1609 	} else if (strcmp(argv[2], "free") == 0) {

  1610 	    Tcl_SetResult(interp, (char *) ckalloc(100), TCL_DYNAMIC);

  1611 	    strcpy(interp->result, "This is a malloc-ed string");

  1612 	} else if (strcmp(argv[2], "special") == 0) {

  1613 	    interp->result = (char *) ckalloc(100);

  1614 	    interp->result += 4;

  1615 	    interp->freeProc = SpecialFree;

  1616 	    strcpy(interp->result, "This is a specially-allocated string");

  1617 	} else {

  1618 	    Tcl_AppendResult(interp, "bad gresult option \"", argv[2],

  1619 		    "\": must be staticsmall, staticlarge, free, or special",

  1620 		    (char *) NULL);

  1621 	    return TCL_ERROR;

  1622 	}

  1623 	Tcl_DStringGetResult(interp, &dstring);

  1624     } else if (strcmp(argv[1], "length") == 0) {

  1625 	char buf[TCL_INTEGER_SPACE];

  1626 	

  1627 	if (argc != 2) {

  1628 	    goto wrongNumArgs;

  1629 	}

  1630 	TclFormatInt(buf, Tcl_DStringLength(&dstring));

  1631 	Tcl_SetResult(interp, buf, TCL_VOLATILE);

  1632     } else if (strcmp(argv[1], "result") == 0) {

  1633 	if (argc != 2) {

  1634 	    goto wrongNumArgs;

  1635 	}

  1636 	Tcl_DStringResult(interp, &dstring);

  1637     } else if (strcmp(argv[1], "trunc") == 0) {

  1638 	if (argc != 3) {

  1639 	    goto wrongNumArgs;

  1640 	}

  1641 	if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) {

  1642 	    return TCL_ERROR;

  1643 	}

  1644 	Tcl_DStringTrunc(&dstring, count);

  1645     } else if (strcmp(argv[1], "start") == 0) {

  1646 	if (argc != 2) {

  1647 	    goto wrongNumArgs;

  1648 	}

  1649 	Tcl_DStringStartSublist(&dstring);

  1650     } else {

  1651 	Tcl_AppendResult(interp, "bad option \"", argv[1],

  1652 		"\": must be append, element, end, free, get, length, ",

  1653 		"result, trunc, or start", (char *) NULL);

  1654 	return TCL_ERROR;

  1655     }

  1656     return TCL_OK;

  1657 }

  1658 

  1659 /*

  1660  * The procedure below is used as a special freeProc to test how well

  1661  * Tcl_DStringGetResult handles freeProc's other than free.

  1662  */

  1663 

  1664 static void SpecialFree(blockPtr)

  1665     char *blockPtr;			/* Block to free. */

  1666 {

  1667     ckfree(blockPtr - 4);

  1668 }

  1669 

  1670 /*

  1671  *----------------------------------------------------------------------

  1672  *

  1673  * TestencodingCmd --

  1674  *

  1675  *	This procedure implements the "testencoding" command.  It is used

  1676  *	to test the encoding package.

  1677  *

  1678  * Results:

  1679  *	A standard Tcl result.

  1680  *

  1681  * Side effects:

  1682  *	Load encodings.

  1683  *

  1684  *----------------------------------------------------------------------

  1685  */

  1686 

  1687 	/* ARGSUSED */

  1688 static int

  1689 TestencodingObjCmd(dummy, interp, objc, objv)

  1690     ClientData dummy;		/* Not used. */

  1691     Tcl_Interp *interp;		/* Current interpreter. */

  1692     int objc;			/* Number of arguments. */

  1693     Tcl_Obj *CONST objv[];	/* Argument objects. */

  1694 {

  1695     Tcl_Encoding encoding;

  1696     int index, length;

  1697     char *string;

  1698     TclEncoding *encodingPtr;

  1699     static CONST char *optionStrings[] = {

  1700 	"create",	"delete",	"path",

  1701 	NULL

  1702     };

  1703     enum options {

  1704 	ENC_CREATE,	ENC_DELETE,	ENC_PATH

  1705     };

  1706     

  1707     if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,

  1708 	    &index) != TCL_OK) {

  1709 	return TCL_ERROR;

  1710     }

  1711 

  1712     switch ((enum options) index) {

  1713 	case ENC_CREATE: {

  1714 	    Tcl_EncodingType type;

  1715 

  1716 	    if (objc != 5) {

  1717 		return TCL_ERROR;

  1718 	    }

  1719 	    encodingPtr = (TclEncoding *) ckalloc(sizeof(TclEncoding));

  1720 	    encodingPtr->interp = interp;

  1721 

  1722 	    string = Tcl_GetStringFromObj(objv[3], &length);

  1723 	    encodingPtr->toUtfCmd = (char *) ckalloc((unsigned) (length + 1));

  1724 	    memcpy(encodingPtr->toUtfCmd, string, (unsigned) length + 1);

  1725 

  1726 	    string = Tcl_GetStringFromObj(objv[4], &length);

  1727 	    encodingPtr->fromUtfCmd = (char *) ckalloc((unsigned) (length + 1));

  1728 	    memcpy(encodingPtr->fromUtfCmd, string, (unsigned) (length + 1));

  1729 

  1730 	    string = Tcl_GetStringFromObj(objv[2], &length);

  1731 

  1732 	    type.encodingName = string;

  1733 	    type.toUtfProc = EncodingToUtfProc;

  1734 	    type.fromUtfProc = EncodingFromUtfProc;

  1735 	    type.freeProc = EncodingFreeProc;

  1736 	    type.clientData = (ClientData) encodingPtr;

  1737 	    type.nullSize = 1;

  1738 

  1739 	    Tcl_CreateEncoding(&type);

  1740 	    break;

  1741 	}

  1742 	case ENC_DELETE: {

  1743 	    if (objc != 3) {

  1744 		return TCL_ERROR;

  1745 	    }

  1746 	    encoding = Tcl_GetEncoding(NULL, Tcl_GetString(objv[2]));

  1747 	    Tcl_FreeEncoding(encoding);

  1748 	    Tcl_FreeEncoding(encoding);

  1749 	    break;

  1750 	}

  1751 	case ENC_PATH: {

  1752 	    if (objc == 2) {

  1753 		Tcl_SetObjResult(interp, TclGetLibraryPath());

  1754 	    } else {

  1755 		TclSetLibraryPath(objv[2]);

  1756 	    }

  1757 	    break;

  1758 	}

  1759     }

  1760     return TCL_OK;

  1761 }

  1762 static int 

  1763 EncodingToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,

  1764 	srcReadPtr, dstWrotePtr, dstCharsPtr)

  1765     ClientData clientData;	/* TclEncoding structure. */

  1766     CONST char *src;		/* Source string in specified encoding. */

  1767     int srcLen;			/* Source string length in bytes. */

  1768     int flags;			/* Conversion control flags. */

  1769     Tcl_EncodingState *statePtr;/* Current state. */

  1770     char *dst;			/* Output buffer. */

  1771     int dstLen;			/* The maximum length of output buffer. */

  1772     int *srcReadPtr;		/* Filled with number of bytes read. */

  1773     int *dstWrotePtr;		/* Filled with number of bytes stored. */

  1774     int *dstCharsPtr;		/* Filled with number of chars stored. */

  1775 {

  1776     int len;

  1777     TclEncoding *encodingPtr;

  1778 

  1779     encodingPtr = (TclEncoding *) clientData;

  1780     Tcl_GlobalEval(encodingPtr->interp, encodingPtr->toUtfCmd);

  1781 

  1782     len = strlen(Tcl_GetStringResult(encodingPtr->interp));

  1783     if (len > dstLen) {

  1784 	len = dstLen;

  1785     }

  1786     memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), (unsigned) len);

  1787     Tcl_ResetResult(encodingPtr->interp);

  1788 

  1789     *srcReadPtr = srcLen;

  1790     *dstWrotePtr = len;

  1791     *dstCharsPtr = len;

  1792     return TCL_OK;

  1793 }

  1794 static int 

  1795 EncodingFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,

  1796 	srcReadPtr, dstWrotePtr, dstCharsPtr)

  1797     ClientData clientData;	/* TclEncoding structure. */

  1798     CONST char *src;		/* Source string in specified encoding. */

  1799     int srcLen;			/* Source string length in bytes. */

  1800     int flags;			/* Conversion control flags. */

  1801     Tcl_EncodingState *statePtr;/* Current state. */

  1802     char *dst;			/* Output buffer. */

  1803     int dstLen;			/* The maximum length of output buffer. */

  1804     int *srcReadPtr;		/* Filled with number of bytes read. */

  1805     int *dstWrotePtr;		/* Filled with number of bytes stored. */

  1806     int *dstCharsPtr;		/* Filled with number of chars stored. */

  1807 {

  1808     int len;

  1809     TclEncoding *encodingPtr;

  1810 

  1811     encodingPtr = (TclEncoding *) clientData;

  1812     Tcl_GlobalEval(encodingPtr->interp, encodingPtr->fromUtfCmd);

  1813 

  1814     len = strlen(Tcl_GetStringResult(encodingPtr->interp));

  1815     if (len > dstLen) {

  1816 	len = dstLen;

  1817     }

  1818     memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), (unsigned) len);

  1819     Tcl_ResetResult(encodingPtr->interp);

  1820 

  1821     *srcReadPtr = srcLen;

  1822     *dstWrotePtr = len;

  1823     *dstCharsPtr = len;

  1824     return TCL_OK;

  1825 }

  1826 static void

  1827 EncodingFreeProc(clientData)

  1828     ClientData clientData;	/* ClientData associated with type. */

  1829 {

  1830     TclEncoding *encodingPtr;

  1831 

  1832     encodingPtr = (TclEncoding *) clientData;

  1833     ckfree((char *) encodingPtr->toUtfCmd);

  1834     ckfree((char *) encodingPtr->fromUtfCmd);

  1835     ckfree((char *) encodingPtr);

  1836 }

  1837 

  1838 /*

  1839  *----------------------------------------------------------------------

  1840  *

  1841  * TestevalexObjCmd --

  1842  *

  1843  *	This procedure implements the "testevalex" command.  It is

  1844  *	used to test Tcl_EvalEx.

  1845  *

  1846  * Results:

  1847  *	A standard Tcl result.

  1848  *

  1849  * Side effects:

  1850  *	None.

  1851  *

  1852  *----------------------------------------------------------------------

  1853  */

  1854 

  1855 static int

  1856 TestevalexObjCmd(dummy, interp, objc, objv)

  1857     ClientData dummy;			/* Not used. */

  1858     Tcl_Interp *interp;			/* Current interpreter. */

  1859     int objc;				/* Number of arguments. */

  1860     Tcl_Obj *CONST objv[];		/* Argument objects. */

  1861 {

  1862     Interp *iPtr = (Interp *) interp;

  1863     int code, oldFlags, length, flags;

  1864     char *string;

  1865 

  1866     if (objc == 1) {

  1867 	/*

  1868 	 * The command was invoked with no arguments, so just toggle

  1869 	 * the flag that determines whether we use Tcl_EvalEx.

  1870 	 */

  1871 

  1872 	if (iPtr->flags & USE_EVAL_DIRECT) {

  1873 	    iPtr->flags &= ~USE_EVAL_DIRECT;

  1874 	    Tcl_SetResult(interp, "disabling direct evaluation", TCL_STATIC);

  1875 	} else {

  1876 	    iPtr->flags |= USE_EVAL_DIRECT;

  1877 	    Tcl_SetResult(interp, "enabling direct evaluation", TCL_STATIC);

  1878 	}

  1879 	return TCL_OK;

  1880     }

  1881 

  1882     flags = 0;

  1883     if (objc == 3) {

  1884 	string = Tcl_GetStringFromObj(objv[2], &length);

  1885 	if (strcmp(string, "global") != 0) {

  1886 	    Tcl_AppendResult(interp, "bad value \"", string,

  1887 		    "\": must be global", (char *) NULL);

  1888 	    return TCL_ERROR;

  1889 	}

  1890 	flags = TCL_EVAL_GLOBAL;

  1891     } else if (objc != 2) {

  1892 	Tcl_WrongNumArgs(interp, 1, objv, "script ?global?");

  1893         return TCL_ERROR;

  1894     }

  1895     Tcl_SetResult(interp, "xxx", TCL_STATIC);

  1896 

  1897     /*

  1898      * Note, we have to set the USE_EVAL_DIRECT flag in the interpreter

  1899      * in addition to calling Tcl_EvalEx.  This is needed so that even nested

  1900      * commands are evaluated directly.

  1901      */

  1902 

  1903     oldFlags = iPtr->flags;

  1904     iPtr->flags |= USE_EVAL_DIRECT;

  1905     string = Tcl_GetStringFromObj(objv[1], &length);

  1906     code = Tcl_EvalEx(interp, string, length, flags); 

  1907     iPtr->flags = (iPtr->flags & ~USE_EVAL_DIRECT)

  1908 	    | (oldFlags & USE_EVAL_DIRECT);

  1909     return code;

  1910 }

  1911 

  1912 /*

  1913  *----------------------------------------------------------------------

  1914  *

  1915  * TestevalobjvObjCmd --

  1916  *

  1917  *	This procedure implements the "testevalobjv" command.  It is

  1918  *	used to test Tcl_EvalObjv.

  1919  *

  1920  * Results:

  1921  *	A standard Tcl result.

  1922  *

  1923  * Side effects:

  1924  *	None.

  1925  *

  1926  *----------------------------------------------------------------------

  1927  */

  1928 

  1929 static int

  1930 TestevalobjvObjCmd(dummy, interp, objc, objv)

  1931     ClientData dummy;			/* Not used. */

  1932     Tcl_Interp *interp;			/* Current interpreter. */

  1933     int objc;				/* Number of arguments. */

  1934     Tcl_Obj *CONST objv[];		/* Argument objects. */

  1935 {

  1936     int evalGlobal;

  1937 

  1938     if (objc < 3) {

  1939 	Tcl_WrongNumArgs(interp, 1, objv, "global word ?word ...?");

  1940         return TCL_ERROR;

  1941     }

  1942     if (Tcl_GetIntFromObj(interp, objv[1], &evalGlobal) != TCL_OK) {

  1943 	return TCL_ERROR;

  1944     }

  1945     return Tcl_EvalObjv(interp, objc-2, objv+2,

  1946 	    (evalGlobal) ? TCL_EVAL_GLOBAL : 0);

  1947 }

  1948 

  1949 /*

  1950  *----------------------------------------------------------------------

  1951  *

  1952  * TesteventObjCmd --

  1953  *

  1954  *	This procedure implements a 'testevent' command.  The command

  1955  *	is used to test event queue management.

  1956  *

  1957  * The command takes two forms:

  1958  *	- testevent queue name position script

  1959  *		Queues an event at the given position in the queue, and

  1960  *		associates a given name with it (the same name may be

  1961  *		associated with multiple events). When the event comes

  1962  *		to the head of the queue, executes the given script at

  1963  *		global level in the current interp. The position may be

  1964  *		one of 'head', 'tail' or 'mark'.

  1965  *	- testevent delete name

  1966  *		Deletes any events associated with the given name from

  1967  *		the queue.

  1968  *

  1969  * Return value:

  1970  *	Returns a standard Tcl result.

  1971  *

  1972  * Side effects:

  1973  *	Manipulates the event queue as directed.

  1974  *

  1975  *----------------------------------------------------------------------

  1976  */

  1977 

  1978 static int

  1979 TesteventObjCmd( ClientData unused,      /* Not used */

  1980 		 Tcl_Interp* interp,     /* Tcl interpreter */

  1981 		 int objc,               /* Parameter count */

  1982 		 Tcl_Obj *CONST objv[] ) /* Parameter vector */

  1983 {

  1984     

  1985     static CONST char* subcommands[] = { /* Possible subcommands */

  1986 	"queue",

  1987 	"delete",

  1988 	NULL

  1989     };

  1990     int subCmdIndex;		/* Index of the chosen subcommand */

  1991     static CONST char* positions[] = { /* Possible queue positions */

  1992 	"head",

  1993 	"tail",

  1994 	"mark",

  1995 	NULL

  1996     };

  1997     int posIndex;		/* Index of the chosen position */

  1998     static CONST Tcl_QueuePosition posNum[] = { 

  1999 	    			/* Interpretation of the chosen position */

  2000 	TCL_QUEUE_HEAD,

  2001 	TCL_QUEUE_TAIL,

  2002 	TCL_QUEUE_MARK

  2003     };

  2004     TestEvent* ev;		/* Event to be queued */

  2005 

  2006     if ( objc < 2 ) {

  2007 	Tcl_WrongNumArgs( interp, 1, objv, "subcommand ?args?" );

  2008 	return TCL_ERROR;

  2009     }

  2010     if ( Tcl_GetIndexFromObj( interp, objv[1], subcommands, "subcommand",

  2011 			      TCL_EXACT, &subCmdIndex ) != TCL_OK ) {

  2012 	return TCL_ERROR;

  2013     }

  2014     switch ( subCmdIndex ) {

  2015     case 0:			/* queue */

  2016 	if ( objc != 5 ) {

  2017 	    Tcl_WrongNumArgs( interp, 2, objv, "name position script" );

  2018 	    return TCL_ERROR;

  2019 	}

  2020 	if ( Tcl_GetIndexFromObj( interp, objv[3], positions,

  2021 				  "position specifier", TCL_EXACT,

  2022 				  &posIndex ) != TCL_OK ) {

  2023 	    return TCL_ERROR;

  2024 	}

  2025 	ev = (TestEvent*) ckalloc( sizeof( TestEvent ) );

  2026 	ev->header.proc = TesteventProc;

  2027 	ev->header.nextPtr = NULL;

  2028 	ev->interp = interp;

  2029 	ev->command = objv[ 4 ];

  2030 	Tcl_IncrRefCount( ev->command );

  2031 	ev->tag = objv[ 2 ];

  2032 	Tcl_IncrRefCount( ev->tag );

  2033 	Tcl_QueueEvent( (Tcl_Event*) ev, posNum[ posIndex ] );

  2034 	break;

  2035 

  2036     case 1:			/* delete */

  2037 	if ( objc != 3 ) {

  2038 	    Tcl_WrongNumArgs( interp, 2, objv, "name" );

  2039 	    return TCL_ERROR;

  2040 	}

  2041 	Tcl_DeleteEvents( TesteventDeleteProc, objv[ 2 ] );

  2042 	break;

  2043     }

  2044 

  2045     return TCL_OK;

  2046 

  2047 }

  2048 

  2049 /*

  2050  *----------------------------------------------------------------------

  2051  *

  2052  * TesteventProc --

  2053  *

  2054  *	Delivers a test event to the Tcl interpreter as part of event

  2055  *	queue testing.

  2056  * 

  2057  * Results:

  2058  *	Returns 1 if the event has been serviced, 0 otherwise.

  2059  *

  2060  * Side effects:

  2061  *	Evaluates the event's callback script, so has whatever

  2062  *	side effects the callback has.  The return value of the

  2063  *	callback script becomes the return value of this function.

  2064  *	If the callback script reports an error, it is reported as

  2065  *	a background error.

  2066  *

  2067  *----------------------------------------------------------------------

  2068  */

  2069 

  2070 static int

  2071 TesteventProc( Tcl_Event* event, /* Event to deliver */

  2072 	       int flags )	/* Current flags for Tcl_ServiceEvent */

  2073 {

  2074     TestEvent * ev = (TestEvent *) event;

  2075     Tcl_Interp* interp = ev->interp;

  2076     Tcl_Obj* command = ev->command;

  2077     int result = Tcl_EvalObjEx( interp, command,

  2078 				TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT );

  2079     int retval;

  2080     if ( result != TCL_OK ) {

  2081 	Tcl_AddErrorInfo( interp,

  2082 			  "    (command bound to \"testevent\" callback)" );

  2083 	Tcl_BackgroundError( interp );

  2084 	return 1;		/* Avoid looping on errors */

  2085     }

  2086     if ( Tcl_GetBooleanFromObj( interp,

  2087 				Tcl_GetObjResult( interp ),

  2088 				&retval ) != TCL_OK ) {

  2089 	Tcl_AddErrorInfo( interp, 

  2090 			  "    (return value from \"testevent\" callback)" );

  2091 	Tcl_BackgroundError( interp );

  2092 	return 1;

  2093     }

  2094     if ( retval ) {

  2095 	Tcl_DecrRefCount( ev->tag );

  2096 	Tcl_DecrRefCount( ev->command );

  2097     }

  2098 	

  2099     return retval;

  2100 }

  2101 

  2102 /*

  2103  *----------------------------------------------------------------------

  2104  *

  2105  * TesteventDeleteProc --

  2106  *

  2107  *	Removes some set of events from the queue.

  2108  *

  2109  * This procedure is used as part of testing event queue management.

  2110  *

  2111  * Results:

  2112  *	Returns 1 if a given event should be deleted, 0 otherwise.

  2113  *

  2114  * Side effects:

  2115  *	None.

  2116  *

  2117  *----------------------------------------------------------------------

  2118  */

  2119 

  2120 static int

  2121 TesteventDeleteProc( Tcl_Event* event, /* Event to examine */

  2122 		     ClientData clientData ) /* Tcl_Obj containing the name

  2123 					      * of the event(s) to remove */

  2124 {

  2125     TestEvent* ev;		/* Event to examine */

  2126     char* evNameStr;

  2127     Tcl_Obj* targetName;	/* Name of the event(s) to delete */

  2128     char* targetNameStr;

  2129 

  2130     if ( event->proc != TesteventProc ) {

  2131 	return 0;

  2132     }

  2133     targetName = (Tcl_Obj*) clientData;

  2134     targetNameStr = (char*) Tcl_GetStringFromObj( targetName, NULL );

  2135     ev = (TestEvent*) event;

  2136     evNameStr = Tcl_GetStringFromObj( ev->tag, NULL );

  2137     if ( strcmp( evNameStr, targetNameStr ) == 0 ) {

  2138 	Tcl_DecrRefCount( ev->tag );

  2139 	Tcl_DecrRefCount( ev->command );

  2140 	return 1;

  2141     } else {

  2142 	return 0;

  2143     }

  2144 }

  2145 

  2146 /*

  2147  *----------------------------------------------------------------------

  2148  *

  2149  * TestexithandlerCmd --

  2150  *

  2151  *	This procedure implements the "testexithandler" command. It is

  2152  *	used to test Tcl_CreateExitHandler and Tcl_DeleteExitHandler.

  2153  *

  2154  * Results:

  2155  *	A standard Tcl result.

  2156  *

  2157  * Side effects:

  2158  *	None.

  2159  *

  2160  *----------------------------------------------------------------------

  2161  */

  2162 

  2163 static int

  2164 TestexithandlerCmd(clientData, interp, argc, argv)

  2165     ClientData clientData;		/* Not used. */

  2166     Tcl_Interp *interp;			/* Current interpreter. */

  2167     int argc;				/* Number of arguments. */

  2168     CONST char **argv;			/* Argument strings. */

  2169 {

  2170     int value;

  2171 

  2172     if (argc != 3) {

  2173 	Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],

  2174                 " create|delete value\"", (char *) NULL);

  2175         return TCL_ERROR;

  2176     }

  2177     if (Tcl_GetInt(interp, argv[2], &value) != TCL_OK) {

  2178 	return TCL_ERROR;

  2179     }

  2180     if (strcmp(argv[1], "create") == 0) {

  2181 	Tcl_CreateExitHandler((value & 1) ? ExitProcOdd : ExitProcEven,

  2182 		(ClientData) value);

  2183     } else if (strcmp(argv[1], "delete") == 0) {

  2184 	Tcl_DeleteExitHandler((value & 1) ? ExitProcOdd : ExitProcEven,

  2185 		(ClientData) value);

  2186     } else {

  2187 	Tcl_AppendResult(interp, "bad option \"", argv[1],

  2188 		"\": must be create or delete", (char *) NULL);

  2189 	return TCL_ERROR;

  2190     }

  2191     return TCL_OK;

  2192 }

  2193 

  2194 static void

  2195 ExitProcOdd(clientData)

  2196     ClientData clientData;		/* Integer value to print. */

  2197 {

  2198     char buf[16 + TCL_INTEGER_SPACE];

  2199 

  2200     sprintf(buf, "odd %d\n", (int) clientData);

  2201     write(1, buf, strlen(buf));

  2202 }

  2203 

  2204 static void

  2205 ExitProcEven(clientData)

  2206     ClientData clientData;		/* Integer value to print. */

  2207 {

  2208     char buf[16 + TCL_INTEGER_SPACE];

  2209 

  2210     sprintf(buf, "even %d\n", (int) clientData);

  2211     write(1, buf, strlen(buf));

  2212 }

  2213 

  2214 /*

  2215  *----------------------------------------------------------------------

  2216  *

  2217  * TestexprlongCmd --

  2218  *

  2219  *	This procedure verifies that Tcl_ExprLong does not modify the

  2220  *	interpreter result if there is no error.

  2221  *

  2222  * Results:

  2223  *	A standard Tcl result.

  2224  *

  2225  * Side effects:

  2226  *	None.

  2227  *

  2228  *----------------------------------------------------------------------

  2229  */

  2230 

  2231 static int

  2232 TestexprlongCmd(clientData, interp, argc, argv)

  2233     ClientData clientData;		/* Not used. */

  2234     Tcl_Interp *interp;			/* Current interpreter. */

  2235     int argc;				/* Number of arguments. */

  2236     CONST char **argv;			/* Argument strings. */

  2237 {

  2238     long exprResult;

  2239     char buf[4 + TCL_INTEGER_SPACE];

  2240     int result;

  2241     

  2242     Tcl_SetResult(interp, "This is a result", TCL_STATIC);

  2243     result = Tcl_ExprLong(interp, "4+1", &exprResult);

  2244     if (result != TCL_OK) {

  2245         return result;

  2246     }

  2247     sprintf(buf, ": %ld", exprResult);

  2248     Tcl_AppendResult(interp, buf, NULL);

  2249     return TCL_OK;

  2250 }

  2251 

  2252 /*

  2253  *----------------------------------------------------------------------

  2254  *

  2255  * TestexprstringCmd --

  2256  *

  2257  *	This procedure tests the basic operation of Tcl_ExprString.

  2258  *

  2259  * Results:

  2260  *	A standard Tcl result.

  2261  *

  2262  * Side effects:

  2263  *	None.

  2264  *

  2265  *----------------------------------------------------------------------

  2266  */

  2267 

  2268 static int

  2269 TestexprstringCmd(clientData, interp, argc, argv)

  2270     ClientData clientData;		/* Not used. */

  2271     Tcl_Interp *interp;			/* Current interpreter. */

  2272     int argc;				/* Number of arguments. */

  2273     CONST char **argv;			/* Argument strings. */

  2274 {

  2275     if (argc != 2) {

  2276         Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],

  2277                 " expression\"", (char *) NULL);

  2278         return TCL_ERROR;

  2279     }

  2280     return Tcl_ExprString(interp, argv[1]);

  2281 }

  2282 

  2283 /*

  2284  *----------------------------------------------------------------------

  2285  *

  2286  * TestfilelinkCmd --

  2287  *

  2288  *	This procedure implements the "testfilelink" command.  It is used

  2289  *	to test the effects of creating and manipulating filesystem links

  2290  *	in Tcl.

  2291  *

  2292  * Results:

  2293  *	A standard Tcl result.

  2294  *

  2295  * Side effects:

  2296  *	May create a link on disk.

  2297  *

  2298  *----------------------------------------------------------------------

  2299  */

  2300 

  2301 static int

  2302 TestfilelinkCmd(clientData, interp, objc, objv)

  2303     ClientData clientData;	/* Not used. */

  2304     Tcl_Interp *interp;		/* Current interpreter. */

  2305     int objc;			/* Number of arguments. */

  2306     Tcl_Obj *CONST objv[];	/* The argument objects. */

  2307 {

  2308     Tcl_Obj *contents;

  2309 

  2310     if (objc < 2 || objc > 3) {

  2311 	Tcl_WrongNumArgs(interp, 1, objv, "source ?target?");

  2312 	return TCL_ERROR;

  2313     }

  2314     

  2315     if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {

  2316 	return TCL_ERROR;

  2317     }

  2318     

  2319     if (objc == 3) {

  2320 	/* Create link from source to target */

  2321 	contents = Tcl_FSLink(objv[1], objv[2], 

  2322 			TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK);

  2323 	if (contents == NULL) {

  2324 	    Tcl_AppendResult(interp, "could not create link from \"", 

  2325 		    Tcl_GetString(objv[1]), "\" to \"", 

  2326 		    Tcl_GetString(objv[2]), "\": ", 

  2327 		    Tcl_PosixError(interp), (char *) NULL);

  2328 	    return TCL_ERROR;

  2329 	}

  2330     } else {

  2331 	/* Read link */

  2332 	contents = Tcl_FSLink(objv[1], NULL, 0);

  2333 	if (contents == NULL) {

  2334 	    Tcl_AppendResult(interp, "could not read link \"", 

  2335 		    Tcl_GetString(objv[1]), "\": ", 

  2336 		    Tcl_PosixError(interp), (char *) NULL);

  2337 	    return TCL_ERROR;

  2338 	}

  2339     }

  2340     Tcl_SetObjResult(interp, contents);

  2341     if (objc == 2) {

  2342 	/* 

  2343 	 * If we are creating a link, this will actually just

  2344 	 * be objv[3], and we don't own it

  2345 	 */

  2346 	Tcl_DecrRefCount(contents);

  2347     }

  2348     return TCL_OK;

  2349 }

  2350 

  2351 /*

  2352  *----------------------------------------------------------------------

  2353  *

  2354  * TestgetassocdataCmd --

  2355  *

  2356  *	This procedure implements the "testgetassocdata" command. It is

  2357  *	used to test Tcl_GetAssocData.

  2358  *

  2359  * Results:

  2360  *	A standard Tcl result.

  2361  *

  2362  * Side effects:

  2363  *	None.

  2364  *

  2365  *----------------------------------------------------------------------

  2366  */

  2367 

  2368 static int

  2369 TestgetassocdataCmd(clientData, interp, argc, argv)

  2370     ClientData clientData;		/* Not used. */

  2371     Tcl_Interp *interp;			/* Current interpreter. */

  2372     int argc;				/* Number of arguments. */

  2373     CONST char **argv;			/* Argument strings. */

  2374 {

  2375     char *res;

  2376     

  2377     if (argc != 2) {

  2378         Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],

  2379                 " data_key\"", (char *) NULL);

  2380         return TCL_ERROR;

  2381     }

  2382     res = (char *) Tcl_GetAssocData(interp, argv[1], NULL);

  2383     if (res != NULL) {

  2384         Tcl_AppendResult(interp, res, NULL);

  2385     }

  2386     return TCL_OK;

  2387 }

  2388 

  2389 /*

  2390  *----------------------------------------------------------------------

  2391  *

  2392  * TestgetplatformCmd --

  2393  *

  2394  *	This procedure implements the "testgetplatform" command. It is

  2395  *	used to retrievel the value of the tclPlatform global variable.

  2396  *

  2397  * Results:

  2398  *	A standard Tcl result.

  2399  *

  2400  * Side effects:

  2401  *	None.

  2402  *

  2403  *----------------------------------------------------------------------

  2404  */

  2405 

  2406 static int

  2407 TestgetplatformCmd(clientData, interp, argc, argv)

  2408     ClientData clientData;		/* Not used. */

  2409     Tcl_Interp *interp;			/* Current interpreter. */

  2410     int argc;				/* Number of arguments. */

  2411     CONST char **argv;			/* Argument strings. */

  2412 {

  2413     static CONST char *platformStrings[] = { "unix", "mac", "windows" };

  2414     TclPlatformType *platform;

  2415 

  2416 #ifdef __WIN32__

  2417     platform = TclWinGetPlatform();

  2418 #else

  2419     platform = &tclPlatform;

  2420 #endif

  2421     

  2422     if (argc != 1) {

  2423         Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],

  2424 		(char *) NULL);

  2425         return TCL_ERROR;

  2426     }

  2427 

  2428     Tcl_AppendResult(interp, platformStrings[*platform], NULL);

  2429     return TCL_OK;

  2430 }

  2431 

  2432 /*

  2433  *----------------------------------------------------------------------

  2434  *

  2435  * TestinterpdeleteCmd --

  2436  *

  2437  *	This procedure tests the code in tclInterp.c that deals with

  2438  *	interpreter deletion. It deletes a user-specified interpreter

  2439  *	from the hierarchy, and subsequent code checks integrity.

  2440  *

  2441  * Results:

  2442  *	A standard Tcl result.

  2443  *

  2444  * Side effects:

  2445  *	Deletes one or more interpreters.

  2446  *

  2447  *----------------------------------------------------------------------

  2448  */

  2449 

  2450 	/* ARGSUSED */

  2451 static int

  2452 TestinterpdeleteCmd(dummy, interp, argc, argv)

  2453     ClientData dummy;			/* Not used. */

  2454     Tcl_Interp *interp;			/* Current interpreter. */

  2455     int argc;				/* Number of arguments. */

  2456     CONST char **argv;			/* Argument strings. */

  2457 {

  2458     Tcl_Interp *slaveToDelete;

  2459 

  2460     if (argc != 2) {

  2461         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

  2462                 " path\"", (char *) NULL);

  2463         return TCL_ERROR;

  2464     }

  2465     slaveToDelete = Tcl_GetSlave(interp, argv[1]);

  2466     if (slaveToDelete == (Tcl_Interp *) NULL) {

  2467         return TCL_ERROR;

  2468     }

  2469     Tcl_DeleteInterp(slaveToDelete);

  2470     return TCL_OK;

  2471 }

  2472 

  2473 /*

  2474  *----------------------------------------------------------------------

  2475  *

  2476  * TestlinkCmd --

  2477  *

  2478  *	This procedure implements the "testlink" command.  It is used

  2479  *	to test Tcl_LinkVar and related library procedures.

  2480  *

  2481  * Results:

  2482  *	A standard Tcl result.

  2483  *

  2484  * Side effects:

  2485  *	Creates and deletes various variable links, plus returns

  2486  *	values of the linked variables.

  2487  *

  2488  *----------------------------------------------------------------------

  2489  */

  2490 

  2491 	/* ARGSUSED */

  2492 static int

  2493 TestlinkCmd(dummy, interp, argc, argv)

  2494     ClientData dummy;			/* Not used. */

  2495     Tcl_Interp *interp;			/* Current interpreter. */

  2496     int argc;				/* Number of arguments. */

  2497     CONST char **argv;			/* Argument strings. */

  2498 {

  2499     static int intVar = 43;

  2500     static int boolVar = 4;

  2501     static double realVar = 1.23;

  2502     static Tcl_WideInt wideVar = Tcl_LongAsWide(79);

  2503     static char *stringVar = NULL;

  2504     static int created = 0;

  2505     char buffer[2*TCL_DOUBLE_SPACE];

  2506     int writable, flag;

  2507     Tcl_Obj *tmp;

  2508 

  2509     if (argc < 2) {

  2510 	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

  2511 		" option ?arg arg arg arg arg?\"", (char *) NULL);

  2512 	return TCL_ERROR;

  2513     }

  2514     if (strcmp(argv[1], "create") == 0) {

  2515 	if (argc != 7) {

  2516 	    Tcl_AppendResult(interp, "wrong # args: should be \"",

  2517 		argv[0], " ", argv[1],

  2518 		" intRO realRO boolRO stringRO wideRO\"", (char *) NULL);

  2519 	    return TCL_ERROR;

  2520 	}

  2521 	if (created) {

  2522 	    Tcl_UnlinkVar(interp, "int");

  2523 	    Tcl_UnlinkVar(interp, "real");

  2524 	    Tcl_UnlinkVar(interp, "bool");

  2525 	    Tcl_UnlinkVar(interp, "string");

  2526 	    Tcl_UnlinkVar(interp, "wide");

  2527 	}

  2528 	created = 1;

  2529 	if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) {

  2530 	    return TCL_ERROR;

  2531 	}

  2532 	flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;

  2533 	if (Tcl_LinkVar(interp, "int", (char *) &intVar,

  2534 		TCL_LINK_INT | flag) != TCL_OK) {

  2535 	    return TCL_ERROR;

  2536 	}

  2537 	if (Tcl_GetBoolean(interp, argv[3], &writable) != TCL_OK) {

  2538 	    return TCL_ERROR;

  2539 	}

  2540 	flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;

  2541 	if (Tcl_LinkVar(interp, "real", (char *) &realVar,

  2542 		TCL_LINK_DOUBLE | flag) != TCL_OK) {

  2543 	    return TCL_ERROR;

  2544 	}

  2545 	if (Tcl_GetBoolean(interp, argv[4], &writable) != TCL_OK) {

  2546 	    return TCL_ERROR;

  2547 	}

  2548 	flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;

  2549 	if (Tcl_LinkVar(interp, "bool", (char *) &boolVar,

  2550 		TCL_LINK_BOOLEAN | flag) != TCL_OK) {

  2551 	    return TCL_ERROR;

  2552 	}

  2553 	if (Tcl_GetBoolean(interp, argv[5], &writable) != TCL_OK) {

  2554 	    return TCL_ERROR;

  2555 	}

  2556 	flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;

  2557 	if (Tcl_LinkVar(interp, "string", (char *) &stringVar,

  2558 		TCL_LINK_STRING | flag) != TCL_OK) {

  2559 	    return TCL_ERROR;

  2560 	}

  2561 	if (Tcl_GetBoolean(interp, argv[6], &writable) != TCL_OK) {

  2562 	    return TCL_ERROR;

  2563 	}

  2564 	flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;

  2565 	if (Tcl_LinkVar(interp, "wide", (char *) &wideVar,

  2566 			TCL_LINK_WIDE_INT | flag) != TCL_OK) {

  2567 	    return TCL_ERROR;

  2568 	}

  2569     } else if (strcmp(argv[1], "delete") == 0) {

  2570 	Tcl_UnlinkVar(interp, "int");

  2571 	Tcl_UnlinkVar(interp, "real");

  2572 	Tcl_UnlinkVar(interp, "bool");

  2573 	Tcl_UnlinkVar(interp, "string");

  2574 	Tcl_UnlinkVar(interp, "wide");

  2575 	created = 0;

  2576     } else if (strcmp(argv[1], "get") == 0) {

  2577 	TclFormatInt(buffer, intVar);

  2578 	Tcl_AppendElement(interp, buffer);

  2579 	Tcl_PrintDouble((Tcl_Interp *) NULL, realVar, buffer);

  2580 	Tcl_AppendElement(interp, buffer);

  2581 	TclFormatInt(buffer, boolVar);

  2582 	Tcl_AppendElement(interp, buffer);

  2583 	Tcl_AppendElement(interp, (stringVar == NULL) ? "-" : stringVar);

  2584 	/*

  2585 	 * Wide ints only have an object-based interface.

  2586 	 */

  2587 	tmp = Tcl_NewWideIntObj(wideVar);

  2588 	Tcl_AppendElement(interp, Tcl_GetString(tmp));

  2589 	Tcl_DecrRefCount(tmp);

  2590     } else if (strcmp(argv[1], "set") == 0) {

  2591 	if (argc != 7) {

  2592 	    Tcl_AppendResult(interp, "wrong # args: should be \"",

  2593 		    argv[0], " ", argv[1],

  2594 		    " intValue realValue boolValue stringValue wideValue\"",

  2595 		    (char *) NULL);

  2596 	    return TCL_ERROR;

  2597 	}

  2598 	if (argv[2][0] != 0) {

  2599 	    if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) {

  2600 		return TCL_ERROR;

  2601 	    }

  2602 	}

  2603 	if (argv[3][0] != 0) {

  2604 	    if (Tcl_GetDouble(interp, argv[3], &realVar) != TCL_OK) {

  2605 		return TCL_ERROR;

  2606 	    }

  2607 	}

  2608 	if (argv[4][0] != 0) {

  2609 	    if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) {

  2610 		return TCL_ERROR;

  2611 	    }

  2612 	}

  2613 	if (argv[5][0] != 0) {

  2614 	    if (stringVar != NULL) {

  2615 		ckfree(stringVar);

  2616 	    }

  2617 	    if (strcmp(argv[5], "-") == 0) {

  2618 		stringVar = NULL;

  2619 	    } else {

  2620 		stringVar = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1));

  2621 		strcpy(stringVar, argv[5]);

  2622 	    }

  2623 	}

  2624 	if (argv[6][0] != 0) {

  2625 	    tmp = Tcl_NewStringObj(argv[6], -1);

  2626 	    if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {

  2627 		Tcl_DecrRefCount(tmp);

  2628 		return TCL_ERROR;

  2629 	    }

  2630 	    Tcl_DecrRefCount(tmp);

  2631 	}

  2632     } else if (strcmp(argv[1], "update") == 0) {

  2633 	if (argc != 7) {

  2634 	    Tcl_AppendResult(interp, "wrong # args: should be \"",

  2635 		    argv[0], " ", argv[1],

  2636 		    "intValue realValue boolValue stringValue wideValue\"",

  2637 		    (char *) NULL);

  2638 	    return TCL_ERROR;

  2639 	}

  2640 	if (argv[2][0] != 0) {

  2641 	    if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) {

  2642 		return TCL_ERROR;

  2643 	    }

  2644 	    Tcl_UpdateLinkedVar(interp, "int");

  2645 	}

  2646 	if (argv[3][0] != 0) {

  2647 	    if (Tcl_GetDouble(interp, argv[3], &realVar) != TCL_OK) {

  2648 		return TCL_ERROR;

  2649 	    }

  2650 	    Tcl_UpdateLinkedVar(interp, "real");

  2651 	}

  2652 	if (argv[4][0] != 0) {

  2653 	    if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) {

  2654 		return TCL_ERROR;

  2655 	    }

  2656 	    Tcl_UpdateLinkedVar(interp, "bool");

  2657 	}

  2658 	if (argv[5][0] != 0) {

  2659 	    if (stringVar != NULL) {

  2660 		ckfree(stringVar);

  2661 	    }

  2662 	    if (strcmp(argv[5], "-") == 0) {

  2663 		stringVar = NULL;

  2664 	    } else {

  2665 		stringVar = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1));

  2666 		strcpy(stringVar, argv[5]);

  2667 	    }

  2668 	    Tcl_UpdateLinkedVar(interp, "string");

  2669 	}

  2670 	if (argv[6][0] != 0) {

  2671 	    tmp = Tcl_NewStringObj(argv[6], -1);

  2672 	    if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {

  2673 		Tcl_DecrRefCount(tmp);

  2674 		return TCL_ERROR;

  2675 	    }

  2676 	    Tcl_DecrRefCount(tmp);

  2677 	    Tcl_UpdateLinkedVar(interp, "wide");

  2678 	}

  2679     } else {

  2680 	Tcl_AppendResult(interp, "bad option \"", argv[1],

  2681 		"\": should be create, delete, get, set, or update",

  2682 		(char *) NULL);

  2683 	return TCL_ERROR;

  2684     }

  2685     return TCL_OK;

  2686 }

  2687 

  2688 /*

  2689  *----------------------------------------------------------------------

  2690  *

  2691  * TestlocaleCmd --

  2692  *

  2693  *	This procedure implements the "testlocale" command.  It is used

  2694  *	to test the effects of setting different locales in Tcl.

  2695  *

  2696  * Results:

  2697  *	A standard Tcl result.

  2698  *

  2699  * Side effects:

  2700  *	Modifies the current C locale.

  2701  *

  2702  *----------------------------------------------------------------------

  2703  */

  2704 

  2705 static int

  2706 TestlocaleCmd(clientData, interp, objc, objv)

  2707     ClientData clientData;	/* Not used. */

  2708     Tcl_Interp *interp;		/* Current interpreter. */

  2709     int objc;			/* Number of arguments. */

  2710     Tcl_Obj *CONST objv[];	/* The argument objects. */

  2711 {

  2712     int index;

  2713     char *locale;

  2714 

  2715     static CONST char *optionStrings[] = {

  2716     	"ctype", "numeric", "time", "collate", "monetary", 

  2717 	"all",	NULL

  2718     };

  2719     static int lcTypes[] = {

  2720 	LC_CTYPE, LC_NUMERIC, LC_TIME, LC_COLLATE, LC_MONETARY,

  2721 	LC_ALL

  2722     };

  2723 

  2724     /*

  2725      * LC_CTYPE, etc. correspond to the indices for the strings.

  2726      */

  2727 

  2728     if (objc < 2 || objc > 3) {

  2729 	Tcl_WrongNumArgs(interp, 1, objv, "category ?locale?");

  2730 	return TCL_ERROR;

  2731     }

  2732     

  2733     if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,

  2734 	    &index) != TCL_OK) {

  2735 	return TCL_ERROR;

  2736     }

  2737 

  2738     if (objc == 3) {

  2739 	locale = Tcl_GetString(objv[2]);

  2740     } else {

  2741 	locale = NULL;

  2742     }

  2743     locale = setlocale(lcTypes[index], locale);

  2744     if (locale) {

  2745 	Tcl_SetStringObj(Tcl_GetObjResult(interp), locale, -1);

  2746     }

  2747     return TCL_OK;

  2748 }

  2749 

  2750 /*

  2751  *----------------------------------------------------------------------

  2752  *

  2753  * TestMathFunc --

  2754  *

  2755  *	This is a user-defined math procedure to test out math procedures

  2756  *	with no arguments.

  2757  *

  2758  * Results:

  2759  *	A normal Tcl completion code.

  2760  *

  2761  * Side effects:

  2762  *	None.

  2763  *

  2764  *----------------------------------------------------------------------

  2765  */

  2766 

  2767 	/* ARGSUSED */

  2768 static int

  2769 TestMathFunc(clientData, interp, args, resultPtr)

  2770     ClientData clientData;		/* Integer value to return. */

  2771     Tcl_Interp *interp;			/* Not used. */

  2772     Tcl_Value *args;			/* Not used. */

  2773     Tcl_Value *resultPtr;		/* Where to store result. */

  2774 {

  2775     resultPtr->type = TCL_INT;

  2776     resultPtr->intValue = (int) clientData;

  2777     return TCL_OK;

  2778 }

  2779 

  2780 /*

  2781  *----------------------------------------------------------------------

  2782  *

  2783  * TestMathFunc2 --

  2784  *

  2785  *	This is a user-defined math procedure to test out math procedures

  2786  *	that do have arguments, in this case 2.

  2787  *

  2788  * Results:

  2789  *	A normal Tcl completion code.

  2790  *

  2791  * Side effects:

  2792  *	None.

  2793  *

  2794  *----------------------------------------------------------------------

  2795  */

  2796 

  2797 	/* ARGSUSED */

  2798 static int

  2799 TestMathFunc2(clientData, interp, args, resultPtr)

  2800     ClientData clientData;		/* Integer value to return. */

  2801     Tcl_Interp *interp;			/* Used to report errors. */

  2802     Tcl_Value *args;			/* Points to an array of two

  2803 					 * Tcl_Value structs for the 

  2804 					 * two arguments. */

  2805     Tcl_Value *resultPtr;		/* Where to store the result. */

  2806 {

  2807     int result = TCL_OK;

  2808     

  2809     /*

  2810      * Return the maximum of the two arguments with the correct type.

  2811      */

  2812     

  2813     if (args[0].type == TCL_INT) {

  2814 	int i0 = args[0].intValue;

  2815 	

  2816 	if (args[1].type == TCL_INT) {

  2817 	    int i1 = args[1].intValue;

  2818 	    

  2819 	    resultPtr->type = TCL_INT;

  2820 	    resultPtr->intValue = ((i0 > i1)? i0 : i1);

  2821 	} else if (args[1].type == TCL_DOUBLE) {

  2822 	    double d0 = i0;

  2823 	    double d1 = args[1].doubleValue;

  2824 

  2825 	    resultPtr->type = TCL_DOUBLE;

  2826 	    resultPtr->doubleValue = ((d0 > d1)? d0 : d1);

  2827 	} else if (args[1].type == TCL_WIDE_INT) {

  2828 	    Tcl_WideInt w0 = Tcl_LongAsWide(i0);

  2829 	    Tcl_WideInt w1 = args[1].wideValue;

  2830 

  2831 	    resultPtr->type = TCL_WIDE_INT;

  2832 	    resultPtr->wideValue = ((w0 > w1)? w0 : w1);

  2833 	} else {

  2834 	    Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC);

  2835 	    result = TCL_ERROR;

  2836 	}

  2837     } else if (args[0].type == TCL_DOUBLE) {

  2838 	double d0 = args[0].doubleValue;

  2839 	

  2840 	if (args[1].type == TCL_INT) {

  2841 	    double d1 = args[1].intValue;

  2842 	    

  2843 	    resultPtr->type = TCL_DOUBLE;

  2844 	    resultPtr->doubleValue = ((d0 > d1)? d0 : d1);

  2845 	} else if (args[1].type == TCL_DOUBLE) {

  2846 	    double d1 = args[1].doubleValue;

  2847 

  2848 	    resultPtr->type = TCL_DOUBLE;

  2849 	    resultPtr->doubleValue = ((d0 > d1)? d0 : d1);

  2850 	} else if (args[1].type == TCL_WIDE_INT) {

  2851 	    double d1 = Tcl_WideAsDouble(args[1].wideValue);

  2852 

  2853 	    resultPtr->type = TCL_DOUBLE;

  2854 	    resultPtr->doubleValue = ((d0 > d1)? d0 : d1);

  2855 	} else {

  2856 	    Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC);

  2857 	    result = TCL_ERROR;

  2858 	}

  2859     } else if (args[0].type == TCL_WIDE_INT) {

  2860 	Tcl_WideInt w0 = args[0].wideValue;

  2861 	

  2862 	if (args[1].type == TCL_INT) {

  2863 	    Tcl_WideInt w1 = Tcl_LongAsWide(args[1].intValue);

  2864 	    

  2865 	    resultPtr->type = TCL_WIDE_INT;

  2866 	    resultPtr->wideValue = ((w0 > w1)? w0 : w1);

  2867 	} else if (args[1].type == TCL_DOUBLE) {

  2868 	    double d0 = Tcl_WideAsDouble(w0);

  2869 	    double d1 = args[1].doubleValue;

  2870 

  2871 	    resultPtr->type = TCL_DOUBLE;

  2872 	    resultPtr->doubleValue = ((d0 > d1)? d0 : d1);

  2873 	} else if (args[1].type == TCL_WIDE_INT) {

  2874 	    Tcl_WideInt w1 = args[1].wideValue;

  2875 

  2876 	    resultPtr->type = TCL_WIDE_INT;

  2877 	    resultPtr->wideValue = ((w0 > w1)? w0 : w1);

  2878 	} else {

  2879 	    Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC);

  2880 	    result = TCL_ERROR;

  2881 	}

  2882     } else {

  2883 	Tcl_SetResult(interp, "T3: wrong type for arg 1", TCL_STATIC);

  2884 	result = TCL_ERROR;

  2885     }

  2886     return result;

  2887 }

  2888 

  2889 /*

  2890  *----------------------------------------------------------------------

  2891  *

  2892  * CleanupTestSetassocdataTests --

  2893  *

  2894  *	This function is called when an interpreter is deleted to clean

  2895  *	up any data left over from running the testsetassocdata command.

  2896  *

  2897  * Results:

  2898  *	None.

  2899  *

  2900  * Side effects:

  2901  *	Releases storage.

  2902  *

  2903  *----------------------------------------------------------------------

  2904  */

  2905 	/* ARGSUSED */

  2906 static void

  2907 CleanupTestSetassocdataTests(clientData, interp)

  2908     ClientData clientData;		/* Data to be released. */

  2909     Tcl_Interp *interp;			/* Interpreter being deleted. */

  2910 {

  2911     ckfree((char *) clientData);

  2912 }

  2913 

  2914 /*

  2915  *----------------------------------------------------------------------

  2916  *

  2917  * TestparserObjCmd --

  2918  *

  2919  *	This procedure implements the "testparser" command.  It is

  2920  *	used for testing the new Tcl script parser in Tcl 8.1.

  2921  *

  2922  * Results:

  2923  *	A standard Tcl result.

  2924  *

  2925  * Side effects:

  2926  *	None.

  2927  *

  2928  *----------------------------------------------------------------------

  2929  */

  2930 

  2931 static int

  2932 TestparserObjCmd(clientData, interp, objc, objv)

  2933     ClientData clientData;	/* Not used. */

  2934     Tcl_Interp *interp;		/* Current interpreter. */

  2935     int objc;			/* Number of arguments. */

  2936     Tcl_Obj *CONST objv[];	/* The argument objects. */

  2937 {

  2938     char *script;

  2939     int length, dummy;

  2940     Tcl_Parse parse;

  2941 

  2942     if (objc != 3) {

  2943 	Tcl_WrongNumArgs(interp, 1, objv, "script length");

  2944 	return TCL_ERROR;

  2945     }

  2946     script = Tcl_GetStringFromObj(objv[1], &dummy);

  2947     if (Tcl_GetIntFromObj(interp, objv[2], &length)) {

  2948 	return TCL_ERROR;

  2949     }

  2950     if (length == 0) {

  2951 	length = dummy;

  2952     }

  2953     if (Tcl_ParseCommand(interp, script, length, 0, &parse) != TCL_OK) {

  2954 	Tcl_AddErrorInfo(interp, "\n    (remainder of script: \"");

  2955 	Tcl_AddErrorInfo(interp, parse.term);

  2956 	Tcl_AddErrorInfo(interp, "\")");

  2957 	return TCL_ERROR;

  2958     }

  2959 

  2960     /*

  2961      * The parse completed successfully.  Just print out the contents

  2962      * of the parse structure into the interpreter's result.

  2963      */

  2964 

  2965     PrintParse(interp, &parse);

  2966     Tcl_FreeParse(&parse);

  2967     return TCL_OK;

  2968 }

  2969 

  2970 /*

  2971  *----------------------------------------------------------------------

  2972  *

  2973  * TestexprparserObjCmd --

  2974  *

  2975  *	This procedure implements the "testexprparser" command.  It is

  2976  *	used for testing the new Tcl expression parser in Tcl 8.1.

  2977  *

  2978  * Results:

  2979  *	A standard Tcl result.

  2980  *

  2981  * Side effects:

  2982  *	None.

  2983  *

  2984  *----------------------------------------------------------------------

  2985  */

  2986 

  2987 static int

  2988 TestexprparserObjCmd(clientData, interp, objc, objv)

  2989     ClientData clientData;	/* Not used. */

  2990     Tcl_Interp *interp;		/* Current interpreter. */

  2991     int objc;			/* Number of arguments. */

  2992     Tcl_Obj *CONST objv[];	/* The argument objects. */

  2993 {

  2994     char *script;

  2995     int length, dummy;

  2996     Tcl_Parse parse;

  2997 

  2998     if (objc != 3) {

  2999 	Tcl_WrongNumArgs(interp, 1, objv, "expr length");

  3000 	return TCL_ERROR;

  3001     }

  3002     script = Tcl_GetStringFromObj(objv[1], &dummy);

  3003     if (Tcl_GetIntFromObj(interp, objv[2], &length)) {

  3004 	return TCL_ERROR;

  3005     }

  3006     if (length == 0) {

  3007 	length = dummy;

  3008     }

  3009     if (Tcl_ParseExpr(interp, script, length, &parse) != TCL_OK) {

  3010 	Tcl_AddErrorInfo(interp, "\n    (remainder of expr: \"");

  3011 	Tcl_AddErrorInfo(interp, parse.term);

  3012 	Tcl_AddErrorInfo(interp, "\")");

  3013 	return TCL_ERROR;

  3014     }

  3015 

  3016     /*

  3017      * The parse completed successfully.  Just print out the contents

  3018      * of the parse structure into the interpreter's result.

  3019      */

  3020 

  3021     PrintParse(interp, &parse);

  3022     Tcl_FreeParse(&parse);

  3023     return TCL_OK;

  3024 }

  3025 

  3026 /*

  3027  *----------------------------------------------------------------------

  3028  *

  3029  * PrintParse --

  3030  *

  3031  *	This procedure prints out the contents of a Tcl_Parse structure

  3032  *	in the result of an interpreter.

  3033  *

  3034  * Results:

  3035  *	Interp's result is set to a prettily formatted version of the

  3036  *	contents of parsePtr.

  3037  *

  3038  * Side effects:

  3039  *	None.

  3040  *

  3041  *----------------------------------------------------------------------

  3042  */

  3043 

  3044 static void

  3045 PrintParse(interp, parsePtr)

  3046     Tcl_Interp *interp;		/* Interpreter whose result is to be set to

  3047 				 * the contents of a parse structure. */

  3048     Tcl_Parse *parsePtr;	/* Parse structure to print out. */

  3049 {

  3050     Tcl_Obj *objPtr;

  3051     char *typeString;

  3052     Tcl_Token *tokenPtr;

  3053     int i;

  3054 

  3055     objPtr = Tcl_GetObjResult(interp);

  3056     if (parsePtr->commentSize > 0) {

  3057 	Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,

  3058 		Tcl_NewStringObj(parsePtr->commentStart,

  3059 			parsePtr->commentSize));

  3060     } else {

  3061 	Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,

  3062 		Tcl_NewStringObj("-", 1));

  3063     }

  3064     Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,

  3065 	    Tcl_NewStringObj(parsePtr->commandStart, parsePtr->commandSize));

  3066     Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,

  3067 	    Tcl_NewIntObj(parsePtr->numWords));

  3068     for (i = 0; i < parsePtr->numTokens; i++) {

  3069 	tokenPtr = &parsePtr->tokenPtr[i];

  3070 	switch (tokenPtr->type) {

  3071 	    case TCL_TOKEN_WORD:

  3072 		typeString = "word";

  3073 		break;

  3074 	    case TCL_TOKEN_SIMPLE_WORD:

  3075 		typeString = "simple";

  3076 		break;

  3077 	    case TCL_TOKEN_TEXT:

  3078 		typeString = "text";

  3079 		break;

  3080 	    case TCL_TOKEN_BS:

  3081 		typeString = "backslash";

  3082 		break;

  3083 	    case TCL_TOKEN_COMMAND:

  3084 		typeString = "command";

  3085 		break;

  3086 	    case TCL_TOKEN_VARIABLE:

  3087 		typeString = "variable";

  3088 		break;

  3089 	    case TCL_TOKEN_SUB_EXPR:

  3090 		typeString = "subexpr";

  3091 		break;

  3092 	    case TCL_TOKEN_OPERATOR:

  3093 		typeString = "operator";

  3094 		break;

  3095 	    default:

  3096 		typeString = "??";

  3097 		break;

  3098 	}

  3099 	Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,

  3100 		Tcl_NewStringObj(typeString, -1));

  3101 	Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,

  3102 		Tcl_NewStringObj(tokenPtr->start, tokenPtr->size));

  3103 	Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,

  3104 		Tcl_NewIntObj(tokenPtr->numComponents));

  3105     }

  3106     Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,

  3107 	    Tcl_NewStringObj(parsePtr->commandStart + parsePtr->commandSize,

  3108 	    -1));

  3109 }

  3110 

  3111 /*

  3112  *----------------------------------------------------------------------

  3113  *

  3114  * TestparsevarObjCmd --

  3115  *

  3116  *	This procedure implements the "testparsevar" command.  It is

  3117  *	used for testing Tcl_ParseVar.

  3118  *

  3119  * Results:

  3120  *	A standard Tcl result.

  3121  *

  3122  * Side effects:

  3123  *	None.

  3124  *

  3125  *----------------------------------------------------------------------

  3126  */

  3127 

  3128 static int

  3129 TestparsevarObjCmd(clientData, interp, objc, objv)

  3130     ClientData clientData;	/* Not used. */

  3131     Tcl_Interp *interp;		/* Current interpreter. */

  3132     int objc;			/* Number of arguments. */

  3133     Tcl_Obj *CONST objv[];	/* The argument objects. */

  3134 {

  3135     CONST char *value;

  3136     CONST char *name, *termPtr;

  3137 

  3138     if (objc != 2) {

  3139 	Tcl_WrongNumArgs(interp, 1, objv, "varName");

  3140 	return TCL_ERROR;

  3141     }

  3142     name = Tcl_GetString(objv[1]);

  3143     value = Tcl_ParseVar(interp, name, &termPtr);

  3144     if (value == NULL) {

  3145 	return TCL_ERROR;

  3146     }

  3147 

  3148     Tcl_AppendElement(interp, value);

  3149     Tcl_AppendElement(interp, termPtr);

  3150     return TCL_OK;

  3151 }

  3152 

  3153 /*

  3154  *----------------------------------------------------------------------

  3155  *

  3156  * TestparsevarnameObjCmd --

  3157  *

  3158  *	This procedure implements the "testparsevarname" command.  It is

  3159  *	used for testing the new Tcl script parser in Tcl 8.1.

  3160  *

  3161  * Results:

  3162  *	A standard Tcl result.

  3163  *

  3164  * Side effects:

  3165  *	None.

  3166  *

  3167  *----------------------------------------------------------------------

  3168  */

  3169 

  3170 static int

  3171 TestparsevarnameObjCmd(clientData, interp, objc, objv)

  3172     ClientData clientData;	/* Not used. */

  3173     Tcl_Interp *interp;		/* Current interpreter. */

  3174     int objc;			/* Number of arguments. */

  3175     Tcl_Obj *CONST objv[];	/* The argument objects. */

  3176 {

  3177     char *script;

  3178     int append, length, dummy;

  3179     Tcl_Parse parse;

  3180 

  3181     if (objc != 4) {

  3182 	Tcl_WrongNumArgs(interp, 1, objv, "script length append");

  3183 	return TCL_ERROR;

  3184     }

  3185     script = Tcl_GetStringFromObj(objv[1], &dummy);

  3186     if (Tcl_GetIntFromObj(interp, objv[2], &length)) {

  3187 	return TCL_ERROR;

  3188     }

  3189     if (length == 0) {

  3190 	length = dummy;

  3191     }

  3192     if (Tcl_GetIntFromObj(interp, objv[3], &append)) {

  3193 	return TCL_ERROR;

  3194     }

  3195     if (Tcl_ParseVarName(interp, script, length, &parse, append) != TCL_OK) {

  3196 	Tcl_AddErrorInfo(interp, "\n    (remainder of script: \"");

  3197 	Tcl_AddErrorInfo(interp, parse.term);

  3198 	Tcl_AddErrorInfo(interp, "\")");

  3199 	return TCL_ERROR;

  3200     }

  3201 

  3202     /*

  3203      * The parse completed successfully.  Just print out the contents

  3204      * of the parse structure into the interpreter's result.

  3205      */

  3206 

  3207     parse.commentSize = 0;

  3208     parse.commandStart = script + parse.tokenPtr->size;

  3209     parse.commandSize = 0;

  3210     PrintParse(interp, &parse);

  3211     Tcl_FreeParse(&parse);

  3212     return TCL_OK;

  3213 }

  3214 

  3215 /*

  3216  *----------------------------------------------------------------------

  3217  *

  3218  * TestregexpObjCmd --

  3219  *

  3220  *	This procedure implements the "testregexp" command. It is

  3221  *	used to give a direct interface for regexp flags.  It's identical

  3222  *	to Tcl_RegexpObjCmd except for the -xflags option, and the

  3223  *	consequences thereof (including the REG_EXPECT kludge).

  3224  *

  3225  * Results:

  3226  *	A standard Tcl result.

  3227  *

  3228  * Side effects:

  3229  *	See the user documentation.

  3230  *

  3231  *----------------------------------------------------------------------

  3232  */

  3233 

  3234 	/* ARGSUSED */

  3235 static int

  3236 TestregexpObjCmd(dummy, interp, objc, objv)

  3237     ClientData dummy;			/* Not used. */

  3238     Tcl_Interp *interp;			/* Current interpreter. */

  3239     int objc;				/* Number of arguments. */

  3240     Tcl_Obj *CONST objv[];		/* Argument objects. */

  3241 {

  3242     int i, ii, indices, stringLength, match, about;

  3243     int hasxflags, cflags, eflags;

  3244     Tcl_RegExp regExpr;

  3245     char *string;

  3246     Tcl_Obj *objPtr;

  3247     Tcl_RegExpInfo info;

  3248     static CONST char *options[] = {

  3249 	"-indices",	"-nocase",	"-about",	"-expanded",

  3250 	"-line",	"-linestop",	"-lineanchor",

  3251 	"-xflags",

  3252 	"--",		(char *) NULL

  3253     };

  3254     enum options {

  3255 	REGEXP_INDICES, REGEXP_NOCASE,	REGEXP_ABOUT,	REGEXP_EXPANDED,

  3256 	REGEXP_MULTI,	REGEXP_NOCROSS,	REGEXP_NEWL,

  3257 	REGEXP_XFLAGS,

  3258 	REGEXP_LAST

  3259     };

  3260 

  3261     indices = 0;

  3262     about = 0;

  3263     cflags = REG_ADVANCED;

  3264     eflags = 0;

  3265     hasxflags = 0;

  3266     

  3267     for (i = 1; i < objc; i++) {

  3268 	char *name;

  3269 	int index;

  3270 

  3271 	name = Tcl_GetString(objv[i]);

  3272 	if (name[0] != '-') {

  3273 	    break;

  3274 	}

  3275 	if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT,

  3276 		&index) != TCL_OK) {

  3277 	    return TCL_ERROR;

  3278 	}

  3279 	switch ((enum options) index) {

  3280 	    case REGEXP_INDICES: {

  3281 		indices = 1;

  3282 		break;

  3283 	    }

  3284 	    case REGEXP_NOCASE: {

  3285 		cflags |= REG_ICASE;

  3286 		break;

  3287 	    }

  3288 	    case REGEXP_ABOUT: {

  3289 		about = 1;

  3290 		break;

  3291 	    }

  3292 	    case REGEXP_EXPANDED: {

  3293 		cflags |= REG_EXPANDED;

  3294 		break;

  3295 	    }

  3296 	    case REGEXP_MULTI: {

  3297 		cflags |= REG_NEWLINE;

  3298 		break;

  3299 	    }

  3300 	    case REGEXP_NOCROSS: {

  3301 		cflags |= REG_NLSTOP;

  3302 		break;

  3303 	    }

  3304 	    case REGEXP_NEWL: {

  3305 		cflags |= REG_NLANCH;

  3306 		break;

  3307 	    }

  3308 	    case REGEXP_XFLAGS: {

  3309 		hasxflags = 1;

  3310 		break;

  3311 	    }

  3312 	    case REGEXP_LAST: {

  3313 		i++;

  3314 		goto endOfForLoop;

  3315 	    }

  3316 	}

  3317     }

  3318 

  3319     endOfForLoop:

  3320     if (objc - i < hasxflags + 2 - about) {

  3321 	Tcl_WrongNumArgs(interp, 1, objv,

  3322 		"?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?");

  3323 	return TCL_ERROR;

  3324     }

  3325     objc -= i;

  3326     objv += i;

  3327 

  3328     if (hasxflags) {

  3329 	string = Tcl_GetStringFromObj(objv[0], &stringLength);

  3330 	TestregexpXflags(string, stringLength, &cflags, &eflags);

  3331 	objc--;

  3332 	objv++;

  3333     }

  3334 

  3335     regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);

  3336     if (regExpr == NULL) {

  3337 	return TCL_ERROR;

  3338     }

  3339     objPtr = objv[1];

  3340 

  3341     if (about) {

  3342 	if (TclRegAbout(interp, regExpr) < 0) {

  3343 	    return TCL_ERROR;

  3344 	}

  3345 	return TCL_OK;

  3346     }

  3347 

  3348     match = Tcl_RegExpExecObj(interp, regExpr, objPtr, 0 /* offset */,

  3349 	    objc-2 /* nmatches */, eflags);

  3350 

  3351     if (match < 0) {

  3352 	return TCL_ERROR;

  3353     }

  3354     if (match == 0) {

  3355 	/*

  3356 	 * Set the interpreter's object result to an integer object w/

  3357 	 * value 0. 

  3358 	 */

  3359 	

  3360 	Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);

  3361 	if (objc > 2 && (cflags&REG_EXPECT) && indices) {

  3362 	    char *varName;

  3363 	    CONST char *value;

  3364 	    int start, end;

  3365 	    char resinfo[TCL_INTEGER_SPACE * 2];

  3366 

  3367 	    varName = Tcl_GetString(objv[2]);

  3368 	    TclRegExpRangeUniChar(regExpr, -1, &start, &end);

  3369 	    sprintf(resinfo, "%d %d", start, end-1);

  3370 	    value = Tcl_SetVar(interp, varName, resinfo, 0);

  3371 	    if (value == NULL) {

  3372 		Tcl_AppendResult(interp, "couldn't set variable \"",

  3373 			varName, "\"", (char *) NULL);

  3374 		return TCL_ERROR;

  3375 	    }

  3376 	} else if (cflags & TCL_REG_CANMATCH) {

  3377 	    char *varName;

  3378 	    CONST char *value;

  3379 	    char resinfo[TCL_INTEGER_SPACE * 2];

  3380 

  3381 	    Tcl_RegExpGetInfo(regExpr, &info);

  3382 	    varName = Tcl_GetString(objv[2]);

  3383 	    sprintf(resinfo, "%ld", info.extendStart);

  3384 	    value = Tcl_SetVar(interp, varName, resinfo, 0);

  3385 	    if (value == NULL) {

  3386 		Tcl_AppendResult(interp, "couldn't set variable \"",

  3387 			varName, "\"", (char *) NULL);

  3388 		return TCL_ERROR;

  3389 	    }

  3390 	}

  3391 	return TCL_OK;

  3392     }

  3393 

  3394     /*

  3395      * If additional variable names have been specified, return

  3396      * index information in those variables.

  3397      */

  3398 

  3399     objc -= 2;

  3400     objv += 2;

  3401 

  3402     Tcl_RegExpGetInfo(regExpr, &info);

  3403     for (i = 0; i < objc; i++) {

  3404 	int start, end;

  3405 	Tcl_Obj *newPtr, *varPtr, *valuePtr;

  3406 	

  3407 	varPtr = objv[i];

  3408 	ii = ((cflags&REG_EXPECT) && i == objc-1) ? -1 : i;

  3409 	if (indices) {

  3410 	    Tcl_Obj *objs[2];

  3411 

  3412 	    if (ii == -1) {

  3413 		TclRegExpRangeUniChar(regExpr, ii, &start, &end);

  3414 	    } else if (ii > info.nsubs) {

  3415 		start = -1;

  3416 		end = -1;

  3417 	    } else {

  3418 		start = info.matches[ii].start;

  3419 		end = info.matches[ii].end;

  3420 	    }

  3421 

  3422 	    /*

  3423 	     * Adjust index so it refers to the last character in the

  3424 	     * match instead of the first character after the match.

  3425 	     */

  3426 	    

  3427 	    if (end >= 0) {

  3428 		end--;

  3429 	    }

  3430 

  3431 	    objs[0] = Tcl_NewLongObj(start);

  3432 	    objs[1] = Tcl_NewLongObj(end);

  3433 

  3434 	    newPtr = Tcl_NewListObj(2, objs);

  3435 	} else {

  3436 	    if (ii == -1) {

  3437 		TclRegExpRangeUniChar(regExpr, ii, &start, &end);

  3438 		newPtr = Tcl_GetRange(objPtr, start, end);

  3439 	    } else if (ii > info.nsubs) {

  3440 		newPtr = Tcl_NewObj();

  3441 	    } else {

  3442 		newPtr = Tcl_GetRange(objPtr, info.matches[ii].start,

  3443 			info.matches[ii].end - 1);

  3444 	    }

  3445 	}

  3446 	Tcl_IncrRefCount(newPtr);

  3447 	valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, 0);

  3448 	Tcl_DecrRefCount(newPtr);

  3449 	if (valuePtr == NULL) {

  3450 	    Tcl_AppendResult(interp, "couldn't set variable \"",

  3451 		    Tcl_GetString(varPtr), "\"", (char *) NULL);

  3452 	    return TCL_ERROR;

  3453 	}

  3454     }

  3455 

  3456     /*

  3457      * Set the interpreter's object result to an integer object w/ value 1. 

  3458      */

  3459 	

  3460     Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);

  3461     return TCL_OK;

  3462 }

  3463 

  3464 /*

  3465  *---------------------------------------------------------------------------

  3466  *

  3467  * TestregexpXflags --

  3468  *

  3469  *	Parse a string of extended regexp flag letters, for testing.

  3470  *

  3471  * Results:

  3472  *	No return value (you're on your own for errors here).

  3473  *

  3474  * Side effects:

  3475  *	Modifies *cflagsPtr, a regcomp flags word, and *eflagsPtr, a

  3476  *	regexec flags word, as appropriate.

  3477  *

  3478  *----------------------------------------------------------------------

  3479  */

  3480 

  3481 static void

  3482 TestregexpXflags(string, length, cflagsPtr, eflagsPtr)

  3483     char *string;		/* The string of flags. */

  3484     int length;			/* The length of the string in bytes. */

  3485     int *cflagsPtr;		/* compile flags word */

  3486     int *eflagsPtr;		/* exec flags word */

  3487 {

  3488     int i;

  3489     int cflags;

  3490     int eflags;

  3491 

  3492     cflags = *cflagsPtr;

  3493     eflags = *eflagsPtr;

  3494     for (i = 0; i < length; i++) {

  3495 	switch (string[i]) {

  3496 	    case 'a': {

  3497 		cflags |= REG_ADVF;

  3498 		break;

  3499 	    }

  3500 	    case 'b': {

  3501 		cflags &= ~REG_ADVANCED;

  3502 		break;

  3503 	    }

  3504 	    case 'c': {

  3505 		cflags |= TCL_REG_CANMATCH;

  3506 		break;

  3507 	    }

  3508 	    case 'e': {

  3509 		cflags &= ~REG_ADVANCED;

  3510 		cflags |= REG_EXTENDED;

  3511 		break;

  3512 	    }

  3513 	    case 'q': {

  3514 		cflags &= ~REG_ADVANCED;

  3515 		cflags |= REG_QUOTE;

  3516 		break;

  3517 	    }

  3518 	    case 'o': {			/* o for opaque */

  3519 		cflags |= REG_NOSUB;

  3520 		break;

  3521 	    }

  3522 	    case 's': {			/* s for start */

  3523 		cflags |= REG_BOSONLY;

  3524 		break;

  3525 	    }

  3526 	    case '+': {

  3527 		cflags |= REG_FAKE;

  3528 		break;

  3529 	    }

  3530 	    case ',': {

  3531 		cflags |= REG_PROGRESS;

  3532 		break;

  3533 	    }

  3534 	    case '.': {

  3535 		cflags |= REG_DUMP;

  3536 		break;

  3537 	    }

  3538 	    case ':': {

  3539 		eflags |= REG_MTRACE;

  3540 		break;

  3541 	    }

  3542 	    case ';': {

  3543 		eflags |= REG_FTRACE;

  3544 		break;

  3545 	    }

  3546 	    case '^': {

  3547 		eflags |= REG_NOTBOL;

  3548 		break;

  3549 	    }

  3550 	    case '$': {

  3551 		eflags |= REG_NOTEOL;

  3552 		break;

  3553 	    }

  3554 	    case 't': {

  3555 		cflags |= REG_EXPECT;

  3556 		break;

  3557 	    }

  3558 	    case '%': {

  3559 		eflags |= REG_SMALL;

  3560 		break;

  3561 	    }

  3562 	}

  3563     }

  3564 

  3565     *cflagsPtr = cflags;

  3566     *eflagsPtr = eflags;

  3567 }

  3568 

  3569 /*

  3570  *----------------------------------------------------------------------

  3571  *

  3572  * TestsetassocdataCmd --

  3573  *

  3574  *	This procedure implements the "testsetassocdata" command. It is used

  3575  *	to test Tcl_SetAssocData.

  3576  *

  3577  * Results:

  3578  *	A standard Tcl result.

  3579  *

  3580  * Side effects:

  3581  *	Modifies or creates an association between a key and associated

  3582  *	data for this interpreter.

  3583  *

  3584  *----------------------------------------------------------------------

  3585  */

  3586 

  3587 static int

  3588 TestsetassocdataCmd(clientData, interp, argc, argv)

  3589     ClientData clientData;		/* Not used. */

  3590     Tcl_Interp *interp;			/* Current interpreter. */

  3591     int argc;				/* Number of arguments. */

  3592     CONST char **argv;			/* Argument strings. */

  3593 {

  3594     char *buf;

  3595     char *oldData;

  3596     Tcl_InterpDeleteProc *procPtr;

  3597     

  3598     if (argc != 3) {

  3599         Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],

  3600                 " data_key data_item\"", (char *) NULL);

  3601         return TCL_ERROR;

  3602     }

  3603 

  3604     buf = ckalloc((unsigned) strlen(argv[2]) + 1);

  3605     strcpy(buf, argv[2]);

  3606 

  3607     /*

  3608      * If we previously associated a malloced value with the variable,

  3609      * free it before associating a new value.

  3610      */

  3611 

  3612     oldData = (char *) Tcl_GetAssocData(interp, argv[1], &procPtr);

  3613     if ((oldData != NULL) && (procPtr == CleanupTestSetassocdataTests)) {

  3614 	ckfree(oldData);

  3615     }

  3616     

  3617     Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests, 

  3618 	(ClientData) buf);

  3619     return TCL_OK;

  3620 }

  3621 

  3622 /*

  3623  *----------------------------------------------------------------------

  3624  *

  3625  * TestsetplatformCmd --

  3626  *

  3627  *	This procedure implements the "testsetplatform" command. It is

  3628  *	used to change the tclPlatform global variable so all file

  3629  *	name conversions can be tested on a single platform.

  3630  *

  3631  * Results:

  3632  *	A standard Tcl result.

  3633  *

  3634  * Side effects:

  3635  *	Sets the tclPlatform global variable.

  3636  *

  3637  *----------------------------------------------------------------------

  3638  */

  3639 

  3640 static int

  3641 TestsetplatformCmd(clientData, interp, argc, argv)

  3642     ClientData clientData;		/* Not used. */

  3643     Tcl_Interp *interp;			/* Current interpreter. */

  3644     int argc;				/* Number of arguments. */

  3645     CONST char **argv;			/* Argument strings. */

  3646 {

  3647     size_t length;

  3648     TclPlatformType *platform;

  3649 

  3650 #ifdef __WIN32__

  3651     platform = TclWinGetPlatform();

  3652 #else

  3653     platform = &tclPlatform;

  3654 #endif

  3655     

  3656     if (argc != 2) {

  3657         Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],

  3658                 " platform\"", (char *) NULL);

  3659         return TCL_ERROR;

  3660     }

  3661 

  3662     length = strlen(argv[1]);

  3663     if (strncmp(argv[1], "unix", length) == 0) {

  3664 	*platform = TCL_PLATFORM_UNIX;

  3665     } else if (strncmp(argv[1], "mac", length) == 0) {

  3666 	*platform = TCL_PLATFORM_MAC;

  3667     } else if (strncmp(argv[1], "windows", length) == 0) {

  3668 	*platform = TCL_PLATFORM_WINDOWS;

  3669     } else {

  3670         Tcl_AppendResult(interp, "unsupported platform: should be one of ",

  3671 		"unix, mac, or windows", (char *) NULL);

  3672 	return TCL_ERROR;

  3673     }

  3674     return TCL_OK;

  3675 }

  3676 

  3677 /*

  3678  *----------------------------------------------------------------------

  3679  *

  3680  * TeststaticpkgCmd --

  3681  *

  3682  *	This procedure implements the "teststaticpkg" command.

  3683  *	It is used to test the procedure Tcl_StaticPackage.

  3684  *

  3685  * Results:

  3686  *	A standard Tcl result.

  3687  *

  3688  * Side effects:

  3689  *	When the packge given by argv[1] is loaded into an interpeter,

  3690  *	variable "x" in that interpreter is set to "loaded".

  3691  *

  3692  *----------------------------------------------------------------------

  3693  */

  3694 

  3695 static int

  3696 TeststaticpkgCmd(dummy, interp, argc, argv)

  3697     ClientData dummy;			/* Not used. */

  3698     Tcl_Interp *interp;			/* Current interpreter. */

  3699     int argc;				/* Number of arguments. */

  3700     CONST char **argv;			/* Argument strings. */

  3701 {

  3702     int safe, loaded;

  3703 

  3704     if (argc != 4) {

  3705 	Tcl_AppendResult(interp, "wrong # arguments: should be \"",

  3706 		argv[0], " pkgName safe loaded\"", (char *) NULL);

  3707 	return TCL_ERROR;

  3708     }

  3709     if (Tcl_GetInt(interp, argv[2], &safe) != TCL_OK) {

  3710 	return TCL_ERROR;

  3711     }

  3712     if (Tcl_GetInt(interp, argv[3], &loaded) != TCL_OK) {

  3713 	return TCL_ERROR;

  3714     }

  3715     Tcl_StaticPackage((loaded) ? interp : NULL, argv[1], StaticInitProc,

  3716 	    (safe) ? StaticInitProc : NULL);

  3717     return TCL_OK;

  3718 }

  3719 

  3720 static int

  3721 StaticInitProc(interp)

  3722     Tcl_Interp *interp;			/* Interpreter in which package

  3723 					 * is supposedly being loaded. */

  3724 {

  3725     Tcl_SetVar(interp, "x", "loaded", TCL_GLOBAL_ONLY);

  3726     return TCL_OK;

  3727 }

  3728 

  3729 /*

  3730  *----------------------------------------------------------------------

  3731  *

  3732  * TesttranslatefilenameCmd --

  3733  *

  3734  *	This procedure implements the "testtranslatefilename" command.

  3735  *	It is used to test the Tcl_TranslateFileName command.

  3736  *

  3737  * Results:

  3738  *	A standard Tcl result.

  3739  *

  3740  * Side effects:

  3741  *	None.

  3742  *

  3743  *----------------------------------------------------------------------

  3744  */

  3745 

  3746 static int

  3747 TesttranslatefilenameCmd(dummy, interp, argc, argv)

  3748     ClientData dummy;			/* Not used. */

  3749     Tcl_Interp *interp;			/* Current interpreter. */

  3750     int argc;				/* Number of arguments. */

  3751     CONST char **argv;			/* Argument strings. */

  3752 {

  3753     Tcl_DString buffer;

  3754     CONST char *result;

  3755 

  3756     if (argc != 2) {

  3757 	Tcl_AppendResult(interp, "wrong # arguments: should be \"",

  3758 		argv[0], " path\"", (char *) NULL);

  3759 	return TCL_ERROR;

  3760     }

  3761     result = Tcl_TranslateFileName(interp, argv[1], &buffer);

  3762     if (result == NULL) {

  3763 	return TCL_ERROR;

  3764     }

  3765     Tcl_AppendResult(interp, result, NULL);

  3766     Tcl_DStringFree(&buffer);

  3767     return TCL_OK;

  3768 }

  3769 

  3770 /*

  3771  *----------------------------------------------------------------------

  3772  *

  3773  * TestupvarCmd --

  3774  *

  3775  *	This procedure implements the "testupvar2" command.  It is used

  3776  *	to test Tcl_UpVar and Tcl_UpVar2.

  3777  *

  3778  * Results:

  3779  *	A standard Tcl result.

  3780  *

  3781  * Side effects:

  3782  *	Creates or modifies an "upvar" reference.

  3783  *

  3784  *----------------------------------------------------------------------

  3785  */

  3786 

  3787 	/* ARGSUSED */

  3788 static int

  3789 TestupvarCmd(dummy, interp, argc, argv)

  3790     ClientData dummy;			/* Not used. */

  3791     Tcl_Interp *interp;			/* Current interpreter. */

  3792     int argc;				/* Number of arguments. */

  3793     CONST char **argv;			/* Argument strings. */

  3794 {

  3795     int flags = 0;

  3796     

  3797     if ((argc != 5) && (argc != 6)) {

  3798 	Tcl_AppendResult(interp, "wrong # arguments: should be \"",

  3799 		argv[0], " level name ?name2? dest global\"", (char *) NULL);

  3800 	return TCL_ERROR;

  3801     }

  3802 

  3803     if (argc == 5) {

  3804 	if (strcmp(argv[4], "global") == 0) {

  3805 	    flags = TCL_GLOBAL_ONLY;

  3806 	} else if (strcmp(argv[4], "namespace") == 0) {

  3807 	    flags = TCL_NAMESPACE_ONLY;

  3808 	}

  3809 	return Tcl_UpVar(interp, argv[1], argv[2], argv[3], flags);

  3810     } else {

  3811 	if (strcmp(argv[5], "global") == 0) {

  3812 	    flags = TCL_GLOBAL_ONLY;

  3813 	} else if (strcmp(argv[5], "namespace") == 0) {

  3814 	    flags = TCL_NAMESPACE_ONLY;

  3815 	}

  3816 	return Tcl_UpVar2(interp, argv[1], argv[2], 

  3817 		(argv[3][0] == 0) ? (char *) NULL : argv[3], argv[4],

  3818 		flags);

  3819     }

  3820 }

  3821 

  3822 /*

  3823  *----------------------------------------------------------------------

  3824  *

  3825  * TestseterrorcodeCmd --

  3826  *

  3827  *	This procedure implements the "testseterrorcodeCmd".

  3828  *	This tests up to five elements passed to the

  3829  *	Tcl_SetErrorCode command.

  3830  *

  3831  * Results:

  3832  *	A standard Tcl result. Always returns TCL_ERROR so that

  3833  *	the error code can be tested.

  3834  *

  3835  * Side effects:

  3836  *	None.

  3837  *

  3838  *----------------------------------------------------------------------

  3839  */

  3840 

  3841 	/* ARGSUSED */

  3842 static int

  3843 TestseterrorcodeCmd(dummy, interp, argc, argv)

  3844     ClientData dummy;			/* Not used. */

  3845     Tcl_Interp *interp;			/* Current interpreter. */

  3846     int argc;				/* Number of arguments. */

  3847     CONST char **argv;			/* Argument strings. */

  3848 {

  3849     if (argc > 6) {

  3850 	Tcl_SetResult(interp, "too many args", TCL_STATIC);

  3851 	return TCL_ERROR;

  3852     }

  3853     Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4],

  3854 	    argv[5], NULL);

  3855     return TCL_ERROR;

  3856 }

  3857 

  3858 /*

  3859  *----------------------------------------------------------------------

  3860  *

  3861  * TestsetobjerrorcodeCmd --

  3862  *

  3863  *	This procedure implements the "testsetobjerrorcodeCmd".

  3864  *	This tests the Tcl_SetObjErrorCode function.

  3865  *

  3866  * Results:

  3867  *	A standard Tcl result. Always returns TCL_ERROR so that

  3868  *	the error code can be tested.

  3869  *

  3870  * Side effects:

  3871  *	None.

  3872  *

  3873  *----------------------------------------------------------------------

  3874  */

  3875 

  3876 	/* ARGSUSED */

  3877 static int

  3878 TestsetobjerrorcodeCmd(dummy, interp, objc, objv)

  3879     ClientData dummy;		/* Not used. */

  3880     Tcl_Interp *interp;		/* Current interpreter. */

  3881     int objc;			/* Number of arguments. */

  3882     Tcl_Obj *CONST objv[];	/* The argument objects. */

  3883 {

  3884     Tcl_Obj *listObjPtr;

  3885 

  3886     if (objc > 1) {

  3887 	listObjPtr = Tcl_ConcatObj(objc - 1, objv + 1);

  3888     } else {

  3889 	listObjPtr = Tcl_NewObj();

  3890     }

  3891     Tcl_IncrRefCount(listObjPtr);

  3892     Tcl_SetObjErrorCode(interp, listObjPtr);

  3893     Tcl_DecrRefCount(listObjPtr);

  3894     return TCL_ERROR;

  3895 }

  3896 

  3897 /*

  3898  *----------------------------------------------------------------------

  3899  *

  3900  * TestfeventCmd --

  3901  *

  3902  *	This procedure implements the "testfevent" command.  It is

  3903  *	used for testing the "fileevent" command.

  3904  *

  3905  * Results:

  3906  *	A standard Tcl result.

  3907  *

  3908  * Side effects:

  3909  *	Creates and deletes interpreters.

  3910  *

  3911  *----------------------------------------------------------------------

  3912  */

  3913 

  3914 	/* ARGSUSED */

  3915 static int

  3916 TestfeventCmd(clientData, interp, argc, argv)

  3917     ClientData clientData;		/* Not used. */

  3918     Tcl_Interp *interp;			/* Current interpreter. */

  3919     int argc;				/* Number of arguments. */

  3920     CONST char **argv;			/* Argument strings. */

  3921 {

  3922     static Tcl_Interp *interp2 = NULL;

  3923     int code;

  3924     Tcl_Channel chan;

  3925 

  3926     if (argc < 2) {

  3927 	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

  3928 		" option ?arg arg ...?", (char *) NULL);

  3929 	return TCL_ERROR;

  3930     }

  3931     if (strcmp(argv[1], "cmd") == 0) {

  3932 	if (argc != 3) {

  3933 	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

  3934 		    " cmd script", (char *) NULL);

  3935 	    return TCL_ERROR;

  3936 	}

  3937         if (interp2 != (Tcl_Interp *) NULL) {

  3938             code = Tcl_GlobalEval(interp2, argv[2]);

  3939 	    Tcl_SetObjResult(interp, Tcl_GetObjResult(interp2));

  3940             return code;

  3941         } else {

  3942             Tcl_AppendResult(interp,

  3943                     "called \"testfevent code\" before \"testfevent create\"",

  3944                     (char *) NULL);

  3945             return TCL_ERROR;

  3946         }

  3947     } else if (strcmp(argv[1], "create") == 0) {

  3948 	if (interp2 != NULL) {

  3949             Tcl_DeleteInterp(interp2);

  3950 	}

  3951         interp2 = Tcl_CreateInterp();

  3952 	return Tcl_Init(interp2);

  3953     } else if (strcmp(argv[1], "delete") == 0) {

  3954 	if (interp2 != NULL) {

  3955             Tcl_DeleteInterp(interp2);

  3956 	}

  3957 	interp2 = NULL;

  3958     } else if (strcmp(argv[1], "share") == 0) {

  3959         if (interp2 != NULL) {

  3960             chan = Tcl_GetChannel(interp, argv[2], NULL);

  3961             if (chan == (Tcl_Channel) NULL) {

  3962                 return TCL_ERROR;

  3963             }

  3964             Tcl_RegisterChannel(interp2, chan);

  3965         }

  3966     }

  3967     

  3968     return TCL_OK;

  3969 }

  3970 

  3971 /*

  3972  *----------------------------------------------------------------------

  3973  *

  3974  * TestpanicCmd --

  3975  *

  3976  *	Calls the panic routine.

  3977  *

  3978  * Results:

  3979  *      Always returns TCL_OK. 

  3980  *

  3981  * Side effects:

  3982  *	May exit application.

  3983  *

  3984  *----------------------------------------------------------------------

  3985  */

  3986 

  3987 static int

  3988 TestpanicCmd(dummy, interp, argc, argv)

  3989     ClientData dummy;			/* Not used. */

  3990     Tcl_Interp *interp;			/* Current interpreter. */

  3991     int argc;				/* Number of arguments. */

  3992     CONST char **argv;			/* Argument strings. */

  3993 {

  3994     CONST char *argString;

  3995     

  3996     /*

  3997      *  Put the arguments into a var args structure

  3998      *  Append all of the arguments together separated by spaces

  3999      */

  4000 

  4001     argString = Tcl_Merge(argc-1, argv+1);

  4002     panic(argString);

  4003     ckfree((char *)argString);

  4004  

  4005     return TCL_OK;

  4006 }

  4007 

  4008 static int

  4009 TestfileCmd(dummy, interp, argc, argv)

  4010     ClientData dummy;			/* Not used. */

  4011     Tcl_Interp *interp;			/* Current interpreter. */

  4012     int argc;			/* Number of arguments. */

  4013     Tcl_Obj *CONST argv[];	/* The argument objects. */

  4014 {

  4015     int force, i, j, result;

  4016     Tcl_Obj *error = NULL;

  4017     char *subcmd;

  4018     

  4019     if (argc < 3) {

  4020 	return TCL_ERROR;

  4021     }

  4022 

  4023     force = 0;

  4024     i = 2;

  4025     if (strcmp(Tcl_GetString(argv[2]), "-force") == 0) {

  4026         force = 1;

  4027 	i = 3;

  4028     }

  4029 

  4030     if (argc - i > 2) {

  4031 	return TCL_ERROR;

  4032     }

  4033 

  4034     for (j = i; j < argc; j++) {

  4035         if (Tcl_FSGetNormalizedPath(interp, argv[j]) == NULL) {

  4036 	    return TCL_ERROR;

  4037 	}

  4038     }

  4039 

  4040     subcmd = Tcl_GetString(argv[1]);

  4041     

  4042     if (strcmp(subcmd, "mv") == 0) {

  4043 	result = TclpObjRenameFile(argv[i], argv[i + 1]);

  4044     } else if (strcmp(subcmd, "cp") == 0) {

  4045         result = TclpObjCopyFile(argv[i], argv[i + 1]);

  4046     } else if (strcmp(subcmd, "rm") == 0) {

  4047         result = TclpObjDeleteFile(argv[i]);

  4048     } else if (strcmp(subcmd, "mkdir") == 0) {

  4049         result = TclpObjCreateDirectory(argv[i]);

  4050     } else if (strcmp(subcmd, "cpdir") == 0) {

  4051         result = TclpObjCopyDirectory(argv[i], argv[i + 1], &error);

  4052     } else if (strcmp(subcmd, "rmdir") == 0) {

  4053         result = TclpObjRemoveDirectory(argv[i], force, &error);

  4054     } else {

  4055         result = TCL_ERROR;

  4056 	goto end;

  4057     }

  4058 	

  4059     if (result != TCL_OK) {

  4060 	if (error != NULL) {

  4061 	    if (Tcl_GetString(error)[0] != '\0') {

  4062 		Tcl_AppendResult(interp, Tcl_GetString(error), " ", NULL);

  4063 	    }

  4064 	    Tcl_DecrRefCount(error);

  4065 	}

  4066 	Tcl_AppendResult(interp, Tcl_ErrnoId(), (char *) NULL);

  4067     }

  4068 

  4069     end:

  4070 

  4071     return result;

  4072 }

  4073 

  4074 /*

  4075  *----------------------------------------------------------------------

  4076  *

  4077  * TestgetvarfullnameCmd --

  4078  *

  4079  *	Implements the "testgetvarfullname" cmd that is used when testing

  4080  *	the Tcl_GetVariableFullName procedure.

  4081  *

  4082  * Results:

  4083  *	A standard Tcl result.

  4084  *

  4085  * Side effects:

  4086  *	None.

  4087  *

  4088  *----------------------------------------------------------------------

  4089  */

  4090 

  4091 static int

  4092 TestgetvarfullnameCmd(dummy, interp, objc, objv)

  4093     ClientData dummy;		/* Not used. */

  4094     Tcl_Interp *interp;		/* Current interpreter. */

  4095     int objc;			/* Number of arguments. */

  4096     Tcl_Obj *CONST objv[];	/* The argument objects. */

  4097 {

  4098     char *name, *arg;

  4099     int flags = 0;

  4100     Tcl_Namespace *namespacePtr;

  4101     Tcl_CallFrame frame;

  4102     Tcl_Var variable;

  4103     int result;

  4104 

  4105     if (objc != 3) {

  4106 	Tcl_WrongNumArgs(interp, 1, objv, "name scope");

  4107         return TCL_ERROR;

  4108     }

  4109     

  4110     name = Tcl_GetString(objv[1]);

  4111 

  4112     arg = Tcl_GetString(objv[2]);

  4113     if (strcmp(arg, "global") == 0) {

  4114 	flags = TCL_GLOBAL_ONLY;

  4115     } else if (strcmp(arg, "namespace") == 0) {

  4116 	flags = TCL_NAMESPACE_ONLY;

  4117     }

  4118 

  4119     /*

  4120      * This command, like any other created with Tcl_Create[Obj]Command,

  4121      * runs in the global namespace. As a "namespace-aware" command that

  4122      * needs to run in a particular namespace, it must activate that

  4123      * namespace itself.

  4124      */

  4125 

  4126     if (flags == TCL_NAMESPACE_ONLY) {

  4127 	namespacePtr = Tcl_FindNamespace(interp, "::test_ns_var",

  4128 	        (Tcl_Namespace *) NULL, TCL_LEAVE_ERR_MSG);

  4129 	if (namespacePtr == NULL) {

  4130 	    return TCL_ERROR;

  4131 	}

  4132 	result = Tcl_PushCallFrame(interp, &frame, namespacePtr,

  4133                 /*isProcCallFrame*/ 0);

  4134 	if (result != TCL_OK) {

  4135 	    return result;

  4136 	}

  4137     }

  4138     

  4139     variable = Tcl_FindNamespaceVar(interp, name, (Tcl_Namespace *) NULL,

  4140 	    (flags | TCL_LEAVE_ERR_MSG));

  4141 

  4142     if (flags == TCL_NAMESPACE_ONLY) {

  4143 	Tcl_PopCallFrame(interp);

  4144     }

  4145     if (variable == (Tcl_Var) NULL) {

  4146 	return TCL_ERROR;

  4147     }

  4148     Tcl_GetVariableFullName(interp, variable, Tcl_GetObjResult(interp));

  4149     return TCL_OK;

  4150 }

  4151 

  4152 /*

  4153  *----------------------------------------------------------------------

  4154  *

  4155  * GetTimesCmd --

  4156  *

  4157  *	This procedure implements the "gettimes" command.  It is

  4158  *	used for computing the time needed for various basic operations

  4159  *	such as reading variables, allocating memory, sprintf, converting

  4160  *	variables, etc.

  4161  *

  4162  * Results:

  4163  *	A standard Tcl result.

  4164  *

  4165  * Side effects:

  4166  *	Allocates and frees memory, sets a variable "a" in the interpreter.

  4167  *

  4168  *----------------------------------------------------------------------

  4169  */

  4170 

  4171 static int

  4172 GetTimesCmd(unused, interp, argc, argv)

  4173     ClientData unused;		/* Unused. */

  4174     Tcl_Interp *interp;		/* The current interpreter. */

  4175     int argc;			/* The number of arguments. */

  4176     CONST char **argv;		/* The argument strings. */

  4177 {

  4178     Interp *iPtr = (Interp *) interp;

  4179     int i, n;

  4180     double timePer;

  4181     Tcl_Time start, stop;

  4182     Tcl_Obj *objPtr;

  4183     Tcl_Obj **objv;

  4184     CONST char *s;

  4185     char newString[TCL_INTEGER_SPACE];

  4186 

  4187     /* alloc & free 100000 times */

  4188     fprintf(stderr, "alloc & free 100000 6 word items\n");

  4189     Tcl_GetTime(&start);

  4190     for (i = 0;  i < 100000;  i++) {

  4191 	objPtr = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj));

  4192 	ckfree((char *) objPtr);

  4193     }

  4194     Tcl_GetTime(&stop);

  4195     timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);

  4196     fprintf(stderr, "   %.3f usec per alloc+free\n", timePer/100000);

  4197     

  4198     /* alloc 5000 times */

  4199     fprintf(stderr, "alloc 5000 6 word items\n");

  4200     objv = (Tcl_Obj **) ckalloc(5000 * sizeof(Tcl_Obj *));

  4201     Tcl_GetTime(&start);

  4202     for (i = 0;  i < 5000;  i++) {

  4203 	objv[i] = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj));

  4204     }

  4205     Tcl_GetTime(&stop);

  4206     timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);

  4207     fprintf(stderr, "   %.3f usec per alloc\n", timePer/5000);

  4208     

  4209     /* free 5000 times */

  4210     fprintf(stderr, "free 5000 6 word items\n");

  4211     Tcl_GetTime(&start);

  4212     for (i = 0;  i < 5000;  i++) {

  4213 	ckfree((char *) objv[i]);

  4214     }

  4215     Tcl_GetTime(&stop);

  4216     timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);

  4217     fprintf(stderr, "   %.3f usec per free\n", timePer/5000);

  4218 

  4219     /* Tcl_NewObj 5000 times */

  4220     fprintf(stderr, "Tcl_NewObj 5000 times\n");

  4221     Tcl_GetTime(&start);

  4222     for (i = 0;  i < 5000;  i++) {

  4223 	objv[i] = Tcl_NewObj();

  4224     }

  4225     Tcl_GetTime(&stop);

  4226     timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);

  4227     fprintf(stderr, "   %.3f usec per Tcl_NewObj\n", timePer/5000);

  4228     

  4229     /* Tcl_DecrRefCount 5000 times */

  4230     fprintf(stderr, "Tcl_DecrRefCount 5000 times\n");

  4231     Tcl_GetTime(&start);

  4232     for (i = 0;  i < 5000;  i++) {

  4233 	objPtr = objv[i];

  4234 	Tcl_DecrRefCount(objPtr);

  4235     }

  4236     Tcl_GetTime(&stop);

  4237     timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);

  4238     fprintf(stderr, "   %.3f usec per Tcl_DecrRefCount\n", timePer/5000);

  4239     ckfree((char *) objv);

  4240 

  4241     /* TclGetString 100000 times */

  4242     fprintf(stderr, "TclGetStringFromObj of \"12345\" 100000 times\n");

  4243     objPtr = Tcl_NewStringObj("12345", -1);

  4244     Tcl_GetTime(&start);

  4245     for (i = 0;  i < 100000;  i++) {

  4246 	(void) TclGetString(objPtr);

  4247     }

  4248     Tcl_GetTime(&stop);

  4249     timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);

  4250     fprintf(stderr, "   %.3f usec per TclGetStringFromObj of \"12345\"\n",

  4251 	    timePer/100000);

  4252 

  4253     /* Tcl_GetIntFromObj 100000 times */

  4254     fprintf(stderr, "Tcl_GetIntFromObj of \"12345\" 100000 times\n");

  4255     Tcl_GetTime(&start);

  4256     for (i = 0;  i < 100000;  i++) {

  4257 	if (Tcl_GetIntFromObj(interp, objPtr, &n) != TCL_OK) {

  4258 	    return TCL_ERROR;

  4259 	}

  4260     }

  4261     Tcl_GetTime(&stop);

  4262     timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);

  4263     fprintf(stderr, "   %.3f usec per Tcl_GetIntFromObj of \"12345\"\n",

  4264 	    timePer/100000);

  4265     Tcl_DecrRefCount(objPtr);

  4266     

  4267     /* Tcl_GetInt 100000 times */

  4268     fprintf(stderr, "Tcl_GetInt of \"12345\" 100000 times\n");

  4269     Tcl_GetTime(&start);

  4270     for (i = 0;  i < 100000;  i++) {

  4271 	if (Tcl_GetInt(interp, "12345", &n) != TCL_OK) {

  4272 	    return TCL_ERROR;

  4273 	}

  4274     }

  4275     Tcl_GetTime(&stop);

  4276     timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);

  4277     fprintf(stderr, "   %.3f usec per Tcl_GetInt of \"12345\"\n",

  4278 	    timePer/100000);

  4279 

  4280     /* sprintf 100000 times */

  4281     fprintf(stderr, "sprintf of 12345 100000 times\n");

  4282     Tcl_GetTime(&start);

  4283     for (i = 0;  i < 100000;  i++) {

  4284 	sprintf(newString, "%d", 12345);

  4285     }

  4286     Tcl_GetTime(&stop);

  4287     timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);

  4288     fprintf(stderr, "   %.3f usec per sprintf of 12345\n",

  4289 	    timePer/100000);

  4290 

  4291     /* hashtable lookup 100000 times */

  4292     fprintf(stderr, "hashtable lookup of \"gettimes\" 100000 times\n");

  4293     Tcl_GetTime(&start);

  4294     for (i = 0;  i < 100000;  i++) {

  4295 	(void) Tcl_FindHashEntry(&iPtr->globalNsPtr->cmdTable, "gettimes");

  4296     }

  4297     Tcl_GetTime(&stop);

  4298     timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);

  4299     fprintf(stderr, "   %.3f usec per hashtable lookup of \"gettimes\"\n",

  4300 	    timePer/100000);

  4301 

  4302     /* Tcl_SetVar 100000 times */

  4303     fprintf(stderr, "Tcl_SetVar of \"12345\" 100000 times\n");

  4304     Tcl_GetTime(&start);

  4305     for (i = 0;  i < 100000;  i++) {

  4306 	s = Tcl_SetVar(interp, "a", "12345", TCL_LEAVE_ERR_MSG);

  4307 	if (s == NULL) {

  4308 	    return TCL_ERROR;

  4309 	}

  4310     }

  4311     Tcl_GetTime(&stop);

  4312     timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);

  4313     fprintf(stderr, "   %.3f usec per Tcl_SetVar of a to \"12345\"\n",

  4314 	    timePer/100000);

  4315 

  4316     /* Tcl_GetVar 100000 times */

  4317     fprintf(stderr, "Tcl_GetVar of a==\"12345\" 100000 times\n");

  4318     Tcl_GetTime(&start);

  4319     for (i = 0;  i < 100000;  i++) {

  4320 	s = Tcl_GetVar(interp, "a", TCL_LEAVE_ERR_MSG);

  4321 	if (s == NULL) {

  4322 	    return TCL_ERROR;

  4323 	}

  4324     }

  4325     Tcl_GetTime(&stop);

  4326     timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);

  4327     fprintf(stderr, "   %.3f usec per Tcl_GetVar of a==\"12345\"\n",

  4328 	    timePer/100000);

  4329     

  4330     Tcl_ResetResult(interp);

  4331     return TCL_OK;

  4332 }

  4333 

  4334 /*

  4335  *----------------------------------------------------------------------

  4336  *

  4337  * NoopCmd --

  4338  *

  4339  *	This procedure is just used to time the overhead involved in

  4340  *	parsing and invoking a command.

  4341  *

  4342  * Results:

  4343  *	None.

  4344  *

  4345  * Side effects:

  4346  *	None.

  4347  *

  4348  *----------------------------------------------------------------------

  4349  */

  4350 

  4351 static int

  4352 NoopCmd(unused, interp, argc, argv)

  4353     ClientData unused;		/* Unused. */

  4354     Tcl_Interp *interp;		/* The current interpreter. */

  4355     int argc;			/* The number of arguments. */

  4356     CONST char **argv;		/* The argument strings. */

  4357 {

  4358     return TCL_OK;

  4359 }

  4360 

  4361 /*

  4362  *----------------------------------------------------------------------

  4363  *

  4364  * NoopObjCmd --

  4365  *

  4366  *	This object-based procedure is just used to time the overhead

  4367  *	involved in parsing and invoking a command.

  4368  *

  4369  * Results:

  4370  *	Returns the TCL_OK result code.

  4371  *

  4372  * Side effects:

  4373  *	None.

  4374  *

  4375  *----------------------------------------------------------------------

  4376  */

  4377 

  4378 static int

  4379 NoopObjCmd(unused, interp, objc, objv)

  4380     ClientData unused;		/* Not used. */

  4381     Tcl_Interp *interp;		/* Current interpreter. */

  4382     int objc;			/* Number of arguments. */

  4383     Tcl_Obj *CONST objv[];	/* The argument objects. */

  4384 {

  4385     return TCL_OK;

  4386 }

  4387 

  4388 /*

  4389  *----------------------------------------------------------------------

  4390  *

  4391  * TestsetCmd --

  4392  *

  4393  *	Implements the "testset{err,noerr}" cmds that are used when testing

  4394  *	Tcl_Set/GetVar C Api with/without TCL_LEAVE_ERR_MSG flag

  4395  *

  4396  * Results:

  4397  *	A standard Tcl result.

  4398  *

  4399  * Side effects:

  4400  *     Variables may be set.

  4401  *

  4402  *----------------------------------------------------------------------

  4403  */

  4404 

  4405 	/* ARGSUSED */

  4406 static int

  4407 TestsetCmd(data, interp, argc, argv)

  4408     ClientData data;			/* Additional flags for Get/SetVar2. */

  4409     register Tcl_Interp *interp;	/* Current interpreter. */

  4410     int argc;				/* Number of arguments. */

  4411     CONST char **argv;			/* Argument strings. */

  4412 {

  4413     int flags = (int) data;

  4414     CONST char *value;

  4415 

  4416     if (argc == 2) {

  4417         Tcl_SetResult(interp, "before get", TCL_STATIC);

  4418 	value = Tcl_GetVar2(interp, argv[1], (char *) NULL, flags);

  4419         if (value == NULL) {

  4420             return TCL_ERROR;

  4421         }

  4422 	Tcl_AppendElement(interp, value);

  4423         return TCL_OK;

  4424     } else if (argc == 3) {

  4425 	Tcl_SetResult(interp, "before set", TCL_STATIC);

  4426         value = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2], flags);

  4427         if (value == NULL) {

  4428             return TCL_ERROR;

  4429         }

  4430 	Tcl_AppendElement(interp, value);

  4431 	return TCL_OK;

  4432     } else {

  4433 	Tcl_AppendResult(interp, "wrong # args: should be \"",

  4434 		argv[0], " varName ?newValue?\"", (char *) NULL);

  4435 	return TCL_ERROR;

  4436     }

  4437 }

  4438 

  4439 /*

  4440  *----------------------------------------------------------------------

  4441  *

  4442  * TestsaveresultCmd --

  4443  *

  4444  *	Implements the "testsaveresult" cmd that is used when testing

  4445  *	the Tcl_SaveResult, Tcl_RestoreResult, and

  4446  *	Tcl_DiscardResult interfaces.

  4447  *

  4448  * Results:

  4449  *	A standard Tcl result.

  4450  *

  4451  * Side effects:

  4452  *	None.

  4453  *

  4454  *----------------------------------------------------------------------

  4455  */

  4456 

  4457 	/* ARGSUSED */

  4458 static int

  4459 TestsaveresultCmd(dummy, interp, objc, objv)

  4460     ClientData dummy;			/* Not used. */

  4461     register Tcl_Interp *interp;	/* Current interpreter. */

  4462     int objc;			/* Number of arguments. */

  4463     Tcl_Obj *CONST objv[];	/* The argument objects. */

  4464 {

  4465     int discard, result, index;

  4466     Tcl_SavedResult state;

  4467     Tcl_Obj *objPtr;

  4468     static CONST char *optionStrings[] = {

  4469 	"append", "dynamic", "free", "object", "small", NULL

  4470     };

  4471     enum options {

  4472 	RESULT_APPEND, RESULT_DYNAMIC, RESULT_FREE, RESULT_OBJECT, RESULT_SMALL

  4473     };

  4474 

  4475     /*

  4476      * Parse arguments

  4477      */

  4478 

  4479     if (objc != 4) {

  4480 	Tcl_WrongNumArgs(interp, 1, objv, "type script discard");

  4481         return TCL_ERROR;

  4482     }

  4483     if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,

  4484 	    &index) != TCL_OK) {

  4485 	return TCL_ERROR;

  4486     }

  4487     if (Tcl_GetBooleanFromObj(interp, objv[3], &discard) != TCL_OK) {

  4488 	return TCL_ERROR;

  4489     }

  4490 

  4491     objPtr = NULL;		/* Lint. */

  4492     switch ((enum options) index) {

  4493 	case RESULT_SMALL:

  4494 	    Tcl_SetResult(interp, "small result", TCL_VOLATILE);

  4495 	    break;

  4496 	case RESULT_APPEND:

  4497 	    Tcl_AppendResult(interp, "append result", NULL);

  4498 	    break;

  4499 	case RESULT_FREE: {

  4500 	    char *buf = ckalloc(200);

  4501 	    strcpy(buf, "free result");

  4502 	    Tcl_SetResult(interp, buf, TCL_DYNAMIC);

  4503 	    break;

  4504 	}

  4505 	case RESULT_DYNAMIC:

  4506 	    Tcl_SetResult(interp, "dynamic result", TestsaveresultFree);

  4507 	    break;

  4508 	case RESULT_OBJECT:

  4509 	    objPtr = Tcl_NewStringObj("object result", -1);

  4510 	    Tcl_SetObjResult(interp, objPtr);

  4511 	    break;

  4512     }

  4513 

  4514     freeCount = 0;

  4515     Tcl_SaveResult(interp, &state);

  4516 

  4517     if (((enum options) index) == RESULT_OBJECT) {

  4518 	result = Tcl_EvalObjEx(interp, objv[2], 0);

  4519     } else {

  4520 	result = Tcl_Eval(interp, Tcl_GetString(objv[2]));

  4521     }

  4522 

  4523     if (discard) {

  4524 	Tcl_DiscardResult(&state);

  4525     } else {

  4526 	Tcl_RestoreResult(interp, &state);

  4527 	result = TCL_OK;

  4528     }

  4529 

  4530     switch ((enum options) index) {

  4531 	case RESULT_DYNAMIC: {

  4532 	    int present = interp->freeProc == TestsaveresultFree;

  4533 	    int called = freeCount;

  4534 	    Tcl_AppendElement(interp, called ? "called" : "notCalled");

  4535 	    Tcl_AppendElement(interp, present ? "present" : "missing");

  4536 	    break;

  4537 	}

  4538 	case RESULT_OBJECT:

  4539 	    Tcl_AppendElement(interp, Tcl_GetObjResult(interp) == objPtr

  4540 		    ? "same" : "different");

  4541 	    break;

  4542 	default:

  4543 	    break;

  4544     }

  4545     return result;

  4546 }

  4547 

  4548 /*

  4549  *----------------------------------------------------------------------

  4550  *

  4551  * TestsaveresultFree --

  4552  *

  4553  *	Special purpose freeProc used by TestsaveresultCmd.

  4554  *

  4555  * Results:

  4556  *	None.

  4557  *

  4558  * Side effects:

  4559  *	Increments the freeCount.

  4560  *

  4561  *----------------------------------------------------------------------

  4562  */

  4563 

  4564 static void

  4565 TestsaveresultFree(blockPtr)

  4566     char *blockPtr;

  4567 {

  4568     freeCount++;

  4569 }

  4570 

  4571 /*

  4572  *----------------------------------------------------------------------

  4573  *

  4574  * TeststatprocCmd  --

  4575  *

  4576  *	Implements the "testTclStatProc" cmd that is used to test the

  4577  *	'TclStatInsertProc' & 'TclStatDeleteProc' C Apis.

  4578  *

  4579  * Results:

  4580  *	A standard Tcl result.

  4581  *

  4582  * Side effects:

  4583  *	None.

  4584  *

  4585  *----------------------------------------------------------------------

  4586  */

  4587 

  4588 static int

  4589 TeststatprocCmd (dummy, interp, argc, argv)

  4590     ClientData dummy;			/* Not used. */

  4591     register Tcl_Interp *interp;	/* Current interpreter. */

  4592     int argc;				/* Number of arguments. */

  4593     CONST char **argv;			/* Argument strings. */

  4594 {

  4595     TclStatProc_ *proc;

  4596     int retVal;

  4597 

  4598     if (argc != 3) {

  4599 	Tcl_AppendResult(interp, "wrong # args: should be \"",

  4600 		argv[0], " option arg\"", (char *) NULL);

  4601 	return TCL_ERROR;

  4602     }

  4603 

  4604     if (strcmp(argv[2], "TclpStat") == 0) {

  4605 	proc = PretendTclpStat;

  4606     } else if (strcmp(argv[2], "TestStatProc1") == 0) {

  4607 	proc = TestStatProc1;

  4608     } else if (strcmp(argv[2], "TestStatProc2") == 0) {

  4609 	proc = TestStatProc2;

  4610     } else if (strcmp(argv[2], "TestStatProc3") == 0) {

  4611 	proc = TestStatProc3;

  4612     } else {

  4613 	Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ",

  4614 		"must be TclpStat, ",

  4615 		"TestStatProc1, TestStatProc2, or TestStatProc3",

  4616 		(char *) NULL);

  4617 	return TCL_ERROR;

  4618     }

  4619 

  4620     if (strcmp(argv[1], "insert") == 0) {

  4621 	if (proc == PretendTclpStat) {

  4622 	    Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ",

  4623 		   "must be ",

  4624 		   "TestStatProc1, TestStatProc2, or TestStatProc3",

  4625 		   (char *) NULL);

  4626 	    return TCL_ERROR;

  4627 	}

  4628 	retVal = TclStatInsertProc(proc);

  4629     } else if (strcmp(argv[1], "delete") == 0) {

  4630 	retVal = TclStatDeleteProc(proc);

  4631     } else {

  4632 	Tcl_AppendResult(interp, "bad option \"", argv[1], "\": ",

  4633 		"must be insert or delete", (char *) NULL);

  4634 	return TCL_ERROR;

  4635     }

  4636 

  4637     if (retVal == TCL_ERROR) {

  4638 	Tcl_AppendResult(interp, "\"", argv[2], "\": ",

  4639 		"could not be ", argv[1], "ed", (char *) NULL);

  4640     }

  4641 

  4642     return retVal;

  4643 }

  4644 

  4645 static int PretendTclpStat(path, buf)

  4646     CONST char *path;

  4647     struct stat *buf;

  4648 {

  4649     int ret;

  4650     Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1);

  4651 #ifdef TCL_WIDE_INT_IS_LONG

  4652     Tcl_IncrRefCount(pathPtr);

  4653     ret = TclpObjStat(pathPtr, buf);

  4654     Tcl_DecrRefCount(pathPtr);

  4655     return ret;

  4656 #else /* TCL_WIDE_INT_IS_LONG */

  4657     Tcl_StatBuf realBuf;

  4658     Tcl_IncrRefCount(pathPtr);

  4659     ret = TclpObjStat(pathPtr, &realBuf);

  4660     Tcl_DecrRefCount(pathPtr);

  4661     if (ret != -1) {

  4662 #   define OUT_OF_RANGE(x) \

  4663 	(((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \

  4664 	 ((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX))

  4665 #if defined(__GNUC__) && __GNUC__ >= 2

  4666 /*

  4667  * Workaround gcc warning of "comparison is always false due to limited range of

  4668  * data type" in this macro by checking max type size, and when necessary ANDing

  4669  * with the complement of ULONG_MAX instead of the comparison:

  4670  */

  4671 #   define OUT_OF_URANGE(x) \

  4672 	((((Tcl_WideUInt)(~ (__typeof__(x)) 0)) > (Tcl_WideUInt)ULONG_MAX) && \

  4673 	 (((Tcl_WideUInt)(x)) & ~(Tcl_WideUInt)ULONG_MAX))

  4674 #else

  4675 #   define OUT_OF_URANGE(x) \

  4676 	(((Tcl_WideUInt)(x)) > (Tcl_WideUInt)ULONG_MAX)

  4677 #endif

  4678 

  4679 	/*

  4680 	 * Perform the result-buffer overflow check manually.

  4681 	 *

  4682 	 * Note that ino_t/ino64_t is unsigned...

  4683 	 */

  4684 

  4685         if (OUT_OF_URANGE(realBuf.st_ino) || OUT_OF_RANGE(realBuf.st_size)

  4686 #   ifdef HAVE_ST_BLOCKS

  4687 		|| OUT_OF_RANGE(realBuf.st_blocks)

  4688 #   endif

  4689 	    ) {

  4690 #   ifdef EOVERFLOW

  4691 	    errno = EOVERFLOW;

  4692 #   else

  4693 #       ifdef EFBIG

  4694             errno = EFBIG;

  4695 #       else

  4696 #           error "what error should be returned for a value out of range?"

  4697 #       endif

  4698 #   endif

  4699 	    return -1;

  4700 	}

  4701 

  4702 #   undef OUT_OF_RANGE

  4703 #   undef OUT_OF_URANGE

  4704 

  4705 	/*

  4706 	 * Copy across all supported fields, with possible type

  4707 	 * coercions on those fields that change between the normal

  4708 	 * and lf64 versions of the stat structure (on Solaris at

  4709 	 * least.)  This is slow when the structure sizes coincide,

  4710 	 * but that's what you get for mixing interfaces...

  4711 	 */

  4712 

  4713 	buf->st_mode    = realBuf.st_mode;

  4714 	buf->st_ino     = (ino_t) realBuf.st_ino;

  4715 	buf->st_dev     = realBuf.st_dev;

  4716 	buf->st_rdev    = realBuf.st_rdev;

  4717 	buf->st_nlink   = realBuf.st_nlink;

  4718 	buf->st_uid     = realBuf.st_uid;

  4719 	buf->st_gid     = realBuf.st_gid;

  4720 	buf->st_size    = (off_t) realBuf.st_size;

  4721 	buf->st_atime   = realBuf.st_atime;

  4722 	buf->st_mtime   = realBuf.st_mtime;

  4723 	buf->st_ctime   = realBuf.st_ctime;

  4724 #   ifdef HAVE_ST_BLOCKS

  4725 	buf->st_blksize = realBuf.st_blksize;

  4726 	buf->st_blocks  = (blkcnt_t) realBuf.st_blocks;

  4727 #   endif

  4728     }

  4729     return ret;

  4730 #endif /* TCL_WIDE_INT_IS_LONG */

  4731 }

  4732 

  4733 /* Be careful in the compares in these tests, since the Macintosh puts a  

  4734  * leading : in the beginning of non-absolute paths before passing them 

  4735  * into the file command procedures.

  4736  */

  4737 

  4738 static int

  4739 TestStatProc1(path, buf)

  4740     CONST char *path;

  4741     struct stat *buf;

  4742 {

  4743     memset(buf, 0, sizeof(struct stat));

  4744     buf->st_size = 1234;

  4745     return ((strstr(path, "testStat1%.fil") == NULL) ? -1 : 0);

  4746 }

  4747 

  4748 

  4749 static int

  4750 TestStatProc2(path, buf)

  4751     CONST char *path;

  4752     struct stat *buf;

  4753 {

  4754     memset(buf, 0, sizeof(struct stat));

  4755     buf->st_size = 2345;

  4756     return ((strstr(path, "testStat2%.fil") == NULL) ? -1 : 0);

  4757 }

  4758 

  4759 

  4760 static int

  4761 TestStatProc3(path, buf)

  4762     CONST char *path;

  4763     struct stat *buf;

  4764 {

  4765     memset(buf, 0, sizeof(struct stat));

  4766     buf->st_size = 3456;

  4767     return ((strstr(path, "testStat3%.fil") == NULL) ? -1 : 0);

  4768 }

  4769 

  4770 /*

  4771  *----------------------------------------------------------------------

  4772  *

  4773  * TestmainthreadCmd  --

  4774  *

  4775  *	Implements the "testmainthread" cmd that is used to test the

  4776  *	'Tcl_GetCurrentThread' API.

  4777  *

  4778  * Results:

  4779  *	A standard Tcl result.

  4780  *

  4781  * Side effects:

  4782  *	None.

  4783  *

  4784  *----------------------------------------------------------------------

  4785  */

  4786 

  4787 static int

  4788 TestmainthreadCmd (dummy, interp, argc, argv)

  4789     ClientData dummy;			/* Not used. */

  4790     register Tcl_Interp *interp;	/* Current interpreter. */

  4791     int argc;				/* Number of arguments. */

  4792     CONST char **argv;			/* Argument strings. */

  4793 {

  4794   if (argc == 1) {

  4795       Tcl_Obj *idObj = Tcl_NewLongObj((long)Tcl_GetCurrentThread());

  4796       Tcl_SetObjResult(interp, idObj);

  4797       return TCL_OK;

  4798   } else {

  4799       Tcl_SetResult(interp, "wrong # args", TCL_STATIC);

  4800       return TCL_ERROR;

  4801   }

  4802 }

  4803 

  4804 /*

  4805  *----------------------------------------------------------------------

  4806  *

  4807  * MainLoop --

  4808  *

  4809  *	A main loop set by TestsetmainloopCmd below.

  4810  *

  4811  * Results:

  4812  * 	None.

  4813  *

  4814  * Side effects:

  4815  *	Event handlers could do anything.

  4816  *

  4817  *----------------------------------------------------------------------

  4818  */

  4819 

  4820 static void

  4821 MainLoop(void)

  4822 {

  4823     while (!exitMainLoop) {

  4824 	Tcl_DoOneEvent(0);

  4825     }

  4826     fprintf(stdout,"Exit MainLoop\n");

  4827     fflush(stdout);

  4828 }

  4829 

  4830 /*

  4831  *----------------------------------------------------------------------

  4832  *

  4833  * TestsetmainloopCmd  --

  4834  *

  4835  *	Implements the "testsetmainloop" cmd that is used to test the

  4836  *	'Tcl_SetMainLoop' API.

  4837  *

  4838  * Results:

  4839  *	A standard Tcl result.

  4840  *

  4841  * Side effects:

  4842  *	None.

  4843  *

  4844  *----------------------------------------------------------------------

  4845  */

  4846 

  4847 static int

  4848 TestsetmainloopCmd (dummy, interp, argc, argv)

  4849     ClientData dummy;			/* Not used. */

  4850     register Tcl_Interp *interp;	/* Current interpreter. */

  4851     int argc;				/* Number of arguments. */

  4852     CONST char **argv;			/* Argument strings. */

  4853 {

  4854   exitMainLoop = 0;

  4855   Tcl_SetMainLoop(MainLoop);

  4856   return TCL_OK;

  4857 }

  4858 

  4859 /*

  4860  *----------------------------------------------------------------------

  4861  *

  4862  * TestexitmainloopCmd  --

  4863  *

  4864  *	Implements the "testexitmainloop" cmd that is used to test the

  4865  *	'Tcl_SetMainLoop' API.

  4866  *

  4867  * Results:

  4868  *	A standard Tcl result.

  4869  *

  4870  * Side effects:

  4871  *	None.

  4872  *

  4873  *----------------------------------------------------------------------

  4874  */

  4875 

  4876 static int

  4877 TestexitmainloopCmd (dummy, interp, argc, argv)

  4878     ClientData dummy;			/* Not used. */

  4879     register Tcl_Interp *interp;	/* Current interpreter. */

  4880     int argc;				/* Number of arguments. */

  4881     CONST char **argv;			/* Argument strings. */

  4882 {

  4883   exitMainLoop = 1;

  4884   return TCL_OK;

  4885 }

  4886 

  4887 /*

  4888  *----------------------------------------------------------------------

  4889  *

  4890  * TestaccessprocCmd  --

  4891  *

  4892  *	Implements the "testTclAccessProc" cmd that is used to test the

  4893  *	'TclAccessInsertProc' & 'TclAccessDeleteProc' C Apis.

  4894  *

  4895  * Results:

  4896  *	A standard Tcl result.

  4897  *

  4898  * Side effects:

  4899  *	None.

  4900  *

  4901  *----------------------------------------------------------------------

  4902  */

  4903 

  4904 static int

  4905 TestaccessprocCmd (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     TclAccessProc_ *proc;

  4912     int retVal;

  4913 

  4914     if (argc != 3) {

  4915 	Tcl_AppendResult(interp, "wrong # args: should be \"",

  4916 		argv[0], " option arg\"", (char *) NULL);

  4917 	return TCL_ERROR;

  4918     }

  4919 

  4920     if (strcmp(argv[2], "TclpAccess") == 0) {

  4921 	proc = PretendTclpAccess;

  4922     } else if (strcmp(argv[2], "TestAccessProc1") == 0) {

  4923 	proc = TestAccessProc1;

  4924     } else if (strcmp(argv[2], "TestAccessProc2") == 0) {

  4925 	proc = TestAccessProc2;

  4926     } else if (strcmp(argv[2], "TestAccessProc3") == 0) {

  4927 	proc = TestAccessProc3;

  4928     } else {

  4929 	Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ",

  4930 		"must be TclpAccess, ",

  4931 		"TestAccessProc1, TestAccessProc2, or TestAccessProc3",

  4932 		(char *) NULL);

  4933 	return TCL_ERROR;

  4934     }

  4935 

  4936     if (strcmp(argv[1], "insert") == 0) {

  4937 	if (proc == PretendTclpAccess) {

  4938 	    Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ",

  4939 		   "must be ",

  4940 		   "TestAccessProc1, TestAccessProc2, or TestAccessProc3",

  4941 		   (char *) NULL);

  4942 	    return TCL_ERROR;

  4943 	}

  4944 	retVal = TclAccessInsertProc(proc);

  4945     } else if (strcmp(argv[1], "delete") == 0) {

  4946 	retVal = TclAccessDeleteProc(proc);

  4947     } else {

  4948 	Tcl_AppendResult(interp, "bad option \"", argv[1], "\": ",

  4949 		"must be insert or delete", (char *) NULL);

  4950 	return TCL_ERROR;

  4951     }

  4952 

  4953     if (retVal == TCL_ERROR) {

  4954 	Tcl_AppendResult(interp, "\"", argv[2], "\": ",

  4955 		"could not be ", argv[1], "ed", (char *) NULL);

  4956     }

  4957 

  4958     return retVal;

  4959 }

  4960 

  4961 static int PretendTclpAccess(path, mode)

  4962     CONST char *path;

  4963     int mode;

  4964 {

  4965     int ret;

  4966     Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1);

  4967     Tcl_IncrRefCount(pathPtr);

  4968     ret = TclpObjAccess(pathPtr, mode);

  4969     Tcl_DecrRefCount(pathPtr);

  4970     return ret;

  4971 }

  4972 

  4973 static int

  4974 TestAccessProc1(path, mode)

  4975     CONST char *path;

  4976     int mode;

  4977 {

  4978     return ((strstr(path, "testAccess1%.fil") == NULL) ? -1 : 0);

  4979 }

  4980 

  4981 

  4982 static int

  4983 TestAccessProc2(path, mode)

  4984     CONST char *path;

  4985     int mode;

  4986 {

  4987     return ((strstr(path, "testAccess2%.fil") == NULL) ? -1 : 0);

  4988 }

  4989 

  4990 

  4991 static int

  4992 TestAccessProc3(path, mode)

  4993     CONST char *path;

  4994     int mode;

  4995 {

  4996     return ((strstr(path, "testAccess3%.fil") == NULL) ? -1 : 0);

  4997 }

  4998 

  4999 /*

  5000  *----------------------------------------------------------------------

  5001  *

  5002  * TestopenfilechannelprocCmd  --

  5003  *

  5004  *	Implements the "testTclOpenFileChannelProc" cmd that is used to test the

  5005  *	'TclOpenFileChannelInsertProc' & 'TclOpenFileChannelDeleteProc' C Apis.

  5006  *

  5007  * Results:

  5008  *	A standard Tcl result.

  5009  *

  5010  * Side effects:

  5011  *	None.

  5012  *

  5013  *----------------------------------------------------------------------

  5014  */

  5015 

  5016 static int

  5017 TestopenfilechannelprocCmd (dummy, interp, argc, argv)

  5018     ClientData dummy;			/* Not used. */

  5019     register Tcl_Interp *interp;	/* Current interpreter. */

  5020     int argc;				/* Number of arguments. */

  5021     CONST char **argv;			/* Argument strings. */

  5022 {

  5023     TclOpenFileChannelProc_ *proc;

  5024     int retVal;

  5025 

  5026     if (argc != 3) {

  5027 	Tcl_AppendResult(interp, "wrong # args: should be \"",

  5028 		argv[0], " option arg\"", (char *) NULL);

  5029 	return TCL_ERROR;

  5030     }

  5031 

  5032     if (strcmp(argv[2], "TclpOpenFileChannel") == 0) {

  5033 	proc = PretendTclpOpenFileChannel;

  5034     } else if (strcmp(argv[2], "TestOpenFileChannelProc1") == 0) {

  5035 	proc = TestOpenFileChannelProc1;

  5036     } else if (strcmp(argv[2], "TestOpenFileChannelProc2") == 0) {

  5037 	proc = TestOpenFileChannelProc2;

  5038     } else if (strcmp(argv[2], "TestOpenFileChannelProc3") == 0) {

  5039 	proc = TestOpenFileChannelProc3;

  5040     } else {

  5041 	Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ",

  5042 		"must be TclpOpenFileChannel, ",

  5043 		"TestOpenFileChannelProc1, TestOpenFileChannelProc2, or ",

  5044 		"TestOpenFileChannelProc3",

  5045 		(char *) NULL);

  5046 	return TCL_ERROR;

  5047     }

  5048 

  5049     if (strcmp(argv[1], "insert") == 0) {

  5050 	if (proc == PretendTclpOpenFileChannel) {

  5051 	    Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ",

  5052 		   "must be ",

  5053 		   "TestOpenFileChannelProc1, TestOpenFileChannelProc2, or ",

  5054 		   "TestOpenFileChannelProc3",

  5055 		   (char *) NULL);

  5056 	    return TCL_ERROR;

  5057 	}

  5058 	retVal = TclOpenFileChannelInsertProc(proc);

  5059     } else if (strcmp(argv[1], "delete") == 0) {

  5060 	retVal = TclOpenFileChannelDeleteProc(proc);

  5061     } else {

  5062 	Tcl_AppendResult(interp, "bad option \"", argv[1], "\": ",

  5063 		"must be insert or delete", (char *) NULL);

  5064 	return TCL_ERROR;

  5065     }

  5066 

  5067     if (retVal == TCL_ERROR) {

  5068 	Tcl_AppendResult(interp, "\"", argv[2], "\": ",

  5069 		"could not be ", argv[1], "ed", (char *) NULL);

  5070     }

  5071 

  5072     return retVal;

  5073 }

  5074 

  5075 static Tcl_Channel

  5076 PretendTclpOpenFileChannel(interp, fileName, modeString, permissions)

  5077     Tcl_Interp *interp;                 /* Interpreter for error reporting;

  5078 					 * can be NULL. */

  5079     CONST char *fileName;               /* Name of file to open. */

  5080     CONST char *modeString;             /* A list of POSIX open modes or

  5081 					 * a string such as "rw". */

  5082     int permissions;                    /* If the open involves creating a

  5083 					 * file, with what modes to create

  5084 					 * it? */

  5085 {

  5086     Tcl_Channel ret;

  5087     int mode, seekFlag;

  5088     Tcl_Obj *pathPtr;

  5089     mode = TclGetOpenMode(interp, modeString, &seekFlag);

  5090     if (mode == -1) {

  5091 	return NULL;

  5092     }

  5093     pathPtr = Tcl_NewStringObj(fileName, -1);

  5094     Tcl_IncrRefCount(pathPtr);

  5095     ret = TclpOpenFileChannel(interp, pathPtr, mode, permissions);

  5096     Tcl_DecrRefCount(pathPtr);

  5097     if (ret != NULL) {

  5098 	if (seekFlag) {

  5099 	    if (Tcl_Seek(ret, (Tcl_WideInt)0, SEEK_END) < (Tcl_WideInt)0) {

  5100 		if (interp != (Tcl_Interp *) NULL) {

  5101 		    Tcl_AppendResult(interp,

  5102 		      "could not seek to end of file while opening \"",

  5103 		      fileName, "\": ", 

  5104 		      Tcl_PosixError(interp), (char *) NULL);

  5105 		}

  5106 		Tcl_Close(NULL, ret);

  5107 		return NULL;

  5108 	    }

  5109 	}

  5110     }

  5111     return ret;

  5112 }

  5113 

  5114 static Tcl_Channel

  5115 TestOpenFileChannelProc1(interp, fileName, modeString, permissions)

  5116     Tcl_Interp *interp;                 /* Interpreter for error reporting;

  5117                                          * can be NULL. */

  5118     CONST char *fileName;               /* Name of file to open. */

  5119     CONST char *modeString;             /* A list of POSIX open modes or

  5120                                          * a string such as "rw". */

  5121     int permissions;                    /* If the open involves creating a

  5122                                          * file, with what modes to create

  5123                                          * it? */

  5124 {

  5125     CONST char *expectname="testOpenFileChannel1%.fil";

  5126     Tcl_DString ds;

  5127     

  5128     Tcl_DStringInit(&ds);

  5129     Tcl_JoinPath(1, &expectname, &ds);

  5130 

  5131     if (!strcmp(Tcl_DStringValue(&ds), fileName)) {

  5132 	Tcl_DStringFree(&ds);

  5133 	return (PretendTclpOpenFileChannel(interp, "__testOpenFileChannel1%__.fil",

  5134 		modeString, permissions));

  5135     } else {

  5136 	Tcl_DStringFree(&ds);

  5137 	return (NULL);

  5138     }

  5139 }

  5140 

  5141 

  5142 static Tcl_Channel

  5143 TestOpenFileChannelProc2(interp, fileName, modeString, permissions)

  5144     Tcl_Interp *interp;                 /* Interpreter for error reporting;

  5145                                          * can be NULL. */

  5146     CONST char *fileName;               /* Name of file to open. */

  5147     CONST char *modeString;             /* A list of POSIX open modes or

  5148                                          * a string such as "rw". */

  5149     int permissions;                    /* If the open involves creating a

  5150                                          * file, with what modes to create

  5151                                          * it? */

  5152 {

  5153     CONST char *expectname="testOpenFileChannel2%.fil";

  5154     Tcl_DString ds;

  5155     

  5156     Tcl_DStringInit(&ds);

  5157     Tcl_JoinPath(1, &expectname, &ds);

  5158 

  5159     if (!strcmp(Tcl_DStringValue(&ds), fileName)) {

  5160 	Tcl_DStringFree(&ds);

  5161 	return (PretendTclpOpenFileChannel(interp, "__testOpenFileChannel2%__.fil",

  5162 		modeString, permissions));

  5163     } else {

  5164 	Tcl_DStringFree(&ds);

  5165 	return (NULL);

  5166     }

  5167 }

  5168 

  5169 

  5170 static Tcl_Channel

  5171 TestOpenFileChannelProc3(interp, fileName, modeString, permissions)

  5172     Tcl_Interp *interp;                 /* Interpreter for error reporting;

  5173                                          * can be NULL. */

  5174     CONST char *fileName;               /* Name of file to open. */

  5175     CONST char *modeString;             /* A list of POSIX open modes or

  5176                                          * a string such as "rw". */

  5177     int permissions;                    /* If the open involves creating a

  5178                                          * file, with what modes to create

  5179                                          * it? */

  5180 {

  5181     CONST char *expectname="testOpenFileChannel3%.fil";

  5182     Tcl_DString ds;

  5183     

  5184     Tcl_DStringInit(&ds);

  5185     Tcl_JoinPath(1, &expectname, &ds);

  5186 

  5187     if (!strcmp(Tcl_DStringValue(&ds), fileName)) {

  5188 	Tcl_DStringFree(&ds);

  5189 	return (PretendTclpOpenFileChannel(interp, "__testOpenFileChannel3%__.fil",

  5190 		modeString, permissions));

  5191     } else {

  5192 	Tcl_DStringFree(&ds);

  5193 	return (NULL);

  5194     }

  5195 }

  5196 

  5197 /*

  5198  *----------------------------------------------------------------------

  5199  *

  5200  * TestChannelCmd --

  5201  *

  5202  *	Implements the Tcl "testchannel" debugging command and its

  5203  *	subcommands. This is part of the testing environment.

  5204  *

  5205  * Results:

  5206  *	A standard Tcl result.

  5207  *

  5208  * Side effects:

  5209  *	None.

  5210  *

  5211  *----------------------------------------------------------------------

  5212  */

  5213 

  5214 	/* ARGSUSED */

  5215 static int

  5216 TestChannelCmd(clientData, interp, argc, argv)

  5217     ClientData clientData;	/* Not used. */

  5218     Tcl_Interp *interp;		/* Interpreter for result. */

  5219     int argc;			/* Count of additional args. */

  5220     CONST char **argv;		/* Additional arg strings. */

  5221 {

  5222     CONST char *cmdName;	/* Sub command. */

  5223     Tcl_HashTable *hTblPtr;	/* Hash table of channels. */

  5224     Tcl_HashSearch hSearch;	/* Search variable. */

  5225     Tcl_HashEntry *hPtr;	/* Search variable. */

  5226     Channel *chanPtr;		/* The actual channel. */

  5227     ChannelState *statePtr;	/* state info for channel */

  5228     Tcl_Channel chan;		/* The opaque type. */

  5229     size_t len;			/* Length of subcommand string. */

  5230     int IOQueued;		/* How much IO is queued inside channel? */

  5231     ChannelBuffer *bufPtr;	/* For iterating over queued IO. */

  5232     char buf[TCL_INTEGER_SPACE];/* For sprintf. */

  5233     int mode;			/* rw mode of the channel */

  5234     

  5235     if (argc < 2) {

  5236         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

  5237                 " subcommand ?additional args..?\"", (char *) NULL);

  5238         return TCL_ERROR;

  5239     }

  5240     cmdName = argv[1];

  5241     len = strlen(cmdName);

  5242 

  5243     chanPtr = (Channel *) NULL;

  5244 

  5245     if (argc > 2) {

  5246         chan = Tcl_GetChannel(interp, argv[2], &mode);

  5247         if (chan == (Tcl_Channel) NULL) {

  5248             return TCL_ERROR;

  5249         }

  5250         chanPtr		= (Channel *) chan;

  5251 	statePtr	= chanPtr->state;

  5252         chanPtr		= statePtr->topChanPtr;

  5253 	chan		= (Tcl_Channel) chanPtr;

  5254     } else {

  5255 	/* lint */

  5256 	statePtr	= NULL;

  5257 	chan		= NULL;

  5258     }

  5259 

  5260     if ((cmdName[0] == 'c') && (strncmp(cmdName, "cut", len) == 0)) {

  5261         if (argc != 3) {

  5262             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

  5263                     " cut channelName\"", (char *) NULL);

  5264             return TCL_ERROR;

  5265         }

  5266         Tcl_CutChannel(chan);

  5267         return TCL_OK;

  5268     }

  5269 

  5270     if ((cmdName[0] == 'c') &&

  5271 	    (strncmp(cmdName, "clearchannelhandlers", len) == 0)) {

  5272         if (argc != 3) {

  5273             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

  5274                     " clearchannelhandlers channelName\"", (char *) NULL);

  5275             return TCL_ERROR;

  5276         }

  5277         Tcl_ClearChannelHandlers(chan);

  5278         return TCL_OK;

  5279     }

  5280 

  5281     if ((cmdName[0] == 'i') && (strncmp(cmdName, "info", len) == 0)) {

  5282         if (argc != 3) {

  5283             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

  5284                     " info channelName\"", (char *) NULL);

  5285             return TCL_ERROR;

  5286         }

  5287         Tcl_AppendElement(interp, argv[2]);

  5288         Tcl_AppendElement(interp, Tcl_ChannelName(chanPtr->typePtr));

  5289         if (statePtr->flags & TCL_READABLE) {

  5290             Tcl_AppendElement(interp, "read");

  5291         } else {

  5292             Tcl_AppendElement(interp, "");

  5293         }

  5294         if (statePtr->flags & TCL_WRITABLE) {

  5295             Tcl_AppendElement(interp, "write");

  5296         } else {

  5297             Tcl_AppendElement(interp, "");

  5298         }

  5299         if (statePtr->flags & CHANNEL_NONBLOCKING) {

  5300             Tcl_AppendElement(interp, "nonblocking");

  5301         } else {

  5302             Tcl_AppendElement(interp, "blocking");

  5303         }

  5304         if (statePtr->flags & CHANNEL_LINEBUFFERED) {

  5305             Tcl_AppendElement(interp, "line");

  5306         } else if (statePtr->flags & CHANNEL_UNBUFFERED) {

  5307             Tcl_AppendElement(interp, "none");

  5308         } else {

  5309             Tcl_AppendElement(interp, "full");

  5310         }

  5311         if (statePtr->flags & BG_FLUSH_SCHEDULED) {

  5312             Tcl_AppendElement(interp, "async_flush");

  5313         } else {

  5314             Tcl_AppendElement(interp, "");

  5315         }

  5316         if (statePtr->flags & CHANNEL_EOF) {

  5317             Tcl_AppendElement(interp, "eof");

  5318         } else {

  5319             Tcl_AppendElement(interp, "");

  5320         }

  5321         if (statePtr->flags & CHANNEL_BLOCKED) {

  5322             Tcl_AppendElement(interp, "blocked");

  5323         } else {

  5324             Tcl_AppendElement(interp, "unblocked");

  5325         }

  5326         if (statePtr->inputTranslation == TCL_TRANSLATE_AUTO) {

  5327             Tcl_AppendElement(interp, "auto");

  5328             if (statePtr->flags & INPUT_SAW_CR) {

  5329                 Tcl_AppendElement(interp, "saw_cr");

  5330             } else {

  5331                 Tcl_AppendElement(interp, "");

  5332             }

  5333         } else if (statePtr->inputTranslation == TCL_TRANSLATE_LF) {

  5334             Tcl_AppendElement(interp, "lf");

  5335             Tcl_AppendElement(interp, "");

  5336         } else if (statePtr->inputTranslation == TCL_TRANSLATE_CR) {

  5337             Tcl_AppendElement(interp, "cr");

  5338             Tcl_AppendElement(interp, "");

  5339         } else if (statePtr->inputTranslation == TCL_TRANSLATE_CRLF) {

  5340             Tcl_AppendElement(interp, "crlf");

  5341             if (statePtr->flags & INPUT_SAW_CR) {

  5342                 Tcl_AppendElement(interp, "queued_cr");

  5343             } else {

  5344                 Tcl_AppendElement(interp, "");

  5345             }

  5346         }

  5347         if (statePtr->outputTranslation == TCL_TRANSLATE_AUTO) {

  5348             Tcl_AppendElement(interp, "auto");

  5349         } else if (statePtr->outputTranslation == TCL_TRANSLATE_LF) {

  5350             Tcl_AppendElement(interp, "lf");

  5351         } else if (statePtr->outputTranslation == TCL_TRANSLATE_CR) {

  5352             Tcl_AppendElement(interp, "cr");

  5353         } else if (statePtr->outputTranslation == TCL_TRANSLATE_CRLF) {

  5354             Tcl_AppendElement(interp, "crlf");

  5355         }

  5356         for (IOQueued = 0, bufPtr = statePtr->inQueueHead;

  5357 	     bufPtr != (ChannelBuffer *) NULL;

  5358 	     bufPtr = bufPtr->nextPtr) {

  5359             IOQueued += bufPtr->nextAdded - bufPtr->nextRemoved;

  5360         }

  5361         TclFormatInt(buf, IOQueued);

  5362         Tcl_AppendElement(interp, buf);

  5363         

  5364         IOQueued = 0;

  5365         if (statePtr->curOutPtr != (ChannelBuffer *) NULL) {

  5366             IOQueued = statePtr->curOutPtr->nextAdded -

  5367                 statePtr->curOutPtr->nextRemoved;

  5368         }

  5369         for (bufPtr = statePtr->outQueueHead;

  5370 	     bufPtr != (ChannelBuffer *) NULL;

  5371 	     bufPtr = bufPtr->nextPtr) {

  5372             IOQueued += (bufPtr->nextAdded - bufPtr->nextRemoved);

  5373         }

  5374         TclFormatInt(buf, IOQueued);

  5375         Tcl_AppendElement(interp, buf);

  5376         

  5377         TclFormatInt(buf, (int)Tcl_Tell((Tcl_Channel) chanPtr));

  5378         Tcl_AppendElement(interp, buf);

  5379 

  5380         TclFormatInt(buf, statePtr->refCount);

  5381         Tcl_AppendElement(interp, buf);

  5382 

  5383         return TCL_OK;

  5384     }

  5385 

  5386     if ((cmdName[0] == 'i') &&

  5387             (strncmp(cmdName, "inputbuffered", len) == 0)) {

  5388         if (argc != 3) {

  5389             Tcl_AppendResult(interp, "channel name required",

  5390                     (char *) NULL);

  5391             return TCL_ERROR;

  5392         }

  5393         

  5394         for (IOQueued = 0, bufPtr = statePtr->inQueueHead;

  5395 	     bufPtr != (ChannelBuffer *) NULL;

  5396 	     bufPtr = bufPtr->nextPtr) {

  5397             IOQueued += bufPtr->nextAdded - bufPtr->nextRemoved;

  5398         }

  5399         TclFormatInt(buf, IOQueued);

  5400         Tcl_AppendResult(interp, buf, (char *) NULL);

  5401         return TCL_OK;

  5402     }

  5403 

  5404     if ((cmdName[0] == 'i') && (strncmp(cmdName, "isshared", len) == 0)) {

  5405         if (argc != 3) {

  5406             Tcl_AppendResult(interp, "channel name required", (char *) NULL);

  5407             return TCL_ERROR;

  5408         }

  5409         

  5410         TclFormatInt(buf, Tcl_IsChannelShared(chan));

  5411         Tcl_AppendResult(interp, buf, (char *) NULL);

  5412         return TCL_OK;

  5413     }

  5414 

  5415     if ((cmdName[0] == 'i') && (strncmp(cmdName, "isstandard", len) == 0)) {

  5416 	if (argc != 3) {

  5417 	    Tcl_AppendResult(interp, "channel name required", (char *) NULL);

  5418 	    return TCL_ERROR;

  5419 	}

  5420 	

  5421 	TclFormatInt(buf, Tcl_IsStandardChannel(chan));

  5422 	Tcl_AppendResult(interp, buf, (char *) NULL);

  5423 	return TCL_OK;

  5424     }

  5425 

  5426     if ((cmdName[0] == 'm') && (strncmp(cmdName, "mode", len) == 0)) {

  5427         if (argc != 3) {

  5428             Tcl_AppendResult(interp, "channel name required",

  5429                     (char *) NULL);

  5430             return TCL_ERROR;

  5431         }

  5432         

  5433         if (statePtr->flags & TCL_READABLE) {

  5434             Tcl_AppendElement(interp, "read");

  5435         } else {

  5436             Tcl_AppendElement(interp, "");

  5437         }

  5438         if (statePtr->flags & TCL_WRITABLE) {

  5439             Tcl_AppendElement(interp, "write");

  5440         } else {

  5441             Tcl_AppendElement(interp, "");

  5442         }

  5443         return TCL_OK;

  5444     }

  5445     

  5446     if ((cmdName[0] == 'm') && (strncmp(cmdName, "mthread", len) == 0)) {

  5447         if (argc != 3) {

  5448             Tcl_AppendResult(interp, "channel name required",

  5449                     (char *) NULL);

  5450             return TCL_ERROR;

  5451         }

  5452 

  5453         TclFormatInt(buf, (long) Tcl_GetChannelThread(chan));

  5454         Tcl_AppendResult(interp, buf, (char *) NULL);

  5455         return TCL_OK;

  5456     }

  5457 

  5458     if ((cmdName[0] == 'n') && (strncmp(cmdName, "name", len) == 0)) {

  5459         if (argc != 3) {

  5460             Tcl_AppendResult(interp, "channel name required",

  5461                     (char *) NULL);

  5462             return TCL_ERROR;

  5463         }

  5464         Tcl_AppendResult(interp, statePtr->channelName, (char *) NULL);

  5465         return TCL_OK;

  5466     }

  5467 

  5468     if ((cmdName[0] == 'o') && (strncmp(cmdName, "open", len) == 0)) {

  5469         hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);

  5470         if (hTblPtr == (Tcl_HashTable *) NULL) {

  5471             return TCL_OK;

  5472         }

  5473         for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);

  5474 	     hPtr != (Tcl_HashEntry *) NULL;

  5475 	     hPtr = Tcl_NextHashEntry(&hSearch)) {

  5476             Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr));

  5477         }

  5478         return TCL_OK;

  5479     }

  5480 

  5481     if ((cmdName[0] == 'o') &&

  5482             (strncmp(cmdName, "outputbuffered", len) == 0)) {

  5483         if (argc != 3) {

  5484             Tcl_AppendResult(interp, "channel name required",

  5485                     (char *) NULL);

  5486             return TCL_ERROR;

  5487         }

  5488 

  5489         IOQueued = 0;

  5490         if (statePtr->curOutPtr != (ChannelBuffer *) NULL) {

  5491             IOQueued = statePtr->curOutPtr->nextAdded -

  5492                 statePtr->curOutPtr->nextRemoved;

  5493         }

  5494         for (bufPtr = statePtr->outQueueHead;

  5495 	     bufPtr != (ChannelBuffer *) NULL;

  5496 	     bufPtr = bufPtr->nextPtr) {

  5497             IOQueued += (bufPtr->nextAdded - bufPtr->nextRemoved);

  5498         }

  5499         TclFormatInt(buf, IOQueued);

  5500         Tcl_AppendResult(interp, buf, (char *) NULL);

  5501         return TCL_OK;

  5502     }

  5503 

  5504     if ((cmdName[0] == 'q') &&

  5505             (strncmp(cmdName, "queuedcr", len) == 0)) {

  5506         if (argc != 3) {

  5507             Tcl_AppendResult(interp, "channel name required",

  5508                     (char *) NULL);

  5509             return TCL_ERROR;

  5510         }

  5511 

  5512         Tcl_AppendResult(interp,

  5513                 (statePtr->flags & INPUT_SAW_CR) ? "1" : "0",

  5514                 (char *) NULL);

  5515         return TCL_OK;

  5516     }

  5517 

  5518     if ((cmdName[0] == 'r') && (strncmp(cmdName, "readable", len) == 0)) {

  5519         hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);

  5520         if (hTblPtr == (Tcl_HashTable *) NULL) {

  5521             return TCL_OK;

  5522         }

  5523         for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);

  5524 	     hPtr != (Tcl_HashEntry *) NULL;

  5525 	     hPtr = Tcl_NextHashEntry(&hSearch)) {

  5526             chanPtr  = (Channel *) Tcl_GetHashValue(hPtr);

  5527 	    statePtr = chanPtr->state;

  5528             if (statePtr->flags & TCL_READABLE) {

  5529                 Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr));

  5530             }

  5531         }

  5532         return TCL_OK;

  5533     }

  5534 

  5535     if ((cmdName[0] == 'r') && (strncmp(cmdName, "refcount", len) == 0)) {

  5536         if (argc != 3) {

  5537             Tcl_AppendResult(interp, "channel name required",

  5538                     (char *) NULL);

  5539             return TCL_ERROR;

  5540         }

  5541         

  5542         TclFormatInt(buf, statePtr->refCount);

  5543         Tcl_AppendResult(interp, buf, (char *) NULL);

  5544         return TCL_OK;

  5545     }

  5546 

  5547     if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) {

  5548         if (argc != 3) {

  5549             Tcl_AppendResult(interp, "channel name required", (char *) NULL);

  5550             return TCL_ERROR;

  5551         }

  5552 

  5553         Tcl_SpliceChannel(chan);

  5554         return TCL_OK;

  5555     }

  5556 

  5557     if ((cmdName[0] == 't') && (strncmp(cmdName, "type", len) == 0)) {

  5558         if (argc != 3) {

  5559             Tcl_AppendResult(interp, "channel name required",

  5560                     (char *) NULL);

  5561             return TCL_ERROR;

  5562         }

  5563         Tcl_AppendResult(interp, Tcl_ChannelName(chanPtr->typePtr),

  5564 		(char *) NULL);

  5565         return TCL_OK;

  5566     }

  5567 

  5568     if ((cmdName[0] == 'w') && (strncmp(cmdName, "writable", len) == 0)) {

  5569         hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);

  5570         if (hTblPtr == (Tcl_HashTable *) NULL) {

  5571             return TCL_OK;

  5572         }

  5573         for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);

  5574 	     hPtr != (Tcl_HashEntry *) NULL;

  5575 	     hPtr = Tcl_NextHashEntry(&hSearch)) {

  5576             chanPtr = (Channel *) Tcl_GetHashValue(hPtr);

  5577 	    statePtr = chanPtr->state;

  5578             if (statePtr->flags & TCL_WRITABLE) {

  5579                 Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr));

  5580             }

  5581         }

  5582         return TCL_OK;

  5583     }

  5584 

  5585     if ((cmdName[0] == 't') && (strncmp(cmdName, "transform", len) == 0)) {

  5586 	/*

  5587 	 * Syntax: transform channel -command command

  5588 	 */

  5589 

  5590         if (argc != 5) {

  5591 	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

  5592 		    " transform channelId -command cmd\"", (char *) NULL);

  5593             return TCL_ERROR;

  5594         }

  5595 	if (strcmp(argv[3], "-command") != 0) {

  5596 	    Tcl_AppendResult(interp, "bad argument \"", argv[3],

  5597 		    "\": should be \"-command\"", (char *) NULL);

  5598 	    return TCL_ERROR;

  5599 	}

  5600 

  5601 	return TclChannelTransform(interp, chan,

  5602 		Tcl_NewStringObj(argv[4], -1));

  5603     }

  5604 

  5605     if ((cmdName[0] == 'u') && (strncmp(cmdName, "unstack", len) == 0)) {

  5606 	/*

  5607 	 * Syntax: unstack channel

  5608 	 */

  5609 

  5610         if (argc != 3) {

  5611 	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

  5612 		    " unstack channel\"", (char *) NULL);

  5613             return TCL_ERROR;

  5614         }

  5615 	return Tcl_UnstackChannel(interp, chan);

  5616     }

  5617 

  5618     Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be ",

  5619             "cut, clearchannelhandlers, info, isshared, mode, open, "

  5620 	    "readable, splice, writable, transform, unstack",

  5621             (char *) NULL);

  5622     return TCL_ERROR;

  5623 }

  5624 

  5625 /*

  5626  *----------------------------------------------------------------------

  5627  *

  5628  * TestChannelEventCmd --

  5629  *

  5630  *	This procedure implements the "testchannelevent" command. It is

  5631  *	used to test the Tcl channel event mechanism.

  5632  *

  5633  * Results:

  5634  *	A standard Tcl result.

  5635  *

  5636  * Side effects:

  5637  *	Creates, deletes and returns channel event handlers.

  5638  *

  5639  *----------------------------------------------------------------------

  5640  */

  5641 

  5642 	/* ARGSUSED */

  5643 static int

  5644 TestChannelEventCmd(dummy, interp, argc, argv)

  5645     ClientData dummy;			/* Not used. */

  5646     Tcl_Interp *interp;			/* Current interpreter. */

  5647     int argc;				/* Number of arguments. */

  5648     CONST char **argv;			/* Argument strings. */

  5649 {

  5650     Tcl_Obj *resultListPtr;

  5651     Channel *chanPtr;

  5652     ChannelState *statePtr;	/* state info for channel */

  5653     EventScriptRecord *esPtr, *prevEsPtr, *nextEsPtr;

  5654     CONST char *cmd;

  5655     int index, i, mask, len;

  5656 

  5657     if ((argc < 3) || (argc > 5)) {

  5658         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

  5659                 " channelName cmd ?arg1? ?arg2?\"", (char *) NULL);

  5660         return TCL_ERROR;

  5661     }

  5662     chanPtr = (Channel *) Tcl_GetChannel(interp, argv[1], NULL);

  5663     if (chanPtr == (Channel *) NULL) {

  5664         return TCL_ERROR;

  5665     }

  5666     statePtr = chanPtr->state;

  5667 

  5668     cmd = argv[2];

  5669     len = strlen(cmd);

  5670     if ((cmd[0] == 'a') && (strncmp(cmd, "add", (unsigned) len) == 0)) {

  5671         if (argc != 5) {

  5672             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

  5673                     " channelName add eventSpec script\"", (char *) NULL);

  5674             return TCL_ERROR;

  5675         }

  5676         if (strcmp(argv[3], "readable") == 0) {

  5677             mask = TCL_READABLE;

  5678         } else if (strcmp(argv[3], "writable") == 0) {

  5679             mask = TCL_WRITABLE;

  5680         } else if (strcmp(argv[3], "none") == 0) {

  5681             mask = 0;

  5682 	} else {

  5683             Tcl_AppendResult(interp, "bad event name \"", argv[3],

  5684                     "\": must be readable, writable, or none", (char *) NULL);

  5685             return TCL_ERROR;

  5686         }

  5687 

  5688         esPtr = (EventScriptRecord *) ckalloc((unsigned)

  5689                 sizeof(EventScriptRecord));

  5690         esPtr->nextPtr = statePtr->scriptRecordPtr;

  5691         statePtr->scriptRecordPtr = esPtr;

  5692         

  5693         esPtr->chanPtr = chanPtr;

  5694         esPtr->interp = interp;

  5695         esPtr->mask = mask;

  5696 	esPtr->scriptPtr = Tcl_NewStringObj(argv[4], -1);

  5697 	Tcl_IncrRefCount(esPtr->scriptPtr);

  5698 

  5699         Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,

  5700                 TclChannelEventScriptInvoker, (ClientData) esPtr);

  5701         

  5702         return TCL_OK;

  5703     }

  5704 

  5705     if ((cmd[0] == 'd') && (strncmp(cmd, "delete", (unsigned) len) == 0)) {

  5706         if (argc != 4) {

  5707             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

  5708                     " channelName delete index\"", (char *) NULL);

  5709             return TCL_ERROR;

  5710         }

  5711         if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) {

  5712             return TCL_ERROR;

  5713         }

  5714         if (index < 0) {

  5715             Tcl_AppendResult(interp, "bad event index: ", argv[3],

  5716                     ": must be nonnegative", (char *) NULL);

  5717             return TCL_ERROR;

  5718         }

  5719         for (i = 0, esPtr = statePtr->scriptRecordPtr;

  5720 	     (i < index) && (esPtr != (EventScriptRecord *) NULL);

  5721 	     i++, esPtr = esPtr->nextPtr) {

  5722 	    /* Empty loop body. */

  5723         }

  5724         if (esPtr == (EventScriptRecord *) NULL) {

  5725             Tcl_AppendResult(interp, "bad event index ", argv[3],

  5726                     ": out of range", (char *) NULL);

  5727             return TCL_ERROR;

  5728         }

  5729         if (esPtr == statePtr->scriptRecordPtr) {

  5730             statePtr->scriptRecordPtr = esPtr->nextPtr;

  5731         } else {

  5732             for (prevEsPtr = statePtr->scriptRecordPtr;

  5733 		 (prevEsPtr != (EventScriptRecord *) NULL) &&

  5734 		     (prevEsPtr->nextPtr != esPtr);

  5735 		 prevEsPtr = prevEsPtr->nextPtr) {

  5736                 /* Empty loop body. */

  5737             }

  5738             if (prevEsPtr == (EventScriptRecord *) NULL) {

  5739                 panic("TestChannelEventCmd: damaged event script list");

  5740             }

  5741             prevEsPtr->nextPtr = esPtr->nextPtr;

  5742         }

  5743         Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,

  5744                 TclChannelEventScriptInvoker, (ClientData) esPtr);

  5745 	Tcl_DecrRefCount(esPtr->scriptPtr);

  5746         ckfree((char *) esPtr);

  5747 

  5748         return TCL_OK;

  5749     }

  5750 

  5751     if ((cmd[0] == 'l') && (strncmp(cmd, "list", (unsigned) len) == 0)) {

  5752         if (argc != 3) {

  5753             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

  5754                     " channelName list\"", (char *) NULL);

  5755             return TCL_ERROR;

  5756         }

  5757 	resultListPtr = Tcl_GetObjResult(interp);

  5758         for (esPtr = statePtr->scriptRecordPtr;

  5759 	     esPtr != (EventScriptRecord *) NULL;

  5760 	     esPtr = esPtr->nextPtr) {

  5761 	    if (esPtr->mask) {

  5762  	        Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(

  5763 		    (esPtr->mask == TCL_READABLE) ? "readable" : "writable", -1));

  5764  	    } else {

  5765  	        Tcl_ListObjAppendElement(interp, resultListPtr, 

  5766 			Tcl_NewStringObj("none", -1));

  5767 	    }

  5768   	    Tcl_ListObjAppendElement(interp, resultListPtr, esPtr->scriptPtr);

  5769         }

  5770 	Tcl_SetObjResult(interp, resultListPtr);

  5771         return TCL_OK;

  5772     }

  5773 

  5774     if ((cmd[0] == 'r') && (strncmp(cmd, "removeall", (unsigned) len) == 0)) {

  5775         if (argc != 3) {

  5776             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

  5777                     " channelName removeall\"", (char *) NULL);

  5778             return TCL_ERROR;

  5779         }

  5780         for (esPtr = statePtr->scriptRecordPtr;

  5781 	     esPtr != (EventScriptRecord *) NULL;

  5782 	     esPtr = nextEsPtr) {

  5783             nextEsPtr = esPtr->nextPtr;

  5784             Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,

  5785                     TclChannelEventScriptInvoker, (ClientData) esPtr);

  5786 	    Tcl_DecrRefCount(esPtr->scriptPtr);

  5787             ckfree((char *) esPtr);

  5788         }

  5789         statePtr->scriptRecordPtr = (EventScriptRecord *) NULL;

  5790         return TCL_OK;

  5791     }

  5792 

  5793     if  ((cmd[0] == 's') && (strncmp(cmd, "set", (unsigned) len) == 0)) {

  5794         if (argc != 5) {

  5795             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

  5796                     " channelName delete index event\"", (char *) NULL);

  5797             return TCL_ERROR;

  5798         }

  5799         if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) {

  5800             return TCL_ERROR;

  5801         }

  5802         if (index < 0) {

  5803             Tcl_AppendResult(interp, "bad event index: ", argv[3],

  5804                     ": must be nonnegative", (char *) NULL);

  5805             return TCL_ERROR;

  5806         }

  5807         for (i = 0, esPtr = statePtr->scriptRecordPtr;

  5808 	     (i < index) && (esPtr != (EventScriptRecord *) NULL);

  5809 	     i++, esPtr = esPtr->nextPtr) {

  5810 	    /* Empty loop body. */

  5811         }

  5812         if (esPtr == (EventScriptRecord *) NULL) {

  5813             Tcl_AppendResult(interp, "bad event index ", argv[3],

  5814                     ": out of range", (char *) NULL);

  5815             return TCL_ERROR;

  5816         }

  5817 

  5818         if (strcmp(argv[4], "readable") == 0) {

  5819             mask = TCL_READABLE;

  5820         } else if (strcmp(argv[4], "writable") == 0) {

  5821             mask = TCL_WRITABLE;

  5822         } else if (strcmp(argv[4], "none") == 0) {

  5823             mask = 0;

  5824 	} else {

  5825             Tcl_AppendResult(interp, "bad event name \"", argv[4],

  5826                     "\": must be readable, writable, or none", (char *) NULL);

  5827             return TCL_ERROR;

  5828         }

  5829 	esPtr->mask = mask;

  5830         Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,

  5831                 TclChannelEventScriptInvoker, (ClientData) esPtr);

  5832 	return TCL_OK;

  5833     }    

  5834     Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of ",

  5835             "add, delete, list, set, or removeall", (char *) NULL);

  5836     return TCL_ERROR;

  5837 }

  5838 

  5839 /*

  5840  *----------------------------------------------------------------------

  5841  *

  5842  * TestWrongNumArgsObjCmd --

  5843  *

  5844  *	Test the Tcl_WrongNumArgs function.

  5845  *

  5846  * Results:

  5847  *	Standard Tcl result.

  5848  *

  5849  * Side effects:

  5850  *	Sets interpreter result.

  5851  *

  5852  *----------------------------------------------------------------------

  5853  */

  5854 

  5855 static int

  5856 TestWrongNumArgsObjCmd(dummy, interp, objc, objv)

  5857     ClientData dummy;			/* Not used. */

  5858     Tcl_Interp *interp;			/* Current interpreter. */

  5859     int objc;				/* Number of arguments. */

  5860     Tcl_Obj *CONST objv[];		/* Argument objects. */

  5861 {

  5862     int i, length;

  5863     char *msg;

  5864 

  5865     if (objc < 3) {

  5866 	/*

  5867 	 * Don't use Tcl_WrongNumArgs here, as that is the function

  5868 	 * we want to test!

  5869 	 */

  5870 	Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC);

  5871 	return TCL_ERROR;

  5872     }

  5873     

  5874     if (Tcl_GetIntFromObj(interp, objv[1], &i) != TCL_OK) {

  5875 	return TCL_ERROR;

  5876     }

  5877 

  5878     msg = Tcl_GetStringFromObj(objv[2], &length);

  5879     if (length == 0) {

  5880 	msg = NULL;

  5881     }

  5882     

  5883     if (i > objc - 3) {

  5884 	/*

  5885 	 * Asked for more arguments than were given.

  5886 	 */

  5887 	Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC);

  5888 	return TCL_ERROR;

  5889     }

  5890 

  5891     Tcl_WrongNumArgs(interp, i, &(objv[3]), msg);

  5892     return TCL_OK;

  5893 }

  5894 

  5895 /*

  5896  *----------------------------------------------------------------------

  5897  *

  5898  * TestGetIndexFromObjStructObjCmd --

  5899  *

  5900  *	Test the Tcl_GetIndexFromObjStruct function.

  5901  *

  5902  * Results:

  5903  *	Standard Tcl result.

  5904  *

  5905  * Side effects:

  5906  *	Sets interpreter result.

  5907  *

  5908  *----------------------------------------------------------------------

  5909  */

  5910 

  5911 static int

  5912 TestGetIndexFromObjStructObjCmd(dummy, interp, objc, objv)

  5913     ClientData dummy;			/* Not used. */

  5914     Tcl_Interp *interp;			/* Current interpreter. */

  5915     int objc;				/* Number of arguments. */

  5916     Tcl_Obj *CONST objv[];		/* Argument objects. */

  5917 {

  5918     char *ary[] = {

  5919 	"a", "b", "c", "d", "e", "f", (char *)NULL,(char *)NULL

  5920     };

  5921     int idx,target;

  5922 

  5923     if (objc != 3) {

  5924 	Tcl_WrongNumArgs(interp, 1, objv, "argument targetvalue");

  5925 	return TCL_ERROR;

  5926     }

  5927     if (Tcl_GetIndexFromObjStruct(interp, objv[1], ary, 2*sizeof(char *),

  5928 				  "dummy", 0, &idx) != TCL_OK) {

  5929 	return TCL_ERROR;

  5930     }

  5931     if (Tcl_GetIntFromObj(interp, objv[2], &target) != TCL_OK) {

  5932 	return TCL_ERROR;

  5933     }

  5934     if (idx != target) {

  5935 	char buffer[64];

  5936 	sprintf(buffer, "%d", idx);

  5937 	Tcl_AppendResult(interp, "index value comparison failed: got ",

  5938 			 buffer, NULL);

  5939 	sprintf(buffer, "%d", target);

  5940 	Tcl_AppendResult(interp, " when ", buffer, " expected", NULL);

  5941 	return TCL_ERROR;

  5942     }

  5943     Tcl_WrongNumArgs(interp, 3, objv, NULL);

  5944     return TCL_OK;

  5945 }

  5946 

  5947 /*

  5948  *----------------------------------------------------------------------

  5949  *

  5950  * TestFilesystemObjCmd --

  5951  *

  5952  *	This procedure implements the "testfilesystem" command.  It is

  5953  *	used to test Tcl_FSRegister, Tcl_FSUnregister, and can be used

  5954  *	to test that the pluggable filesystem works.

  5955  *

  5956  * Results:

  5957  *	A standard Tcl result.

  5958  *

  5959  * Side effects:

  5960  *	Inserts or removes a filesystem from Tcl's stack.

  5961  *

  5962  *----------------------------------------------------------------------

  5963  */

  5964 

  5965 static int

  5966 TestFilesystemObjCmd(dummy, interp, objc, objv)

  5967     ClientData dummy;

  5968     Tcl_Interp *interp;

  5969     int		objc;

  5970     Tcl_Obj	*CONST objv[];

  5971 {

  5972     int res, boolVal;

  5973     char *msg;

  5974     

  5975     if (objc != 2) {

  5976 	Tcl_WrongNumArgs(interp, 1, objv, "boolean");

  5977 	return TCL_ERROR;

  5978     }

  5979     if (Tcl_GetBooleanFromObj(interp, objv[1], &boolVal) != TCL_OK) {

  5980 	return TCL_ERROR;

  5981     }

  5982     if (boolVal) {

  5983 	res = Tcl_FSRegister((ClientData)interp, &testReportingFilesystem);

  5984 	msg = (res == TCL_OK) ? "registered" : "failed";

  5985     } else {

  5986 	res = Tcl_FSUnregister(&testReportingFilesystem);

  5987 	msg = (res == TCL_OK) ? "unregistered" : "failed";

  5988     }

  5989     Tcl_SetResult(interp, msg, TCL_VOLATILE);

  5990     return res;

  5991 }

  5992 

  5993 static int 

  5994 TestReportInFilesystem(Tcl_Obj *pathPtr, ClientData *clientDataPtr)

  5995 {

  5996     static Tcl_Obj* lastPathPtr = NULL;

  5997     

  5998     if (pathPtr == lastPathPtr) {

  5999 	/* Reject all files second time around */

  6000         return -1;

  6001     } else {

  6002 	Tcl_Obj * newPathPtr;

  6003 	/* Try to claim all files first time around */

  6004 

  6005 	newPathPtr = Tcl_DuplicateObj(pathPtr);

  6006 	lastPathPtr = newPathPtr;

  6007 	Tcl_IncrRefCount(newPathPtr);

  6008 	if (Tcl_FSGetFileSystemForPath(newPathPtr) == NULL) {

  6009 	    /* Nothing claimed it.  Therefore we don't either */

  6010 	    Tcl_DecrRefCount(newPathPtr);

  6011 	    lastPathPtr = NULL;

  6012 	    return -1;

  6013 	} else {

  6014 	    lastPathPtr = NULL;

  6015 	    *clientDataPtr = (ClientData) newPathPtr;

  6016 	    return TCL_OK;

  6017 	}

  6018     }

  6019 }

  6020 

  6021 /* 

  6022  * Simple helper function to extract the native vfs representation of a

  6023  * path object, or NULL if no such representation exists.

  6024  */

  6025 static Tcl_Obj* 

  6026 TestReportGetNativePath(Tcl_Obj* pathObjPtr) {

  6027     return (Tcl_Obj*) Tcl_FSGetInternalRep(pathObjPtr, &testReportingFilesystem);

  6028 }

  6029 

  6030 static void 

  6031 TestReportFreeInternalRep(ClientData clientData) {

  6032     Tcl_Obj *nativeRep = (Tcl_Obj*)clientData;

  6033     if (nativeRep != NULL) {

  6034 	/* Free the path */

  6035 	Tcl_DecrRefCount(nativeRep);

  6036     }

  6037 }

  6038 

  6039 static ClientData 

  6040 TestReportDupInternalRep(ClientData clientData) {

  6041     Tcl_Obj *original = (Tcl_Obj*)clientData;

  6042     Tcl_IncrRefCount(original);

  6043     return clientData;

  6044 }

  6045 

  6046 static void

  6047 TestReport(cmd, path, arg2)

  6048     CONST char* cmd;

  6049     Tcl_Obj* path;

  6050     Tcl_Obj* arg2;

  6051 {

  6052     Tcl_Interp* interp = (Tcl_Interp*) Tcl_FSData(&testReportingFilesystem);

  6053     if (interp == NULL) {

  6054 	/* This is bad, but not much we can do about it */

  6055     } else {

  6056 	/* 

  6057 	 * No idea why I decided to program this up using the

  6058 	 * old string-based API, but there you go.  We should

  6059 	 * convert it to objects.

  6060 	 */

  6061 	Tcl_SavedResult savedResult;

  6062 	Tcl_DString ds;

  6063 	Tcl_DStringInit(&ds);

  6064 	Tcl_DStringAppend(&ds, "lappend filesystemReport ",-1);

  6065 	Tcl_DStringStartSublist(&ds);

  6066 	Tcl_DStringAppendElement(&ds, cmd);

  6067 	if (path != NULL) {

  6068 	    Tcl_DStringAppendElement(&ds, Tcl_GetString(path));

  6069 	}

  6070 	if (arg2 != NULL) {

  6071 	    Tcl_DStringAppendElement(&ds, Tcl_GetString(arg2));

  6072 	}

  6073 	Tcl_DStringEndSublist(&ds);

  6074 	Tcl_SaveResult(interp, &savedResult);

  6075 	Tcl_Eval(interp, Tcl_DStringValue(&ds));

  6076 	Tcl_DStringFree(&ds);

  6077 	Tcl_RestoreResult(interp, &savedResult);

  6078    }

  6079 }

  6080 

  6081 static int

  6082 TestReportStat(path, buf)

  6083     Tcl_Obj *path;		/* Path of file to stat (in current CP). */

  6084     Tcl_StatBuf *buf;		/* Filled with results of stat call. */

  6085 {

  6086     TestReport("stat",path, NULL);

  6087     return Tcl_FSStat(TestReportGetNativePath(path),buf);

  6088 }

  6089 static int

  6090 TestReportLstat(path, buf)

  6091     Tcl_Obj *path;		/* Path of file to stat (in current CP). */

  6092     Tcl_StatBuf *buf;		/* Filled with results of stat call. */

  6093 {

  6094     TestReport("lstat",path, NULL);

  6095     return Tcl_FSLstat(TestReportGetNativePath(path),buf);

  6096 }

  6097 static int

  6098 TestReportAccess(path, mode)

  6099     Tcl_Obj *path;		/* Path of file to access (in current CP). */

  6100     int mode;                   /* Permission setting. */

  6101 {

  6102     TestReport("access",path,NULL);

  6103     return Tcl_FSAccess(TestReportGetNativePath(path),mode);

  6104 }

  6105 static Tcl_Channel

  6106 TestReportOpenFileChannel(interp, fileName, mode, permissions)

  6107     Tcl_Interp *interp;                 /* Interpreter for error reporting;

  6108 					 * can be NULL. */

  6109     Tcl_Obj *fileName;                  /* Name of file to open. */

  6110     int mode;                           /* POSIX open mode. */

  6111     int permissions;                    /* If the open involves creating a

  6112 					 * file, with what modes to create

  6113 					 * it? */

  6114 {

  6115     TestReport("open",fileName, NULL);

  6116     return TclpOpenFileChannel(interp, TestReportGetNativePath(fileName),

  6117 				 mode, permissions);

  6118 }

  6119 

  6120 static int

  6121 TestReportMatchInDirectory(interp, resultPtr, dirPtr, pattern, types)

  6122     Tcl_Interp *interp;		/* Interpreter to receive results. */

  6123     Tcl_Obj *resultPtr;		/* Object to lappend results. */

  6124     Tcl_Obj *dirPtr;	        /* Contains path to directory to search. */

  6125     CONST char *pattern;	/* Pattern to match against. */

  6126     Tcl_GlobTypeData *types;	/* Object containing list of acceptable types.

  6127 				 * May be NULL. */

  6128 {

  6129     if (types != NULL && types->type & TCL_GLOB_TYPE_MOUNT) {

  6130 	TestReport("matchmounts",dirPtr, NULL);

  6131 	return TCL_OK;

  6132     } else {

  6133 	TestReport("matchindirectory",dirPtr, NULL);

  6134 	return Tcl_FSMatchInDirectory(interp, resultPtr, 

  6135 				      TestReportGetNativePath(dirPtr), pattern, 

  6136 				      types);

  6137     }

  6138 }

  6139 static int

  6140 TestReportChdir(dirName)

  6141     Tcl_Obj *dirName;

  6142 {

  6143     TestReport("chdir",dirName,NULL);

  6144     return Tcl_FSChdir(TestReportGetNativePath(dirName));

  6145 }

  6146 static int

  6147 TestReportLoadFile(interp, fileName,  

  6148 		   handlePtr, unloadProcPtr)

  6149     Tcl_Interp *interp;		/* Used for error reporting. */

  6150     Tcl_Obj *fileName;		/* Name of the file containing the desired

  6151 				 * code. */

  6152     Tcl_LoadHandle *handlePtr;	/* Filled with token for dynamically loaded

  6153 				 * file which will be passed back to 

  6154 				 * (*unloadProcPtr)() to unload the file. */

  6155     Tcl_FSUnloadFileProc **unloadProcPtr;	

  6156 				/* Filled with address of Tcl_FSUnloadFileProc

  6157 				 * function which should be used for

  6158 				 * this file. */

  6159 {

  6160     TestReport("loadfile",fileName,NULL);

  6161     return Tcl_FSLoadFile(interp, TestReportGetNativePath(fileName), NULL, NULL,

  6162 			  NULL, NULL, handlePtr, unloadProcPtr);

  6163 }

  6164 static Tcl_Obj *

  6165 TestReportLink(path, to, linkType)

  6166     Tcl_Obj *path;		/* Path of file to readlink or link */

  6167     Tcl_Obj *to;		/* Path of file to link to, or NULL */

  6168     int linkType;

  6169 {

  6170     TestReport("link",path,to);

  6171     return Tcl_FSLink(TestReportGetNativePath(path), to, linkType);

  6172 }

  6173 static int

  6174 TestReportRenameFile(src, dst)

  6175     Tcl_Obj *src;		/* Pathname of file or dir to be renamed

  6176 				 * (UTF-8). */

  6177     Tcl_Obj *dst;		/* New pathname of file or directory

  6178 				 * (UTF-8). */

  6179 {

  6180     TestReport("renamefile",src,dst);

  6181     return Tcl_FSRenameFile(TestReportGetNativePath(src), 

  6182 			    TestReportGetNativePath(dst));

  6183 }

  6184 static int 

  6185 TestReportCopyFile(src, dst)

  6186     Tcl_Obj *src;		/* Pathname of file to be copied (UTF-8). */

  6187     Tcl_Obj *dst;		/* Pathname of file to copy to (UTF-8). */

  6188 {

  6189     TestReport("copyfile",src,dst);

  6190     return Tcl_FSCopyFile(TestReportGetNativePath(src), 

  6191 			    TestReportGetNativePath(dst));

  6192 }

  6193 static int

  6194 TestReportDeleteFile(path)

  6195     Tcl_Obj *path;		/* Pathname of file to be removed (UTF-8). */

  6196 {

  6197     TestReport("deletefile",path,NULL);

  6198     return Tcl_FSDeleteFile(TestReportGetNativePath(path));

  6199 }

  6200 static int

  6201 TestReportCreateDirectory(path)

  6202     Tcl_Obj *path;		/* Pathname of directory to create (UTF-8). */

  6203 {

  6204     TestReport("createdirectory",path,NULL);

  6205     return Tcl_FSCreateDirectory(TestReportGetNativePath(path));

  6206 }

  6207 static int

  6208 TestReportCopyDirectory(src, dst, errorPtr)

  6209     Tcl_Obj *src;		/* Pathname of directory to be copied

  6210 				 * (UTF-8). */

  6211     Tcl_Obj *dst;		/* Pathname of target directory (UTF-8). */

  6212     Tcl_Obj **errorPtr;	        /* If non-NULL, to be filled with UTF-8 name 

  6213                        	         * of file causing error. */

  6214 {

  6215     TestReport("copydirectory",src,dst);

  6216     return Tcl_FSCopyDirectory(TestReportGetNativePath(src), 

  6217 			    TestReportGetNativePath(dst), errorPtr);

  6218 }

  6219 static int

  6220 TestReportRemoveDirectory(path, recursive, errorPtr)

  6221     Tcl_Obj *path;		/* Pathname of directory to be removed

  6222 				 * (UTF-8). */

  6223     int recursive;		/* If non-zero, removes directories that

  6224 				 * are nonempty.  Otherwise, will only remove

  6225 				 * empty directories. */

  6226     Tcl_Obj **errorPtr;	        /* If non-NULL, to be filled with UTF-8 name 

  6227                        	         * of file causing error. */

  6228 {

  6229     TestReport("removedirectory",path,NULL);

  6230     return Tcl_FSRemoveDirectory(TestReportGetNativePath(path), recursive, 

  6231 				 errorPtr);

  6232 }

  6233 static CONST char**

  6234 TestReportFileAttrStrings(fileName, objPtrRef)

  6235     Tcl_Obj* fileName;

  6236     Tcl_Obj** objPtrRef;

  6237 {

  6238     TestReport("fileattributestrings",fileName,NULL);

  6239     return Tcl_FSFileAttrStrings(TestReportGetNativePath(fileName), objPtrRef);

  6240 }

  6241 static int

  6242 TestReportFileAttrsGet(interp, index, fileName, objPtrRef)

  6243     Tcl_Interp *interp;		/* The interpreter for error reporting. */

  6244     int index;			/* index of the attribute command. */

  6245     Tcl_Obj *fileName;		/* filename we are operating on. */

  6246     Tcl_Obj **objPtrRef;	/* for output. */

  6247 {

  6248     TestReport("fileattributesget",fileName,NULL);

  6249     return Tcl_FSFileAttrsGet(interp, index, 

  6250 			      TestReportGetNativePath(fileName), objPtrRef);

  6251 }

  6252 static int

  6253 TestReportFileAttrsSet(interp, index, fileName, objPtr)

  6254     Tcl_Interp *interp;		/* The interpreter for error reporting. */

  6255     int index;			/* index of the attribute command. */

  6256     Tcl_Obj *fileName;		/* filename we are operating on. */

  6257     Tcl_Obj *objPtr;		/* for input. */

  6258 {

  6259     TestReport("fileattributesset",fileName,objPtr);

  6260     return Tcl_FSFileAttrsSet(interp, index, 

  6261 			      TestReportGetNativePath(fileName), objPtr);

  6262 }

  6263 static int 

  6264 TestReportUtime (fileName, tval)

  6265     Tcl_Obj* fileName;

  6266     struct utimbuf *tval;

  6267 {

  6268     TestReport("utime",fileName,NULL);

  6269     return Tcl_FSUtime(TestReportGetNativePath(fileName), tval);

  6270 }

  6271 static int

  6272 TestReportNormalizePath(interp, pathPtr, nextCheckpoint)

  6273     Tcl_Interp *interp;

  6274     Tcl_Obj *pathPtr;

  6275     int nextCheckpoint;

  6276 {

  6277     TestReport("normalizepath",pathPtr,NULL);

  6278     return nextCheckpoint;

  6279 }

  6280 

  6281 static int 

  6282 SimplePathInFilesystem(Tcl_Obj *pathPtr, ClientData *clientDataPtr) {

  6283     CONST char *str = Tcl_GetString(pathPtr);

  6284     if (strncmp(str,"simplefs:/",10)) {

  6285 	return -1;

  6286     }

  6287     return TCL_OK;

  6288 }

  6289 

  6290 /* 

  6291  * Since TclCopyChannel insists on an interpreter, we use this

  6292  * to simplify our test scripts.  Would be better if it could

  6293  * copy without an interp

  6294  */

  6295 static Tcl_Interp *simpleInterpPtr = NULL;

  6296 /* We use this to ensure we clean up after ourselves */

  6297 static Tcl_Obj *tempFile = NULL;

  6298 

  6299 /* 

  6300  * This is a very 'hacky' filesystem which is used just to 

  6301  * test two important features of the vfs code: (1) that

  6302  * you can load a shared library from a vfs, (2) that when

  6303  * copying files from one fs to another, the 'mtime' is

  6304  * preserved.

  6305  * 

  6306  * It treats any file in 'simplefs:/' as a file, and

  6307  * artificially creates a real file on the fly which it uses

  6308  * to extract information from.  The real file it uses is

  6309  * whatever follows the trailing '/' (e.g. 'foo' in 'simplefs:/foo'),

  6310  * and that file is assumed to exist in the native pwd, and is

  6311  * copied over to the native temporary directory where it is

  6312  * accessed.

  6313  * 

  6314  * Please do not consider this filesystem a model of how

  6315  * things are to be done.  It is quite the opposite!  But, it

  6316  * does allow us to test two important features.

  6317  * 

  6318  * Finally: this fs can only be used from one interpreter.

  6319  */

  6320 static int

  6321 TestSimpleFilesystemObjCmd(dummy, interp, objc, objv)

  6322     ClientData dummy;

  6323     Tcl_Interp *interp;

  6324     int		objc;

  6325     Tcl_Obj	*CONST objv[];

  6326 {

  6327     int res, boolVal;

  6328     char *msg;

  6329     

  6330     if (objc != 2) {

  6331 	Tcl_WrongNumArgs(interp, 1, objv, "boolean");

  6332 	return TCL_ERROR;

  6333     }

  6334     if (Tcl_GetBooleanFromObj(interp, objv[1], &boolVal) != TCL_OK) {

  6335 	return TCL_ERROR;

  6336     }

  6337     if (boolVal) {

  6338 	res = Tcl_FSRegister((ClientData)interp, &simpleFilesystem);

  6339 	msg = (res == TCL_OK) ? "registered" : "failed";

  6340 	simpleInterpPtr = interp;

  6341     } else {

  6342 	if (tempFile != NULL) {

  6343 	    Tcl_FSDeleteFile(tempFile);

  6344 	    Tcl_DecrRefCount(tempFile);

  6345 	    tempFile = NULL;

  6346 	}

  6347 	res = Tcl_FSUnregister(&simpleFilesystem);

  6348 	msg = (res == TCL_OK) ? "unregistered" : "failed";

  6349 	simpleInterpPtr = NULL;

  6350     }

  6351     Tcl_SetResult(interp, msg, TCL_VOLATILE);

  6352     return res;

  6353 }

  6354 

  6355 /* 

  6356  * Treats a file name 'simplefs:/foo' by copying the file 'foo'

  6357  * in the current (native) directory to a temporary native file,

  6358  * and then returns that native file.

  6359  */

  6360 static Tcl_Obj*

  6361 SimpleCopy(pathPtr)

  6362     Tcl_Obj *pathPtr;                   /* Name of file to copy. */

  6363 {

  6364     int res;

  6365     CONST char *str;

  6366     Tcl_Obj *origPtr;

  6367     Tcl_Obj *tempPtr;

  6368 

  6369     tempPtr = TclpTempFileName();

  6370     Tcl_IncrRefCount(tempPtr);

  6371 

  6372     /* 

  6373      * We assume the same name in the current directory is ok.

  6374      */

  6375     str = Tcl_GetString(pathPtr);

  6376     origPtr = Tcl_NewStringObj(str+10,-1);

  6377     Tcl_IncrRefCount(origPtr);

  6378 

  6379     res = TclCrossFilesystemCopy(simpleInterpPtr, origPtr, tempPtr);

  6380     Tcl_DecrRefCount(origPtr);

  6381 

  6382     if (res != TCL_OK) {

  6383 	Tcl_FSDeleteFile(tempPtr);

  6384 	Tcl_DecrRefCount(tempPtr);

  6385 	return NULL;

  6386     }

  6387     return tempPtr;

  6388 }

  6389 

  6390 static Tcl_Channel

  6391 SimpleOpenFileChannel(interp, pathPtr, mode, permissions)

  6392     Tcl_Interp *interp;                 /* Interpreter for error reporting;

  6393 					 * can be NULL. */

  6394     Tcl_Obj *pathPtr;                   /* Name of file to open. */

  6395     int mode;             		/* POSIX open mode. */

  6396     int permissions;                    /* If the open involves creating a

  6397 					 * file, with what modes to create

  6398 					 * it? */

  6399 {

  6400     Tcl_Obj *tempPtr;

  6401     Tcl_Channel chan;

  6402     

  6403     if ((mode != 0) && !(mode & O_RDONLY)) {

  6404 	Tcl_AppendResult(interp, "read-only", 

  6405 		(char *) NULL);

  6406 	return NULL;

  6407     }

  6408     

  6409     tempPtr = SimpleCopy(pathPtr);

  6410     

  6411     if (tempPtr == NULL) {

  6412 	return NULL;

  6413     }

  6414     

  6415     chan = Tcl_FSOpenFileChannel(interp, tempPtr, "r", permissions);

  6416 

  6417     if (tempFile != NULL) {

  6418         Tcl_FSDeleteFile(tempFile);

  6419 	Tcl_DecrRefCount(tempFile);

  6420 	tempFile = NULL;

  6421     }

  6422     /* 

  6423      * Store file pointer in this global variable so we can delete

  6424      * it later 

  6425      */

  6426     tempFile = tempPtr;

  6427     return chan;

  6428 }

  6429 

  6430 static int

  6431 SimpleAccess(pathPtr, mode)

  6432     Tcl_Obj *pathPtr;		/* Path of file to access (in current CP). */

  6433     int mode;                   /* Permission setting. */

  6434 {

  6435     /* All files exist */

  6436     return TCL_OK;

  6437 }

  6438 

  6439 static int

  6440 SimpleStat(pathPtr, bufPtr)

  6441     Tcl_Obj *pathPtr;		/* Path of file to stat (in current CP). */

  6442     Tcl_StatBuf *bufPtr;	/* Filled with results of stat call. */

  6443 {

  6444     Tcl_Obj *tempPtr = SimpleCopy(pathPtr);

  6445     if (tempPtr == NULL) {

  6446 	/* We just pretend the file exists anyway */

  6447 	return TCL_OK;

  6448     } else {

  6449 	int res = Tcl_FSStat(tempPtr, bufPtr);

  6450 	Tcl_FSDeleteFile(tempPtr);

  6451 	Tcl_DecrRefCount(tempPtr);

  6452 	return res;

  6453     }

  6454 }

  6455 

  6456 static Tcl_Obj*

  6457 SimpleListVolumes(void)

  6458 {

  6459     /* Add one new volume */

  6460     Tcl_Obj *retVal;

  6461 

  6462     retVal = Tcl_NewStringObj("simplefs:/",-1);

  6463     Tcl_IncrRefCount(retVal);

  6464     return retVal;

  6465 }

  6466 

  6467 /*

  6468  * Used to check correct string-length determining in Tcl_NumUtfChars

  6469  */

  6470 static int

  6471 TestNumUtfCharsCmd(clientData, interp, objc, objv)

  6472     ClientData clientData;

  6473     Tcl_Interp *interp;

  6474     int objc;

  6475     Tcl_Obj *CONST objv[];

  6476 {

  6477     if (objc > 1) {

  6478 	int len = -1;

  6479 	if (objc > 2) {

  6480 	    (void) Tcl_GetStringFromObj(objv[1], &len);

  6481 	}

  6482 	len = Tcl_NumUtfChars(Tcl_GetString(objv[1]), len);

  6483 	Tcl_SetObjResult(interp, Tcl_NewIntObj(len));

  6484     }

  6485     return TCL_OK;

  6486 }
Symaptic