1 /*
2 * win-tkMain.c --
3 *
4 * modified version of TkMain et. al.
5 *
6 * Copyright (c) 1997-2002 The Regents of the University of California.
7 * All rights reserved.
8 *
9 * Redistribution and use in source and binary forms, with or without
10 * modification, are permitted provided that the following conditions are met:
11 *
12 * A. Redistributions of source code must retain the above copyright notice,
13 * this list of conditions and the following disclaimer.
14 * B. Redistributions in binary form must reproduce the above copyright notice,
15 * this list of conditions and the following disclaimer in the documentation
16 * and/or other materials provided with the distribution.
17 * C. Neither the names of the copyright holders nor the names of its
18 * contributors may be used to endorse or promote products derived from this
19 * software without specific prior written permission.
20 *
21 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
22 * IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
23 * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
24 * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE
25 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
26 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
27 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
28 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
29 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
30 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
31 * POSSIBILITY OF SUCH DAMAGE.
32 */
33
34 #include "tk.h"
35 #include "compat/tkcompat.h"
36 #include <string.h>
37 #include <stdio.h>
38
39 extern int outputErr(const char* szPrefix, Tcl_Interp* interp);
40
41 /*
42 * tkMain.c --
43 *
44 * This file contains a generic main program for Tk-based applications.
45 * It can be used as-is for many applications, just by supplying a
46 * different appInitProc procedure for each specific application.
47 * Or, it can be used as a template for creating new main programs
48 * for Tk applications.
49 *
50 * Copyright (c) 1990-1994 The Regents of the University of California.
51 * Copyright (c) 1994-1996 Sun Microsystems, Inc.
52 *
53 * See the file "license.terms" for information on usage and redistribution
54 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
55 *
56 * SCCS: @(#) tkMain.c 1.150 96/09/05 18:42:25
57 */
58
59 /*
60 * Global variables used by the main program:
61 */
62
63 static Tcl_Interp *interp; /* Interpreter for this application. */
64 static Tcl_DString command; /* Used to assemble lines of terminal input
65 * into Tcl commands. */
66 static Tcl_DString line; /* Used to read the next line from the
67 * terminal input. */
68 static int tty; /* Non-zero means standard input is a
69 * terminal-like device. Zero means it's
70 * a file. */
71
72
73 /*
74 * Forward declarations for procedures defined later in this file.
75 */
76
77 static void Prompt(Tcl_Interp *interp, int partial);
78 static void StdinProc(ClientData clientData, int mask);
79
80 /*
81 *----------------------------------------------------------------------
82 *
83 * Win_TK_Main --
84 *
85 * This function replaces Tk_Main
86 *
87 * Results:
88 * None. This procedure never returns (it exits the process when
89 * it's done.
90 *
91 * Side effects:
92 * This procedure initializes the Tk world and then starts
93 * interpreting commands; almost anything could happen, depending
94 * on the script being interpreted.
95 *
96 * Difference from Tk_Main:
97 * When there is an error, it output a message box and waits for
98 * the user to press okay before exiting. This allows the user to
99 * see the error Message.
100 *
101 *----------------------------------------------------------------------
102 */
103
104 void
105 Win_Tk_Main(argc, argv, appInitProc)
106 int argc; /* Number of arguments. */
107 char **argv; /* Array of argument strings. */
108 Tcl_AppInitProc *appInitProc; /* Application-specific initialization
109 * procedure to call after most
110 * initialization but before starting
111 * to execute commands. */
112 {
113 char *args, *fileName;
114 char buf[20];
115 int code;
116 size_t length;
117 Tcl_Channel inChannel, outChannel;
118
119 Tcl_FindExecutable(argv[0]);
120 interp = Tcl_CreateInterp();
121 #ifdef TCL_MEM_DEBUG
122 Tcl_InitMemory(interp);
123 #endif
124
125 /*
126 * Parse command-line arguments. A leading "-file" argument is
127 * ignored (a historical relic from the distant past). If the
128 * next argument doesn't start with a "-" then strip it off and
129 * use it as the name of a script file to process.
130 */
131
132 fileName = NULL;
133 if (argc > 1) {
134 length = strlen(argv[1]);
135 if ((length >= 2) && (strncmp(argv[1], "-file", length) == 0)) {
136 argc--;
137 argv++;
138 }
139 }
140 if ((argc > 1) && (argv[1][0] != '-')) {
141 fileName = argv[1];
142 argc--;
143 argv++;
144 }
145
146 /*
147 * Make command-line arguments available in the Tcl variables "argc"
148 * and "argv".
149 */
150
151 args = Tcl_Merge(argc-1, argv+1);
152 Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY);
153 ckfree(args);
154 sprintf(buf, "%d", argc-1);
155 Tcl_SetVar(interp, "argc", buf, TCL_GLOBAL_ONLY);
156 Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0],
157 TCL_GLOBAL_ONLY);
158
159 /*
160 * Set the "tcl_interactive" variable.
161 */
162
163 /*
164 * For now, under Windows, we assume we are not running as a console mode
165 * app, so we need to use the GUI console. In order to enable this, we
166 * always claim to be running on a tty. This probably isn't the right
167 * way to do it.
168 */
169
170 #ifdef __WIN32__
171 tty = 1;
172 #else
173 /* tty = isatty(0); */
174 #endif
175 Tcl_SetVar(interp, "tcl_interactive",
176 ((fileName == NULL) && tty) ? "1" : "", TCL_GLOBAL_ONLY);
177
178 /*
179 * Invoke application-specific initialization.
180 */
181
182 if ((*appInitProc)(interp) != TCL_OK) {
183 outputErr("Application specific initialization failed!", interp);
184 }
185
186 /*
187 * Invoke the script specified on the command line, if any.
188 */
189
190 if (fileName != NULL) {
191 code = Tcl_EvalFile(interp, fileName);
192 if (code != TCL_OK) {
193 /*
194 * The following statement guarantees that the errorInfo
195 * variable is set properly.
196 */
197
198 Tcl_AddErrorInfo(interp, "");
199 outputErr("error when evaluating script\n", interp);
200 Tcl_DeleteInterp(interp);
201 Tcl_Exit(1);
202 }
203 tty = 0;
204 } else {
205
206 /*
207 * Evaluate the .rc file, if one has been specified.
208 */
209
210 Tcl_SourceRCFile(interp);
211
212 /*
213 * Establish a channel handler for stdin.
214 */
215
216 inChannel = Tcl_GetStdChannel(TCL_STDIN);
217 if (inChannel) {
218 Tcl_CreateChannelHandler(inChannel, TCL_READABLE, StdinProc,
219 (ClientData) inChannel);
220 }
221 if (tty) {
222 Prompt(interp, 0);
223 }
224 }
225
226 outChannel = Tcl_GetStdChannel(TCL_STDOUT);
227 if (outChannel) {
228 Tcl_Flush(outChannel);
229 }
230 Tcl_DStringInit(&command);
231 Tcl_DStringInit(&line);
232 Tcl_ResetResult(interp);
233
234 /*
235 * Loop infinitely, waiting for commands to execute. When there
236 * are no windows left, Tk_MainLoop returns and we exit.
237 */
238
239 Tk_MainLoop();
240 Tcl_DeleteInterp(interp);
241 Tcl_Exit(0);
242
243 }
244
245 /*----------------------------------------------------------------------
246 *
247 * StdinProc --
248 *
249 * This procedure is invoked by the event dispatcher whenever
250 * standard input becomes readable. It grabs the next line of
251 * input characters, adds them to a command being assembled, and
252 * executes the command if it's complete.
253 *
254 * Results:
255 * None.
256 *
257 * Side effects:
258 * Could be almost arbitrary, depending on the command that's
259 * typed.
260 *
261 *----------------------------------------------------------------------
262 */
263
264 /* ARGSUSED */
265 static void
266 StdinProc(clientData, mask)
267 ClientData clientData; /* Not used. */
268 int mask; /* Not used. */
269 {
270 static int gotPartial = 0;
271 char *cmd;
272 int code, count;
273 Tcl_Channel chan = (Tcl_Channel) clientData;
274
275 count = Tcl_Gets(chan, &line);
276
277 if (count < 0) {
278 if (!gotPartial) {
279 if (tty) {
280 Tcl_Exit(0);
281 } else {
282 Tcl_DeleteChannelHandler(chan, StdinProc, (ClientData) chan);
283 }
284 return;
285 } else {
286 count = 0;
287 }
288 }
289
290 (void) Tcl_DStringAppend(&command, Tcl_DStringValue(&line), -1);
291 cmd = Tcl_DStringAppend(&command, "\n", -1);
292 Tcl_DStringFree(&line);
293
294 if (!Tcl_CommandComplete(cmd)) {
295 gotPartial = 1;
296 goto prompt;
297 }
298 gotPartial = 0;
299
300 /*
301 * Disable the stdin channel handler while evaluating the command;
302 * otherwise if the command re-enters the event loop we might
303 * process commands from stdin before the current command is
304 * finished. Among other things, this will trash the text of the
305 * command being evaluated.
306 */
307
308 Tcl_CreateChannelHandler(chan, 0, StdinProc, (ClientData) chan);
309 code = Tcl_RecordAndEval(interp, cmd, TCL_EVAL_GLOBAL);
310 Tcl_CreateChannelHandler(chan, TCL_READABLE, StdinProc,
311 (ClientData) chan);
312 Tcl_DStringFree(&command);
313 if (*interp->result != 0) {
314 if ((code != TCL_OK) || (tty)) {
315 /*
316 * The statement below used to call "printf", but that resulted
317 * in core dumps under Solaris 2.3 if the result was very long.
318 *
319 * NOTE: This probably will not work under Windows either.
320 */
321
322 puts(interp->result);
323 }
324 }
325
326 /*
327 * Output a prompt.
328 */
329
330 prompt:
331 if (tty) {
332 Prompt(interp, gotPartial);
333 }
334 Tcl_ResetResult(interp);
335 }
336
337 /*
338 *----------------------------------------------------------------------
339 *
340 * Prompt --
341 *
342 * Issue a prompt on standard output, or invoke a script
343 * to issue the prompt.
344 *
345 * Results:
346 * None.
347 *
348 * Side effects:
349 * A prompt gets output, and a Tcl script may be evaluated
350 * in interp.
351 *
352 *----------------------------------------------------------------------
353 */
354
355 static void
356 Prompt(interp, partial)
357 Tcl_Interp *interp; /* Interpreter to use for prompting. */
358 int partial; /* Non-zero means there already
359 * exists a partial command, so use
360 * the secondary prompt. */
361 {
362 char *promptCmd;
363 int code;
364 Tcl_Channel outChannel, errChannel;
365
366 promptCmd = Tcl_GetVar(interp,
367 partial ? "tcl_prompt2" : "tcl_prompt1", TCL_GLOBAL_ONLY);
368 if (promptCmd == NULL) {
369 defaultPrompt:
370 if (!partial) {
371
372 /*
373 * We must check that outChannel is a real channel - it
374 * is possible that someone has transferred stdout out of
375 * this interpreter with "interp transfer".
376 */
377
378 outChannel = Tcl_GetChannel(interp, "stdout", NULL);
379 if (outChannel != (Tcl_Channel) NULL) {
380 Tcl_Write(outChannel, "% ", 2);
381 }
382 }
383 } else {
384 code = Tcl_Eval(interp, promptCmd);
385 if (code != TCL_OK) {
386 Tcl_AddErrorInfo(interp,
387 "\n (script that generates prompt)");
388 /*
389 * We must check that errChannel is a real channel - it
390 * is possible that someone has transferred stderr out of
391 * this interpreter with "interp transfer".
392 */
393
394 errChannel = Tcl_GetChannel(interp, "stderr", NULL);
395 if (errChannel != (Tcl_Channel) NULL) {
396 Tcl_Write(errChannel, interp->result, -1);
397 Tcl_Write(errChannel, "\n", 1);
398 }
399 goto defaultPrompt;
400 }
401 }
402 outChannel = Tcl_GetChannel(interp, "stdout", NULL);
403 if (outChannel != (Tcl_Channel) NULL) {
404 Tcl_Flush(outChannel);
405 }
406 }
407
This page was automatically generated by the
LXR engine.
Visit the LXR main site for more
information.