Return to tcltest.c CVS log

Up to [Micropolis - Activity] / micropolis / src / tcl

Annotation of micropolis/src/tcl/tcltest.c, revision 1.1

1.1     ! root        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: }

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.