Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: downloads/tcl8.5.2/generic/tclMain.c @ 63

Last change on this file since 63 was 25, checked in by landauf, 16 years ago

added tcl to libs
File size: 23.7 KB
Line 
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
33extern CRTIMPORT int    isatty(int fd);
34
35static Tcl_Obj *tclStartupScriptPath = NULL;
36static Tcl_Obj *tclStartupScriptEncoding = NULL;
37static 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
45typedef 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
51typedef 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
68static void             Prompt(Tcl_Interp *interp, PromptType *promptPtr);
69static 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
87void
88Tcl_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
134Tcl_Obj *
135Tcl_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
169void
170TclSetStartupScriptPath(
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
193Tcl_Obj *
194TclGetStartupScriptPath(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
217void
218TclSetStartupScriptFileName(
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
242CONST char *
243TclGetStartupScriptFileName(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
270void
271Tcl_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
330void
331Tcl_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
708void
709Tcl_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 */
735static void
736StdinProc(
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
846static void
847Prompt(
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 */
Note: See TracBrowser for help on using the repository browser.