Attachment "main.patch" to
ticket [486453ffff]
added by
dgp
2002-01-06 05:43:09.
Index: ChangeLog
===================================================================
RCS file: /cvsroot/tcl/tcl/ChangeLog,v
retrieving revision 1.778
diff -u -r1.778 ChangeLog
--- ChangeLog 2002/01/04 15:43:45 1.778
+++ ChangeLog 2002/01/05 22:37:34
@@ -1,3 +1,48 @@
+2002-01-05 Don Porter <[email protected]>
+
+ * doc/Tcl_Main.3:
+ * generic/tclMain.c: Substantial rewrite and expanded documentation
+ of Tcl_Main to correct a number of bugs and flaws:
+
+ * Interactive Tcl_Main can now enter a main loop, exit
+ that loop and continue interactive operations. The loop
+ may even exit in the midst of interactive command typing
+ without loss of the partial command. [Bugs 486453, 474131]
+ * Tcl_Main now gracefully handles deletion of its master
+ interpreter.
+ * Interactive Tcl_Main can now operate with non-blocking stdin
+ * Interactive Tcl_Main can now detect EOF on stdin even in
+ mid-command. [Bug 491341]
+ * Added VFS-aware internal routines for managing the
+ startup script selection.
+ * Tcl variable 'tcl_interactive' is now linked to C variable
+ 'tty' so that one can disable/enable interactive prompts
+ at the script level when there is no startup script. This
+ is meant for use by the test suite.
+ * Consistent use of the Tcl libraries standard channels as
+ returned by Tcl_GetStdChannel(); as opposed to the channels
+ named 'stdin', 'stdout', and 'stderr' in the master interp,
+ which can be different or unavailable.
+ * Tcl_Main now calls Tcl_Exit() if evaluation of [exit] in the
+ master interpreter returns, assuring Tcl_Main does not return.
+ * Documented Tcl_Main's absence from public stub table
+ * Documented that Tcl_Main does not return.
+ * Documented Tcl variables set by Tcl_Main.
+ * All prompts are done from a single procedure, Prompt.
+ * Use of Tcl_Obj-enabled interfaces everywhere.
+
+ * generic/tclInt.decls (TclGetStartupScriptPath,
+ TclSetStartupScriptPath): New internal VFS-aware routines for
+ managing the startup script of Tcl_Main.
+ * generic/tclIntDecls.h:
+ * generic/tclStubInit.c: make genstubs
+
+ * generic/tclTest.c (TestsetmainloopCmd,TestexitmainloopCmd,
+ Tcltest_Init,TestinterpdeleteCmd):
+ * tests/main.test (new): Added new file to test suite that
+ thoroughly tests generic/tclMain.c; added some new test commands
+ for testing Tcl_SetMainLoop().
+
2002-01-04 Don Porter <[email protected]>
* generic/tclThreadJoin.c (TclRememberJoinableThread,TclJoinThread):
Index: doc/Tcl_Main.3
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/Tcl_Main.3,v
retrieving revision 1.5
diff -u -r1.5 Tcl_Main.3
--- doc/Tcl_Main.3 2001/12/10 15:50:47 1.5
+++ doc/Tcl_Main.3 2002/01/05 22:37:36
@@ -49,20 +49,52 @@
\fBTcl_Main\fR then does all the work of creating and running a
\fBtclsh\fR-like application.
.PP
-When it is has finished its own initialization, but before
-it processes commands, \fBTcl_Main\fR calls the procedure given by
-the \fIappInitProc\fR argument. This procedure provides a ``hook''
-for the application to perform its own initialization, such as defining
-application-specific commands. The procedure must have an interface
-that matches the type \fBTcl_AppInitProc\fR:
+\fBTcl_Main\fR is not provided by the public interface of Tcl's
+stub library. Programs that call \fBTcl_Main\fR must be linked
+against the standard Tcl library. Extensions (stub-enabled or
+not) are not intended to call \fBTcl_Main\fR.
+.PP
+\fBTcl_Main\fR and therefore all applications based upon it, like
+\fBtclsh\fR, use \fBTcl_GetStdChannel\fR to initialize the standard
+channels to their default values. See \fBTcl_StandardChannels\fR for
+more information.
+.PP
+\fBTcl_Main\fR supports two modes of operation, depending on the
+values of \fIargc\fR and \fIargv\fR. If \fIargv[1]\fR exists and
+does not begin with the character \fI-\fR, it is taken to be the
+name of a file containing a \fIstartup script\fR, which \fBTcl_Main\fR
+will attempt to evaluate. Otherwise, \fBTcl_Main\fR will enter an
+interactive mode.
+.PP
+In either mode, \fBTcl_Main\fB will define in its master interpreter
+the Tcl variables \fIargc\fR, \fIargv\fR, \fIargv0\fR, and
+\fItcl_interactive\fR, as described in the documentation for \fBtclsh\fR.
+.PP
+When it has finished its own initialization, but before it processes
+commands, \fBTcl_Main\fR calls the procedure given by the
+\fIappInitProc\fR argument. This procedure provides a ``hook'' for
+the application to perform its own initialization of the interpreter
+created by \fBTcl_Main\fR, such as defining application-specific
+commands. The procedure must have an interface that matches the
+type \fBTcl_AppInitProc\fR:
.CS
typedef int Tcl_AppInitProc(Tcl_Interp *\fIinterp\fR);
.CE
\fIAppInitProc\fR is almost always a pointer to \fBTcl_AppInit\fR; for more
details on this procedure, see the documentation for \fBTcl_AppInit\fR.
-When the \fIappInitProc\fR is finished, the startup script will be
-evaluated. If none exists, then an interactive prompt is provided.
+.PP
+When the \fIappInitProc\fR is finished, \fBTcl_Main\fR enters one
+of its two modes. If a startup script has been provided, \fBTcl_Main\fR
+attempts to evaluate it. Otherwise interactive operations begin,
+with prompts and command evaluation results written to the standard
+output channel, and commands read from the standard input channel
+and then evaluated. The prompts written to the standard output
+channel may be customized by defining the Tcl variables \fItcl_prompt1\fR
+and \fItcl_prompt2\fR as described in the documentation for \fBtclsh\fR.
+The prompts and command evaluation results are written to the standard
+output channel only if the Tcl variable \fItcl_interactive\fR in the
+master interpreter holds a non-zero integer value.
.PP
.VS 8.4
\fBTcl_SetMainLoop\fR allows setting an event loop procedure to be run.
@@ -70,21 +102,28 @@
loop. The event loop will run following the startup script. If you
are in interactive mode, setting the main loop procedure will cause the
prompt to become fileevent based and then the loop procedure is called.
+When the loop procedure returns in interactive mode, interactive operation
+will continue.
The main loop procedure must have an interface that matches the type
\fBTcl_MainLoopProc\fR:
.CS
typedef void Tcl_MainLoopProc(void);
.CE
.VE 8.4
-
.PP
-\fBTcl_Main\fR and therefore all applications based upon it, like
-\fBtclsh\fR, use \fBTcl_GetStdChannel\fR to initialize the standard
-channels to their default values. See \fBTcl_StandardChannels\fR for
-more information.
+\fBTcl_Main\fR does not return. Normally a program based on
+\fBTcl_Main\fR will terminate when the \fBexit\fR command is
+evaluated. In interactive mode, if an EOF or channel error
+is encountered on the standard input channel, then \fBTcl_Main\fR
+itself will evaluate the \fBexit\fR command after the main loop
+procedure (if any) returns. In non-interactive mode, after
+\fBTcl_Main\fR evaluates the startup script, and the main loop
+procedure (if any) returns, \fBTcl_Main\fR will also evaluate
+the \fBexit\fR command.
.SH "SEE ALSO"
-Tcl_GetStdChannel(3)
+tclsh(1), Tcl_GetStdChannel(3), Tcl_StandardChannels(3), Tcl_AppInit(3),
+exit(n)
.SH KEYWORDS
application-specific initialization, command-line arguments, main program
Index: generic/tclInt.decls
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.decls,v
retrieving revision 1.38
diff -u -r1.38 tclInt.decls
--- generic/tclInt.decls 2001/11/23 01:26:47 1.38
+++ generic/tclInt.decls 2002/01/05 22:37:45
@@ -611,10 +611,10 @@
Var * TclVarTraceExists (Tcl_Interp *interp, char *varName)
}
declare 158 generic {
- void TclSetStartupScriptFileName(char *filename)
+ void TclSetStartupScriptFileName(CONST char *filename)
}
declare 159 generic {
- char *TclGetStartupScriptFileName(void)
+ CONST char *TclGetStartupScriptFileName(void)
}
#declare 160 generic {
# int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators, \
@@ -659,6 +659,15 @@
int index,
Tcl_Obj* valuePtr )
}
+
+# VFS-aware versions of Tcl*StartupScriptFileName (158 and 159 above)
+declare 167 generic {
+ void TclSetStartupScriptPath(Tcl_Obj *pathPtr)
+}
+declare 168 generic {
+ Tcl_Obj *TclGetStartupScriptPath(void)
+}
+
##############################################################################
Index: generic/tclIntDecls.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclIntDecls.h,v
retrieving revision 1.31
diff -u -r1.31 tclIntDecls.h
--- generic/tclIntDecls.h 2001/11/14 23:17:03 1.31
+++ generic/tclIntDecls.h 2002/01/05 22:37:58
@@ -477,9 +477,9 @@
char * varName));
/* 158 */
EXTERN void TclSetStartupScriptFileName _ANSI_ARGS_((
- char * filename));
+ CONST char * filename));
/* 159 */
-EXTERN char * TclGetStartupScriptFileName _ANSI_ARGS_((void));
+EXTERN CONST char * TclGetStartupScriptFileName _ANSI_ARGS_((void));
/* Slot 160 is reserved */
/* 161 */
EXTERN int TclChannelTransform _ANSI_ARGS_((Tcl_Interp * interp,
@@ -497,6 +497,11 @@
EXTERN int TclListObjSetElement _ANSI_ARGS_((Tcl_Interp* interp,
Tcl_Obj* listPtr, int index,
Tcl_Obj* valuePtr));
+/* 167 */
+EXTERN void TclSetStartupScriptPath _ANSI_ARGS_((
+ Tcl_Obj * pathPtr));
+/* 168 */
+EXTERN Tcl_Obj * TclGetStartupScriptPath _ANSI_ARGS_((void));
typedef struct TclIntStubs {
int magic;
@@ -692,8 +697,8 @@
void *reserved155;
void (*tclRegError) _ANSI_ARGS_((Tcl_Interp * interp, char * msg, int status)); /* 156 */
Var * (*tclVarTraceExists) _ANSI_ARGS_((Tcl_Interp * interp, char * varName)); /* 157 */
- void (*tclSetStartupScriptFileName) _ANSI_ARGS_((char * filename)); /* 158 */
- char * (*tclGetStartupScriptFileName) _ANSI_ARGS_((void)); /* 159 */
+ void (*tclSetStartupScriptFileName) _ANSI_ARGS_((CONST char * filename)); /* 158 */
+ CONST char * (*tclGetStartupScriptFileName) _ANSI_ARGS_((void)); /* 159 */
void *reserved160;
int (*tclChannelTransform) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, Tcl_Obj * cmdObjPtr)); /* 161 */
void (*tclChannelEventScriptInvoker) _ANSI_ARGS_((ClientData clientData, int flags)); /* 162 */
@@ -701,6 +706,8 @@
void (*tclExpandCodeArray) _ANSI_ARGS_((void * envPtr)); /* 164 */
void (*tclpSetInitialEncodings) _ANSI_ARGS_((void)); /* 165 */
int (*tclListObjSetElement) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* listPtr, int index, Tcl_Obj* valuePtr)); /* 166 */
+ void (*tclSetStartupScriptPath) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 167 */
+ Tcl_Obj * (*tclGetStartupScriptPath) _ANSI_ARGS_((void)); /* 168 */
} TclIntStubs;
#ifdef __cplusplus
@@ -1308,6 +1315,14 @@
#ifndef TclListObjSetElement
#define TclListObjSetElement \
(tclIntStubsPtr->tclListObjSetElement) /* 166 */
+#endif
+#ifndef TclSetStartupScriptPath
+#define TclSetStartupScriptPath \
+ (tclIntStubsPtr->tclSetStartupScriptPath) /* 167 */
+#endif
+#ifndef TclGetStartupScriptPath
+#define TclGetStartupScriptPath \
+ (tclIntStubsPtr->tclGetStartupScriptPath) /* 168 */
#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
Index: generic/tclMain.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclMain.c,v
retrieving revision 1.14
diff -u -r1.14 tclMain.c
--- generic/tclMain.c 2001/11/23 01:28:53 1.14
+++ generic/tclMain.c 2002/01/05 22:38:02
@@ -33,9 +33,6 @@
* Declarations for various library procedures and variables (don't want
* to include tclPort.h here, because people might copy this file out of
* the Tcl source directory to make their own modified versions).
- * Note: "exit" should really be declared here, but there's no way to
- * declare it without causing conflicts with other definitions elsewher
- * on some systems, so it's better just to leave it out.
*/
#if !defined(MAC_TCL)
@@ -43,29 +40,42 @@
#else
#include <unistd.h>
#endif
-extern char * strcpy _ANSI_ARGS_((char *dst, CONST char *src));
-static char *tclStartupScriptFileName = NULL;
+static Tcl_Obj *tclStartupScriptPath = NULL;
static Tcl_MainLoopProc *mainLoopProc = NULL;
-typedef struct ThreadSpecificData {
- Tcl_Interp *interp; /* Interpreter for this thread. */
- Tcl_DString command; /* Used to assemble lines of terminal input
- * into Tcl commands. */
- Tcl_DString line; /* Used to read the next line from the
- * terminal input. */
+/*
+ * Structure defintiion for information used to keep the state of
+ * an interactive command processor that reads lines from standard
+ * input and writes prompts and results to standard output.
+ */
+
+typedef enum {
+ PROMPT_NONE, /* Print no prompt */
+ PROMPT_START, /* Print prompt for command start */
+ PROMPT_CONTINUE /* Print prompt for command continuation */
+} PromptType;
+
+typedef struct InteractiveState {
+ Tcl_Channel input; /* The standard input channel from which
+ * lines are read. */
int tty; /* Non-zero means standard input is a
* terminal-like device. Zero means it's
* a file. */
-} ThreadSpecificData;
-Tcl_ThreadDataKey dataKey;
+ Tcl_Obj *commandPtr; /* Used to assemble lines of input into
+ * Tcl commands. */
+ PromptType prompt; /* Next prompt to print */
+ Tcl_Interp *interp; /* Interpreter that evaluates interactive
+ * commands. */
+} InteractiveState;
/*
* Forward declarations for procedures defined later in this file.
*/
-static void Prompt _ANSI_ARGS_((Tcl_Interp *interp, int partial));
+static void Prompt _ANSI_ARGS_((Tcl_Interp *interp,
+ PromptType *promptPtr));
static void StdinProc _ANSI_ARGS_((ClientData clientData,
int mask));
@@ -73,6 +83,58 @@
/*
*----------------------------------------------------------------------
*
+ * TclSetStartupScriptPath --
+ *
+ * Primes the startup script VFS path, used to override the
+ * command line processing.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * This procedure initializes the VFS path of the Tcl script to
+ * run at startup.
+ *
+ *----------------------------------------------------------------------
+ */
+void TclSetStartupScriptPath(pathPtr)
+ Tcl_Obj *pathPtr;
+{
+ if (tclStartupScriptPath != NULL) {
+ Tcl_DecrRefCount(tclStartupScriptPath);
+ }
+ tclStartupScriptPath = pathPtr;
+ if (tclStartupScriptPath != NULL) {
+ Tcl_IncrRefCount(tclStartupScriptPath);
+ }
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetStartupScriptPath --
+ *
+ * Gets the startup script VFS path, used to override the
+ * command line processing.
+ *
+ * Results:
+ * The startup script VFS path, NULL if none has been set.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+Tcl_Obj *TclGetStartupScriptPath()
+{
+ return tclStartupScriptPath;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclSetStartupScriptFileName --
*
* Primes the startup script file name, used to override the
@@ -88,9 +150,10 @@
*----------------------------------------------------------------------
*/
void TclSetStartupScriptFileName(fileName)
- char *fileName;
+ CONST char *fileName;
{
- tclStartupScriptFileName = fileName;
+ Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1);
+ TclSetStartupScriptPath(pathPtr);
}
@@ -110,9 +173,9 @@
*
*----------------------------------------------------------------------
*/
-char *TclGetStartupScriptFileName()
+CONST char *TclGetStartupScriptFileName()
{
- return tclStartupScriptFileName;
+ return Tcl_GetString(TclGetStartupScriptPath());
}
@@ -148,22 +211,18 @@
{
Tcl_Obj *resultPtr;
Tcl_Obj *commandPtr = NULL;
- char buffer[1000], *args;
- int code, gotPartial, length;
+ char buffer[TCL_INTEGER_SPACE + 5], *args;
+ PromptType prompt = PROMPT_START;
+ int code, length, tty;
int exitCode = 0;
Tcl_Channel inChannel, outChannel, errChannel;
Tcl_Interp *interp;
Tcl_DString argString;
- ThreadSpecificData *tsdPtr;
Tcl_FindExecutable(argv[0]);
- tsdPtr = (ThreadSpecificData *)
- Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
- tsdPtr->interp = interp = Tcl_CreateInterp();
-#ifdef TCL_MEM_DEBUG
+ interp = Tcl_CreateInterp();
Tcl_InitMemory(interp);
-#endif
/*
* Make command-line arguments available in the Tcl variables "argc"
@@ -171,9 +230,9 @@
* strip it off and use it as the name of a script file to process.
*/
- if (tclStartupScriptFileName == NULL) {
+ if (TclGetStartupScriptPath() == NULL) {
if ((argc > 1) && (argv[1][0] != '-')) {
- tclStartupScriptFileName = argv[1];
+ TclSetStartupScriptFileName(argv[1]);
argc--;
argv++;
}
@@ -184,14 +243,14 @@
Tcl_DStringFree(&argString);
ckfree(args);
- if (tclStartupScriptFileName == NULL) {
+ if (TclGetStartupScriptPath() == NULL) {
Tcl_ExternalToUtfDString(NULL, argv[0], -1, &argString);
} else {
- tclStartupScriptFileName = Tcl_ExternalToUtfDString(NULL,
- tclStartupScriptFileName, -1, &argString);
+ TclSetStartupScriptFileName(Tcl_ExternalToUtfDString(NULL,
+ TclGetStartupScriptFileName(), -1, &argString));
}
- TclFormatInt(buffer, argc-1);
+ TclFormatInt(buffer, (long) argc-1);
Tcl_SetVar(interp, "argc", buffer, TCL_GLOBAL_ONLY);
Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&argString), TCL_GLOBAL_ONLY);
@@ -199,15 +258,16 @@
* Set the "tcl_interactive" variable.
*/
- tsdPtr->tty = isatty(0);
+ tty = isatty(0);
Tcl_SetVar(interp, "tcl_interactive",
- ((tclStartupScriptFileName == NULL) && tsdPtr->tty) ? "1" : "0",
+ ((TclGetStartupScriptPath() == NULL) && tty) ? "1" : "0",
TCL_GLOBAL_ONLY);
/*
* Invoke application-specific initialization.
*/
+ Tcl_Preserve((ClientData) interp);
if ((*appInitProc)(interp) != TCL_OK) {
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel) {
@@ -217,17 +277,21 @@
Tcl_WriteChars(errChannel, "\n", 1);
}
}
+ if (Tcl_InterpDeleted(interp)) {
+ goto done;
+ }
/*
* If a script file was specified then just source that file
* and quit.
*/
- if (tclStartupScriptFileName != NULL) {
- code = Tcl_EvalFile(interp, tclStartupScriptFileName);
+ if (TclGetStartupScriptPath() != NULL) {
+ code = Tcl_FSEvalFile(interp, TclGetStartupScriptPath());
if (code != TCL_OK) {
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel) {
+
/*
* The following statement guarantees that the errorInfo
* variable is set properly.
@@ -260,49 +324,44 @@
commandPtr = Tcl_NewObj();
Tcl_IncrRefCount(commandPtr);
+ /*
+ * Get a new value for tty if anyone writes to ::tcl_interactive
+ */
+ Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty, TCL_LINK_BOOLEAN);
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
- gotPartial = 0;
- while (1) {
- if (tsdPtr->tty) {
- Tcl_Obj *promptCmdPtr;
-
- promptCmdPtr = Tcl_GetVar2Ex(interp,
- (gotPartial ? "tcl_prompt2" : "tcl_prompt1"),
- NULL, TCL_GLOBAL_ONLY);
- if (promptCmdPtr == NULL) {
- defaultPrompt:
- if (!gotPartial && outChannel) {
- Tcl_WriteChars(outChannel, "% ", 2);
- }
- } else {
- code = Tcl_EvalObjEx(interp, promptCmdPtr, 0);
- inChannel = Tcl_GetStdChannel(TCL_STDIN);
- outChannel = Tcl_GetStdChannel(TCL_STDOUT);
- errChannel = Tcl_GetStdChannel(TCL_STDERR);
- if (code != TCL_OK) {
- if (errChannel) {
- Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
- Tcl_WriteChars(errChannel, "\n", 1);
- }
- Tcl_AddErrorInfo(interp,
- "\n (script that generates prompt)");
- goto defaultPrompt;
- }
+ while ((inChannel != (Tcl_Channel) NULL) && !Tcl_InterpDeleted(interp)) {
+ if (tty) {
+ Prompt(interp, &prompt);
+ if (Tcl_InterpDeleted(interp)) {
+ break;
}
- if (outChannel) {
- Tcl_Flush(outChannel);
+ inChannel = Tcl_GetStdChannel(TCL_STDIN);
+ if (inChannel == (Tcl_Channel) NULL) {
+ break;
}
}
- if (!inChannel) {
- goto done;
- }
length = Tcl_GetsObj(inChannel, commandPtr);
if (length < 0) {
- goto done;
- }
- if ((length == 0) && Tcl_Eof(inChannel) && (!gotPartial)) {
- goto done;
+ if (Tcl_InputBlocked(inChannel)) {
+
+ /*
+ * This can only happen if stdin has been set to
+ * non-blocking. In that case cycle back and try
+ * again. This sets up a tight polling loop (since
+ * we have no event loop running). If this causes
+ * bad CPU hogging, we might try toggling the blocking
+ * on stdin instead.
+ */
+
+ continue;
+ }
+
+ /*
+ * Either EOF, or an error on stdin; we're done
+ */
+
+ break;
}
/*
@@ -311,12 +370,12 @@
Tcl_AppendToObj(commandPtr, "\n", 1);
if (!TclObjCommandComplete(commandPtr)) {
- gotPartial = 1;
+ prompt = PROMPT_CONTINUE;
continue;
}
- gotPartial = 0;
- code = Tcl_RecordAndEvalObj(interp, commandPtr, 0);
+ prompt = PROMPT_START;
+ code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL);
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
errChannel = Tcl_GetStdChannel(TCL_STDERR);
@@ -328,7 +387,7 @@
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
Tcl_WriteChars(errChannel, "\n", 1);
}
- } else if (tsdPtr->tty) {
+ } else if (tty) {
resultPtr = Tcl_GetObjResult(interp);
Tcl_GetStringFromObj(resultPtr, &length);
if ((length > 0) && outChannel) {
@@ -337,43 +396,71 @@
}
}
if (mainLoopProc != NULL) {
+
/*
* If a main loop has been defined while running interactively,
* we want to start a fileevent based prompt by establishing a
* channel handler for stdin.
*/
+ InteractiveState *isPtr = NULL;
+
if (inChannel) {
+ if (tty) {
+ Prompt(interp, &prompt);
+ }
+ isPtr = (InteractiveState *)
+ ckalloc((int) sizeof(InteractiveState));
+ isPtr->input = inChannel;
+ isPtr->tty = tty;
+ isPtr->commandPtr = commandPtr;
+ isPtr->prompt = prompt;
+ isPtr->interp = interp;
+
+ Tcl_UnlinkVar(interp, "tcl_interactive");
+ Tcl_LinkVar(interp, "tcl_interactive", (char *) &(isPtr->tty),
+ TCL_LINK_BOOLEAN);
+
Tcl_CreateChannelHandler(inChannel, TCL_READABLE, StdinProc,
- (ClientData) inChannel);
- }
- if (tsdPtr->tty) {
- Prompt(interp, 0);
+ (ClientData) isPtr);
}
- Tcl_DStringInit(&tsdPtr->command);
- Tcl_DStringInit(&tsdPtr->line);
(*mainLoopProc)();
mainLoopProc = NULL;
- break;
+
+ if (inChannel) {
+ tty = isPtr->tty;
+ Tcl_UnlinkVar(interp, "tcl_interactive");
+ Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty,
+ TCL_LINK_BOOLEAN);
+ prompt = isPtr->prompt;
+ if (isPtr->input != (Tcl_Channel) NULL) {
+ Tcl_DeleteChannelHandler(isPtr->input, StdinProc,
+ (ClientData) isPtr);
+ }
+ ckfree((char *)isPtr);
+ }
+ inChannel = Tcl_GetStdChannel(TCL_STDIN);
+ outChannel = Tcl_GetStdChannel(TCL_STDOUT);
+ errChannel = Tcl_GetStdChannel(TCL_STDERR);
}
#ifdef TCL_MEM_DEBUG
+
+ /*
+ * This code here only for the (unsupported and deprecated)
+ * [checkmem] command.
+ */
+
if (tclMemDumpFileName != NULL) {
- Tcl_DecrRefCount(commandPtr);
+ mainLoopProc = NULL;
Tcl_DeleteInterp(interp);
- Tcl_Exit(0);
}
#endif
}
- /*
- * Rather than calling exit, invoke the "exit" command so that
- * users can replace "exit" with some other command to do additional
- * cleanup on exit. The Tcl_Eval call should never return.
- */
-
done:
if ((exitCode == 0) && (mainLoopProc != NULL)) {
+
/*
* If everything has gone OK so far, call the main loop proc,
* if it exists. Packages (like Tk) can set it to start processing
@@ -385,9 +472,37 @@
}
if (commandPtr != NULL) {
Tcl_DecrRefCount(commandPtr);
+ }
+
+ /*
+ * Rather than calling exit, invoke the "exit" command so that
+ * users can replace "exit" with some other command to do additional
+ * cleanup on exit. The Tcl_Eval call should never return.
+ */
+
+ if (!Tcl_InterpDeleted(interp)) {
+ sprintf(buffer, "exit %d", exitCode);
+ Tcl_Eval(interp, buffer);
+
+ /*
+ * If Tcl_Eval returns, trying to eval [exit], something
+ * unusual is happening. Maybe interp has been deleted;
+ * maybe [exit] was redefined. We still want to cleanup
+ * and exit.
+ */
+
+ if (!Tcl_InterpDeleted(interp)) {
+ Tcl_DeleteInterp(interp);
+ }
}
- sprintf(buffer, "exit %d", exitCode);
- Tcl_Eval(interp, buffer);
+
+ /*
+ * If we get here, the master interp has been deleted. Allow
+ * its destruction with the last matching Tcl_Release.
+ */
+
+ Tcl_Release((ClientData) interp);
+ Tcl_Exit(exitCode);
}
/*
@@ -437,40 +552,38 @@
/* ARGSUSED */
static void
StdinProc(clientData, mask)
- ClientData clientData; /* Not used. */
+ ClientData clientData; /* The state of interactive cmd line */
int mask; /* Not used. */
{
- static int gotPartial = 0;
- char *cmd;
- int code, count;
- Tcl_Channel chan = (Tcl_Channel) clientData;
- ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
- Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
- Tcl_Interp *interp = tsdPtr->interp;
-
- count = Tcl_Gets(chan, &tsdPtr->line);
-
- if (count < 0) {
- if (!gotPartial) {
- if (tsdPtr->tty) {
- Tcl_Exit(0);
- } else {
- Tcl_DeleteChannelHandler(chan, StdinProc, (ClientData) chan);
- }
+ InteractiveState *isPtr = (InteractiveState *) clientData;
+ Tcl_Channel chan = isPtr->input;
+ Tcl_Obj *commandPtr = isPtr->commandPtr;
+ Tcl_Interp *interp = isPtr->interp;
+ int code, length;
+
+ length = Tcl_GetsObj(chan, commandPtr);
+ if (length < 0) {
+ if (Tcl_InputBlocked(chan)) {
return;
- }
+ }
+ if (isPtr->tty) {
+ /*
+ * Would be better to find a way to exit the mainLoop?
+ * Or perhaps evaluate [exit]? Leaving as is for now due
+ * to compatibility concerns.
+ */
+ Tcl_Exit(0);
+ }
+ Tcl_DeleteChannelHandler(chan, StdinProc, (ClientData) isPtr);
+ return;
}
- (void) Tcl_DStringAppend(&tsdPtr->command, Tcl_DStringValue(
- &tsdPtr->line), -1);
- Tcl_DStringAppend(&tsdPtr->command, "\n", -1);
- cmd = Tcl_DStringValue(&tsdPtr->command);
- Tcl_DStringFree(&tsdPtr->line);
- if (!Tcl_CommandComplete(cmd)) {
- gotPartial = 1;
+ Tcl_AppendToObj(commandPtr, "\n", 1);
+ if (!TclObjCommandComplete(commandPtr)) {
+ isPtr->prompt = PROMPT_CONTINUE;
goto prompt;
}
- gotPartial = 0;
+ isPtr->prompt = PROMPT_START;
/*
* Disable the stdin channel handler while evaluating the command;
@@ -480,34 +593,41 @@
* command being evaluated.
*/
- Tcl_CreateChannelHandler(chan, 0, StdinProc, (ClientData) chan);
- code = Tcl_RecordAndEval(interp, cmd, TCL_EVAL_GLOBAL);
-
- chan = Tcl_GetStdChannel(TCL_STDIN);
- if (chan) {
+ Tcl_CreateChannelHandler(chan, 0, StdinProc, (ClientData) isPtr);
+ code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL);
+ isPtr->input = chan = Tcl_GetStdChannel(TCL_STDIN);
+ Tcl_DecrRefCount(commandPtr);
+ isPtr->commandPtr = commandPtr = Tcl_NewObj();
+ Tcl_IncrRefCount(commandPtr);
+ if (chan != (Tcl_Channel) NULL) {
Tcl_CreateChannelHandler(chan, TCL_READABLE, StdinProc,
- (ClientData) chan);
+ (ClientData) isPtr);
}
- Tcl_DStringFree(&tsdPtr->command);
- if (Tcl_GetStringResult(interp)[0] != '\0') {
- if ((code != TCL_OK) || (tsdPtr->tty)) {
- chan = Tcl_GetStdChannel(TCL_STDOUT);
- if (chan) {
- Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
- Tcl_WriteChars(chan, "\n", 1);
- }
+ if (code != TCL_OK) {
+ Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
+ if (errChannel != (Tcl_Channel) NULL) {
+ Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
+ Tcl_WriteChars(errChannel, "\n", 1);
+ }
+ } else if (isPtr->tty) {
+ Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
+ Tcl_Channel outChannel = Tcl_GetStdChannel(TCL_STDOUT);
+ Tcl_GetStringFromObj(resultPtr, &length);
+ if ((length >0) && (outChannel != (Tcl_Channel) NULL)) {
+ Tcl_WriteObj(outChannel, resultPtr);
+ Tcl_WriteChars(outChannel, "\n", 1);
}
}
/*
- * Output a prompt.
+ * If a tty stdin is still around, output a prompt.
*/
prompt:
- if (tsdPtr->tty) {
- Prompt(interp, gotPartial);
+ if (isPtr->tty && (isPtr->input != (Tcl_Channel) NULL)) {
+ Prompt(interp, &(isPtr->prompt));
+ isPtr->input = Tcl_GetStdChannel(TCL_STDIN);
}
- Tcl_ResetResult(interp);
}
/*
@@ -529,45 +649,39 @@
*/
static void
-Prompt(interp, partial)
+Prompt(interp, promptPtr)
Tcl_Interp *interp; /* Interpreter to use for prompting. */
- int partial; /* Non-zero means there already
- * exists a partial command, so use
- * the secondary prompt. */
+ PromptType *promptPtr; /* Points to type of prompt to print.
+ * Filled with PROMPT_NONE after a
+ * prompt is printed. */
{
- char *promptCmd;
+ Tcl_Obj *promptCmdPtr;
int code;
Tcl_Channel outChannel, errChannel;
- promptCmd = Tcl_GetVar(interp,
- partial ? "tcl_prompt2" : "tcl_prompt1", TCL_GLOBAL_ONLY);
- if (promptCmd == NULL) {
-defaultPrompt:
- if (!partial) {
-
- /*
- * We must check that outChannel is a real channel - it
- * is possible that someone has transferred stdout out of
- * this interpreter with "interp transfer".
- */
-
- outChannel = Tcl_GetChannel(interp, "stdout", NULL);
- if (outChannel != (Tcl_Channel) NULL) {
- Tcl_WriteChars(outChannel, "% ", 2);
- }
+ if (*promptPtr == PROMPT_NONE) {
+ return;
+ }
+
+ promptCmdPtr = Tcl_GetVar2Ex(interp,
+ ((*promptPtr == PROMPT_CONTINUE) ? "tcl_prompt2" : "tcl_prompt1"),
+ NULL, TCL_GLOBAL_ONLY);
+ if (Tcl_InterpDeleted(interp)) {
+ return;
+ }
+ if (promptCmdPtr == NULL) {
+ defaultPrompt:
+ outChannel = Tcl_GetStdChannel(TCL_STDOUT);
+ if ((*promptPtr == PROMPT_START)
+ && (outChannel != (Tcl_Channel) NULL)) {
+ Tcl_WriteChars(outChannel, "% ", 2);
}
} else {
- code = Tcl_Eval(interp, promptCmd);
+ code = Tcl_EvalObjEx(interp, promptCmdPtr, TCL_EVAL_GLOBAL);
if (code != TCL_OK) {
Tcl_AddErrorInfo(interp,
"\n (script that generates prompt)");
- /*
- * We must check that errChannel is a real channel - it
- * is possible that someone has transferred stderr out of
- * this interpreter with "interp transfer".
- */
-
- errChannel = Tcl_GetChannel(interp, "stderr", NULL);
+ errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel != (Tcl_Channel) NULL) {
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
Tcl_WriteChars(errChannel, "\n", 1);
@@ -575,8 +689,9 @@
goto defaultPrompt;
}
}
- outChannel = Tcl_GetChannel(interp, "stdout", NULL);
+ outChannel = Tcl_GetStdChannel(TCL_STDOUT);
if (outChannel != (Tcl_Channel) NULL) {
Tcl_Flush(outChannel);
}
+ *promptPtr = PROMPT_NONE;
}
Index: generic/tclStubInit.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclStubInit.c,v
retrieving revision 1.65
diff -u -r1.65 tclStubInit.c
--- generic/tclStubInit.c 2001/11/23 01:29:01 1.65
+++ generic/tclStubInit.c 2002/01/05 22:38:11
@@ -246,6 +246,8 @@
TclExpandCodeArray, /* 164 */
TclpSetInitialEncodings, /* 165 */
TclListObjSetElement, /* 166 */
+ TclSetStartupScriptPath, /* 167 */
+ TclGetStartupScriptPath, /* 168 */
};
TclIntPlatStubs tclIntPlatStubs = {
Index: generic/tclTest.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclTest.c,v
retrieving revision 1.34
diff -u -r1.34 tclTest.c
--- generic/tclTest.c 2001/11/23 01:29:07 1.34
+++ generic/tclTest.c 2002/01/05 22:38:56
@@ -107,6 +107,12 @@
static int freeCount;
/*
+ * Boolean flag used by the "testsetmainloop" and "testexitmainloop"
+ * commands.
+ */
+static int exitMainLoop = 0;
+
+/*
* Forward declarations for procedures defined later in this file:
*/
@@ -239,6 +245,10 @@
Tcl_Value *resultPtr));
static int TestmainthreadCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
+static int TestsetmainloopCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int argc, char **argv));
+static int TestexitmainloopCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int argc, char **argv));
static Tcl_Channel PretendTclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp,
char *filename, char *modeString, int permissions));
static Tcl_Channel TestOpenFileChannelProc1 _ANSI_ARGS_((Tcl_Interp *interp,
@@ -408,7 +418,15 @@
Tcl_Interp *interp; /* Interpreter for application. */
{
Tcl_ValueType t3ArgTypes[2];
-
+
+ Tcl_Obj *listPtr;
+ Tcl_Obj **objv;
+ int objc, index;
+ static char *specialOptions[] = {
+ "-appinitprocerror", "-appinitprocdeleteinterp",
+ "-appinitprocclosestderr", "-appinitprocsetrcfile", (char *) NULL
+ };
+
if (Tcl_PkgProvide(interp, "Tcltest", TCL_VERSION) == TCL_ERROR) {
return TCL_ERROR;
}
@@ -532,6 +550,10 @@
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd,
+ (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateCommand(interp, "testexitmainloop", TestexitmainloopCmd,
+ (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
t3ArgTypes[0] = TCL_EITHER;
t3ArgTypes[1] = TCL_EITHER;
Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2,
@@ -544,6 +566,42 @@
#endif
/*
+ * Check for special options used in ../tests/main.test
+ */
+
+ listPtr = Tcl_GetVar2Ex(interp, "argv", NULL, TCL_GLOBAL_ONLY);
+ if (listPtr != NULL) {
+ if (Tcl_ListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (objc && (Tcl_GetIndexFromObj(NULL, objv[0], specialOptions, NULL,
+ TCL_EXACT, &index) == TCL_OK)) {
+ switch (index) {
+ case 0: {
+ return TCL_ERROR;
+ }
+ case 1: {
+ Tcl_DeleteInterp(interp);
+ return TCL_ERROR;
+ }
+ case 2: {
+ int mode;
+ Tcl_UnregisterChannel(interp,
+ Tcl_GetChannel(interp, "stderr", &mode));
+ return TCL_ERROR;
+ }
+ case 3: {
+ if (objc-1) {
+ Tcl_SetVar2Ex(interp, "tcl_rcFileName", NULL,
+ objv[1], TCL_GLOBAL_ONLY);
+ }
+ return TCL_ERROR;
+ }
+ }
+ }
+ }
+
+ /*
* And finally add any platform specific test commands.
*/
@@ -1934,11 +1992,6 @@
" path\"", (char *) NULL);
return TCL_ERROR;
}
- if (argv[1][0] == '\0') {
- Tcl_AppendResult(interp, "cannot delete current interpreter",
- (char *) NULL);
- return TCL_ERROR;
- }
slaveToDelete = Tcl_GetSlave(interp, argv[1]);
if (slaveToDelete == (Tcl_Interp *) NULL) {
return TCL_ERROR;
@@ -4163,6 +4216,89 @@
Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
return TCL_ERROR;
}
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * MainLoop --
+ *
+ * A main loop set by TestsetmainloopCmd below.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Event handlers could do anything.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+MainLoop()
+{
+ while (!exitMainLoop) {
+ Tcl_DoOneEvent(0);
+ }
+ fprintf(stdout,"Exit MainLoop\n");
+ fflush(stdout);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestsetmainloopCmd --
+ *
+ * Implements the "testsetmainloop" cmd that is used to test the
+ * 'Tcl_SetMainLoop' API.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestsetmainloopCmd (dummy, interp, argc, argv)
+ ClientData dummy; /* Not used. */
+ register Tcl_Interp *interp; /* Current interpreter. */
+ int argc; /* Number of arguments. */
+ char **argv; /* Argument strings. */
+{
+ exitMainLoop = 0;
+ Tcl_SetMainLoop(MainLoop);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestexitmainloopCmd --
+ *
+ * Implements the "testexitmainloop" cmd that is used to test the
+ * 'Tcl_SetMainLoop' API.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestexitmainloopCmd (dummy, interp, argc, argv)
+ ClientData dummy; /* Not used. */
+ register Tcl_Interp *interp; /* Current interpreter. */
+ int argc; /* Number of arguments. */
+ char **argv; /* Argument strings. */
+{
+ exitMainLoop = 1;
+ return TCL_OK;
}
/*
