]> git.zerfleddert.de Git - micropolis/blob - src/tcl/tcltest.c
fix colors on BGR displays
[micropolis] / 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 }
Impressum, Datenschutz