home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / tcl / tcl7.0b1 / tclTest.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-07-08  |  13.1 KB  |  445 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.6 93/07/08 09:59:28 ouster Exp $ SPRITE (Berkeley)";
  32. #endif /* not lint */
  33.  
  34. #include "tclInt.h"
  35.  
  36. /*
  37.  * The variable below holds a startup script to be executed at the
  38.  * beginning of the application.
  39.  */
  40.  
  41. char initCmd[] =
  42. "if [file exists [info library]/init.tcl] {\n\
  43.     source [info library]/init.tcl\n\
  44. } else {\n\
  45.     set msg \"can't find [info library]/init.tcl; perhaps you need to\\n\"\n\
  46.     append msg \"install Tcl or set your TCL_LIBRARY environment \"\n\
  47.     append msg \"variable?\"\n\
  48.     error $msg\n\
  49. }";
  50.  
  51. /*
  52.  * The following variable is a special hack that allows applications
  53.  * to be linked using the procedure "main" from the Tcl library.  The
  54.  * variable generates a reference to "main", which causes main to
  55.  * be brought in from the library (and all of Tcl with it).
  56.  */
  57.  
  58. extern int main();
  59. int *tclDummyMainPtr = (int *) main;
  60.  
  61. /*
  62.  * Dynamic string shared by TestdcallCmd and DelCallbackProc;  used
  63.  * to collect the results of the various deletion callbacks.
  64.  */
  65.  
  66. static Tcl_DString delString;
  67. static Tcl_Interp *delInterp;
  68.  
  69. /*
  70.  * Forward declarations for procedures defined later in this file:
  71.  */
  72.  
  73. static void        CmdDelProc1 _ANSI_ARGS_((ClientData clientData));
  74. static void        CmdDelProc2 _ANSI_ARGS_((ClientData clientData));
  75. static int        CmdProc1 _ANSI_ARGS_((ClientData clientData,
  76.                 Tcl_Interp *interp, int argc, char **argv));
  77. static int        CmdProc2 _ANSI_ARGS_((ClientData clientData,
  78.                 Tcl_Interp *interp, int argc, char **argv));
  79. static void        DelCallbackProc _ANSI_ARGS_((ClientData clientData,
  80.                 Tcl_Interp *interp));
  81. static int        TestcmdinfoCmd _ANSI_ARGS_((ClientData dummy,
  82.                 Tcl_Interp *interp, int argc, char **argv));
  83. static int        TestdcallCmd _ANSI_ARGS_((ClientData dummy,
  84.                 Tcl_Interp *interp, int argc, char **argv));
  85. static int        TestlinkCmd _ANSI_ARGS_((ClientData dummy,
  86.                 Tcl_Interp *interp, int argc, char **argv));
  87.  
  88. /*
  89.  *----------------------------------------------------------------------
  90.  *
  91.  * Tcl_AppInit --
  92.  *
  93.  *    This procedure performs application-specific initialization.
  94.  *    Most applications, especially those that incorporate additional
  95.  *    packages, will have their own version of this procedure.
  96.  *
  97.  * Results:
  98.  *    Returns a standard Tcl completion code, and leaves an error
  99.  *    message in interp->result if an error occurs.
  100.  *
  101.  * Side effects:
  102.  *    Depends on the startup script.
  103.  *
  104.  *----------------------------------------------------------------------
  105.  */
  106.  
  107. int
  108. Tcl_AppInit(interp)
  109.     Tcl_Interp *interp;        /* Interpreter for application. */
  110. {
  111.     /*
  112.      * Calls to init procedures for various included packages should
  113.      * appear below, if there are any included packages:
  114.      */
  115.  
  116.     Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, (ClientData) 0,
  117.         (Tcl_CmdDeleteProc *) NULL);
  118.     Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, (ClientData) 0,
  119.         (Tcl_CmdDeleteProc *) NULL);
  120.     Tcl_CreateCommand(interp, "testlink", TestlinkCmd, (ClientData) 0,
  121.         (Tcl_CmdDeleteProc *) NULL);
  122.  
  123.     /*
  124.      * Execute a start-up script.
  125.      */
  126.  
  127.     return Tcl_Eval(interp, initCmd);
  128. }
  129.  
  130. /*
  131.  *----------------------------------------------------------------------
  132.  *
  133.  * TestdcallCmd --
  134.  *
  135.  *    This procedure implements the "testdcall" command.  It is used
  136.  *    to test Tcl_CallWhenDeleted.
  137.  *
  138.  * Results:
  139.  *    A standard Tcl result.
  140.  *
  141.  * Side effects:
  142.  *    Creates and deletes interpreters.
  143.  *
  144.  *----------------------------------------------------------------------
  145.  */
  146.  
  147.     /* ARGSUSED */
  148. static int
  149. TestdcallCmd(dummy, interp, argc, argv)
  150.     ClientData dummy;            /* Not used. */
  151.     Tcl_Interp *interp;            /* Current interpreter. */
  152.     int argc;                /* Number of arguments. */
  153.     char **argv;            /* Argument strings. */
  154. {
  155.     int i;
  156.  
  157.     delInterp = Tcl_CreateInterp();
  158.     Tcl_DStringInit(&delString);
  159.     for (i = 1; i < argc; i++) {
  160.     Tcl_CallWhenDeleted(delInterp, DelCallbackProc, (ClientData) argv[i]);
  161.     }
  162.     Tcl_DeleteInterp(delInterp);
  163.     Tcl_DStringResult(interp, &delString);
  164.     return TCL_OK;
  165. }
  166.  
  167. /*
  168.  * The deletion callback used by TestdcallCmd:
  169.  */
  170.  
  171. static void
  172. DelCallbackProc(clientData, interp)
  173.     ClientData clientData;        /* String value to append to
  174.                      * delString. */
  175.     Tcl_Interp *interp;            /* Interpreter being deleted. */
  176. {
  177.     char *string = (char *) clientData;
  178.  
  179.     Tcl_DStringAppendElement(&delString, string);
  180.     if (interp != delInterp) {
  181.     Tcl_DStringAppendElement(&delString, "bogus interpreter argument!");
  182.     }
  183. }
  184.  
  185. /*
  186.  *----------------------------------------------------------------------
  187.  *
  188.  * TestcmdinfoCmd --
  189.  *
  190.  *    This procedure implements the "testcmdinfo" command.  It is used
  191.  *    to test Tcl_GetCmdInfo, Tcl_SetCmdInfo, and command creation
  192.  *    and deletion.
  193.  *
  194.  * Results:
  195.  *    A standard Tcl result.
  196.  *
  197.  * Side effects:
  198.  *    Creates and deletes various commands and modifies their data.
  199.  *
  200.  *----------------------------------------------------------------------
  201.  */
  202.  
  203.     /* ARGSUSED */
  204. static int
  205. TestcmdinfoCmd(dummy, interp, argc, argv)
  206.     ClientData dummy;            /* Not used. */
  207.     Tcl_Interp *interp;            /* Current interpreter. */
  208.     int argc;                /* Number of arguments. */
  209.     char **argv;            /* Argument strings. */
  210. {
  211.     Tcl_CmdInfo info;
  212.  
  213.     if (argc != 3) {
  214.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  215.         " option cmdName\"", (char *) NULL);
  216.     return TCL_ERROR;
  217.     }
  218.     if (strcmp(argv[1], "create") == 0) {
  219.     Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original",
  220.         CmdDelProc1);
  221.     } else if (strcmp(argv[1], "delete") == 0) {
  222.     Tcl_DStringInit(&delString);
  223.     Tcl_DeleteCommand(interp, argv[2]);
  224.     Tcl_DStringResult(interp, &delString);
  225.     } else if (strcmp(argv[1], "get") == 0) {
  226.     if (Tcl_GetCommandInfo(interp, argv[2], &info) ==0) {
  227.         interp->result = "??";
  228.         return TCL_OK;
  229.     }
  230.     if (info.proc == CmdProc1) {
  231.         Tcl_AppendResult(interp, "CmdProc1", " ",
  232.             (char *) info.clientData, (char *) NULL);
  233.     } else if (info.proc == CmdProc2) {
  234.         Tcl_AppendResult(interp, "CmdProc2", " ",
  235.             (char *) info.clientData, (char *) NULL);
  236.     } else {
  237.         Tcl_AppendResult(interp, "unknown", (char *) NULL);
  238.     }
  239.     if (info.deleteProc == CmdDelProc1) {
  240.         Tcl_AppendResult(interp, " CmdDelProc1", " ",
  241.             (char *) info.deleteData, (char *) NULL);
  242.     } else if (info.deleteProc == CmdDelProc2) {
  243.         Tcl_AppendResult(interp, " CmdDelProc2", " ",
  244.             (char *) info.deleteData, (char *) NULL);
  245.     } else {
  246.         Tcl_AppendResult(interp, " unknown", (char *) NULL);
  247.     }
  248.     } else if (strcmp(argv[1], "modify") == 0) {
  249.     info.proc = CmdProc2;
  250.     info.clientData = (ClientData) "new_command_data";
  251.     info.deleteProc = CmdDelProc2;
  252.     info.deleteData = (ClientData) "new_delete_data";
  253.     if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) {
  254.         interp->result = "0";
  255.     } else {
  256.         interp->result = "1";
  257.     }
  258.     } else {
  259.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  260.         "\": must be create, delete, get, or modify",
  261.         (char *) NULL);
  262.     return TCL_ERROR;
  263.     }
  264.     return TCL_OK;
  265. }
  266.  
  267.     /*ARGSUSED*/
  268. static int
  269. CmdProc1(clientData, interp, argc, argv)
  270.     ClientData clientData;        /* String to return. */
  271.     Tcl_Interp *interp;            /* Current interpreter. */
  272.     int argc;                /* Number of arguments. */
  273.     char **argv;            /* Argument strings. */
  274. {
  275.     Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData,
  276.         (char *) NULL);
  277.     return TCL_OK;
  278. }
  279.  
  280.     /*ARGSUSED*/
  281. static int
  282. CmdProc2(clientData, interp, argc, argv)
  283.     ClientData clientData;        /* String to return. */
  284.     Tcl_Interp *interp;            /* Current interpreter. */
  285.     int argc;                /* Number of arguments. */
  286.     char **argv;            /* Argument strings. */
  287. {
  288.     Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData,
  289.         (char *) NULL);
  290.     return TCL_OK;
  291. }
  292.  
  293. static void
  294. CmdDelProc1(clientData)
  295.     ClientData clientData;        /* String to save. */
  296. {
  297.     Tcl_DStringInit(&delString);
  298.     Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1);
  299.     Tcl_DStringAppend(&delString, (char *) clientData, -1);
  300. }
  301.  
  302. static void
  303. CmdDelProc2(clientData)
  304.     ClientData clientData;        /* String to save. */
  305. {
  306.     Tcl_DStringInit(&delString);
  307.     Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1);
  308.     Tcl_DStringAppend(&delString, (char *) clientData, -1);
  309. }
  310.  
  311. /*
  312.  *----------------------------------------------------------------------
  313.  *
  314.  * TestLinkCmd --
  315.  *
  316.  *    This procedure implements the "testlink" command.  It is used
  317.  *    to test Tcl_LinkVar and related library procedures.
  318.  *
  319.  * Results:
  320.  *    A standard Tcl result.
  321.  *
  322.  * Side effects:
  323.  *    Creates and deletes various variable links, plus returns
  324.  *    values of the linked variables.
  325.  *
  326.  *----------------------------------------------------------------------
  327.  */
  328.  
  329.     /* ARGSUSED */
  330. static int
  331. TestlinkCmd(dummy, interp, argc, argv)
  332.     ClientData dummy;            /* Not used. */
  333.     Tcl_Interp *interp;            /* Current interpreter. */
  334.     int argc;                /* Number of arguments. */
  335.     char **argv;            /* Argument strings. */
  336. {
  337.     static int intVar = 43;
  338.     static int boolVar = 4;
  339.     static double realVar = 1.23;
  340.     static char *stringVar = NULL;
  341.     char buffer[TCL_DOUBLE_SPACE];
  342.     int writable;
  343.  
  344.     if (argc < 2) {
  345.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  346.         " option ?arg arg arg?\"", (char *) NULL);
  347.     return TCL_ERROR;
  348.     }
  349.     if (strcmp(argv[1], "create") == 0) {
  350.     if (Tcl_LinkVar(interp, "int", (char *) &intVar, TCL_LINK_INT)
  351.         != TCL_OK) {
  352.         return TCL_ERROR;
  353.     }
  354.     if (Tcl_LinkVar(interp, "real", (char *) &realVar, TCL_LINK_DOUBLE)
  355.         != TCL_OK) {
  356.         return TCL_ERROR;
  357.     }
  358.     if (Tcl_LinkVar(interp, "bool", (char *) &boolVar, TCL_LINK_BOOLEAN)
  359.         != TCL_OK) {
  360.         return TCL_ERROR;
  361.     }
  362.     if (Tcl_LinkVar(interp, "string", (char *) &stringVar, TCL_LINK_STRING)
  363.         != TCL_OK) {
  364.         return TCL_ERROR;
  365.     }
  366.     } else if (strcmp(argv[1], "delete") == 0) {
  367.     Tcl_UnlinkVar(interp, "int");
  368.     Tcl_UnlinkVar(interp, "real");
  369.     Tcl_UnlinkVar(interp, "bool");
  370.     Tcl_UnlinkVar(interp, "string");
  371.     } else if (strcmp(argv[1], "get") == 0) {
  372.     sprintf(buffer, "%d", intVar);
  373.     Tcl_AppendElement(interp, buffer);
  374.     Tcl_PrintDouble(interp, realVar, buffer);
  375.     Tcl_AppendElement(interp, buffer);
  376.     sprintf(buffer, "%d", boolVar);
  377.     Tcl_AppendElement(interp, buffer);
  378.     Tcl_AppendElement(interp, (stringVar == NULL) ? "-" : stringVar);
  379.     } else if (strcmp(argv[1], "set") == 0) {
  380.     if (argc != 6) {
  381.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  382.         argv[0], " ", argv[1],
  383.         "intValue realValue boolValue stringValue\"", (char *) NULL);
  384.         return TCL_ERROR;
  385.     }
  386.     if (argv[2][0] != 0) {
  387.         if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) {
  388.         return TCL_ERROR;
  389.         }
  390.     }
  391.     if (argv[3][0] != 0) {
  392.         if (Tcl_GetDouble(interp, argv[3], &realVar) != TCL_OK) {
  393.         return TCL_ERROR;
  394.         }
  395.     }
  396.     if (argv[4][0] != 0) {
  397.         if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) {
  398.         return TCL_ERROR;
  399.         }
  400.     }
  401.     if (argv[5][0] != 0) {
  402.         if (stringVar != NULL) {
  403.         ckfree(stringVar);
  404.         }
  405.         if (strcmp(argv[5], "-") == 0) {
  406.         stringVar = NULL;
  407.         } else {
  408.         stringVar = ckalloc((unsigned) (strlen(argv[5]) + 1));
  409.         strcpy(stringVar, argv[5]);
  410.         }
  411.     }
  412.     } else if (strcmp(argv[1], "writable") == 0) {
  413.     if (argv[2][0] != 0) {
  414.         if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) {
  415.         return TCL_ERROR;
  416.         }
  417.         Tcl_LinkedVarWritable(interp, "int", writable);
  418.     }
  419.     if (argv[3][0] != 0) {
  420.         if (Tcl_GetBoolean(interp, argv[3], &writable) != TCL_OK) {
  421.         return TCL_ERROR;
  422.         }
  423.         Tcl_LinkedVarWritable(interp, "real", writable);
  424.     }
  425.     if (argv[4][0] != 0) {
  426.         if (Tcl_GetBoolean(interp, argv[4], &writable) != TCL_OK) {
  427.         return TCL_ERROR;
  428.         }
  429.         Tcl_LinkedVarWritable(interp, "bool", writable);
  430.     }
  431.     if (argv[5][0] != 0) {
  432.         if (Tcl_GetBoolean(interp, argv[5], &writable) != TCL_OK) {
  433.         return TCL_ERROR;
  434.         }
  435.         Tcl_LinkedVarWritable(interp, "string", writable);
  436.     }
  437.     } else {
  438.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  439.         "\": should be create, delete, get, set, or writable",
  440.         (char *) NULL);
  441.     return TCL_ERROR;
  442.     }
  443.     return TCL_OK;
  444. }
  445.