1 | /* |
---|
2 | * tclMain.c -- |
---|
3 | * |
---|
4 | * Main program for Tcl shells and other Tcl-based applications. |
---|
5 | * |
---|
6 | * Copyright (c) 1988-1994 The Regents of the University of California. |
---|
7 | * Copyright (c) 1994-1997 Sun Microsystems, Inc. |
---|
8 | * Copyright (c) 2000 Ajuba Solutions. |
---|
9 | * |
---|
10 | * See the file "license.terms" for information on usage and redistribution of |
---|
11 | * this file, and for a DISCLAIMER OF ALL WARRANTIES. |
---|
12 | * |
---|
13 | * RCS: @(#) $Id: tclMain.c,v 1.44 2007/12/13 15:23:19 dgp Exp $ |
---|
14 | */ |
---|
15 | |
---|
16 | #include "tclInt.h" |
---|
17 | |
---|
18 | #undef TCL_STORAGE_CLASS |
---|
19 | #define TCL_STORAGE_CLASS DLLEXPORT |
---|
20 | |
---|
21 | /* |
---|
22 | * The default prompt used when the user has not overridden it. |
---|
23 | */ |
---|
24 | |
---|
25 | #define DEFAULT_PRIMARY_PROMPT "% " |
---|
26 | |
---|
27 | /* |
---|
28 | * Declarations for various library functions and variables (don't want to |
---|
29 | * include tclPort.h here, because people might copy this file out of the Tcl |
---|
30 | * source directory to make their own modified versions). |
---|
31 | */ |
---|
32 | |
---|
33 | extern CRTIMPORT int isatty(int fd); |
---|
34 | |
---|
35 | static Tcl_Obj *tclStartupScriptPath = NULL; |
---|
36 | static Tcl_Obj *tclStartupScriptEncoding = NULL; |
---|
37 | static Tcl_MainLoopProc *mainLoopProc = NULL; |
---|
38 | |
---|
39 | /* |
---|
40 | * Structure definition for information used to keep the state of an |
---|
41 | * interactive command processor that reads lines from standard input and |
---|
42 | * writes prompts and results to standard output. |
---|
43 | */ |
---|
44 | |
---|
45 | typedef enum { |
---|
46 | PROMPT_NONE, /* Print no prompt */ |
---|
47 | PROMPT_START, /* Print prompt for command start */ |
---|
48 | PROMPT_CONTINUE /* Print prompt for command continuation */ |
---|
49 | } PromptType; |
---|
50 | |
---|
51 | typedef struct InteractiveState { |
---|
52 | Tcl_Channel input; /* The standard input channel from which lines |
---|
53 | * are read. */ |
---|
54 | int tty; /* Non-zero means standard input is a |
---|
55 | * terminal-like device. Zero means it's a |
---|
56 | * file. */ |
---|
57 | Tcl_Obj *commandPtr; /* Used to assemble lines of input into Tcl |
---|
58 | * commands. */ |
---|
59 | PromptType prompt; /* Next prompt to print */ |
---|
60 | Tcl_Interp *interp; /* Interpreter that evaluates interactive |
---|
61 | * commands. */ |
---|
62 | } InteractiveState; |
---|
63 | |
---|
64 | /* |
---|
65 | * Forward declarations for functions defined later in this file. |
---|
66 | */ |
---|
67 | |
---|
68 | static void Prompt(Tcl_Interp *interp, PromptType *promptPtr); |
---|
69 | static void StdinProc(ClientData clientData, int mask); |
---|
70 | |
---|
71 | /* |
---|
72 | *---------------------------------------------------------------------- |
---|
73 | * |
---|
74 | * Tcl_SetStartupScript -- |
---|
75 | * |
---|
76 | * Sets the path and encoding of the startup script to be evaluated by |
---|
77 | * Tcl_Main, used to override the command line processing. |
---|
78 | * |
---|
79 | * Results: |
---|
80 | * None. |
---|
81 | * |
---|
82 | * Side effects: |
---|
83 | * |
---|
84 | *---------------------------------------------------------------------- |
---|
85 | */ |
---|
86 | |
---|
87 | void |
---|
88 | Tcl_SetStartupScript( |
---|
89 | Tcl_Obj *path, /* Filesystem path of startup script file */ |
---|
90 | CONST char *encoding) /* Encoding of the data in that file */ |
---|
91 | { |
---|
92 | Tcl_Obj *newEncoding = NULL; |
---|
93 | if (encoding != NULL) { |
---|
94 | newEncoding = Tcl_NewStringObj(encoding, -1); |
---|
95 | } |
---|
96 | |
---|
97 | if (tclStartupScriptPath != NULL) { |
---|
98 | Tcl_DecrRefCount(tclStartupScriptPath); |
---|
99 | } |
---|
100 | tclStartupScriptPath = path; |
---|
101 | if (tclStartupScriptPath != NULL) { |
---|
102 | Tcl_IncrRefCount(tclStartupScriptPath); |
---|
103 | } |
---|
104 | |
---|
105 | if (tclStartupScriptEncoding != NULL) { |
---|
106 | Tcl_DecrRefCount(tclStartupScriptEncoding); |
---|
107 | } |
---|
108 | tclStartupScriptEncoding = newEncoding; |
---|
109 | if (tclStartupScriptEncoding != NULL) { |
---|
110 | Tcl_IncrRefCount(tclStartupScriptEncoding); |
---|
111 | } |
---|
112 | } |
---|
113 | |
---|
114 | /* |
---|
115 | *---------------------------------------------------------------------- |
---|
116 | * |
---|
117 | * Tcl_GetStartupScript -- |
---|
118 | * |
---|
119 | * Gets the path and encoding of the startup script to be evaluated by |
---|
120 | * Tcl_Main. |
---|
121 | * |
---|
122 | * Results: |
---|
123 | * The path of the startup script; NULL if none has been set. |
---|
124 | * |
---|
125 | * Side effects: |
---|
126 | * If encodingPtr is not NULL, stores a (CONST char *) in it pointing to |
---|
127 | * the encoding name registered for the startup script. Tcl retains |
---|
128 | * ownership of the string, and may free it. Caller should make a copy |
---|
129 | * for long-term use. |
---|
130 | * |
---|
131 | *---------------------------------------------------------------------- |
---|
132 | */ |
---|
133 | |
---|
134 | Tcl_Obj * |
---|
135 | Tcl_GetStartupScript( |
---|
136 | CONST char **encodingPtr) /* When not NULL, points to storage for the |
---|
137 | * (CONST char *) that points to the |
---|
138 | * registered encoding name for the startup |
---|
139 | * script */ |
---|
140 | { |
---|
141 | if (encodingPtr != NULL) { |
---|
142 | if (tclStartupScriptEncoding == NULL) { |
---|
143 | *encodingPtr = NULL; |
---|
144 | } else { |
---|
145 | *encodingPtr = Tcl_GetString(tclStartupScriptEncoding); |
---|
146 | } |
---|
147 | } |
---|
148 | return tclStartupScriptPath; |
---|
149 | } |
---|
150 | |
---|
151 | /* |
---|
152 | *---------------------------------------------------------------------- |
---|
153 | * |
---|
154 | * TclSetStartupScriptPath -- |
---|
155 | * |
---|
156 | * Primes the startup script VFS path, used to override the command line |
---|
157 | * processing. |
---|
158 | * |
---|
159 | * Results: |
---|
160 | * None. |
---|
161 | * |
---|
162 | * Side effects: |
---|
163 | * This function initializes the VFS path of the Tcl script to run at |
---|
164 | * startup. |
---|
165 | * |
---|
166 | *---------------------------------------------------------------------- |
---|
167 | */ |
---|
168 | |
---|
169 | void |
---|
170 | TclSetStartupScriptPath( |
---|
171 | Tcl_Obj *path) |
---|
172 | { |
---|
173 | Tcl_SetStartupScript(path, NULL); |
---|
174 | } |
---|
175 | |
---|
176 | /* |
---|
177 | *---------------------------------------------------------------------- |
---|
178 | * |
---|
179 | * TclGetStartupScriptPath -- |
---|
180 | * |
---|
181 | * Gets the startup script VFS path, used to override the command line |
---|
182 | * processing. |
---|
183 | * |
---|
184 | * Results: |
---|
185 | * The startup script VFS path, NULL if none has been set. |
---|
186 | * |
---|
187 | * Side effects: |
---|
188 | * None. |
---|
189 | * |
---|
190 | *---------------------------------------------------------------------- |
---|
191 | */ |
---|
192 | |
---|
193 | Tcl_Obj * |
---|
194 | TclGetStartupScriptPath(void) |
---|
195 | { |
---|
196 | return Tcl_GetStartupScript(NULL); |
---|
197 | } |
---|
198 | |
---|
199 | /* |
---|
200 | *---------------------------------------------------------------------- |
---|
201 | * |
---|
202 | * TclSetStartupScriptFileName -- |
---|
203 | * |
---|
204 | * Primes the startup script file name, used to override the command line |
---|
205 | * processing. |
---|
206 | * |
---|
207 | * Results: |
---|
208 | * None. |
---|
209 | * |
---|
210 | * Side effects: |
---|
211 | * This function initializes the file name of the Tcl script to run at |
---|
212 | * startup. |
---|
213 | * |
---|
214 | *---------------------------------------------------------------------- |
---|
215 | */ |
---|
216 | |
---|
217 | void |
---|
218 | TclSetStartupScriptFileName( |
---|
219 | CONST char *fileName) |
---|
220 | { |
---|
221 | Tcl_Obj *path = Tcl_NewStringObj(fileName,-1); |
---|
222 | Tcl_SetStartupScript(path, NULL); |
---|
223 | } |
---|
224 | |
---|
225 | /* |
---|
226 | *---------------------------------------------------------------------- |
---|
227 | * |
---|
228 | * TclGetStartupScriptFileName -- |
---|
229 | * |
---|
230 | * Gets the startup script file name, used to override the command line |
---|
231 | * processing. |
---|
232 | * |
---|
233 | * Results: |
---|
234 | * The startup script file name, NULL if none has been set. |
---|
235 | * |
---|
236 | * Side effects: |
---|
237 | * None. |
---|
238 | * |
---|
239 | *---------------------------------------------------------------------- |
---|
240 | */ |
---|
241 | |
---|
242 | CONST char * |
---|
243 | TclGetStartupScriptFileName(void) |
---|
244 | { |
---|
245 | Tcl_Obj *path = Tcl_GetStartupScript(NULL); |
---|
246 | |
---|
247 | if (path == NULL) { |
---|
248 | return NULL; |
---|
249 | } |
---|
250 | return Tcl_GetString(path); |
---|
251 | } |
---|
252 | |
---|
253 | /*---------------------------------------------------------------------- |
---|
254 | * |
---|
255 | * Tcl_SourceRCFile -- |
---|
256 | * |
---|
257 | * This function is typically invoked by Tcl_Main of Tk_Main function to |
---|
258 | * source an application specific rc file into the interpreter at startup |
---|
259 | * time. |
---|
260 | * |
---|
261 | * Results: |
---|
262 | * None. |
---|
263 | * |
---|
264 | * Side effects: |
---|
265 | * Depends on what's in the rc script. |
---|
266 | * |
---|
267 | *---------------------------------------------------------------------- |
---|
268 | */ |
---|
269 | |
---|
270 | void |
---|
271 | Tcl_SourceRCFile( |
---|
272 | Tcl_Interp *interp) /* Interpreter to source rc file into. */ |
---|
273 | { |
---|
274 | Tcl_DString temp; |
---|
275 | CONST char *fileName; |
---|
276 | Tcl_Channel errChannel; |
---|
277 | |
---|
278 | fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY); |
---|
279 | if (fileName != NULL) { |
---|
280 | Tcl_Channel c; |
---|
281 | CONST char *fullName; |
---|
282 | |
---|
283 | Tcl_DStringInit(&temp); |
---|
284 | fullName = Tcl_TranslateFileName(interp, fileName, &temp); |
---|
285 | if (fullName == NULL) { |
---|
286 | /* |
---|
287 | * Couldn't translate the file name (e.g. it referred to a bogus |
---|
288 | * user or there was no HOME environment variable). Just do |
---|
289 | * nothing. |
---|
290 | */ |
---|
291 | } else { |
---|
292 | /* |
---|
293 | * Test for the existence of the rc file before trying to read it. |
---|
294 | */ |
---|
295 | |
---|
296 | c = Tcl_OpenFileChannel(NULL, fullName, "r", 0); |
---|
297 | if (c != (Tcl_Channel) NULL) { |
---|
298 | Tcl_Close(NULL, c); |
---|
299 | if (Tcl_EvalFile(interp, fullName) != TCL_OK) { |
---|
300 | errChannel = Tcl_GetStdChannel(TCL_STDERR); |
---|
301 | if (errChannel) { |
---|
302 | Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); |
---|
303 | Tcl_WriteChars(errChannel, "\n", 1); |
---|
304 | } |
---|
305 | } |
---|
306 | } |
---|
307 | } |
---|
308 | Tcl_DStringFree(&temp); |
---|
309 | } |
---|
310 | } |
---|
311 | |
---|
312 | /*---------------------------------------------------------------------- |
---|
313 | * |
---|
314 | * Tcl_Main -- |
---|
315 | * |
---|
316 | * Main program for tclsh and most other Tcl-based applications. |
---|
317 | * |
---|
318 | * Results: |
---|
319 | * None. This function never returns (it exits the process when it's |
---|
320 | * done). |
---|
321 | * |
---|
322 | * Side effects: |
---|
323 | * This function initializes the Tcl world and then starts interpreting |
---|
324 | * commands; almost anything could happen, depending on the script being |
---|
325 | * interpreted. |
---|
326 | * |
---|
327 | *---------------------------------------------------------------------- |
---|
328 | */ |
---|
329 | |
---|
330 | void |
---|
331 | Tcl_Main( |
---|
332 | int argc, /* Number of arguments. */ |
---|
333 | char **argv, /* Array of argument strings. */ |
---|
334 | Tcl_AppInitProc *appInitProc) |
---|
335 | /* Application-specific initialization |
---|
336 | * function to call after most initialization |
---|
337 | * but before starting to execute commands. */ |
---|
338 | { |
---|
339 | Tcl_Obj *path, *resultPtr, *argvPtr, *commandPtr = NULL; |
---|
340 | CONST char *encodingName = NULL; |
---|
341 | PromptType prompt = PROMPT_START; |
---|
342 | int code, length, tty, exitCode = 0; |
---|
343 | Tcl_Channel inChannel, outChannel, errChannel; |
---|
344 | Tcl_Interp *interp; |
---|
345 | Tcl_DString appName; |
---|
346 | |
---|
347 | Tcl_FindExecutable(argv[0]); |
---|
348 | |
---|
349 | interp = Tcl_CreateInterp(); |
---|
350 | Tcl_InitMemory(interp); |
---|
351 | |
---|
352 | /* |
---|
353 | * If the application has not already set a startup script, parse the |
---|
354 | * first few command line arguments to determine the script path and |
---|
355 | * encoding. |
---|
356 | */ |
---|
357 | |
---|
358 | if (NULL == Tcl_GetStartupScript(NULL)) { |
---|
359 | |
---|
360 | /* |
---|
361 | * Check whether first 3 args (argv[1] - argv[3]) look like |
---|
362 | * -encoding ENCODING FILENAME |
---|
363 | * or like |
---|
364 | * FILENAME |
---|
365 | */ |
---|
366 | |
---|
367 | if ((argc > 3) && (0 == strcmp("-encoding", argv[1])) |
---|
368 | && ('-' != argv[3][0])) { |
---|
369 | Tcl_SetStartupScript(Tcl_NewStringObj(argv[3], -1), argv[2]); |
---|
370 | argc -= 3; |
---|
371 | argv += 3; |
---|
372 | } else if ((argc > 1) && ('-' != argv[1][0])) { |
---|
373 | Tcl_SetStartupScript(Tcl_NewStringObj(argv[1], -1), NULL); |
---|
374 | argc--; |
---|
375 | argv++; |
---|
376 | } |
---|
377 | } |
---|
378 | |
---|
379 | path = Tcl_GetStartupScript(&encodingName); |
---|
380 | if (path == NULL) { |
---|
381 | Tcl_ExternalToUtfDString(NULL, argv[0], -1, &appName); |
---|
382 | } else { |
---|
383 | CONST char *pathName = Tcl_GetStringFromObj(path, &length); |
---|
384 | Tcl_ExternalToUtfDString(NULL, pathName, length, &appName); |
---|
385 | path = Tcl_NewStringObj(Tcl_DStringValue(&appName), -1); |
---|
386 | Tcl_SetStartupScript(path, encodingName); |
---|
387 | } |
---|
388 | Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&appName), TCL_GLOBAL_ONLY); |
---|
389 | Tcl_DStringFree(&appName); |
---|
390 | argc--; |
---|
391 | argv++; |
---|
392 | |
---|
393 | Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY); |
---|
394 | |
---|
395 | argvPtr = Tcl_NewListObj(0, NULL); |
---|
396 | while (argc--) { |
---|
397 | Tcl_DString ds; |
---|
398 | Tcl_ExternalToUtfDString(NULL, *argv++, -1, &ds); |
---|
399 | Tcl_ListObjAppendElement(NULL, argvPtr, Tcl_NewStringObj( |
---|
400 | Tcl_DStringValue(&ds), Tcl_DStringLength(&ds))); |
---|
401 | Tcl_DStringFree(&ds); |
---|
402 | } |
---|
403 | Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY); |
---|
404 | |
---|
405 | /* |
---|
406 | * Set the "tcl_interactive" variable. |
---|
407 | */ |
---|
408 | |
---|
409 | tty = isatty(0); |
---|
410 | Tcl_SetVar(interp, "tcl_interactive", ((path == NULL) && tty) ? "1" : "0", |
---|
411 | TCL_GLOBAL_ONLY); |
---|
412 | |
---|
413 | /* |
---|
414 | * Invoke application-specific initialization. |
---|
415 | */ |
---|
416 | |
---|
417 | Tcl_Preserve((ClientData) interp); |
---|
418 | if ((*appInitProc)(interp) != TCL_OK) { |
---|
419 | errChannel = Tcl_GetStdChannel(TCL_STDERR); |
---|
420 | if (errChannel) { |
---|
421 | Tcl_WriteChars(errChannel, |
---|
422 | "application-specific initialization failed: ", -1); |
---|
423 | Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); |
---|
424 | Tcl_WriteChars(errChannel, "\n", 1); |
---|
425 | } |
---|
426 | } |
---|
427 | if (Tcl_InterpDeleted(interp)) { |
---|
428 | goto done; |
---|
429 | } |
---|
430 | if (Tcl_LimitExceeded(interp)) { |
---|
431 | goto done; |
---|
432 | } |
---|
433 | |
---|
434 | /* |
---|
435 | * If a script file was specified then just source that file and quit. |
---|
436 | * Must fetch it again, as the appInitProc might have reset it. |
---|
437 | */ |
---|
438 | |
---|
439 | path = Tcl_GetStartupScript(&encodingName); |
---|
440 | if (path != NULL) { |
---|
441 | code = Tcl_FSEvalFileEx(interp, path, encodingName); |
---|
442 | if (code != TCL_OK) { |
---|
443 | errChannel = Tcl_GetStdChannel(TCL_STDERR); |
---|
444 | if (errChannel) { |
---|
445 | Tcl_Obj *options = Tcl_GetReturnOptions(interp, code); |
---|
446 | Tcl_Obj *keyPtr, *valuePtr; |
---|
447 | |
---|
448 | TclNewLiteralStringObj(keyPtr, "-errorinfo"); |
---|
449 | Tcl_IncrRefCount(keyPtr); |
---|
450 | Tcl_DictObjGet(NULL, options, keyPtr, &valuePtr); |
---|
451 | Tcl_DecrRefCount(keyPtr); |
---|
452 | |
---|
453 | if (valuePtr) { |
---|
454 | Tcl_WriteObj(errChannel, valuePtr); |
---|
455 | } |
---|
456 | Tcl_WriteChars(errChannel, "\n", 1); |
---|
457 | } |
---|
458 | exitCode = 1; |
---|
459 | } |
---|
460 | goto done; |
---|
461 | } |
---|
462 | |
---|
463 | /* |
---|
464 | * We're running interactively. Source a user-specific startup file if the |
---|
465 | * application specified one and if the file exists. |
---|
466 | */ |
---|
467 | |
---|
468 | Tcl_SourceRCFile(interp); |
---|
469 | if (Tcl_LimitExceeded(interp)) { |
---|
470 | goto done; |
---|
471 | } |
---|
472 | |
---|
473 | /* |
---|
474 | * Process commands from stdin until there's an end-of-file. Note that we |
---|
475 | * need to fetch the standard channels again after every eval, since they |
---|
476 | * may have been changed. |
---|
477 | */ |
---|
478 | |
---|
479 | commandPtr = Tcl_NewObj(); |
---|
480 | Tcl_IncrRefCount(commandPtr); |
---|
481 | |
---|
482 | /* |
---|
483 | * Get a new value for tty if anyone writes to ::tcl_interactive |
---|
484 | */ |
---|
485 | |
---|
486 | Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty, TCL_LINK_BOOLEAN); |
---|
487 | inChannel = Tcl_GetStdChannel(TCL_STDIN); |
---|
488 | outChannel = Tcl_GetStdChannel(TCL_STDOUT); |
---|
489 | while ((inChannel != (Tcl_Channel) NULL) && !Tcl_InterpDeleted(interp)) { |
---|
490 | if (mainLoopProc == NULL) { |
---|
491 | if (tty) { |
---|
492 | Prompt(interp, &prompt); |
---|
493 | if (Tcl_InterpDeleted(interp)) { |
---|
494 | break; |
---|
495 | } |
---|
496 | if (Tcl_LimitExceeded(interp)) { |
---|
497 | break; |
---|
498 | } |
---|
499 | inChannel = Tcl_GetStdChannel(TCL_STDIN); |
---|
500 | if (inChannel == (Tcl_Channel) NULL) { |
---|
501 | break; |
---|
502 | } |
---|
503 | } |
---|
504 | if (Tcl_IsShared(commandPtr)) { |
---|
505 | Tcl_DecrRefCount(commandPtr); |
---|
506 | commandPtr = Tcl_DuplicateObj(commandPtr); |
---|
507 | Tcl_IncrRefCount(commandPtr); |
---|
508 | } |
---|
509 | length = Tcl_GetsObj(inChannel, commandPtr); |
---|
510 | if (length < 0) { |
---|
511 | if (Tcl_InputBlocked(inChannel)) { |
---|
512 | /* |
---|
513 | * This can only happen if stdin has been set to |
---|
514 | * non-blocking. In that case cycle back and try again. |
---|
515 | * This sets up a tight polling loop (since we have no |
---|
516 | * event loop running). If this causes bad CPU hogging, |
---|
517 | * we might try toggling the blocking on stdin instead. |
---|
518 | */ |
---|
519 | |
---|
520 | continue; |
---|
521 | } |
---|
522 | |
---|
523 | /* |
---|
524 | * Either EOF, or an error on stdin; we're done |
---|
525 | */ |
---|
526 | |
---|
527 | break; |
---|
528 | } |
---|
529 | |
---|
530 | /* |
---|
531 | * Add the newline removed by Tcl_GetsObj back to the string. |
---|
532 | * Have to add it back before testing completeness, because |
---|
533 | * it can make a difference. [Bug 1775878]. |
---|
534 | */ |
---|
535 | |
---|
536 | if (Tcl_IsShared(commandPtr)) { |
---|
537 | Tcl_DecrRefCount(commandPtr); |
---|
538 | commandPtr = Tcl_DuplicateObj(commandPtr); |
---|
539 | Tcl_IncrRefCount(commandPtr); |
---|
540 | } |
---|
541 | Tcl_AppendToObj(commandPtr, "\n", 1); |
---|
542 | if (!TclObjCommandComplete(commandPtr)) { |
---|
543 | prompt = PROMPT_CONTINUE; |
---|
544 | continue; |
---|
545 | } |
---|
546 | |
---|
547 | prompt = PROMPT_START; |
---|
548 | /* |
---|
549 | * The final newline is syntactically redundant, and causes |
---|
550 | * some error messages troubles deeper in, so lop it back off. |
---|
551 | */ |
---|
552 | Tcl_GetStringFromObj(commandPtr, &length); |
---|
553 | Tcl_SetObjLength(commandPtr, --length); |
---|
554 | code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL); |
---|
555 | inChannel = Tcl_GetStdChannel(TCL_STDIN); |
---|
556 | outChannel = Tcl_GetStdChannel(TCL_STDOUT); |
---|
557 | errChannel = Tcl_GetStdChannel(TCL_STDERR); |
---|
558 | Tcl_DecrRefCount(commandPtr); |
---|
559 | commandPtr = Tcl_NewObj(); |
---|
560 | Tcl_IncrRefCount(commandPtr); |
---|
561 | if (code != TCL_OK) { |
---|
562 | if (errChannel) { |
---|
563 | Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); |
---|
564 | Tcl_WriteChars(errChannel, "\n", 1); |
---|
565 | } |
---|
566 | } else if (tty) { |
---|
567 | resultPtr = Tcl_GetObjResult(interp); |
---|
568 | Tcl_IncrRefCount(resultPtr); |
---|
569 | Tcl_GetStringFromObj(resultPtr, &length); |
---|
570 | if ((length > 0) && outChannel) { |
---|
571 | Tcl_WriteObj(outChannel, resultPtr); |
---|
572 | Tcl_WriteChars(outChannel, "\n", 1); |
---|
573 | } |
---|
574 | Tcl_DecrRefCount(resultPtr); |
---|
575 | } |
---|
576 | } else { /* (mainLoopProc != NULL) */ |
---|
577 | /* |
---|
578 | * If a main loop has been defined while running interactively, we |
---|
579 | * want to start a fileevent based prompt by establishing a |
---|
580 | * channel handler for stdin. |
---|
581 | */ |
---|
582 | |
---|
583 | InteractiveState *isPtr = NULL; |
---|
584 | |
---|
585 | if (inChannel) { |
---|
586 | if (tty) { |
---|
587 | Prompt(interp, &prompt); |
---|
588 | } |
---|
589 | isPtr = (InteractiveState *) |
---|
590 | ckalloc((int) sizeof(InteractiveState)); |
---|
591 | isPtr->input = inChannel; |
---|
592 | isPtr->tty = tty; |
---|
593 | isPtr->commandPtr = commandPtr; |
---|
594 | isPtr->prompt = prompt; |
---|
595 | isPtr->interp = interp; |
---|
596 | |
---|
597 | Tcl_UnlinkVar(interp, "tcl_interactive"); |
---|
598 | Tcl_LinkVar(interp, "tcl_interactive", (char *) &(isPtr->tty), |
---|
599 | TCL_LINK_BOOLEAN); |
---|
600 | |
---|
601 | Tcl_CreateChannelHandler(inChannel, TCL_READABLE, StdinProc, |
---|
602 | (ClientData) isPtr); |
---|
603 | } |
---|
604 | |
---|
605 | (*mainLoopProc)(); |
---|
606 | mainLoopProc = NULL; |
---|
607 | |
---|
608 | if (inChannel) { |
---|
609 | tty = isPtr->tty; |
---|
610 | Tcl_UnlinkVar(interp, "tcl_interactive"); |
---|
611 | Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty, |
---|
612 | TCL_LINK_BOOLEAN); |
---|
613 | prompt = isPtr->prompt; |
---|
614 | commandPtr = isPtr->commandPtr; |
---|
615 | if (isPtr->input != (Tcl_Channel) NULL) { |
---|
616 | Tcl_DeleteChannelHandler(isPtr->input, StdinProc, |
---|
617 | (ClientData) isPtr); |
---|
618 | } |
---|
619 | ckfree((char *)isPtr); |
---|
620 | } |
---|
621 | inChannel = Tcl_GetStdChannel(TCL_STDIN); |
---|
622 | outChannel = Tcl_GetStdChannel(TCL_STDOUT); |
---|
623 | errChannel = Tcl_GetStdChannel(TCL_STDERR); |
---|
624 | } |
---|
625 | #ifdef TCL_MEM_DEBUG |
---|
626 | |
---|
627 | /* |
---|
628 | * This code here only for the (unsupported and deprecated) [checkmem] |
---|
629 | * command. |
---|
630 | */ |
---|
631 | |
---|
632 | if (tclMemDumpFileName != NULL) { |
---|
633 | mainLoopProc = NULL; |
---|
634 | Tcl_DeleteInterp(interp); |
---|
635 | } |
---|
636 | #endif |
---|
637 | } |
---|
638 | |
---|
639 | done: |
---|
640 | if ((exitCode == 0) && (mainLoopProc != NULL) |
---|
641 | && !Tcl_LimitExceeded(interp)) { |
---|
642 | /* |
---|
643 | * If everything has gone OK so far, call the main loop proc, if it |
---|
644 | * exists. Packages (like Tk) can set it to start processing events at |
---|
645 | * this point. |
---|
646 | */ |
---|
647 | |
---|
648 | (*mainLoopProc)(); |
---|
649 | mainLoopProc = NULL; |
---|
650 | } |
---|
651 | if (commandPtr != NULL) { |
---|
652 | Tcl_DecrRefCount(commandPtr); |
---|
653 | } |
---|
654 | |
---|
655 | /* |
---|
656 | * Rather than calling exit, invoke the "exit" command so that users can |
---|
657 | * replace "exit" with some other command to do additional cleanup on |
---|
658 | * exit. The Tcl_EvalObjEx call should never return. |
---|
659 | */ |
---|
660 | |
---|
661 | if (!Tcl_InterpDeleted(interp)) { |
---|
662 | if (!Tcl_LimitExceeded(interp)) { |
---|
663 | Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode); |
---|
664 | Tcl_IncrRefCount(cmd); |
---|
665 | Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL); |
---|
666 | Tcl_DecrRefCount(cmd); |
---|
667 | } |
---|
668 | |
---|
669 | /* |
---|
670 | * If Tcl_EvalObjEx returns, trying to eval [exit], something unusual |
---|
671 | * is happening. Maybe interp has been deleted; maybe [exit] was |
---|
672 | * redefined, maybe we've blown up because of an exceeded limit. We |
---|
673 | * still want to cleanup and exit. |
---|
674 | */ |
---|
675 | |
---|
676 | if (!Tcl_InterpDeleted(interp)) { |
---|
677 | Tcl_DeleteInterp(interp); |
---|
678 | } |
---|
679 | } |
---|
680 | Tcl_SetStartupScript(NULL, NULL); |
---|
681 | |
---|
682 | /* |
---|
683 | * If we get here, the master interp has been deleted. Allow its |
---|
684 | * destruction with the last matching Tcl_Release. |
---|
685 | */ |
---|
686 | |
---|
687 | Tcl_Release((ClientData) interp); |
---|
688 | Tcl_Exit(exitCode); |
---|
689 | } |
---|
690 | |
---|
691 | /* |
---|
692 | *--------------------------------------------------------------- |
---|
693 | * |
---|
694 | * Tcl_SetMainLoop -- |
---|
695 | * |
---|
696 | * Sets an alternative main loop function. |
---|
697 | * |
---|
698 | * Results: |
---|
699 | * Returns the previously defined main loop function. |
---|
700 | * |
---|
701 | * Side effects: |
---|
702 | * This function will be called before Tcl exits, allowing for the |
---|
703 | * creation of an event loop. |
---|
704 | * |
---|
705 | *--------------------------------------------------------------- |
---|
706 | */ |
---|
707 | |
---|
708 | void |
---|
709 | Tcl_SetMainLoop( |
---|
710 | Tcl_MainLoopProc *proc) |
---|
711 | { |
---|
712 | mainLoopProc = proc; |
---|
713 | } |
---|
714 | |
---|
715 | /* |
---|
716 | *---------------------------------------------------------------------- |
---|
717 | * |
---|
718 | * StdinProc -- |
---|
719 | * |
---|
720 | * This function is invoked by the event dispatcher whenever standard |
---|
721 | * input becomes readable. It grabs the next line of input characters, |
---|
722 | * adds them to a command being assembled, and executes the command if |
---|
723 | * it's complete. |
---|
724 | * |
---|
725 | * Results: |
---|
726 | * None. |
---|
727 | * |
---|
728 | * Side effects: |
---|
729 | * Could be almost arbitrary, depending on the command that's typed. |
---|
730 | * |
---|
731 | *---------------------------------------------------------------------- |
---|
732 | */ |
---|
733 | |
---|
734 | /* ARGSUSED */ |
---|
735 | static void |
---|
736 | StdinProc( |
---|
737 | ClientData clientData, /* The state of interactive cmd line */ |
---|
738 | int mask) /* Not used. */ |
---|
739 | { |
---|
740 | InteractiveState *isPtr = (InteractiveState *) clientData; |
---|
741 | Tcl_Channel chan = isPtr->input; |
---|
742 | Tcl_Obj *commandPtr = isPtr->commandPtr; |
---|
743 | Tcl_Interp *interp = isPtr->interp; |
---|
744 | int code, length; |
---|
745 | |
---|
746 | if (Tcl_IsShared(commandPtr)) { |
---|
747 | Tcl_DecrRefCount(commandPtr); |
---|
748 | commandPtr = Tcl_DuplicateObj(commandPtr); |
---|
749 | Tcl_IncrRefCount(commandPtr); |
---|
750 | } |
---|
751 | length = Tcl_GetsObj(chan, commandPtr); |
---|
752 | if (length < 0) { |
---|
753 | if (Tcl_InputBlocked(chan)) { |
---|
754 | return; |
---|
755 | } |
---|
756 | if (isPtr->tty) { |
---|
757 | /* |
---|
758 | * Would be better to find a way to exit the mainLoop? Or perhaps |
---|
759 | * evaluate [exit]? Leaving as is for now due to compatibility |
---|
760 | * concerns. |
---|
761 | */ |
---|
762 | |
---|
763 | Tcl_Exit(0); |
---|
764 | } |
---|
765 | Tcl_DeleteChannelHandler(chan, StdinProc, (ClientData) isPtr); |
---|
766 | return; |
---|
767 | } |
---|
768 | |
---|
769 | if (Tcl_IsShared(commandPtr)) { |
---|
770 | Tcl_DecrRefCount(commandPtr); |
---|
771 | commandPtr = Tcl_DuplicateObj(commandPtr); |
---|
772 | Tcl_IncrRefCount(commandPtr); |
---|
773 | } |
---|
774 | Tcl_AppendToObj(commandPtr, "\n", 1); |
---|
775 | if (!TclObjCommandComplete(commandPtr)) { |
---|
776 | isPtr->prompt = PROMPT_CONTINUE; |
---|
777 | goto prompt; |
---|
778 | } |
---|
779 | isPtr->prompt = PROMPT_START; |
---|
780 | Tcl_GetStringFromObj(commandPtr, &length); |
---|
781 | Tcl_SetObjLength(commandPtr, --length); |
---|
782 | |
---|
783 | /* |
---|
784 | * Disable the stdin channel handler while evaluating the command; |
---|
785 | * otherwise if the command re-enters the event loop we might process |
---|
786 | * commands from stdin before the current command is finished. Among other |
---|
787 | * things, this will trash the text of the command being evaluated. |
---|
788 | */ |
---|
789 | |
---|
790 | Tcl_CreateChannelHandler(chan, 0, StdinProc, (ClientData) isPtr); |
---|
791 | code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL); |
---|
792 | isPtr->input = chan = Tcl_GetStdChannel(TCL_STDIN); |
---|
793 | Tcl_DecrRefCount(commandPtr); |
---|
794 | isPtr->commandPtr = commandPtr = Tcl_NewObj(); |
---|
795 | Tcl_IncrRefCount(commandPtr); |
---|
796 | if (chan != (Tcl_Channel) NULL) { |
---|
797 | Tcl_CreateChannelHandler(chan, TCL_READABLE, StdinProc, |
---|
798 | (ClientData) isPtr); |
---|
799 | } |
---|
800 | if (code != TCL_OK) { |
---|
801 | Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR); |
---|
802 | if (errChannel != (Tcl_Channel) NULL) { |
---|
803 | Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); |
---|
804 | Tcl_WriteChars(errChannel, "\n", 1); |
---|
805 | } |
---|
806 | } else if (isPtr->tty) { |
---|
807 | Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); |
---|
808 | Tcl_Channel outChannel = Tcl_GetStdChannel(TCL_STDOUT); |
---|
809 | Tcl_IncrRefCount(resultPtr); |
---|
810 | Tcl_GetStringFromObj(resultPtr, &length); |
---|
811 | if ((length >0) && (outChannel != (Tcl_Channel) NULL)) { |
---|
812 | Tcl_WriteObj(outChannel, resultPtr); |
---|
813 | Tcl_WriteChars(outChannel, "\n", 1); |
---|
814 | } |
---|
815 | Tcl_DecrRefCount(resultPtr); |
---|
816 | } |
---|
817 | |
---|
818 | /* |
---|
819 | * If a tty stdin is still around, output a prompt. |
---|
820 | */ |
---|
821 | |
---|
822 | prompt: |
---|
823 | if (isPtr->tty && (isPtr->input != (Tcl_Channel) NULL)) { |
---|
824 | Prompt(interp, &(isPtr->prompt)); |
---|
825 | isPtr->input = Tcl_GetStdChannel(TCL_STDIN); |
---|
826 | } |
---|
827 | } |
---|
828 | |
---|
829 | /* |
---|
830 | *---------------------------------------------------------------------- |
---|
831 | * |
---|
832 | * Prompt -- |
---|
833 | * |
---|
834 | * Issue a prompt on standard output, or invoke a script to issue the |
---|
835 | * prompt. |
---|
836 | * |
---|
837 | * Results: |
---|
838 | * None. |
---|
839 | * |
---|
840 | * Side effects: |
---|
841 | * A prompt gets output, and a Tcl script may be evaluated in interp. |
---|
842 | * |
---|
843 | *---------------------------------------------------------------------- |
---|
844 | */ |
---|
845 | |
---|
846 | static void |
---|
847 | Prompt( |
---|
848 | Tcl_Interp *interp, /* Interpreter to use for prompting. */ |
---|
849 | PromptType *promptPtr) /* Points to type of prompt to print. Filled |
---|
850 | * with PROMPT_NONE after a prompt is |
---|
851 | * printed. */ |
---|
852 | { |
---|
853 | Tcl_Obj *promptCmdPtr; |
---|
854 | int code; |
---|
855 | Tcl_Channel outChannel, errChannel; |
---|
856 | |
---|
857 | if (*promptPtr == PROMPT_NONE) { |
---|
858 | return; |
---|
859 | } |
---|
860 | |
---|
861 | promptCmdPtr = Tcl_GetVar2Ex(interp, |
---|
862 | ((*promptPtr == PROMPT_CONTINUE) ? "tcl_prompt2" : "tcl_prompt1"), |
---|
863 | NULL, TCL_GLOBAL_ONLY); |
---|
864 | |
---|
865 | if (Tcl_InterpDeleted(interp)) { |
---|
866 | return; |
---|
867 | } |
---|
868 | if (promptCmdPtr == NULL) { |
---|
869 | defaultPrompt: |
---|
870 | outChannel = Tcl_GetStdChannel(TCL_STDOUT); |
---|
871 | if ((*promptPtr == PROMPT_START) |
---|
872 | && (outChannel != (Tcl_Channel) NULL)) { |
---|
873 | Tcl_WriteChars(outChannel, DEFAULT_PRIMARY_PROMPT, |
---|
874 | strlen(DEFAULT_PRIMARY_PROMPT)); |
---|
875 | } |
---|
876 | } else { |
---|
877 | code = Tcl_EvalObjEx(interp, promptCmdPtr, TCL_EVAL_GLOBAL); |
---|
878 | if (code != TCL_OK) { |
---|
879 | Tcl_AddErrorInfo(interp, |
---|
880 | "\n (script that generates prompt)"); |
---|
881 | errChannel = Tcl_GetStdChannel(TCL_STDERR); |
---|
882 | if (errChannel != (Tcl_Channel) NULL) { |
---|
883 | Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); |
---|
884 | Tcl_WriteChars(errChannel, "\n", 1); |
---|
885 | } |
---|
886 | goto defaultPrompt; |
---|
887 | } |
---|
888 | } |
---|
889 | |
---|
890 | outChannel = Tcl_GetStdChannel(TCL_STDOUT); |
---|
891 | if (outChannel != (Tcl_Channel) NULL) { |
---|
892 | Tcl_Flush(outChannel); |
---|
893 | } |
---|
894 | *promptPtr = PROMPT_NONE; |
---|
895 | } |
---|
896 | |
---|
897 | /* |
---|
898 | * Local Variables: |
---|
899 | * mode: c |
---|
900 | * c-basic-offset: 4 |
---|
901 | * fill-column: 78 |
---|
902 | * End: |
---|
903 | */ |
---|