Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: downloads/tcl8.5.2/generic/tclTest.c @ 35

Last change on this file since 35 was 25, checked in by landauf, 17 years ago

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