]> git.zerfleddert.de Git - micropolis/blame - src/tcl/tcltest.c
fix colors on BGR displays
[micropolis] / src / tcl / tcltest.c
CommitLineData
6a5fa4e0
MG
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
19static 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
27extern int exit();
28extern int Tcl_DumpActiveMemory();
29
30Tcl_Interp *interp;
31Tcl_CmdBuf buffer;
32char dumpFile[100];
33int quitFlag = 0;
34
35char *initCmd =
36 "if [file exists [info library]/init.tcl] {source [info library]/init.tcl}";
37
38 /* ARGSUSED */
39int
40cmdCheckmem(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 */
57int
58cmdEcho(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
88int
89main()
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}
Impressum, Datenschutz