summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2002-01-05 22:55:51 (GMT)
committerdgp <dgp@users.sourceforge.net>2002-01-05 22:55:51 (GMT)
commit33ac8d206a0d1b8f7463f7b9780e168dd06898b9 (patch)
tree079d4ac0f5133b723b4406e3605a8ba6b18c5aab /generic
parent3d702184fba3a33fbbe7ea89cc9870549cf93471 (diff)
downloadtcl-33ac8d206a0d1b8f7463f7b9780e168dd06898b9.zip
tcl-33ac8d206a0d1b8f7463f7b9780e168dd06898b9.tar.gz
tcl-33ac8d206a0d1b8f7463f7b9780e168dd06898b9.tar.bz2
* 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().
Diffstat (limited to 'generic')
-rw-r--r--generic/tclInt.decls15
-rw-r--r--generic/tclIntDecls.h25
-rw-r--r--generic/tclMain.c453
-rw-r--r--generic/tclStubInit.c4
-rw-r--r--generic/tclTest.c150
5 files changed, 462 insertions, 185 deletions
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 23dfdd0..1b7915b 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -12,7 +12,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: tclInt.decls,v 1.38 2001/11/23 01:26:47 das Exp $
+# RCS: @(#) $Id: tclInt.decls,v 1.39 2002/01/05 22:55:51 dgp Exp $
library tcl
@@ -611,10 +611,10 @@ declare 157 generic {
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, \
@@ -660,6 +660,15 @@ declare 166 generic {
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)
+}
+
+
##############################################################################
# Define the platform specific internal Tcl interface. These functions are
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index 5e36ba9..9e4574e 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIntDecls.h,v 1.31 2001/11/14 23:17:03 hobbs Exp $
+ * RCS: @(#) $Id: tclIntDecls.h,v 1.32 2002/01/05 22:55:51 dgp Exp $
*/
#ifndef _TCLINTDECLS
@@ -477,9 +477,9 @@ EXTERN Var * TclVarTraceExists _ANSI_ARGS_((Tcl_Interp * interp,
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 void TclpSetInitialEncodings _ANSI_ARGS_((void));
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 @@ typedef struct TclIntStubs {
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 @@ typedef struct TclIntStubs {
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
@@ -1309,6 +1316,14 @@ extern TclIntStubs *tclIntStubsPtr;
#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) */
diff --git a/generic/tclMain.c b/generic/tclMain.c
index 8b4ef51..0678e3f 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclMain.c,v 1.14 2001/11/23 01:28:53 das Exp $
+ * RCS: @(#) $Id: tclMain.c,v 1.15 2002/01/05 22:55:52 dgp Exp $
*/
#include "tcl.h"
@@ -33,9 +33,6 @@ int (*tclDummyLinkVarPtr)() = Tcl_LinkVar;
* 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 @@ extern int isatty _ANSI_ARGS_((int fd));
#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 @@ static void StdinProc _ANSI_ARGS_((ClientData clientData,
/*
*----------------------------------------------------------------------
*
+ * 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 @@ static void StdinProc _ANSI_ARGS_((ClientData clientData,
*----------------------------------------------------------------------
*/
void TclSetStartupScriptFileName(fileName)
- char *fileName;
+ CONST char *fileName;
{
- tclStartupScriptFileName = fileName;
+ Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1);
+ TclSetStartupScriptPath(pathPtr);
}
@@ -110,9 +173,9 @@ void TclSetStartupScriptFileName(fileName)
*
*----------------------------------------------------------------------
*/
-char *TclGetStartupScriptFileName()
+CONST char *TclGetStartupScriptFileName()
{
- return tclStartupScriptFileName;
+ return Tcl_GetString(TclGetStartupScriptPath());
}
@@ -148,22 +211,18 @@ Tcl_Main(argc, argv, appInitProc)
{
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 @@ Tcl_Main(argc, argv, appInitProc)
* 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_Main(argc, argv, appInitProc)
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 @@ Tcl_Main(argc, argv, appInitProc)
* 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_Main(argc, argv, appInitProc)
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 @@ Tcl_Main(argc, argv, appInitProc)
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_Main(argc, argv, appInitProc)
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_Main(argc, argv, appInitProc)
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 @@ Tcl_Main(argc, argv, appInitProc)
}
}
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);
+ (ClientData) isPtr);
}
- if (tsdPtr->tty) {
- Prompt(interp, 0);
- }
- 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
@@ -386,8 +473,36 @@ Tcl_Main(argc, argv, appInitProc)
if (commandPtr != NULL) {
Tcl_DecrRefCount(commandPtr);
}
- sprintf(buffer, "exit %d", exitCode);
- Tcl_Eval(interp, buffer);
+
+ /*
+ * 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);
+ }
+ }
+
+ /*
+ * 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 @@ Tcl_SetMainLoop(proc)
/* 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 @@ StdinProc(clientData, mask)
* 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 @@ StdinProc(clientData, mask)
*/
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 @@ defaultPrompt:
goto defaultPrompt;
}
}
- outChannel = Tcl_GetChannel(interp, "stdout", NULL);
+ outChannel = Tcl_GetStdChannel(TCL_STDOUT);
if (outChannel != (Tcl_Channel) NULL) {
Tcl_Flush(outChannel);
}
+ *promptPtr = PROMPT_NONE;
}
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 0a03bc9..9f739bd 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclStubInit.c,v 1.65 2001/11/23 01:29:01 das Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.66 2002/01/05 22:55:52 dgp Exp $
*/
#include "tclInt.h"
@@ -246,6 +246,8 @@ TclIntStubs tclIntStubs = {
TclExpandCodeArray, /* 164 */
TclpSetInitialEncodings, /* 165 */
TclListObjSetElement, /* 166 */
+ TclSetStartupScriptPath, /* 167 */
+ TclGetStartupScriptPath, /* 168 */
};
TclIntPlatStubs tclIntPlatStubs = {
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 029d0b9..2b977f2 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclTest.c,v 1.34 2001/11/23 01:29:07 das Exp $
+ * RCS: @(#) $Id: tclTest.c,v 1.35 2002/01/05 22:55:52 dgp Exp $
*/
#define TCL_TEST
@@ -107,6 +107,12 @@ typedef struct TclEncoding {
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 @@ static int TestMathFunc2 _ANSI_ARGS_((ClientData clientData,
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 @@ Tcltest_Init(interp)
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 @@ Tcltest_Init(interp)
(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 @@ Tcltest_Init(interp)
#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 @@ TestinterpdeleteCmd(dummy, interp, argc, argv)
" 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;
@@ -4164,6 +4217,89 @@ TestmainthreadCmd (dummy, interp, argc, argv)
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;
+}
/*
*----------------------------------------------------------------------