home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tcl2-73c.zip / tcl7.3 / tclTest.c < prev    next >
C/C++ Source or Header  |  1993-10-23  |  23KB  |  787 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 The Regents of the University of California.
  10.  * All rights reserved.
  11.  *
  12.  * Permission is hereby granted, without written agreement and without
  13.  * license or royalty fees, to use, copy, modify, and distribute this
  14.  * software and its documentation for any purpose, provided that the
  15.  * above copyright notice and the following two paragraphs appear in
  16.  * all copies of this software.
  17.  * 
  18.  * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  19.  * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  20.  * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  21.  * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  22.  *
  23.  * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  24.  * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  25.  * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  26.  * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  27.  * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  28.  */
  29.  
  30. #ifndef lint
  31. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclTest.c,v 1.15 93/09/09 16:46:52 ouster Exp $ SPRITE (Berkeley)";
  32. #endif /* not lint */
  33.  
  34. #include "tclInt.h"
  35. #include "tclUnix.h"
  36.  
  37. /*
  38.  * The following variable is a special hack that allows applications
  39.  * to be linked using the procedure "main" from the Tcl library.  The
  40.  * variable generates a reference to "main", which causes main to
  41.  * be brought in from the library (and all of Tcl with it).
  42.  */
  43.  
  44. extern int main();
  45. int *tclDummyMainPtr = (int *) main;
  46.  
  47. /*
  48.  * Dynamic string shared by TestdcallCmd and DelCallbackProc;  used
  49.  * to collect the results of the various deletion callbacks.
  50.  */
  51.  
  52. static Tcl_DString delString;
  53. static Tcl_Interp *delInterp;
  54.  
  55. /*
  56.  * One of the following structures exists for each asynchronous
  57.  * handler created by the "testasync" command".
  58.  */
  59.  
  60. typedef struct TestAsyncHandler {
  61.     int id;                /* Identifier for this handler. */
  62.     Tcl_AsyncHandler handler;        /* Tcl's token for the handler. */
  63.     char *command;            /* Command to invoke when the
  64.                      * handler is invoked. */
  65.     struct TestAsyncHandler *nextPtr;    /* Next is list of handlers. */
  66. } TestAsyncHandler;
  67.  
  68. static TestAsyncHandler *firstHandler = NULL;
  69.  
  70. /*
  71.  * The variable below is a token for an asynchronous handler for
  72.  * interrupt signals, or NULL if none exists.
  73.  */
  74.  
  75. static Tcl_AsyncHandler intHandler;
  76.  
  77. /*
  78.  * The dynamic string below is used by the "testdstring" command
  79.  * to test the dynamic string facilities.
  80.  */
  81.  
  82. static Tcl_DString dstring;
  83.  
  84. /*
  85.  * Forward declarations for procedures defined later in this file:
  86.  */
  87.  
  88. static int        AsyncHandlerProc _ANSI_ARGS_((ClientData clientData,
  89.                 Tcl_Interp *interp, int code));
  90. static void        CmdDelProc1 _ANSI_ARGS_((ClientData clientData));
  91. static void        CmdDelProc2 _ANSI_ARGS_((ClientData clientData));
  92. static int        CmdProc1 _ANSI_ARGS_((ClientData clientData,
  93.                 Tcl_Interp *interp, int argc, char **argv));
  94. static int        CmdProc2 _ANSI_ARGS_((ClientData clientData,
  95.                 Tcl_Interp *interp, int argc, char **argv));
  96. static void        DelCallbackProc _ANSI_ARGS_((ClientData clientData,
  97.                 Tcl_Interp *interp));
  98. static int        IntHandlerProc _ANSI_ARGS_((ClientData clientData,
  99.                 Tcl_Interp *interp, int code));
  100. static void        IntProc();
  101. static int        TestasyncCmd _ANSI_ARGS_((ClientData dummy,
  102.                 Tcl_Interp *interp, int argc, char **argv));
  103. static int        TestcmdinfoCmd _ANSI_ARGS_((ClientData dummy,
  104.                 Tcl_Interp *interp, int argc, char **argv));
  105. static int        TestdcallCmd _ANSI_ARGS_((ClientData dummy,
  106.                 Tcl_Interp *interp, int argc, char **argv));
  107. static int        TestdstringCmd _ANSI_ARGS_((ClientData dummy,
  108.                 Tcl_Interp *interp, int argc, char **argv));
  109. static int        TestlinkCmd _ANSI_ARGS_((ClientData dummy,
  110.                 Tcl_Interp *interp, int argc, char **argv));
  111. static int        TestMathFunc _ANSI_ARGS_((ClientData clientData,
  112.                 Tcl_Interp *interp, Tcl_Value *args,
  113.                 Tcl_Value *resultPtr));
  114.  
  115. /*
  116.  *----------------------------------------------------------------------
  117.  *
  118.  * Tcl_AppInit --
  119.  *
  120.  *    This procedure performs application-specific initialization.
  121.  *    Most applications, especially those that incorporate additional
  122.  *    packages, will have their own version of this procedure.
  123.  *
  124.  * Results:
  125.  *    Returns a standard Tcl completion code, and leaves an error
  126.  *    message in interp->result if an error occurs.
  127.  *
  128.  * Side effects:
  129.  *    Depends on the startup script.
  130.  *
  131.  *----------------------------------------------------------------------
  132.  */
  133.  
  134. int
  135. Tcl_AppInit(interp)
  136.     Tcl_Interp *interp;        /* Interpreter for application. */
  137. {
  138.     /*
  139.      * Call the init procedures for included packages.  Each call should
  140.      * look like this:
  141.      *
  142.      * if (Mod_Init(interp) == TCL_ERROR) {
  143.      *     return TCL_ERROR;
  144.      * }
  145.      *
  146.      * where "Mod" is the name of the module.
  147.      */
  148.  
  149.     if (Tcl_Init(interp) == TCL_ERROR) {
  150.     return TCL_ERROR;
  151.     }
  152.  
  153.     /*
  154.      * Create additional commands and math functions for testing Tcl.
  155.      */
  156.  
  157.     Tcl_CreateCommand(interp, "testasync", TestasyncCmd, (ClientData) 0,
  158.         (Tcl_CmdDeleteProc *) NULL);
  159.     Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, (ClientData) 0,
  160.         (Tcl_CmdDeleteProc *) NULL);
  161.     Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, (ClientData) 0,
  162.         (Tcl_CmdDeleteProc *) NULL);
  163.     Tcl_DStringInit(&dstring);
  164.     Tcl_CreateCommand(interp, "testdstring", TestdstringCmd, (ClientData) 0,
  165.         (Tcl_CmdDeleteProc *) NULL);
  166.     Tcl_CreateCommand(interp, "testlink", TestlinkCmd, (ClientData) 0,
  167.         (Tcl_CmdDeleteProc *) NULL);
  168.     Tcl_CreateMathFunc(interp, "T1", 0, (Tcl_ValueType *) NULL, TestMathFunc,
  169.         (ClientData) 123);
  170.     Tcl_CreateMathFunc(interp, "T2", 0, (Tcl_ValueType *) NULL, TestMathFunc,
  171.         (ClientData) 345);
  172.  
  173.     /*
  174.      * Specify a user-specific startup file to invoke if the application
  175.      * is run interactively.  If this line is deleted then no user-specific
  176.      * startup file will be run under any conditions.
  177.      */
  178.  
  179.     tcl_RcFileName = "~/.tclshrc";
  180.     return TCL_OK;
  181. }
  182.  
  183. /*
  184.  *----------------------------------------------------------------------
  185.  *
  186.  * TestasyncCmd --
  187.  *
  188.  *    This procedure implements the "testasync" command.  It is used
  189.  *    to test the asynchronous handler facilities of Tcl.
  190.  *
  191.  * Results:
  192.  *    A standard Tcl result.
  193.  *
  194.  * Side effects:
  195.  *    Creates, deletes, and invokes handlers.
  196.  *
  197.  *----------------------------------------------------------------------
  198.  */
  199.  
  200.     /* ARGSUSED */
  201. static int
  202. TestasyncCmd(dummy, interp, argc, argv)
  203.     ClientData dummy;            /* Not used. */
  204.     Tcl_Interp *interp;            /* Current interpreter. */
  205.     int argc;                /* Number of arguments. */
  206.     char **argv;            /* Argument strings. */
  207. {
  208.     TestAsyncHandler *asyncPtr, *prevPtr;
  209.     int id, code;
  210.     static int nextId = 1;
  211.  
  212.     if (argc < 2) {
  213.     wrongNumArgs:
  214.     interp->result = "wrong # args";
  215.     return TCL_ERROR;
  216.     }
  217.     if (strcmp(argv[1], "create") == 0) {
  218.     if (argc != 3) {
  219.         goto wrongNumArgs;
  220.     }
  221.     asyncPtr = (TestAsyncHandler *) ckalloc(sizeof(TestAsyncHandler));
  222.     asyncPtr->id = nextId;
  223.     nextId++;
  224.     asyncPtr->handler = Tcl_AsyncCreate(AsyncHandlerProc,
  225.         (ClientData) asyncPtr);
  226.     asyncPtr->command = ckalloc((unsigned) (strlen(argv[2]) + 1));
  227.     strcpy(asyncPtr->command, argv[2]);
  228.     asyncPtr->nextPtr = firstHandler;
  229.     firstHandler = asyncPtr;
  230.     sprintf(interp->result, "%d", asyncPtr->id);
  231.     } else if (strcmp(argv[1], "delete") == 0) {
  232.     if (argc == 2) {
  233.         while (firstHandler != NULL) {
  234.         asyncPtr = firstHandler;
  235.         firstHandler = asyncPtr->nextPtr;
  236.         Tcl_AsyncDelete(asyncPtr->handler);
  237.         ckfree(asyncPtr->command);
  238.         ckfree((char *) asyncPtr);
  239.         }
  240.         return TCL_OK;
  241.     }
  242.     if (argc != 3) {
  243.         goto wrongNumArgs;
  244.     }
  245.     if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) {
  246.         return TCL_ERROR;
  247.     }
  248.     for (prevPtr = NULL, asyncPtr = firstHandler; asyncPtr != NULL;
  249.         prevPtr = asyncPtr, asyncPtr = asyncPtr->nextPtr) {
  250.         if (asyncPtr->id != id) {
  251.         continue;
  252.         }
  253.         if (prevPtr == NULL) {
  254.         firstHandler = asyncPtr->nextPtr;
  255.         } else {
  256.         prevPtr->nextPtr = asyncPtr->nextPtr;
  257.         }
  258.         Tcl_AsyncDelete(asyncPtr->handler);
  259.         ckfree(asyncPtr->command);
  260.         ckfree((char *) asyncPtr);
  261.         break;
  262.     }
  263.     } else if (strcmp(argv[1], "int") == 0) {
  264.     if (argc != 2) {
  265.         goto wrongNumArgs;
  266.     }
  267.     intHandler = Tcl_AsyncCreate(IntHandlerProc, (ClientData) interp);
  268.     signal(SIGINT, IntProc);
  269.     } else if (strcmp(argv[1], "mark") == 0) {
  270.     if (argc != 5) {
  271.         goto wrongNumArgs;
  272.     }
  273.     if ((Tcl_GetInt(interp, argv[2], &id) != TCL_OK)
  274.         || (Tcl_GetInt(interp, argv[4], &code) != TCL_OK)) {
  275.         return TCL_ERROR;
  276.     }
  277.     for (asyncPtr = firstHandler; asyncPtr != NULL;
  278.         asyncPtr = asyncPtr->nextPtr) {
  279.         if (asyncPtr->id == id) {
  280.         Tcl_AsyncMark(asyncPtr->handler);
  281.         break;
  282.         }
  283.     }
  284.     Tcl_SetResult(interp, argv[3], TCL_VOLATILE);
  285.     return code;
  286.     } else {
  287.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  288.         "\": must be create, delete, int, or mark",
  289.         (char *) NULL);
  290.     return TCL_ERROR;
  291.     }
  292.     return TCL_OK;
  293. }
  294.  
  295. static int
  296. AsyncHandlerProc(clientData, interp, code)
  297.     ClientData clientData;    /* Pointer to TestAsyncHandler structure. */
  298.     Tcl_Interp *interp;        /* Interpreter in which command was
  299.                  * executed, or NULL. */
  300.     int code;            /* Current return code from command. */
  301. {
  302.     TestAsyncHandler *asyncPtr = (TestAsyncHandler *) clientData;
  303.     char *listArgv[4];
  304.     char string[20], *cmd;
  305.  
  306.     sprintf(string, "%d", code);
  307.     listArgv[0] = asyncPtr->command;
  308.     listArgv[1] = interp->result;
  309.     listArgv[2] = string;
  310.     listArgv[3] = NULL;
  311.     cmd = Tcl_Merge(3, listArgv);
  312.     code = Tcl_Eval(interp, cmd);
  313.     ckfree(cmd);
  314.     return code;
  315. }
  316.  
  317. static void
  318. IntProc()
  319. {
  320.     Tcl_AsyncMark(intHandler);
  321. }
  322.  
  323. static int
  324. IntHandlerProc(clientData, interp, code)
  325.     ClientData clientData;    /* Interpreter in which to invoke command. */
  326.     Tcl_Interp *interp;        /* Interpreter in which command was
  327.                  * executed, or NULL. */
  328.     int code;            /* Current return code from command. */
  329. {
  330.     char *listArgv[4];
  331.     char string[20], *cmd;
  332.  
  333.     interp = (Tcl_Interp *) clientData;
  334.     listArgv[0] = Tcl_GetVar(interp, "sigIntCmd", TCL_GLOBAL_ONLY);
  335.     if (listArgv[0] == NULL) {
  336.     return code;
  337.     }
  338.     listArgv[1] = interp->result;
  339.     sprintf(string, "%d", code);
  340.     listArgv[2] = string;
  341.     listArgv[3] = NULL;
  342.     cmd = Tcl_Merge(3, listArgv);
  343.     code = Tcl_Eval(interp, cmd);
  344.     ckfree(cmd);
  345.     return code;
  346. }
  347.  
  348. /*
  349.  *----------------------------------------------------------------------
  350.  *
  351.  * TestdcallCmd --
  352.  *
  353.  *    This procedure implements the "testdcall" command.  It is used
  354.  *    to test Tcl_CallWhenDeleted.
  355.  *
  356.  * Results:
  357.  *    A standard Tcl result.
  358.  *
  359.  * Side effects:
  360.  *    Creates and deletes interpreters.
  361.  *
  362.  *----------------------------------------------------------------------
  363.  */
  364.  
  365.     /* ARGSUSED */
  366. static int
  367. TestdcallCmd(dummy, interp, argc, argv)
  368.     ClientData dummy;            /* Not used. */
  369.     Tcl_Interp *interp;            /* Current interpreter. */
  370.     int argc;                /* Number of arguments. */
  371.     char **argv;            /* Argument strings. */
  372. {
  373.     int i, id;
  374.  
  375.     delInterp = Tcl_CreateInterp();
  376.     Tcl_DStringInit(&delString);
  377.     for (i = 1; i < argc; i++) {
  378.     if (Tcl_GetInt(interp, argv[i], &id) != TCL_OK) {
  379.         return TCL_ERROR;
  380.     }
  381.     if (id < 0) {
  382.         Tcl_DontCallWhenDeleted(delInterp, DelCallbackProc,
  383.             (ClientData) (-id));
  384.     } else {
  385.         Tcl_CallWhenDeleted(delInterp, DelCallbackProc,
  386.             (ClientData) id);
  387.     }
  388.     }
  389.     Tcl_DeleteInterp(delInterp);
  390.     Tcl_DStringResult(interp, &delString);
  391.     return TCL_OK;
  392. }
  393.  
  394. /*
  395.  * The deletion callback used by TestdcallCmd:
  396.  */
  397.  
  398. static void
  399. DelCallbackProc(clientData, interp)
  400.     ClientData clientData;        /* Numerical value to append to
  401.                      * delString. */
  402.     Tcl_Interp *interp;            /* Interpreter being deleted. */
  403. {
  404.     int id = (int) clientData;
  405.     char buffer[10];
  406.  
  407.     sprintf(buffer, "%d", id);
  408.     Tcl_DStringAppendElement(&delString, buffer);
  409.     if (interp != delInterp) {
  410.     Tcl_DStringAppendElement(&delString, "bogus interpreter argument!");
  411.     }
  412. }
  413.  
  414. /*
  415.  *----------------------------------------------------------------------
  416.  *
  417.  * TestcmdinfoCmd --
  418.  *
  419.  *    This procedure implements the "testcmdinfo" command.  It is used
  420.  *    to test Tcl_GetCmdInfo, Tcl_SetCmdInfo, and command creation
  421.  *    and deletion.
  422.  *
  423.  * Results:
  424.  *    A standard Tcl result.
  425.  *
  426.  * Side effects:
  427.  *    Creates and deletes various commands and modifies their data.
  428.  *
  429.  *----------------------------------------------------------------------
  430.  */
  431.  
  432.     /* ARGSUSED */
  433. static int
  434. TestcmdinfoCmd(dummy, interp, argc, argv)
  435.     ClientData dummy;            /* Not used. */
  436.     Tcl_Interp *interp;            /* Current interpreter. */
  437.     int argc;                /* Number of arguments. */
  438.     char **argv;            /* Argument strings. */
  439. {
  440.     Tcl_CmdInfo info;
  441.  
  442.     if (argc != 3) {
  443.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  444.         " option cmdName\"", (char *) NULL);
  445.     return TCL_ERROR;
  446.     }
  447.     if (strcmp(argv[1], "create") == 0) {
  448.     Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original",
  449.         CmdDelProc1);
  450.     } else if (strcmp(argv[1], "delete") == 0) {
  451.     Tcl_DStringInit(&delString);
  452.     Tcl_DeleteCommand(interp, argv[2]);
  453.     Tcl_DStringResult(interp, &delString);
  454.     } else if (strcmp(argv[1], "get") == 0) {
  455.     if (Tcl_GetCommandInfo(interp, argv[2], &info) ==0) {
  456.         interp->result = "??";
  457.         return TCL_OK;
  458.     }
  459.     if (info.proc == CmdProc1) {
  460.         Tcl_AppendResult(interp, "CmdProc1", " ",
  461.             (char *) info.clientData, (char *) NULL);
  462.     } else if (info.proc == CmdProc2) {
  463.         Tcl_AppendResult(interp, "CmdProc2", " ",
  464.             (char *) info.clientData, (char *) NULL);
  465.     } else {
  466.         Tcl_AppendResult(interp, "unknown", (char *) NULL);
  467.     }
  468.     if (info.deleteProc == CmdDelProc1) {
  469.         Tcl_AppendResult(interp, " CmdDelProc1", " ",
  470.             (char *) info.deleteData, (char *) NULL);
  471.     } else if (info.deleteProc == CmdDelProc2) {
  472.         Tcl_AppendResult(interp, " CmdDelProc2", " ",
  473.             (char *) info.deleteData, (char *) NULL);
  474.     } else {
  475.         Tcl_AppendResult(interp, " unknown", (char *) NULL);
  476.     }
  477.     } else if (strcmp(argv[1], "modify") == 0) {
  478.     info.proc = CmdProc2;
  479.     info.clientData = (ClientData) "new_command_data";
  480.     info.deleteProc = CmdDelProc2;
  481.     info.deleteData = (ClientData) "new_delete_data";
  482.     if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) {
  483.         interp->result = "0";
  484.     } else {
  485.         interp->result = "1";
  486.     }
  487.     } else {
  488.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  489.         "\": must be create, delete, get, or modify",
  490.         (char *) NULL);
  491.     return TCL_ERROR;
  492.     }
  493.     return TCL_OK;
  494. }
  495.  
  496.     /*ARGSUSED*/
  497. static int
  498. CmdProc1(clientData, interp, argc, argv)
  499.     ClientData clientData;        /* String to return. */
  500.     Tcl_Interp *interp;            /* Current interpreter. */
  501.     int argc;                /* Number of arguments. */
  502.     char **argv;            /* Argument strings. */
  503. {
  504.     Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData,
  505.         (char *) NULL);
  506.     return TCL_OK;
  507. }
  508.  
  509.     /*ARGSUSED*/
  510. static int
  511. CmdProc2(clientData, interp, argc, argv)
  512.     ClientData clientData;        /* String to return. */
  513.     Tcl_Interp *interp;            /* Current interpreter. */
  514.     int argc;                /* Number of arguments. */
  515.     char **argv;            /* Argument strings. */
  516. {
  517.     Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData,
  518.         (char *) NULL);
  519.     return TCL_OK;
  520. }
  521.  
  522. static void
  523. CmdDelProc1(clientData)
  524.     ClientData clientData;        /* String to save. */
  525. {
  526.     Tcl_DStringInit(&delString);
  527.     Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1);
  528.     Tcl_DStringAppend(&delString, (char *) clientData, -1);
  529. }
  530.  
  531. static void
  532. CmdDelProc2(clientData)
  533.     ClientData clientData;        /* String to save. */
  534. {
  535.     Tcl_DStringInit(&delString);
  536.     Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1);
  537.     Tcl_DStringAppend(&delString, (char *) clientData, -1);
  538. }
  539.  
  540. /*
  541.  *----------------------------------------------------------------------
  542.  *
  543.  * TestdstringCmd --
  544.  *
  545.  *    This procedure implements the "testdstring" command.  It is used
  546.  *    to test the dynamic string facilities of Tcl.
  547.  *
  548.  * Results:
  549.  *    A standard Tcl result.
  550.  *
  551.  * Side effects:
  552.  *    Creates, deletes, and invokes handlers.
  553.  *
  554.  *----------------------------------------------------------------------
  555.  */
  556.  
  557.     /* ARGSUSED */
  558. static int
  559. TestdstringCmd(dummy, interp, argc, argv)
  560.     ClientData dummy;            /* Not used. */
  561.     Tcl_Interp *interp;            /* Current interpreter. */
  562.     int argc;                /* Number of arguments. */
  563.     char **argv;            /* Argument strings. */
  564. {
  565.     int count;
  566.  
  567.     if (argc < 2) {
  568.     wrongNumArgs:
  569.     interp->result = "wrong # args";
  570.     return TCL_ERROR;
  571.     }
  572.     if (strcmp(argv[1], "append") == 0) {
  573.     if (argc != 4) {
  574.         goto wrongNumArgs;
  575.     }
  576.     if (Tcl_GetInt(interp, argv[3], &count) != TCL_OK) {
  577.         return TCL_ERROR;
  578.     }
  579.     Tcl_DStringAppend(&dstring, argv[2], count);
  580.     } else if (strcmp(argv[1], "element") == 0) {
  581.     if (argc != 3) {
  582.         goto wrongNumArgs;
  583.     }
  584.     Tcl_DStringAppendElement(&dstring, argv[2]);
  585.     } else if (strcmp(argv[1], "end") == 0) {
  586.     if (argc != 2) {
  587.         goto wrongNumArgs;
  588.     }
  589.     Tcl_DStringEndSublist(&dstring);
  590.     } else if (strcmp(argv[1], "free") == 0) {
  591.     if (argc != 2) {
  592.         goto wrongNumArgs;
  593.     }
  594.     Tcl_DStringFree(&dstring);
  595.     } else if (strcmp(argv[1], "get") == 0) {
  596.     if (argc != 2) {
  597.         goto wrongNumArgs;
  598.     }
  599.     interp->result = Tcl_DStringValue(&dstring);
  600.     } else if (strcmp(argv[1], "length") == 0) {
  601.     if (argc != 2) {
  602.         goto wrongNumArgs;
  603.     }
  604.     sprintf(interp->result, "%d", Tcl_DStringLength(&dstring));
  605.     } else if (strcmp(argv[1], "result") == 0) {
  606.     if (argc != 2) {
  607.         goto wrongNumArgs;
  608.     }
  609.     Tcl_DStringResult(interp, &dstring);
  610.     } else if (strcmp(argv[1], "trunc") == 0) {
  611.     if (argc != 3) {
  612.         goto wrongNumArgs;
  613.     }
  614.     if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) {
  615.         return TCL_ERROR;
  616.     }
  617.     Tcl_DStringTrunc(&dstring, count);
  618.     } else if (strcmp(argv[1], "start") == 0) {
  619.     if (argc != 2) {
  620.         goto wrongNumArgs;
  621.     }
  622.     Tcl_DStringStartSublist(&dstring);
  623.     } else {
  624.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  625.         "\": must be append, element, end, free, get, length, ",
  626.         "result, trunc, or start", (char *) NULL);
  627.     return TCL_ERROR;
  628.     }
  629.     return TCL_OK;
  630. }
  631.  
  632. /*
  633.  *----------------------------------------------------------------------
  634.  *
  635.  * TestlinkCmd --
  636.  *
  637.  *    This procedure implements the "testlink" command.  It is used
  638.  *    to test Tcl_LinkVar and related library procedures.
  639.  *
  640.  * Results:
  641.  *    A standard Tcl result.
  642.  *
  643.  * Side effects:
  644.  *    Creates and deletes various variable links, plus returns
  645.  *    values of the linked variables.
  646.  *
  647.  *----------------------------------------------------------------------
  648.  */
  649.  
  650.     /* ARGSUSED */
  651. static int
  652. TestlinkCmd(dummy, interp, argc, argv)
  653.     ClientData dummy;            /* Not used. */
  654.     Tcl_Interp *interp;            /* Current interpreter. */
  655.     int argc;                /* Number of arguments. */
  656.     char **argv;            /* Argument strings. */
  657. {
  658.     static int intVar = 43;
  659.     static int boolVar = 4;
  660.     static double realVar = 1.23;
  661.     static char *stringVar = NULL;
  662.     char buffer[TCL_DOUBLE_SPACE];
  663.     int writable, flag;
  664.  
  665.     if (argc < 2) {
  666.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  667.         " option ?arg arg arg?\"", (char *) NULL);
  668.     return TCL_ERROR;
  669.     }
  670.     if (strcmp(argv[1], "create") == 0) {
  671.     if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) {
  672.         return TCL_ERROR;
  673.     }
  674.     flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
  675.     if (Tcl_LinkVar(interp, "int", (char *) &intVar,
  676.         TCL_LINK_INT | flag) != TCL_OK) {
  677.         return TCL_ERROR;
  678.     }
  679.     if (Tcl_GetBoolean(interp, argv[3], &writable) != TCL_OK) {
  680.         return TCL_ERROR;
  681.     }
  682.     flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
  683.     if (Tcl_LinkVar(interp, "real", (char *) &realVar,
  684.         TCL_LINK_DOUBLE | flag) != TCL_OK) {
  685.         return TCL_ERROR;
  686.     }
  687.     if (Tcl_GetBoolean(interp, argv[4], &writable) != TCL_OK) {
  688.         return TCL_ERROR;
  689.     }
  690.     flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
  691.     if (Tcl_LinkVar(interp, "bool", (char *) &boolVar,
  692.         TCL_LINK_BOOLEAN | flag) != TCL_OK) {
  693.         return TCL_ERROR;
  694.     }
  695.     if (Tcl_GetBoolean(interp, argv[5], &writable) != TCL_OK) {
  696.         return TCL_ERROR;
  697.     }
  698.     flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
  699.     if (Tcl_LinkVar(interp, "string", (char *) &stringVar,
  700.         TCL_LINK_STRING | flag) != TCL_OK) {
  701.         return TCL_ERROR;
  702.     }
  703.     } else if (strcmp(argv[1], "delete") == 0) {
  704.     Tcl_UnlinkVar(interp, "int");
  705.     Tcl_UnlinkVar(interp, "real");
  706.     Tcl_UnlinkVar(interp, "bool");
  707.     Tcl_UnlinkVar(interp, "string");
  708.     } else if (strcmp(argv[1], "get") == 0) {
  709.     sprintf(buffer, "%d", intVar);
  710.     Tcl_AppendElement(interp, buffer);
  711.     Tcl_PrintDouble(interp, realVar, buffer);
  712.     Tcl_AppendElement(interp, buffer);
  713.     sprintf(buffer, "%d", boolVar);
  714.     Tcl_AppendElement(interp, buffer);
  715.     Tcl_AppendElement(interp, (stringVar == NULL) ? "-" : stringVar);
  716.     } else if (strcmp(argv[1], "set") == 0) {
  717.     if (argc != 6) {
  718.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  719.         argv[0], " ", argv[1],
  720.         "intValue realValue boolValue stringValue\"", (char *) NULL);
  721.         return TCL_ERROR;
  722.     }
  723.     if (argv[2][0] != 0) {
  724.         if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) {
  725.         return TCL_ERROR;
  726.         }
  727.     }
  728.     if (argv[3][0] != 0) {
  729.         if (Tcl_GetDouble(interp, argv[3], &realVar) != TCL_OK) {
  730.         return TCL_ERROR;
  731.         }
  732.     }
  733.     if (argv[4][0] != 0) {
  734.         if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) {
  735.         return TCL_ERROR;
  736.         }
  737.     }
  738.     if (argv[5][0] != 0) {
  739.         if (stringVar != NULL) {
  740.         ckfree(stringVar);
  741.         }
  742.         if (strcmp(argv[5], "-") == 0) {
  743.         stringVar = NULL;
  744.         } else {
  745.         stringVar = ckalloc((unsigned) (strlen(argv[5]) + 1));
  746.         strcpy(stringVar, argv[5]);
  747.         }
  748.     }
  749.     } else {
  750.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  751.         "\": should be create, delete, get, or set",
  752.         (char *) NULL);
  753.     return TCL_ERROR;
  754.     }
  755.     return TCL_OK;
  756. }
  757.  
  758. /*
  759.  *----------------------------------------------------------------------
  760.  *
  761.  * TestMathFunc --
  762.  *
  763.  *    This is a user-defined math procedure to test out math procedures
  764.  *    with no arguments.
  765.  *
  766.  * Results:
  767.  *    A normal Tcl completion code.
  768.  *
  769.  * Side effects:
  770.  *    None.
  771.  *
  772.  *----------------------------------------------------------------------
  773.  */
  774.  
  775.     /* ARGSUSED */
  776. static int
  777. TestMathFunc(clientData, interp, args, resultPtr)
  778.     ClientData clientData;        /* Integer value to return. */
  779.     Tcl_Interp *interp;            /* Not used. */
  780.     Tcl_Value *args;            /* Not used. */
  781.     Tcl_Value *resultPtr;        /* Where to store result. */
  782. {
  783.     resultPtr->type = TCL_INT;
  784.     resultPtr->intValue = (int) clientData;
  785.     return TCL_OK;
  786. }
  787.