home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tkisrc04.zip / tcl / os2 / tclTest.c < prev    next >
C/C++ Source or Header  |  1998-08-07  |  59KB  |  1,944 lines
  1. /* 
  2.  * tclTest.c --
  3.  *
  4.  *    This file contains C command procedures for a bunch of additional
  5.  *    Tcl commands that are used for testing out Tcl's C interfaces.
  6.  *    These commands are not normally included in Tcl applications;
  7.  *    they're only used for testing.
  8.  *
  9.  * Copyright (c) 1993-1994 The Regents of the University of California.
  10.  * Copyright (c) 1994-1996 Sun Microsystems, Inc.
  11.  *
  12.  * See the file "license.terms" for information on usage and redistribution
  13.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  14.  *
  15.  * SCCS: @(#) tclTest.c 1.78 96/04/11 14:50:51
  16.  */
  17.  
  18. #include "tclInt.h"
  19. #include "tclPort.h"
  20.  
  21. /*
  22.  * Declare external functions used in Windows tests.
  23.  */
  24.  
  25. #if defined(__WIN32__)
  26. extern TclPlatformType *    TclWinGetPlatform _ANSI_ARGS_((void));
  27. #endif
  28. #if defined(__EMX__)
  29. extern TclPlatformType *    TclOS2GetPlatform _ANSI_ARGS_((void));
  30. #endif
  31.  
  32. /*
  33.  * Dynamic string shared by TestdcallCmd and DelCallbackProc;  used
  34.  * to collect the results of the various deletion callbacks.
  35.  */
  36.  
  37. static Tcl_DString delString;
  38. static Tcl_Interp *delInterp;
  39.  
  40. /*
  41.  * One of the following structures exists for each asynchronous
  42.  * handler created by the "testasync" command".
  43.  */
  44.  
  45. typedef struct TestAsyncHandler {
  46.     int id;                /* Identifier for this handler. */
  47.     Tcl_AsyncHandler handler;        /* Tcl's token for the handler. */
  48.     char *command;            /* Command to invoke when the
  49.                      * handler is invoked. */
  50.     struct TestAsyncHandler *nextPtr;    /* Next is list of handlers. */
  51. } TestAsyncHandler;
  52.  
  53. static TestAsyncHandler *firstHandler = NULL;
  54.  
  55. /*
  56.  * The dynamic string below is used by the "testdstring" command
  57.  * to test the dynamic string facilities.
  58.  */
  59.  
  60. static Tcl_DString dstring;
  61.  
  62. /*
  63.  * One of the following structures exists for each command created
  64.  * by TestdelCmd:
  65.  */
  66.  
  67. typedef struct DelCmd {
  68.     Tcl_Interp *interp;        /* Interpreter in which command exists. */
  69.     char *deleteCmd;        /* Script to execute when command is
  70.                  * deleted.  Malloc'ed. */
  71. } DelCmd;
  72.  
  73. /*
  74.  * The following structure is used to keep track of modal timeout
  75.  * handlers created by the "testmodal" command.
  76.  */
  77.  
  78. typedef struct Modal {
  79.     Tcl_Interp *interp;        /* Interpreter in which to set variable
  80.                  * "x" when timer fires. */
  81.     char *key;            /* Null-terminated string to store in
  82.                  * global variable "x" in interp when
  83.                  * timer fires.  Malloc-ed. */
  84. } Modal;
  85.  
  86. /*
  87.  * Forward declarations for procedures defined later in this file:
  88.  */
  89.  
  90. int            Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp));
  91. static int        AsyncHandlerProc _ANSI_ARGS_((ClientData clientData,
  92.                 Tcl_Interp *interp, int code));
  93. static void        CleanupTestSetassocdataTests _ANSI_ARGS_((
  94.                 ClientData clientData, Tcl_Interp *interp));
  95. static void        CmdDelProc1 _ANSI_ARGS_((ClientData clientData));
  96. static void        CmdDelProc2 _ANSI_ARGS_((ClientData clientData));
  97. static int        CmdProc1 _ANSI_ARGS_((ClientData clientData,
  98.                 Tcl_Interp *interp, int argc, char **argv));
  99. static int        CmdProc2 _ANSI_ARGS_((ClientData clientData,
  100.                 Tcl_Interp *interp, int argc, char **argv));
  101. static void        DelCallbackProc _ANSI_ARGS_((ClientData clientData,
  102.                 Tcl_Interp *interp));
  103. static int        DelCmdProc _ANSI_ARGS_((ClientData clientData,
  104.                 Tcl_Interp *interp, int argc, char **argv));
  105. static void        DelDeleteProc _ANSI_ARGS_((ClientData clientData));
  106. static void        ExitProcEven _ANSI_ARGS_((ClientData clientData));
  107. static void        ExitProcOdd _ANSI_ARGS_((ClientData clientData));
  108. static void        ModalTimeoutProc _ANSI_ARGS_((ClientData clientData));
  109. static void        SpecialFree _ANSI_ARGS_((char *blockPtr));
  110. static int        StaticInitProc _ANSI_ARGS_((Tcl_Interp *interp));
  111. static int        TestasyncCmd _ANSI_ARGS_((ClientData dummy,
  112.                 Tcl_Interp *interp, int argc, char **argv));
  113. static int        TestcmdinfoCmd _ANSI_ARGS_((ClientData dummy,
  114.                 Tcl_Interp *interp, int argc, char **argv));
  115. static int        TestcmdtokenCmd _ANSI_ARGS_((ClientData dummy,
  116.                 Tcl_Interp *interp, int argc, char **argv));
  117. static int        TestdcallCmd _ANSI_ARGS_((ClientData dummy,
  118.                 Tcl_Interp *interp, int argc, char **argv));
  119. static int        TestdelCmd _ANSI_ARGS_((ClientData dummy,
  120.                 Tcl_Interp *interp, int argc, char **argv));
  121. static int        TestdelassocdataCmd _ANSI_ARGS_((ClientData dummy,
  122.                 Tcl_Interp *interp, int argc, char **argv));
  123. static int        TestdstringCmd _ANSI_ARGS_((ClientData dummy,
  124.                 Tcl_Interp *interp, int argc, char **argv));
  125. static int        TestexithandlerCmd _ANSI_ARGS_((ClientData dummy,
  126.                 Tcl_Interp *interp, int argc, char **argv));
  127. static int        TestfilewaitCmd _ANSI_ARGS_((ClientData dummy,
  128.                 Tcl_Interp *interp, int argc, char **argv));
  129. static int        TestgetassocdataCmd _ANSI_ARGS_((ClientData dummy,
  130.                 Tcl_Interp *interp, int argc, char **argv));
  131. static int        TestgetplatformCmd _ANSI_ARGS_((ClientData dummy,
  132.                 Tcl_Interp *interp, int argc, char **argv));
  133. static int        TestfhandleCmd _ANSI_ARGS_((ClientData dummy,
  134.                 Tcl_Interp *interp, int argc, char **argv));
  135. static int        TestinterpdeleteCmd _ANSI_ARGS_((ClientData dummy,
  136.                     Tcl_Interp *interp, int argc, char **argv));
  137. static int        TestlinkCmd _ANSI_ARGS_((ClientData dummy,
  138.                 Tcl_Interp *interp, int argc, char **argv));
  139. static int        TestMathFunc _ANSI_ARGS_((ClientData clientData,
  140.                 Tcl_Interp *interp, Tcl_Value *args,
  141.                 Tcl_Value *resultPtr));
  142. static int        TestmodalCmd _ANSI_ARGS_((ClientData dummy,
  143.                 Tcl_Interp *interp, int argc, char **argv));
  144. static int        TestsetassocdataCmd _ANSI_ARGS_((ClientData dummy,
  145.                 Tcl_Interp *interp, int argc, char **argv));
  146. static int        TestsetplatformCmd _ANSI_ARGS_((ClientData dummy,
  147.                 Tcl_Interp *interp, int argc, char **argv));
  148. static int        TeststaticpkgCmd _ANSI_ARGS_((ClientData dummy,
  149.                 Tcl_Interp *interp, int argc, char **argv));
  150. static int        TesttranslatefilenameCmd _ANSI_ARGS_((ClientData dummy,
  151.                 Tcl_Interp *interp, int argc, char **argv));
  152. static int        TestupvarCmd _ANSI_ARGS_((ClientData dummy,
  153.                 Tcl_Interp *interp, int argc, char **argv));
  154. static int        TestwordendCmd _ANSI_ARGS_((ClientData dummy,
  155.                 Tcl_Interp *interp, int argc, char **argv));
  156. static int        TestfeventCmd _ANSI_ARGS_((ClientData dummy,
  157.                 Tcl_Interp *interp, int argc, char **argv));
  158. static int        TestPanicCmd _ANSI_ARGS_((ClientData dummy,
  159.                 Tcl_Interp *interp, int argc, char **argv));
  160.  
  161. /*
  162.  * External (platform specific) initialization routine:
  163.  */
  164.  
  165. EXTERN int        TclplatformtestInit _ANSI_ARGS_((
  166.                 Tcl_Interp *interp));
  167.  
  168. /*
  169.  *----------------------------------------------------------------------
  170.  *
  171.  * Tcltest_Init --
  172.  *
  173.  *    This procedure performs application-specific initialization.
  174.  *    Most applications, especially those that incorporate additional
  175.  *    packages, will have their own version of this procedure.
  176.  *
  177.  * Results:
  178.  *    Returns a standard Tcl completion code, and leaves an error
  179.  *    message in interp->result if an error occurs.
  180.  *
  181.  * Side effects:
  182.  *    Depends on the startup script.
  183.  *
  184.  *----------------------------------------------------------------------
  185.  */
  186.  
  187. int
  188. Tcltest_Init(interp)
  189.     Tcl_Interp *interp;        /* Interpreter for application. */
  190. {
  191.     if (Tcl_PkgProvide(interp, "Tcltest", "7.5") == TCL_ERROR) {
  192.         return TCL_ERROR;
  193.     }
  194.  
  195.     /*
  196.      * Create additional commands and math functions for testing Tcl.
  197.      */
  198.  
  199.     Tcl_CreateCommand(interp, "testasync", TestasyncCmd, (ClientData) 0,
  200.         (Tcl_CmdDeleteProc *) NULL);
  201.     Tcl_CreateCommand(interp, "testchannel", TclTestChannelCmd,
  202.             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  203.     Tcl_CreateCommand(interp, "testchannelevent", TclTestChannelEventCmd,
  204.             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  205.     Tcl_CreateCommand(interp, "testcmdtoken", TestcmdtokenCmd, (ClientData) 0,
  206.         (Tcl_CmdDeleteProc *) NULL);
  207.     Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, (ClientData) 0,
  208.         (Tcl_CmdDeleteProc *) NULL);
  209.     Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, (ClientData) 0,
  210.         (Tcl_CmdDeleteProc *) NULL);
  211.     Tcl_CreateCommand(interp, "testdel", TestdelCmd, (ClientData) 0,
  212.         (Tcl_CmdDeleteProc *) NULL);
  213.     Tcl_CreateCommand(interp, "testdelassocdata", TestdelassocdataCmd,
  214.             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  215.     Tcl_DStringInit(&dstring);
  216.     Tcl_CreateCommand(interp, "testdstring", TestdstringCmd, (ClientData) 0,
  217.         (Tcl_CmdDeleteProc *) NULL);
  218.     Tcl_CreateCommand(interp, "testexithandler", TestexithandlerCmd,
  219.             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  220.     Tcl_CreateCommand(interp, "testfhandle", TestfhandleCmd,
  221.             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  222.     Tcl_CreateCommand(interp, "testfilewait", TestfilewaitCmd,
  223.             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  224.     Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd,
  225.             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  226.     Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd,
  227.         (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  228.     Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd,
  229.             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  230.     Tcl_CreateCommand(interp, "testlink", TestlinkCmd, (ClientData) 0,
  231.         (Tcl_CmdDeleteProc *) NULL);
  232.     Tcl_CreateCommand(interp, "testmodal", TestmodalCmd,
  233.             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  234.     Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd,
  235.             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  236.     Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd,
  237.         (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  238.     Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd,
  239.         (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  240.     Tcl_CreateCommand(interp, "testtranslatefilename",
  241.             TesttranslatefilenameCmd, (ClientData) 0,
  242.             (Tcl_CmdDeleteProc *) NULL);
  243.     Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, (ClientData) 0,
  244.         (Tcl_CmdDeleteProc *) NULL);
  245.     Tcl_CreateCommand(interp, "testwordend", TestwordendCmd, (ClientData) 0,
  246.         (Tcl_CmdDeleteProc *) NULL);
  247.     Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, (ClientData) 0,
  248.             (Tcl_CmdDeleteProc *) NULL);
  249.     Tcl_CreateCommand(interp, "testpanic", TestPanicCmd, (ClientData) 0,
  250.             (Tcl_CmdDeleteProc *) NULL);
  251.     Tcl_CreateMathFunc(interp, "T1", 0, (Tcl_ValueType *) NULL, TestMathFunc,
  252.         (ClientData) 123);
  253.     Tcl_CreateMathFunc(interp, "T2", 0, (Tcl_ValueType *) NULL, TestMathFunc,
  254.         (ClientData) 345);
  255.  
  256.     /*
  257.      * And finally add any platform specific test commands.
  258.      */
  259.     
  260.     return TclplatformtestInit(interp);
  261. }
  262.  
  263. /*
  264.  *----------------------------------------------------------------------
  265.  *
  266.  * TestasyncCmd --
  267.  *
  268.  *    This procedure implements the "testasync" command.  It is used
  269.  *    to test the asynchronous handler facilities of Tcl.
  270.  *
  271.  * Results:
  272.  *    A standard Tcl result.
  273.  *
  274.  * Side effects:
  275.  *    Creates, deletes, and invokes handlers.
  276.  *
  277.  *----------------------------------------------------------------------
  278.  */
  279.  
  280.     /* ARGSUSED */
  281. static int
  282. TestasyncCmd(dummy, interp, argc, argv)
  283.     ClientData dummy;            /* Not used. */
  284.     Tcl_Interp *interp;            /* Current interpreter. */
  285.     int argc;                /* Number of arguments. */
  286.     char **argv;            /* Argument strings. */
  287. {
  288.     TestAsyncHandler *asyncPtr, *prevPtr;
  289.     int id, code;
  290.     static int nextId = 1;
  291.  
  292.     if (argc < 2) {
  293.     wrongNumArgs:
  294.     interp->result = "wrong # args";
  295.     return TCL_ERROR;
  296.     }
  297.     if (strcmp(argv[1], "create") == 0) {
  298.     if (argc != 3) {
  299.         goto wrongNumArgs;
  300.     }
  301.     asyncPtr = (TestAsyncHandler *) ckalloc(sizeof(TestAsyncHandler));
  302.     asyncPtr->id = nextId;
  303.     nextId++;
  304.     asyncPtr->handler = Tcl_AsyncCreate(AsyncHandlerProc,
  305.         (ClientData) asyncPtr);
  306.     asyncPtr->command = (char *) ckalloc((unsigned) (strlen(argv[2]) + 1));
  307.     strcpy(asyncPtr->command, argv[2]);
  308.     asyncPtr->nextPtr = firstHandler;
  309.     firstHandler = asyncPtr;
  310.     sprintf(interp->result, "%d", asyncPtr->id);
  311.     } else if (strcmp(argv[1], "delete") == 0) {
  312.     if (argc == 2) {
  313.         while (firstHandler != NULL) {
  314.         asyncPtr = firstHandler;
  315.         firstHandler = asyncPtr->nextPtr;
  316.         Tcl_AsyncDelete(asyncPtr->handler);
  317.         ckfree(asyncPtr->command);
  318.         ckfree((char *) asyncPtr);
  319.         }
  320.         return TCL_OK;
  321.     }
  322.     if (argc != 3) {
  323.         goto wrongNumArgs;
  324.     }
  325.     if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) {
  326.         return TCL_ERROR;
  327.     }
  328.     for (prevPtr = NULL, asyncPtr = firstHandler; asyncPtr != NULL;
  329.         prevPtr = asyncPtr, asyncPtr = asyncPtr->nextPtr) {
  330.         if (asyncPtr->id != id) {
  331.         continue;
  332.         }
  333.         if (prevPtr == NULL) {
  334.         firstHandler = asyncPtr->nextPtr;
  335.         } else {
  336.         prevPtr->nextPtr = asyncPtr->nextPtr;
  337.         }
  338.         Tcl_AsyncDelete(asyncPtr->handler);
  339.         ckfree(asyncPtr->command);
  340.         ckfree((char *) asyncPtr);
  341.         break;
  342.     }
  343.     } else if (strcmp(argv[1], "mark") == 0) {
  344.     if (argc != 5) {
  345.         goto wrongNumArgs;
  346.     }
  347.     if ((Tcl_GetInt(interp, argv[2], &id) != TCL_OK)
  348.         || (Tcl_GetInt(interp, argv[4], &code) != TCL_OK)) {
  349.         return TCL_ERROR;
  350.     }
  351.     for (asyncPtr = firstHandler; asyncPtr != NULL;
  352.         asyncPtr = asyncPtr->nextPtr) {
  353.         if (asyncPtr->id == id) {
  354.         Tcl_AsyncMark(asyncPtr->handler);
  355.         break;
  356.         }
  357.     }
  358.     Tcl_SetResult(interp, argv[3], TCL_VOLATILE);
  359.     return code;
  360.     } else {
  361.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  362.         "\": must be create, delete, int, or mark",
  363.         (char *) NULL);
  364.     return TCL_ERROR;
  365.     }
  366.     return TCL_OK;
  367. }
  368.  
  369. static int
  370. AsyncHandlerProc(clientData, interp, code)
  371.     ClientData clientData;    /* Pointer to TestAsyncHandler structure. */
  372.     Tcl_Interp *interp;        /* Interpreter in which command was
  373.                  * executed, or NULL. */
  374.     int code;            /* Current return code from command. */
  375. {
  376.     TestAsyncHandler *asyncPtr = (TestAsyncHandler *) clientData;
  377.     char *listArgv[4];
  378.     char string[20], *cmd;
  379.  
  380.     sprintf(string, "%d", code);
  381.     listArgv[0] = asyncPtr->command;
  382.     listArgv[1] = interp->result;
  383.     listArgv[2] = string;
  384.     listArgv[3] = NULL;
  385.     cmd = Tcl_Merge(3, listArgv);
  386.     code = Tcl_Eval(interp, cmd);
  387.     ckfree(cmd);
  388.     return code;
  389. }
  390.  
  391. /*
  392.  *----------------------------------------------------------------------
  393.  *
  394.  * TestcmdinfoCmd --
  395.  *
  396.  *    This procedure implements the "testcmdinfo" command.  It is used
  397.  *    to test Tcl_GetCommandInfo, Tcl_SetCommandInfo, and command creation
  398.  *    and deletion.
  399.  *
  400.  * Results:
  401.  *    A standard Tcl result.
  402.  *
  403.  * Side effects:
  404.  *    Creates and deletes various commands and modifies their data.
  405.  *
  406.  *----------------------------------------------------------------------
  407.  */
  408.  
  409.     /* ARGSUSED */
  410. static int
  411. TestcmdinfoCmd(dummy, interp, argc, argv)
  412.     ClientData dummy;            /* Not used. */
  413.     Tcl_Interp *interp;            /* Current interpreter. */
  414.     int argc;                /* Number of arguments. */
  415.     char **argv;            /* Argument strings. */
  416. {
  417.     Tcl_CmdInfo info;
  418.  
  419.     if (argc != 3) {
  420.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  421.         " option cmdName\"", (char *) NULL);
  422.     return TCL_ERROR;
  423.     }
  424.     if (strcmp(argv[1], "create") == 0) {
  425.     Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original",
  426.         CmdDelProc1);
  427.     } else if (strcmp(argv[1], "delete") == 0) {
  428.     Tcl_DStringInit(&delString);
  429.     Tcl_DeleteCommand(interp, argv[2]);
  430.     Tcl_DStringResult(interp, &delString);
  431.     } else if (strcmp(argv[1], "get") == 0) {
  432.     if (Tcl_GetCommandInfo(interp, argv[2], &info) ==0) {
  433.         interp->result = "??";
  434.         return TCL_OK;
  435.     }
  436.     if (info.proc == CmdProc1) {
  437.         Tcl_AppendResult(interp, "CmdProc1", " ",
  438.             (char *) info.clientData, (char *) NULL);
  439.     } else if (info.proc == CmdProc2) {
  440.         Tcl_AppendResult(interp, "CmdProc2", " ",
  441.             (char *) info.clientData, (char *) NULL);
  442.     } else {
  443.         Tcl_AppendResult(interp, "unknown", (char *) NULL);
  444.     }
  445.     if (info.deleteProc == CmdDelProc1) {
  446.         Tcl_AppendResult(interp, " CmdDelProc1", " ",
  447.             (char *) info.deleteData, (char *) NULL);
  448.     } else if (info.deleteProc == CmdDelProc2) {
  449.         Tcl_AppendResult(interp, " CmdDelProc2", " ",
  450.             (char *) info.deleteData, (char *) NULL);
  451.     } else {
  452.         Tcl_AppendResult(interp, " unknown", (char *) NULL);
  453.     }
  454.     } else if (strcmp(argv[1], "modify") == 0) {
  455.     info.proc = CmdProc2;
  456.     info.clientData = (ClientData) "new_command_data";
  457.     info.deleteProc = CmdDelProc2;
  458.     info.deleteData = (ClientData) "new_delete_data";
  459.     if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) {
  460.         interp->result = "0";
  461.     } else {
  462.         interp->result = "1";
  463.     }
  464.     } else {
  465.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  466.         "\": must be create, delete, get, or modify",
  467.         (char *) NULL);
  468.     return TCL_ERROR;
  469.     }
  470.     return TCL_OK;
  471. }
  472.  
  473.     /*ARGSUSED*/
  474. static int
  475. CmdProc1(clientData, interp, argc, argv)
  476.     ClientData clientData;        /* String to return. */
  477.     Tcl_Interp *interp;            /* Current interpreter. */
  478.     int argc;                /* Number of arguments. */
  479.     char **argv;            /* Argument strings. */
  480. {
  481.     Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData,
  482.         (char *) NULL);
  483.     return TCL_OK;
  484. }
  485.  
  486.     /*ARGSUSED*/
  487. static int
  488. CmdProc2(clientData, interp, argc, argv)
  489.     ClientData clientData;        /* String to return. */
  490.     Tcl_Interp *interp;            /* Current interpreter. */
  491.     int argc;                /* Number of arguments. */
  492.     char **argv;            /* Argument strings. */
  493. {
  494.     Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData,
  495.         (char *) NULL);
  496.     return TCL_OK;
  497. }
  498.  
  499. static void
  500. CmdDelProc1(clientData)
  501.     ClientData clientData;        /* String to save. */
  502. {
  503.     Tcl_DStringInit(&delString);
  504.     Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1);
  505.     Tcl_DStringAppend(&delString, (char *) clientData, -1);
  506. }
  507.  
  508. static void
  509. CmdDelProc2(clientData)
  510.     ClientData clientData;        /* String to save. */
  511. {
  512.     Tcl_DStringInit(&delString);
  513.     Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1);
  514.     Tcl_DStringAppend(&delString, (char *) clientData, -1);
  515. }
  516.  
  517. /*
  518.  *----------------------------------------------------------------------
  519.  *
  520.  * TestcmdtokenCmd --
  521.  *
  522.  *    This procedure implements the "testcmdtoken" command.  It is used
  523.  *    to test Tcl_Command tokens and Tcl_GetCommandName.
  524.  *
  525.  * Results:
  526.  *    A standard Tcl result.
  527.  *
  528.  * Side effects:
  529.  *    Creates and deletes various commands and modifies their data.
  530.  *
  531.  *----------------------------------------------------------------------
  532.  */
  533.  
  534.     /* ARGSUSED */
  535. static int
  536. TestcmdtokenCmd(dummy, interp, argc, argv)
  537.     ClientData dummy;            /* Not used. */
  538.     Tcl_Interp *interp;            /* Current interpreter. */
  539.     int argc;                /* Number of arguments. */
  540.     char **argv;            /* Argument strings. */
  541. {
  542.     Tcl_Command token;
  543.     long int l;
  544.  
  545.     if (argc != 3) {
  546.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  547.         " option arg\"", (char *) NULL);
  548.     return TCL_ERROR;
  549.     }
  550.     if (strcmp(argv[1], "create") == 0) {
  551.     token = Tcl_CreateCommand(interp, argv[2], CmdProc1,
  552.         (ClientData) "original", (Tcl_CmdDeleteProc *) NULL);
  553.     sprintf(interp->result, "%lx", (long int) token);
  554.     } else if (strcmp(argv[1], "name") == 0) {
  555.     if (sscanf(argv[2], "%lx", &l) != 1) {
  556.         Tcl_AppendResult(interp, "bad command token \"", argv[2],
  557.             "\"", (char *) NULL);
  558.         return TCL_ERROR;
  559.     }
  560.     interp->result = Tcl_GetCommandName(interp, (Tcl_Command) l);
  561.     } else {
  562.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  563.         "\": must be create or name", (char *) NULL);
  564.     return TCL_ERROR;
  565.     }
  566.     return TCL_OK;
  567. }
  568.  
  569. /*
  570.  *----------------------------------------------------------------------
  571.  *
  572.  * TestdcallCmd --
  573.  *
  574.  *    This procedure implements the "testdcall" command.  It is used
  575.  *    to test Tcl_CallWhenDeleted.
  576.  *
  577.  * Results:
  578.  *    A standard Tcl result.
  579.  *
  580.  * Side effects:
  581.  *    Creates and deletes interpreters.
  582.  *
  583.  *----------------------------------------------------------------------
  584.  */
  585.  
  586.     /* ARGSUSED */
  587. static int
  588. TestdcallCmd(dummy, interp, argc, argv)
  589.     ClientData dummy;            /* Not used. */
  590.     Tcl_Interp *interp;            /* Current interpreter. */
  591.     int argc;                /* Number of arguments. */
  592.     char **argv;            /* Argument strings. */
  593. {
  594.     int i, id;
  595.  
  596.     delInterp = Tcl_CreateInterp();
  597.     Tcl_DStringInit(&delString);
  598.     for (i = 1; i < argc; i++) {
  599.     if (Tcl_GetInt(interp, argv[i], &id) != TCL_OK) {
  600.         return TCL_ERROR;
  601.     }
  602.     if (id < 0) {
  603.         Tcl_DontCallWhenDeleted(delInterp, DelCallbackProc,
  604.             (ClientData) (-id));
  605.     } else {
  606.         Tcl_CallWhenDeleted(delInterp, DelCallbackProc,
  607.             (ClientData) id);
  608.     }
  609.     }
  610.     Tcl_DeleteInterp(delInterp);
  611.     Tcl_DStringResult(interp, &delString);
  612.     return TCL_OK;
  613. }
  614.  
  615. /*
  616.  * The deletion callback used by TestdcallCmd:
  617.  */
  618.  
  619. static void
  620. DelCallbackProc(clientData, interp)
  621.     ClientData clientData;        /* Numerical value to append to
  622.                      * delString. */
  623.     Tcl_Interp *interp;            /* Interpreter being deleted. */
  624. {
  625.     int id = (int) clientData;
  626.     char buffer[10];
  627.  
  628.     sprintf(buffer, "%d", id);
  629.     Tcl_DStringAppendElement(&delString, buffer);
  630.     if (interp != delInterp) {
  631.     Tcl_DStringAppendElement(&delString, "bogus interpreter argument!");
  632.     }
  633. }
  634.  
  635. /*
  636.  *----------------------------------------------------------------------
  637.  *
  638.  * TestdelCmd --
  639.  *
  640.  *    This procedure implements the "testdcall" command.  It is used
  641.  *    to test Tcl_CallWhenDeleted.
  642.  *
  643.  * Results:
  644.  *    A standard Tcl result.
  645.  *
  646.  * Side effects:
  647.  *    Creates and deletes interpreters.
  648.  *
  649.  *----------------------------------------------------------------------
  650.  */
  651.  
  652.     /* ARGSUSED */
  653. static int
  654. TestdelCmd(dummy, interp, argc, argv)
  655.     ClientData dummy;            /* Not used. */
  656.     Tcl_Interp *interp;            /* Current interpreter. */
  657.     int argc;                /* Number of arguments. */
  658.     char **argv;            /* Argument strings. */
  659. {
  660.     DelCmd *dPtr;
  661.     Tcl_Interp *slave;
  662.  
  663.     if (argc != 4) {
  664.     interp->result = "wrong # args";
  665.     return TCL_ERROR;
  666.     }
  667.  
  668.     slave = Tcl_GetSlave(interp, argv[1]);
  669.     if (slave == NULL) {
  670.     return TCL_ERROR;
  671.     }
  672.  
  673.     dPtr = (DelCmd *) ckalloc(sizeof(DelCmd));
  674.     dPtr->interp = interp;
  675.     dPtr->deleteCmd = (char *) ckalloc((unsigned) (strlen(argv[3]) + 1));
  676.     strcpy(dPtr->deleteCmd, argv[3]);
  677.  
  678.     Tcl_CreateCommand(slave, argv[2], DelCmdProc, (ClientData) dPtr,
  679.         DelDeleteProc);
  680.     return TCL_OK;
  681. }
  682.  
  683. static int
  684. DelCmdProc(clientData, interp, argc, argv)
  685.     ClientData clientData;        /* String result to return. */
  686.     Tcl_Interp *interp;            /* Current interpreter. */
  687.     int argc;                /* Number of arguments. */
  688.     char **argv;            /* Argument strings. */
  689. {
  690.     DelCmd *dPtr = (DelCmd *) clientData;
  691.  
  692.     Tcl_AppendResult(interp, dPtr->deleteCmd, (char *) NULL);
  693.     ckfree(dPtr->deleteCmd);
  694.     ckfree((char *) dPtr);
  695.     return TCL_OK;
  696. }
  697.  
  698. static void
  699. DelDeleteProc(clientData)
  700.     ClientData clientData;        /* String command to evaluate. */
  701. {
  702.     DelCmd *dPtr = (DelCmd *) clientData;
  703.  
  704.     Tcl_Eval(dPtr->interp, dPtr->deleteCmd);
  705.     Tcl_ResetResult(dPtr->interp);
  706.     ckfree(dPtr->deleteCmd);
  707.     ckfree((char *) dPtr);
  708. }
  709.  
  710. /*
  711.  *----------------------------------------------------------------------
  712.  *
  713.  * TestdelassocdataCmd --
  714.  *
  715.  *    This procedure implements the "testdelassocdata" command. It is used
  716.  *    to test Tcl_DeleteAssocData.
  717.  *
  718.  * Results:
  719.  *    A standard Tcl result.
  720.  *
  721.  * Side effects:
  722.  *    Deletes an association between a key and associated data from an
  723.  *    interpreter.
  724.  *
  725.  *----------------------------------------------------------------------
  726.  */
  727.  
  728. static int
  729. TestdelassocdataCmd(clientData, interp, argc, argv)
  730.     ClientData clientData;        /* Not used. */
  731.     Tcl_Interp *interp;            /* Current interpreter. */
  732.     int argc;                /* Number of arguments. */
  733.     char **argv;            /* Argument strings. */
  734. {
  735.     if (argc != 2) {
  736.         Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
  737.                 " data_key\"", (char *) NULL);
  738.         return TCL_ERROR;
  739.     }
  740.     Tcl_DeleteAssocData(interp, argv[1]);
  741.     return TCL_OK;
  742. }
  743.  
  744. /*
  745.  *----------------------------------------------------------------------
  746.  *
  747.  * TestdstringCmd --
  748.  *
  749.  *    This procedure implements the "testdstring" command.  It is used
  750.  *    to test the dynamic string facilities of Tcl.
  751.  *
  752.  * Results:
  753.  *    A standard Tcl result.
  754.  *
  755.  * Side effects:
  756.  *    Creates, deletes, and invokes handlers.
  757.  *
  758.  *----------------------------------------------------------------------
  759.  */
  760.  
  761.     /* ARGSUSED */
  762. static int
  763. TestdstringCmd(dummy, interp, argc, argv)
  764.     ClientData dummy;            /* Not used. */
  765.     Tcl_Interp *interp;            /* Current interpreter. */
  766.     int argc;                /* Number of arguments. */
  767.     char **argv;            /* Argument strings. */
  768. {
  769.     int count;
  770.  
  771.     if (argc < 2) {
  772.     wrongNumArgs:
  773.     interp->result = "wrong # args";
  774.     return TCL_ERROR;
  775.     }
  776.     if (strcmp(argv[1], "append") == 0) {
  777.     if (argc != 4) {
  778.         goto wrongNumArgs;
  779.     }
  780.     if (Tcl_GetInt(interp, argv[3], &count) != TCL_OK) {
  781.         return TCL_ERROR;
  782.     }
  783.     Tcl_DStringAppend(&dstring, argv[2], count);
  784.     } else if (strcmp(argv[1], "element") == 0) {
  785.     if (argc != 3) {
  786.         goto wrongNumArgs;
  787.     }
  788.     Tcl_DStringAppendElement(&dstring, argv[2]);
  789.     } else if (strcmp(argv[1], "end") == 0) {
  790.     if (argc != 2) {
  791.         goto wrongNumArgs;
  792.     }
  793.     Tcl_DStringEndSublist(&dstring);
  794.     } else if (strcmp(argv[1], "free") == 0) {
  795.     if (argc != 2) {
  796.         goto wrongNumArgs;
  797.     }
  798.     Tcl_DStringFree(&dstring);
  799.     } else if (strcmp(argv[1], "get") == 0) {
  800.     if (argc != 2) {
  801.         goto wrongNumArgs;
  802.     }
  803.     interp->result = Tcl_DStringValue(&dstring);
  804.     } else if (strcmp(argv[1], "gresult") == 0) {
  805.     if (argc != 3) {
  806.         goto wrongNumArgs;
  807.     }
  808.     if (strcmp(argv[2], "staticsmall") == 0) {
  809.         interp->result = "short";
  810.     } else if (strcmp(argv[2], "staticlarge") == 0) {
  811.         interp->result = "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";
  812.     } else if (strcmp(argv[2], "free") == 0) {
  813.         interp->result = (char *) ckalloc(100);
  814.         interp->freeProc = TCL_DYNAMIC;
  815.         strcpy(interp->result, "This is a malloc-ed string");
  816.     } else if (strcmp(argv[2], "special") == 0) {
  817.         interp->result = (char *) ckalloc(100);
  818.         interp->result += 4;
  819.         interp->freeProc = SpecialFree;
  820.         strcpy(interp->result, "This is a specially-allocated string");
  821.     } else {
  822.         Tcl_AppendResult(interp, "bad gresult option \"", argv[2],
  823.             "\": must be staticsmall, staticlarge, free, or special",
  824.             (char *) NULL);
  825.         return TCL_ERROR;
  826.     }
  827.     Tcl_DStringGetResult(interp, &dstring);
  828.     } else if (strcmp(argv[1], "length") == 0) {
  829.     if (argc != 2) {
  830.         goto wrongNumArgs;
  831.     }
  832.     sprintf(interp->result, "%d", Tcl_DStringLength(&dstring));
  833.     } else if (strcmp(argv[1], "result") == 0) {
  834.     if (argc != 2) {
  835.         goto wrongNumArgs;
  836.     }
  837.     Tcl_DStringResult(interp, &dstring);
  838.     } else if (strcmp(argv[1], "trunc") == 0) {
  839.     if (argc != 3) {
  840.         goto wrongNumArgs;
  841.     }
  842.     if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) {
  843.         return TCL_ERROR;
  844.     }
  845.     Tcl_DStringTrunc(&dstring, count);
  846.     } else if (strcmp(argv[1], "start") == 0) {
  847.     if (argc != 2) {
  848.         goto wrongNumArgs;
  849.     }
  850.     Tcl_DStringStartSublist(&dstring);
  851.     } else {
  852.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  853.         "\": must be append, element, end, free, get, length, ",
  854.         "result, trunc, or start", (char *) NULL);
  855.     return TCL_ERROR;
  856.     }
  857.     return TCL_OK;
  858. }
  859.  
  860. /*
  861.  * The procedure below is used as a special freeProc to test how well
  862.  * Tcl_DStringGetResult handles freeProc's other than free.
  863.  */
  864.  
  865. static void SpecialFree(blockPtr)
  866.     char *blockPtr;            /* Block to free. */
  867. {
  868.     ckfree(blockPtr - 4);
  869. }
  870.  
  871. /*
  872.  *----------------------------------------------------------------------
  873.  *
  874.  * TestexithandlerCmd --
  875.  *
  876.  *    This procedure implements the "testexithandler" command. It is
  877.  *    used to test Tcl_CreateExitHandler and Tcl_DeleteExitHandler.
  878.  *
  879.  * Results:
  880.  *    A standard Tcl result.
  881.  *
  882.  * Side effects:
  883.  *    None.
  884.  *
  885.  *----------------------------------------------------------------------
  886.  */
  887.  
  888. static int
  889. TestexithandlerCmd(clientData, interp, argc, argv)
  890.     ClientData clientData;        /* Not used. */
  891.     Tcl_Interp *interp;            /* Current interpreter. */
  892.     int argc;                /* Number of arguments. */
  893.     char **argv;            /* Argument strings. */
  894. {
  895.     int value;
  896.  
  897.     if (argc != 3) {
  898.     Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
  899.                 " create|delete value\"", (char *) NULL);
  900.         return TCL_ERROR;
  901.     }
  902.     if (Tcl_GetInt(interp, argv[2], &value) != TCL_OK) {
  903.     return TCL_ERROR;
  904.     }
  905.     if (strcmp(argv[1], "create") == 0) {
  906.     Tcl_CreateExitHandler((value & 1) ? ExitProcOdd : ExitProcEven,
  907.         (ClientData) value);
  908.     } else if (strcmp(argv[1], "delete") == 0) {
  909.     Tcl_DeleteExitHandler((value & 1) ? ExitProcOdd : ExitProcEven,
  910.         (ClientData) value);
  911.     } else {
  912.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  913.         "\": must be create or delete", (char *) NULL);
  914.     return TCL_ERROR;
  915.     }
  916.     return TCL_OK;
  917. }
  918.  
  919. static void
  920. ExitProcOdd(clientData)
  921.     ClientData clientData;        /* Integer value to print. */
  922. {
  923.     char buf[100];
  924.  
  925.     sprintf(buf, "odd %d\n", (int) clientData);
  926.     write(1, buf, strlen(buf));
  927. }
  928.  
  929. static void
  930. ExitProcEven(clientData)
  931.     ClientData clientData;        /* Integer value to print. */
  932. {
  933.     char buf[100];
  934.  
  935.     sprintf(buf, "even %d\n", (int) clientData);
  936.     write(1, buf, strlen(buf));
  937. }
  938.  
  939. /*
  940.  *----------------------------------------------------------------------
  941.  *
  942.  * TestfhandleCmd --
  943.  *
  944.  *    This procedure implements the "testfhandle" command.  It is
  945.  *    used to test Tcl_GetFile, Tcl_FreeFile, and
  946.  *    Tcl_GetFileInfo.
  947.  *
  948.  * Results:
  949.  *    A standard Tcl result.
  950.  *
  951.  * Side effects:
  952.  *    None.
  953.  *
  954.  *----------------------------------------------------------------------
  955.  */
  956.  
  957. static int
  958. TestfhandleCmd(clientData, interp, argc, argv)
  959.     ClientData clientData;        /* Not used. */
  960.     Tcl_Interp *interp;            /* Current interpreter. */
  961.     int argc;                /* Number of arguments. */
  962.     char **argv;            /* Argument strings. */
  963. {
  964. #define MAX_FHANDLES 10
  965.     static Tcl_File testHandles[MAX_FHANDLES];
  966.     static initialized = 0;
  967.  
  968.     int i, index, type;
  969.     ClientData data;
  970.  
  971.     if (!initialized) {
  972.     for (i = 0; i < MAX_FHANDLES; i++) {
  973.         testHandles[i] = NULL;
  974.     }
  975.     initialized = 1;
  976.     }
  977.     if (argc < 2) {
  978.     Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
  979.                 " option ... \"", (char *) NULL);
  980.         return TCL_ERROR;
  981.     }
  982.     index = -1;
  983.     if (argc >= 3) {
  984.     if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) {
  985.         return TCL_ERROR;
  986.     }
  987.     if (index >= MAX_FHANDLES) {
  988.         Tcl_AppendResult(interp, "bad index ", argv[2], (char *) NULL);
  989.         return TCL_ERROR;
  990.     }
  991.     }
  992.     if (strcmp(argv[1], "compare") == 0) {
  993.     int index2;
  994.     if (argc != 4) {
  995.         Tcl_AppendResult(interp, "wrong # arguments: should be \"",
  996.             argv[0], " index index\"", (char *) NULL);
  997.         return TCL_ERROR;
  998.     }
  999.     if (Tcl_GetInt(interp, argv[3], (int *) &index2) != TCL_OK) {
  1000.         return TCL_ERROR;
  1001.     }
  1002.     if (testHandles[index] == testHandles[index2]) {
  1003.         sprintf(interp->result, "equal");
  1004.     } else {
  1005.         sprintf(interp->result, "notequal");
  1006.     }
  1007.     } else if (strcmp(argv[1], "get") == 0) {
  1008.     if (argc != 5) {
  1009.         Tcl_AppendResult(interp, "wrong # arguments: should be \"",
  1010.             argv[0], " index data type\"", (char *) NULL);
  1011.         return TCL_ERROR;
  1012.     }
  1013.     if (Tcl_GetInt(interp, argv[3], (int *) &data) != TCL_OK) {
  1014.         return TCL_ERROR;
  1015.     }
  1016.     if (Tcl_GetInt(interp, argv[4], &type) != TCL_OK) {
  1017.         return TCL_ERROR;
  1018.     }
  1019.     testHandles[index] = Tcl_GetFile(data, type);
  1020.     } else if (strcmp(argv[1], "free") == 0) {
  1021.     if (argc != 3) {
  1022.         Tcl_AppendResult(interp, "wrong # arguments: should be \"",
  1023.             argv[0], " index\"", (char *) NULL);
  1024.         return TCL_ERROR;
  1025.     }
  1026.     Tcl_FreeFile(testHandles[index]);
  1027.     } else if (strcmp(argv[1], "info1") == 0) {
  1028.     if (argc != 3) {
  1029.         Tcl_AppendResult(interp, "wrong # arguments: should be \"",
  1030.             argv[0], " index\"", (char *) NULL);
  1031.         return TCL_ERROR;
  1032.     }
  1033.     data = Tcl_GetFileInfo(testHandles[index], NULL);
  1034.     sprintf(interp->result, "%d", (int)data);
  1035.     } else if (strcmp(argv[1], "info2") == 0) {
  1036.     if (argc != 3) {
  1037.         Tcl_AppendResult(interp, "wrong # arguments: should be \"",
  1038.             argv[0], " index\"", (char *) NULL);
  1039.         return TCL_ERROR;
  1040.     }
  1041.     data = Tcl_GetFileInfo(testHandles[index], &type);
  1042.     sprintf(interp->result, "%d %d", (int)data, type);
  1043.     } else {
  1044.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  1045.         "\": must be compare, get, free, info1, or info2",
  1046.         (char *) NULL);
  1047.     return TCL_ERROR;
  1048.     }
  1049.     return TCL_OK;
  1050. }
  1051.  
  1052. /*
  1053.  *----------------------------------------------------------------------
  1054.  *
  1055.  * TestfilewaitCmd --
  1056.  *
  1057.  *    This procedure implements the "testfilewait" command. It is
  1058.  *    used to test TclWaitForFile.
  1059.  *
  1060.  * Results:
  1061.  *    A standard Tcl result.
  1062.  *
  1063.  * Side effects:
  1064.  *    None.
  1065.  *
  1066.  *----------------------------------------------------------------------
  1067.  */
  1068.  
  1069. static int
  1070. TestfilewaitCmd(clientData, interp, argc, argv)
  1071.     ClientData clientData;        /* Not used. */
  1072.     Tcl_Interp *interp;            /* Current interpreter. */
  1073.     int argc;                /* Number of arguments. */
  1074.     char **argv;            /* Argument strings. */
  1075. {
  1076.     int mask, result, timeout;
  1077.     Tcl_Channel channel;
  1078.     Tcl_File file;
  1079.  
  1080.     if (argc != 4) {
  1081.     Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
  1082.         " file readable|writable|both timeout\"", (char *) NULL);
  1083.     return TCL_ERROR;
  1084.     }
  1085.     channel = Tcl_GetChannel(interp, argv[1], NULL);
  1086.     if (channel == NULL) {
  1087.     return TCL_ERROR;
  1088.     }
  1089.     if (strcmp(argv[2], "readable") == 0) {
  1090.     mask = TCL_READABLE;
  1091.     } else if (strcmp(argv[2], "writable") == 0){
  1092.     mask = TCL_WRITABLE;
  1093.     } else if (strcmp(argv[2], "both") == 0){
  1094.     mask = TCL_WRITABLE|TCL_READABLE;
  1095.     } else {
  1096.     Tcl_AppendResult(interp, "bad argument \"", argv[2],
  1097.         "\": must be readable, writable, or both", (char *) NULL);
  1098.     return TCL_ERROR;
  1099.     }
  1100.     file = Tcl_GetChannelFile(channel, 
  1101.         (mask & TCL_READABLE) ? TCL_READABLE : TCL_WRITABLE);
  1102.     if (file == NULL) {
  1103.     interp->result = "couldn't get channel file";
  1104.     return TCL_ERROR;
  1105.     }
  1106.     if (Tcl_GetInt(interp, argv[3], &timeout) != TCL_OK) {
  1107.     return TCL_ERROR;
  1108.     }
  1109.     result = TclWaitForFile(file, mask, timeout);
  1110.     if (result & TCL_READABLE) {
  1111.     Tcl_AppendElement(interp, "readable");
  1112.     }
  1113.     if (result & TCL_WRITABLE) {
  1114.     Tcl_AppendElement(interp, "writable");
  1115.     }
  1116.     return TCL_OK;
  1117. }
  1118.  
  1119. /*
  1120.  *----------------------------------------------------------------------
  1121.  *
  1122.  * TestgetassocdataCmd --
  1123.  *
  1124.  *    This procedure implements the "testgetassocdata" command. It is
  1125.  *    used to test Tcl_GetAssocData.
  1126.  *
  1127.  * Results:
  1128.  *    A standard Tcl result.
  1129.  *
  1130.  * Side effects:
  1131.  *    None.
  1132.  *
  1133.  *----------------------------------------------------------------------
  1134.  */
  1135.  
  1136. static int
  1137. TestgetassocdataCmd(clientData, interp, argc, argv)
  1138.     ClientData clientData;        /* Not used. */
  1139.     Tcl_Interp *interp;            /* Current interpreter. */
  1140.     int argc;                /* Number of arguments. */
  1141.     char **argv;            /* Argument strings. */
  1142. {
  1143.     char *res;
  1144.     
  1145.     if (argc != 2) {
  1146.         Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
  1147.                 " data_key\"", (char *) NULL);
  1148.         return TCL_ERROR;
  1149.     }
  1150.     res = (char *) Tcl_GetAssocData(interp, argv[1], NULL);
  1151.     if (res != NULL) {
  1152.         Tcl_AppendResult(interp, res, NULL);
  1153.     }
  1154.     return TCL_OK;
  1155. }
  1156.  
  1157. /*
  1158.  *----------------------------------------------------------------------
  1159.  *
  1160.  * TestgetplatformCmd --
  1161.  *
  1162.  *    This procedure implements the "testgetplatform" command. It is
  1163.  *    used to retrievel the value of the tclPlatform global variable.
  1164.  *
  1165.  * Results:
  1166.  *    A standard Tcl result.
  1167.  *
  1168.  * Side effects:
  1169.  *    None.
  1170.  *
  1171.  *----------------------------------------------------------------------
  1172.  */
  1173.  
  1174. static int
  1175. TestgetplatformCmd(clientData, interp, argc, argv)
  1176.     ClientData clientData;        /* Not used. */
  1177.     Tcl_Interp *interp;            /* Current interpreter. */
  1178.     int argc;                /* Number of arguments. */
  1179.     char **argv;            /* Argument strings. */
  1180. {
  1181.     static char *platformStrings[] = { "unix", "mac", "windows", "os2" };
  1182.     TclPlatformType *platform;
  1183.  
  1184. #ifdef __WIN32__
  1185.     platform = TclWinGetPlatform();
  1186. #else
  1187.     #ifdef __EMX__
  1188.         platform = TclOS2GetPlatform();
  1189.     #else
  1190.         platform = &tclPlatform;
  1191.     #endif
  1192. #endif
  1193.     
  1194.     if (argc != 1) {
  1195.         Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
  1196.         (char *) NULL);
  1197.         return TCL_ERROR;
  1198.     }
  1199.  
  1200.     Tcl_AppendResult(interp, platformStrings[*platform], NULL);
  1201.     return TCL_OK;
  1202. }
  1203.  
  1204. /*
  1205.  *----------------------------------------------------------------------
  1206.  *
  1207.  * TestinterpdeleteCmd --
  1208.  *
  1209.  *    This procedure tests the code in tclInterp.c that deals with
  1210.  *    interpreter deletion. It deletes a user-specified interpreter
  1211.  *    from the hierarchy, and subsequent code checks integrity.
  1212.  *
  1213.  * Results:
  1214.  *    A standard Tcl result.
  1215.  *
  1216.  * Side effects:
  1217.  *    Deletes one or more interpreters.
  1218.  *
  1219.  *----------------------------------------------------------------------
  1220.  */
  1221.  
  1222.     /* ARGSUSED */
  1223. static int
  1224. TestinterpdeleteCmd(dummy, interp, argc, argv)
  1225.     ClientData dummy;            /* Not used. */
  1226.     Tcl_Interp *interp;            /* Current interpreter. */
  1227.     int argc;                /* Number of arguments. */
  1228.     char **argv;            /* Argument strings. */
  1229. {
  1230.     Tcl_Interp *slaveToDelete;
  1231.  
  1232.     if (argc != 2) {
  1233.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1234.                 " path\"", (char *) NULL);
  1235.         return TCL_ERROR;
  1236.     }
  1237.     if (argv[1][0] == '\0') {
  1238.         Tcl_AppendResult(interp, "cannot delete current interpreter",
  1239.                 (char *) NULL);
  1240.         return TCL_ERROR;
  1241.     }
  1242.     slaveToDelete = Tcl_GetSlave(interp, argv[1]);
  1243.     if (slaveToDelete == (Tcl_Interp *) NULL) {
  1244.         Tcl_AppendResult(interp, "could not find interpreter \"",
  1245.                 argv[1], "\"", (char *) NULL);
  1246.         return TCL_ERROR;
  1247.     }
  1248.     Tcl_DeleteInterp(slaveToDelete);
  1249.     return TCL_OK;
  1250. }
  1251.  
  1252. /*
  1253.  *----------------------------------------------------------------------
  1254.  *
  1255.  * TestlinkCmd --
  1256.  *
  1257.  *    This procedure implements the "testlink" command.  It is used
  1258.  *    to test Tcl_LinkVar and related library procedures.
  1259.  *
  1260.  * Results:
  1261.  *    A standard Tcl result.
  1262.  *
  1263.  * Side effects:
  1264.  *    Creates and deletes various variable links, plus returns
  1265.  *    values of the linked variables.
  1266.  *
  1267.  *----------------------------------------------------------------------
  1268.  */
  1269.  
  1270.     /* ARGSUSED */
  1271. static int
  1272. TestlinkCmd(dummy, interp, argc, argv)
  1273.     ClientData dummy;            /* Not used. */
  1274.     Tcl_Interp *interp;            /* Current interpreter. */
  1275.     int argc;                /* Number of arguments. */
  1276.     char **argv;            /* Argument strings. */
  1277. {
  1278.     static int intVar = 43;
  1279.     static int boolVar = 4;
  1280.     static double realVar = 1.23;
  1281.     static char *stringVar = NULL;
  1282.     static int created = 0;
  1283.     char buffer[TCL_DOUBLE_SPACE];
  1284.     int writable, flag;
  1285.  
  1286.     if (argc < 2) {
  1287.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1288.         " option ?arg arg arg?\"", (char *) NULL);
  1289.     return TCL_ERROR;
  1290.     }
  1291.     if (strcmp(argv[1], "create") == 0) {
  1292.     if (created) {
  1293.         Tcl_UnlinkVar(interp, "int");
  1294.         Tcl_UnlinkVar(interp, "real");
  1295.         Tcl_UnlinkVar(interp, "bool");
  1296.         Tcl_UnlinkVar(interp, "string");
  1297.     }
  1298.     created = 1;
  1299.     if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) {
  1300.         return TCL_ERROR;
  1301.     }
  1302.     flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
  1303.     if (Tcl_LinkVar(interp, "int", (char *) &intVar,
  1304.         TCL_LINK_INT | flag) != TCL_OK) {
  1305.         return TCL_ERROR;
  1306.     }
  1307.     if (Tcl_GetBoolean(interp, argv[3], &writable) != TCL_OK) {
  1308.         return TCL_ERROR;
  1309.     }
  1310.     flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
  1311.     if (Tcl_LinkVar(interp, "real", (char *) &realVar,
  1312.         TCL_LINK_DOUBLE | flag) != TCL_OK) {
  1313.         return TCL_ERROR;
  1314.     }
  1315.     if (Tcl_GetBoolean(interp, argv[4], &writable) != TCL_OK) {
  1316.         return TCL_ERROR;
  1317.     }
  1318.     flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
  1319.     if (Tcl_LinkVar(interp, "bool", (char *) &boolVar,
  1320.         TCL_LINK_BOOLEAN | flag) != TCL_OK) {
  1321.         return TCL_ERROR;
  1322.     }
  1323.     if (Tcl_GetBoolean(interp, argv[5], &writable) != TCL_OK) {
  1324.         return TCL_ERROR;
  1325.     }
  1326.     flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
  1327.     if (Tcl_LinkVar(interp, "string", (char *) &stringVar,
  1328.         TCL_LINK_STRING | flag) != TCL_OK) {
  1329.         return TCL_ERROR;
  1330.     }
  1331.     } else if (strcmp(argv[1], "delete") == 0) {
  1332.     Tcl_UnlinkVar(interp, "int");
  1333.     Tcl_UnlinkVar(interp, "real");
  1334.     Tcl_UnlinkVar(interp, "bool");
  1335.     Tcl_UnlinkVar(interp, "string");
  1336.     created = 0;
  1337.     } else if (strcmp(argv[1], "get") == 0) {
  1338.     sprintf(buffer, "%d", intVar);
  1339.     Tcl_AppendElement(interp, buffer);
  1340.     Tcl_PrintDouble(interp, realVar, buffer);
  1341.     Tcl_AppendElement(interp, buffer);
  1342.     sprintf(buffer, "%d", boolVar);
  1343.     Tcl_AppendElement(interp, buffer);
  1344.     Tcl_AppendElement(interp, (stringVar == NULL) ? "-" : stringVar);
  1345.     } else if (strcmp(argv[1], "set") == 0) {
  1346.     if (argc != 6) {
  1347.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1348.         argv[0], " ", argv[1],
  1349.         "intValue realValue boolValue stringValue\"", (char *) NULL);
  1350.         return TCL_ERROR;
  1351.     }
  1352.     if (argv[2][0] != 0) {
  1353.         if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) {
  1354.         return TCL_ERROR;
  1355.         }
  1356.     }
  1357.     if (argv[3][0] != 0) {
  1358.         if (Tcl_GetDouble(interp, argv[3], &realVar) != TCL_OK) {
  1359.         return TCL_ERROR;
  1360.         }
  1361.     }
  1362.     if (argv[4][0] != 0) {
  1363.         if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) {
  1364.         return TCL_ERROR;
  1365.         }
  1366.     }
  1367.     if (argv[5][0] != 0) {
  1368.         if (stringVar != NULL) {
  1369.         ckfree(stringVar);
  1370.         }
  1371.         if (strcmp(argv[5], "-") == 0) {
  1372.         stringVar = NULL;
  1373.         } else {
  1374.         stringVar = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1));
  1375.         strcpy(stringVar, argv[5]);
  1376.         }
  1377.     }
  1378.     } else if (strcmp(argv[1], "update") == 0) {
  1379.     if (argc != 6) {
  1380.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1381.         argv[0], " ", argv[1],
  1382.         "intValue realValue boolValue stringValue\"", (char *) NULL);
  1383.         return TCL_ERROR;
  1384.     }
  1385.     if (argv[2][0] != 0) {
  1386.         if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) {
  1387.         return TCL_ERROR;
  1388.         }
  1389.         Tcl_UpdateLinkedVar(interp, "int");
  1390.     }
  1391.     if (argv[3][0] != 0) {
  1392.         if (Tcl_GetDouble(interp, argv[3], &realVar) != TCL_OK) {
  1393.         return TCL_ERROR;
  1394.         }
  1395.         Tcl_UpdateLinkedVar(interp, "real");
  1396.     }
  1397.     if (argv[4][0] != 0) {
  1398.         if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) {
  1399.         return TCL_ERROR;
  1400.         }
  1401.         Tcl_UpdateLinkedVar(interp, "bool");
  1402.     }
  1403.     if (argv[5][0] != 0) {
  1404.         if (stringVar != NULL) {
  1405.         ckfree(stringVar);
  1406.         }
  1407.         if (strcmp(argv[5], "-") == 0) {
  1408.         stringVar = NULL;
  1409.         } else {
  1410.         stringVar = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1));
  1411.         strcpy(stringVar, argv[5]);
  1412.         }
  1413.         Tcl_UpdateLinkedVar(interp, "string");
  1414.     }
  1415.     } else {
  1416.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  1417.         "\": should be create, delete, get, set, or update",
  1418.         (char *) NULL);
  1419.     return TCL_ERROR;
  1420.     }
  1421.     return TCL_OK;
  1422. }
  1423.  
  1424. /*
  1425.  *----------------------------------------------------------------------
  1426.  *
  1427.  * TestMathFunc --
  1428.  *
  1429.  *    This is a user-defined math procedure to test out math procedures
  1430.  *    with no arguments.
  1431.  *
  1432.  * Results:
  1433.  *    A normal Tcl completion code.
  1434.  *
  1435.  * Side effects:
  1436.  *    None.
  1437.  *
  1438.  *----------------------------------------------------------------------
  1439.  */
  1440.  
  1441.     /* ARGSUSED */
  1442. static int
  1443. TestMathFunc(clientData, interp, args, resultPtr)
  1444.     ClientData clientData;        /* Integer value to return. */
  1445.     Tcl_Interp *interp;            /* Not used. */
  1446.     Tcl_Value *args;            /* Not used. */
  1447.     Tcl_Value *resultPtr;        /* Where to store result. */
  1448. {
  1449.     resultPtr->type = TCL_INT;
  1450.     resultPtr->intValue = (int) clientData;
  1451.     return TCL_OK;
  1452. }
  1453.  
  1454. /*
  1455.  *----------------------------------------------------------------------
  1456.  *
  1457.  * CleanupTestSetassocdataTests --
  1458.  *
  1459.  *    This function is called when an interpreter is deleted to clean
  1460.  *    up any data left over from running the testsetassocdata command.
  1461.  *
  1462.  * Results:
  1463.  *    None.
  1464.  *
  1465.  * Side effects:
  1466.  *    Releases storage.
  1467.  *
  1468.  *----------------------------------------------------------------------
  1469.  */
  1470.     /* ARGSUSED */
  1471. static void
  1472. CleanupTestSetassocdataTests(clientData, interp)
  1473.     ClientData clientData;        /* Data to be released. */
  1474.     Tcl_Interp *interp;            /* Interpreter being deleted. */
  1475. {
  1476.     ckfree((char *) clientData);
  1477. }
  1478.  
  1479. /*
  1480.  *----------------------------------------------------------------------
  1481.  *
  1482.  * TestmodalCmd --
  1483.  *
  1484.  *    This procedure implements the "testmodal" command. It is used
  1485.  *    to test modal timeouts created by Tcl_CreateModalTimeout.
  1486.  *
  1487.  * Results:
  1488.  *    A standard Tcl result.
  1489.  *
  1490.  * Side effects:
  1491.  *    Modifies or creates an association between a key and associated
  1492.  *    data for this interpreter.
  1493.  *
  1494.  *----------------------------------------------------------------------
  1495.  */
  1496.  
  1497. static int
  1498. TestmodalCmd(clientData, interp, argc, argv)
  1499.     ClientData clientData;        /* Not used. */
  1500.     Tcl_Interp *interp;            /* Current interpreter. */
  1501.     int argc;                /* Number of arguments. */
  1502.     char **argv;            /* Argument strings. */
  1503. {
  1504. #define NUM_MODALS 10
  1505.     static Modal modals[NUM_MODALS];
  1506.     static int numModals = 0;
  1507.     int ms;
  1508.  
  1509.     if (argc < 2) {
  1510.         Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
  1511.                 " option ?arg arg ...?\"", (char *) NULL);
  1512.         return TCL_ERROR;
  1513.     }
  1514.  
  1515.     if (strcmp(argv[1], "create") == 0) {
  1516.     if (argc != 4) {
  1517.         Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
  1518.             " create ms key\"", (char *) NULL);
  1519.         return TCL_ERROR;
  1520.     }
  1521.     if (numModals >= NUM_MODALS) {
  1522.         interp->result = "too many modal timeouts";
  1523.         return TCL_ERROR;
  1524.     }
  1525.     if (Tcl_GetInt(interp, argv[2], &ms) != TCL_OK) {
  1526.         return TCL_ERROR;
  1527.     }
  1528.     modals[numModals].interp = interp;
  1529.     modals[numModals].key = (char *) ckalloc((unsigned)
  1530.         (strlen(argv[3]) + 1));
  1531.     strcpy(modals[numModals].key, argv[3]);
  1532.     Tcl_CreateModalTimeout(ms, ModalTimeoutProc,
  1533.         (ClientData) &modals[numModals]);
  1534.     numModals += 1;
  1535.     } else if (strcmp(argv[1], "delete") == 0) {
  1536.     if (numModals == 0) {
  1537.         interp->result = "no more modal timeouts";
  1538.         return TCL_ERROR;
  1539.     }
  1540.     numModals -= 1;
  1541.     ckfree(modals[numModals].key);
  1542.     Tcl_DeleteModalTimeout(ModalTimeoutProc,
  1543.         (ClientData) &modals[numModals]);
  1544.     } else if (strcmp(argv[1], "event") == 0) {
  1545.     Tcl_DoOneEvent(TCL_TIMER_EVENTS|TCL_DONT_WAIT);
  1546.     } else if (strcmp(argv[1], "eventnotimers") == 0) {
  1547.     Tcl_DoOneEvent(0x100000|TCL_DONT_WAIT);
  1548.     } else {
  1549.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  1550.         "\": must be create, delete, event, or eventnotimers",
  1551.         (char *) NULL);
  1552.     return TCL_ERROR;
  1553.     }
  1554.     return TCL_OK;
  1555. }
  1556.  
  1557. static void
  1558. ModalTimeoutProc(clientData)
  1559.     ClientData clientData;    /* Pointer to Modal structure. */
  1560. {
  1561.     Modal *modalPtr = (Modal *) clientData;
  1562.     Tcl_SetVar(modalPtr->interp, "x", modalPtr->key,
  1563.         TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
  1564. }
  1565.  
  1566. /*
  1567.  *----------------------------------------------------------------------
  1568.  *
  1569.  * TestsetassocdataCmd --
  1570.  *
  1571.  *    This procedure implements the "testsetassocdata" command. It is used
  1572.  *    to test Tcl_SetAssocData.
  1573.  *
  1574.  * Results:
  1575.  *    A standard Tcl result.
  1576.  *
  1577.  * Side effects:
  1578.  *    Modifies or creates an association between a key and associated
  1579.  *    data for this interpreter.
  1580.  *
  1581.  *----------------------------------------------------------------------
  1582.  */
  1583.  
  1584. static int
  1585. TestsetassocdataCmd(clientData, interp, argc, argv)
  1586.     ClientData clientData;        /* Not used. */
  1587.     Tcl_Interp *interp;            /* Current interpreter. */
  1588.     int argc;                /* Number of arguments. */
  1589.     char **argv;            /* Argument strings. */
  1590. {
  1591.     char *buf;
  1592.     
  1593.     if (argc != 3) {
  1594.         Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
  1595.                 " data_key data_item\"", (char *) NULL);
  1596.         return TCL_ERROR;
  1597.     }
  1598.  
  1599.     buf = ckalloc((unsigned) strlen(argv[2]) + 1);
  1600.     strcpy(buf, argv[2]);
  1601.     
  1602.     Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests, 
  1603.     (ClientData) buf);
  1604.     return TCL_OK;
  1605. }
  1606.  
  1607. /*
  1608.  *----------------------------------------------------------------------
  1609.  *
  1610.  * TestsetplatformCmd --
  1611.  *
  1612.  *    This procedure implements the "testsetplatform" command. It is
  1613.  *    used to change the tclPlatform global variable so all file
  1614.  *    name conversions can be tested on a single platform.
  1615.  *
  1616.  * Results:
  1617.  *    A standard Tcl result.
  1618.  *
  1619.  * Side effects:
  1620.  *    Sets the tclPlatform global variable.
  1621.  *
  1622.  *----------------------------------------------------------------------
  1623.  */
  1624.  
  1625. static int
  1626. TestsetplatformCmd(clientData, interp, argc, argv)
  1627.     ClientData clientData;        /* Not used. */
  1628.     Tcl_Interp *interp;            /* Current interpreter. */
  1629.     int argc;                /* Number of arguments. */
  1630.     char **argv;            /* Argument strings. */
  1631. {
  1632.     size_t length;
  1633.     TclPlatformType *platform;
  1634.  
  1635. #ifdef __WIN32__
  1636.     platform = TclWinGetPlatform();
  1637. #else
  1638.     #ifdef __EMX__
  1639.         platform = TclOS2GetPlatform();
  1640.     #else
  1641.         platform = &tclPlatform;
  1642.     #endif
  1643. #endif
  1644.     
  1645.     if (argc != 2) {
  1646.         Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
  1647.                 " platform\"", (char *) NULL);
  1648.         return TCL_ERROR;
  1649.     }
  1650.  
  1651.     length = strlen(argv[1]);
  1652.     if (strncmp(argv[1], "unix", length) == 0) {
  1653.     *platform = TCL_PLATFORM_UNIX;
  1654.     } else if (strncmp(argv[1], "mac", length) == 0) {
  1655.     *platform = TCL_PLATFORM_MAC;
  1656.     } else if (strncmp(argv[1], "windows", length) == 0) {
  1657.     *platform = TCL_PLATFORM_WINDOWS;
  1658.     } else {
  1659.         Tcl_AppendResult(interp, "unsupported platform: should be one of ",
  1660.         "unix, mac, or windows", (char *) NULL);
  1661.     return TCL_ERROR;
  1662.     }
  1663.     return TCL_OK;
  1664. }
  1665.  
  1666. /*
  1667.  *----------------------------------------------------------------------
  1668.  *
  1669.  * TeststaticpkgCmd --
  1670.  *
  1671.  *    This procedure implements the "teststaticpkg" command.
  1672.  *    It is used to test the procedure Tcl_StaticPackage.
  1673.  *
  1674.  * Results:
  1675.  *    A standard Tcl result.
  1676.  *
  1677.  * Side effects:
  1678.  *    When the packge given by argv[1] is loaded into an interpeter,
  1679.  *    variable "x" in that interpreter is set to "loaded".
  1680.  *
  1681.  *----------------------------------------------------------------------
  1682.  */
  1683.  
  1684. static int
  1685. TeststaticpkgCmd(dummy, interp, argc, argv)
  1686.     ClientData dummy;            /* Not used. */
  1687.     Tcl_Interp *interp;            /* Current interpreter. */
  1688.     int argc;                /* Number of arguments. */
  1689.     char **argv;            /* Argument strings. */
  1690. {
  1691.     int safe, loaded;
  1692.  
  1693.     if (argc != 4) {
  1694.     Tcl_AppendResult(interp, "wrong # arguments: should be \"",
  1695.         argv[0], " pkgName safe loaded\"", (char *) NULL);
  1696.     return TCL_ERROR;
  1697.     }
  1698.     if (Tcl_GetInt(interp, argv[2], &safe) != TCL_OK) {
  1699.     return TCL_ERROR;
  1700.     }
  1701.     if (Tcl_GetInt(interp, argv[3], &loaded) != TCL_OK) {
  1702.     return TCL_ERROR;
  1703.     }
  1704.     Tcl_StaticPackage((loaded) ? interp : NULL, argv[1], StaticInitProc,
  1705.         (safe) ? StaticInitProc : NULL);
  1706.     return TCL_OK;
  1707. }
  1708.  
  1709. static int
  1710. StaticInitProc(interp)
  1711.     Tcl_Interp *interp;            /* Interpreter in which package
  1712.                      * is supposedly being loaded. */
  1713. {
  1714.     Tcl_SetVar(interp, "x", "loaded", TCL_GLOBAL_ONLY);
  1715.     return TCL_OK;
  1716. }
  1717.  
  1718. /*
  1719.  *----------------------------------------------------------------------
  1720.  *
  1721.  * TesttranslatefilenameCmd --
  1722.  *
  1723.  *    This procedure implements the "testtranslatefilename" command.
  1724.  *    It is used to test the Tcl_TranslateFileName command.
  1725.  *
  1726.  * Results:
  1727.  *    A standard Tcl result.
  1728.  *
  1729.  * Side effects:
  1730.  *    None.
  1731.  *
  1732.  *----------------------------------------------------------------------
  1733.  */
  1734.  
  1735. static int
  1736. TesttranslatefilenameCmd(dummy, interp, argc, argv)
  1737.     ClientData dummy;            /* Not used. */
  1738.     Tcl_Interp *interp;            /* Current interpreter. */
  1739.     int argc;                /* Number of arguments. */
  1740.     char **argv;            /* Argument strings. */
  1741. {
  1742.     Tcl_DString buffer;
  1743.     char *result;
  1744.  
  1745.     if (argc != 2) {
  1746.     Tcl_AppendResult(interp, "wrong # arguments: should be \"",
  1747.         argv[0], " path\"", (char *) NULL);
  1748.     return TCL_ERROR;
  1749.     }
  1750.     result = Tcl_TranslateFileName(interp, argv[1], &buffer);
  1751.     if (result == NULL) {
  1752.     return TCL_ERROR;
  1753.     }
  1754.     Tcl_AppendResult(interp, result, NULL);
  1755.     Tcl_DStringFree(&buffer);
  1756.     return TCL_OK;
  1757. }
  1758.  
  1759. /*
  1760.  *----------------------------------------------------------------------
  1761.  *
  1762.  * TestupvarCmd --
  1763.  *
  1764.  *    This procedure implements the "testupvar2" command.  It is used
  1765.  *    to test Tcl_UpVar and Tcl_UpVar2.
  1766.  *
  1767.  * Results:
  1768.  *    A standard Tcl result.
  1769.  *
  1770.  * Side effects:
  1771.  *    Creates or modifies an "upvar" reference.
  1772.  *
  1773.  *----------------------------------------------------------------------
  1774.  */
  1775.  
  1776.     /* ARGSUSED */
  1777. static int
  1778. TestupvarCmd(dummy, interp, argc, argv)
  1779.     ClientData dummy;            /* Not used. */
  1780.     Tcl_Interp *interp;            /* Current interpreter. */
  1781.     int argc;                /* Number of arguments. */
  1782.     char **argv;            /* Argument strings. */
  1783. {
  1784.     if ((argc != 5) && (argc != 6)) {
  1785.     Tcl_AppendResult(interp, "wrong # arguments: should be \"",
  1786.         argv[0], " level name ?name2? dest global\"", (char *) NULL);
  1787.     return TCL_ERROR;
  1788.     }
  1789.  
  1790.     if (argc == 5) {
  1791.     return Tcl_UpVar(interp, argv[1], argv[2], argv[3],
  1792.         (strcmp(argv[4], "global") == 0) ? TCL_GLOBAL_ONLY : 0);
  1793.     } else {
  1794.     return Tcl_UpVar2(interp, argv[1], argv[2], 
  1795.         (argv[3][0] == 0) ? (char *) NULL : argv[3], argv[4],
  1796.         (strcmp(argv[5], "global") == 0) ? TCL_GLOBAL_ONLY : 0);
  1797.     }
  1798. }
  1799.  
  1800. /*
  1801.  *----------------------------------------------------------------------
  1802.  *
  1803.  * TestwordendCmd --
  1804.  *
  1805.  *    This procedure implements the "testwordend" command.  It is used
  1806.  *    to test TclWordEnd.
  1807.  *
  1808.  * Results:
  1809.  *    A standard Tcl result.
  1810.  *
  1811.  * Side effects:
  1812.  *    None.
  1813.  *
  1814.  *----------------------------------------------------------------------
  1815.  */
  1816.  
  1817.     /* ARGSUSED */
  1818. static int
  1819. TestwordendCmd(dummy, interp, argc, argv)
  1820.     ClientData dummy;            /* Not used. */
  1821.     Tcl_Interp *interp;            /* Current interpreter. */
  1822.     int argc;                /* Number of arguments. */
  1823.     char **argv;            /* Argument strings. */
  1824. {
  1825.     if (argc != 2) {
  1826.     Tcl_AppendResult(interp, "wrong # arguments: should be \"",
  1827.         argv[0], " string\"", (char *) NULL);
  1828.     return TCL_ERROR;
  1829.     }
  1830.     Tcl_SetResult(interp, TclWordEnd(argv[1], 0, (int *) NULL), TCL_VOLATILE);
  1831.     return TCL_OK;
  1832. }
  1833.  
  1834. /*
  1835.  *----------------------------------------------------------------------
  1836.  *
  1837.  * TestfeventCmd --
  1838.  *
  1839.  *    This procedure implements the "testfevent" command.  It is
  1840.  *    used for testing the "fileevent" command.
  1841.  *
  1842.  * Results:
  1843.  *    A standard Tcl result.
  1844.  *
  1845.  * Side effects:
  1846.  *    Creates and deletes interpreters.
  1847.  *
  1848.  *----------------------------------------------------------------------
  1849.  */
  1850.  
  1851.     /* ARGSUSED */
  1852. static int
  1853. TestfeventCmd(clientData, interp, argc, argv)
  1854.     ClientData clientData;        /* Not used. */
  1855.     Tcl_Interp *interp;            /* Current interpreter. */
  1856.     int argc;                /* Number of arguments. */
  1857.     char **argv;            /* Argument strings. */
  1858. {
  1859.     static Tcl_Interp *interp2 = NULL;
  1860.     int code;
  1861.     Tcl_Channel chan;
  1862.  
  1863.     if (argc < 2) {
  1864.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1865.         " option ?arg arg ...?", (char *) NULL);
  1866.     return TCL_ERROR;
  1867.     }
  1868.     if (strcmp(argv[1], "cmd") == 0) {
  1869.     if (argc != 3) {
  1870.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1871.             " cmd script", (char *) NULL);
  1872.         return TCL_ERROR;
  1873.     }
  1874.         if (interp2 != (Tcl_Interp *) NULL) {
  1875.             code = Tcl_GlobalEval(interp2, argv[2]);
  1876.             interp->result = interp2->result;
  1877.             return code;
  1878.         } else {
  1879.             Tcl_AppendResult(interp,
  1880.                     "called \"testfevent code\" before \"testfevent create\"",
  1881.                     (char *) NULL);
  1882.             return TCL_ERROR;
  1883.         }
  1884.     } else if (strcmp(argv[1], "create") == 0) {
  1885.     if (interp2 != NULL) {
  1886.             Tcl_DeleteInterp(interp2);
  1887.     }
  1888.         interp2 = Tcl_CreateInterp();
  1889.     return TCL_OK;
  1890.     } else if (strcmp(argv[1], "delete") == 0) {
  1891.     if (interp2 != NULL) {
  1892.             Tcl_DeleteInterp(interp2);
  1893.     }
  1894.     interp2 = NULL;
  1895.     } else if (strcmp(argv[1], "share") == 0) {
  1896.         if (interp2 != NULL) {
  1897.             chan = Tcl_GetChannel(interp, argv[2], NULL);
  1898.             if (chan == (Tcl_Channel) NULL) {
  1899.                 return TCL_ERROR;
  1900.             }
  1901.             Tcl_RegisterChannel(interp2, chan);
  1902.         }
  1903.     }
  1904.     
  1905.     return TCL_OK;
  1906. }
  1907.  
  1908. /*
  1909.  *----------------------------------------------------------------------
  1910.  *
  1911.  * TestPanicCmd --
  1912.  *
  1913.  *    Calls the panic routine.
  1914.  *
  1915.  * Results:
  1916.  *      Always returns TCL_OK. 
  1917.  *
  1918.  * Side effects:
  1919.  *    May exit application.
  1920.  *
  1921.  *----------------------------------------------------------------------
  1922.  */
  1923.  
  1924. static int
  1925. TestPanicCmd(dummy, interp, argc, argv)
  1926.     ClientData dummy;            /* Not used. */
  1927.     Tcl_Interp *interp;            /* Current interpreter. */
  1928.     int argc;                /* Number of arguments. */
  1929.     char **argv;            /* Argument strings. */
  1930. {
  1931.     char *argString;
  1932.     
  1933.     /*
  1934.      *  Put the arguments into a var args structure
  1935.      *  Append all of the arguments together separated by spaces
  1936.      */
  1937.  
  1938.     argString = Tcl_Merge(argc-1, argv+1);
  1939.     panic(argString);
  1940.     ckfree(argString);
  1941.  
  1942.     return TCL_OK;
  1943. }
  1944.