cvs.zerfleddert.de Git - micropolis/blob - src/tcl/tcltest.c

   1 /*
   2  * tclTest.c --
   3  *
   4  *      Test driver for TCL.
   5  *
   6  * Copyright 1987-1991 Regents of the University of California
   7  * All rights reserved.
   8  *
   9  * Permission to use, copy, modify, and distribute this
  10  * software and its documentation for any purpose and without
  11  * fee is hereby granted, provided that the above copyright
  12  * notice appears in all copies.  The University of California
  13  * makes no representations about the suitability of this
  14  * software for any purpose.  It is provided "as is" without
  15  * express or implied warranty.
  16  */
  17
  18 #ifndef lint
  19 static char rcsid[] = "$Header: /user6/ouster/tcl/tclTest/RCS/tclTest.c,v 1.21 92/01/19 14:15:27 ouster Exp $ SPRITE (Berkeley)";
  20 #endif
  21
  22 #include <stdio.h>
  23 #include <errno.h>
  24 #include <string.h>
  25 #include "tcl.h"
  26
  27 extern int exit();
  28 extern int Tcl_DumpActiveMemory();
  29
  30 Tcl_Interp *interp;
  31 Tcl_CmdBuf buffer;
  32 char dumpFile[100];
  33 int quitFlag = 0;
  34
  35 char *initCmd =
  36     "if [file exists [info library]/init.tcl] {source [info library]/init.tcl}";
  37
  38         /* ARGSUSED */
  39 int
  40 cmdCheckmem(clientData, interp, argc, argv)
  41     ClientData clientData;
  42     Tcl_Interp *interp;
  43     int argc;
  44     char *argv[];
  45 {
  46     if (argc != 2) {
  47         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  48                 " fileName\"", (char *) NULL);
  49         return TCL_ERROR;
  50     }
  51     strcpy(dumpFile, argv[1]);
  52     quitFlag = 1;
  53     return TCL_OK;
  54 }
  55
  56         /* ARGSUSED */
  57 int
  58 cmdEcho(clientData, interp, argc, argv)
  59     ClientData clientData;
  60     Tcl_Interp *interp;
  61     int argc;
  62     char *argv[];
  63 {
  64     int i;
  65
  66     for (i = 1; ; i++) {
  67         if (argv[i] == NULL) {
  68             if (i != argc) {
  69                 echoError:
  70                 sprintf(interp->result,
  71                     "argument list wasn't properly NULL-terminated in \"%s\" command",
  72                     argv[0]);
  73             }
  74             break;
  75         }
  76         if (i >= argc) {
  77             goto echoError;
  78         }
  79         fputs(argv[i], stdout);
  80         if (i < (argc-1)) {
  81             printf(" ");
  82         }
  83     }
  84     printf("\n");
  85     return TCL_OK;
  86 }
  87
  88 int
  89 main()
  90 {
  91     char line[1000], *cmd;
  92     int result, gotPartial;
  93
  94     interp = Tcl_CreateInterp();
  95 #ifdef TCL_MEM_DEBUG
  96     Tcl_InitMemory(interp);
  97 #endif
  98     Tcl_CreateCommand(interp, "echo", cmdEcho, (ClientData) "echo",
  99             (Tcl_CmdDeleteProc *) NULL);
 100     Tcl_CreateCommand(interp, "checkmem", cmdCheckmem, (ClientData) 0,
 101             (Tcl_CmdDeleteProc *) NULL);
 102     buffer = Tcl_CreateCmdBuf();
 103 #ifndef TCL_GENERIC_ONLY
 104     result = Tcl_Eval(interp, initCmd, 0, (char **) NULL);
 105     if (result != TCL_OK) {
 106         printf("%s\n", interp->result);
 107         exit(1);
 108     }
 109 #endif
 110
 111     gotPartial = 0;
 112     while (1) {
 113         clearerr(stdin);
 114         if (!gotPartial) {
 115             fputs("% ", stdout);
 116             fflush(stdout);
 117         }
 118         if (fgets(line, 1000, stdin) == NULL) {
 119             if (!gotPartial) {
 120                 exit(0);
 121             }
 122             line[0] = 0;
 123         }
 124         cmd = Tcl_AssembleCmd(buffer, line);
 125         if (cmd == NULL) {
 126             gotPartial = 1;
 127             continue;
 128         }
 129
 130         gotPartial = 0;
 131         result = Tcl_RecordAndEval(interp, cmd, 0);
 132         if (result == TCL_OK) {
 133             if (*interp->result != 0) {
 134                 printf("%s\n", interp->result);
 135             }
 136             if (quitFlag) {
 137                 Tcl_DeleteInterp(interp);
 138                 Tcl_DeleteCmdBuf(buffer);
 139 #ifdef TCL_MEM_DEBUG
 140                 Tcl_DumpActiveMemory(dumpFile);
 141 #endif
 142                 exit(0);
 143             }
 144         } else {
 145             if (result == TCL_ERROR) {
 146                 printf("Error");
 147             } else {
 148                 printf("Error %d", result);
 149             }
 150             if (*interp->result != 0) {
 151                 printf(": %s\n", interp->result);
 152             } else {
 153                 printf("\n");
 154             }
 155         }
 156     }
 157 }