summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorhobbs <hobbs>2000-11-03 18:46:09 (GMT)
committerhobbs <hobbs>2000-11-03 18:46:09 (GMT)
commitc3064b1f4544c841d840a76bcebdb93c4caf23f7 (patch)
tree650d6d7787b065eec9d05f906658a7b7576b148a
parente30a06ccf0b2e7f424f49c357bbca229380e0af9 (diff)
downloadtcl-c3064b1f4544c841d840a76bcebdb93c4caf23f7.zip
tcl-c3064b1f4544c841d840a76bcebdb93c4caf23f7.tar.gz
tcl-c3064b1f4544c841d840a76bcebdb93c4caf23f7.tar.bz2
* generic/tclStubInit.c:
* generic/tclDecls.h: * generic/tcl.decls: added Tcl_SetMainLoop proc that allows people to set a main loop that will run for tclsh. * generic/tcl.h: added Tcl_MainLoopProc typedef * generic/tclMain.c (Tcl_SetMainLoop, StdinProc, Prompt): new StdinProc and Prompt static procs and Tcl_SetMainLoop stubs proc. The first two handle a fileevent based prompt (taken from tkMain.c). Tcl_SetMainLoop enables the interactive setting of a main loop procedure. This enables Tk to be a loadable package.
-rw-r--r--ChangeLog13
-rw-r--r--generic/tcl.decls10
-rw-r--r--generic/tcl.h3
-rw-r--r--generic/tclDecls.h12
-rw-r--r--generic/tclMain.c260
-rw-r--r--generic/tclStubInit.c4
6 files changed, 284 insertions, 18 deletions
diff --git a/ChangeLog b/ChangeLog
index 55bd568..1363ebe 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,16 @@
+2000-11-03 Jeff Hobbs <hobbs@ajubasolutions.com>
+
+ * generic/tclStubInit.c:
+ * generic/tclDecls.h:
+ * generic/tcl.decls: added Tcl_SetMainLoop proc that allows people
+ to set a main loop that will run for tclsh.
+ * generic/tcl.h: added Tcl_MainLoopProc typedef
+ * generic/tclMain.c (Tcl_SetMainLoop, StdinProc, Prompt): new
+ StdinProc and Prompt static procs and Tcl_SetMainLoop stubs proc.
+ The first two handle a fileevent based prompt (taken from
+ tkMain.c). Tcl_SetMainLoop enables the interactive setting of a
+ main loop procedure. This enables Tk to be a loadable package.
+
2000-11-02 David Gravereaux <davygrvy@ajubasolutions.com>
* generic/tclEvent.c: tclLibraryPath Tcl_Obj didn't have a way
diff --git a/generic/tcl.decls b/generic/tcl.decls
index 47643d4..28905ca 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -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: tcl.decls,v 1.41 2000/09/28 06:38:19 hobbs Exp $
+# RCS: @(#) $Id: tcl.decls,v 1.42 2000/11/03 18:46:10 hobbs Exp $
library tcl
@@ -992,9 +992,13 @@ declare 282 generic {
declare 283 generic {
Tcl_Channel Tcl_GetStackedChannel(Tcl_Channel chan)
}
+
+# 284 was reserved, but added in 8.4a2
+declare 284 generic {
+ void Tcl_SetMainLoop(Tcl_MainLoopProc *proc)
+}
+
# Reserved for future use (8.0.x vs. 8.1)
-# declare 284 generic {
-# }
# declare 285 generic {
# }
diff --git a/generic/tcl.h b/generic/tcl.h
index 9349b15..95eece8 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -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: tcl.h,v 1.82 2000/10/19 18:00:56 jenn Exp $
+ * RCS: @(#) $Id: tcl.h,v 1.83 2000/11/03 18:46:10 hobbs Exp $
*/
#ifndef _TCL
@@ -609,6 +609,7 @@ typedef void (Tcl_CommandTraceProc) _ANSI_ARGS_((ClientData clientData,
typedef void (Tcl_CreateFileHandlerProc) _ANSI_ARGS_((int fd, int mask,
Tcl_FileProc *proc, ClientData clientData));
typedef void (Tcl_DeleteFileHandlerProc) _ANSI_ARGS_((int fd));
+typedef void (Tcl_MainLoopProc) _ANSI_ARGS_((void));
/*
* The following structure represents a type of object, which is a
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 0656d76..743cef2 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -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: tclDecls.h,v 1.42 2000/09/28 06:38:19 hobbs Exp $
+ * RCS: @(#) $Id: tclDecls.h,v 1.43 2000/11/03 18:46:11 hobbs Exp $
*/
#ifndef _TCLDECLS
@@ -913,7 +913,8 @@ EXTERN int Tcl_UnstackChannel _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Channel chan));
/* 283 */
EXTERN Tcl_Channel Tcl_GetStackedChannel _ANSI_ARGS_((Tcl_Channel chan));
-/* Slot 284 is reserved */
+/* 284 */
+EXTERN void Tcl_SetMainLoop _ANSI_ARGS_((Tcl_MainLoopProc * proc));
/* Slot 285 is reserved */
/* 286 */
EXTERN void Tcl_AppendObjToObj _ANSI_ARGS_((Tcl_Obj * objPtr,
@@ -1700,7 +1701,7 @@ typedef struct TclStubs {
Tcl_Channel (*tcl_StackChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_ChannelType * typePtr, ClientData instanceData, int mask, Tcl_Channel prevChan)); /* 281 */
int (*tcl_UnstackChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 282 */
Tcl_Channel (*tcl_GetStackedChannel) _ANSI_ARGS_((Tcl_Channel chan)); /* 283 */
- void *reserved284;
+ void (*tcl_SetMainLoop) _ANSI_ARGS_((Tcl_MainLoopProc * proc)); /* 284 */
void *reserved285;
void (*tcl_AppendObjToObj) _ANSI_ARGS_((Tcl_Obj * objPtr, Tcl_Obj * appendObjPtr)); /* 286 */
Tcl_Encoding (*tcl_CreateEncoding) _ANSI_ARGS_((Tcl_EncodingType * typePtr)); /* 287 */
@@ -3036,7 +3037,10 @@ extern TclStubs *tclStubsPtr;
#define Tcl_GetStackedChannel \
(tclStubsPtr->tcl_GetStackedChannel) /* 283 */
#endif
-/* Slot 284 is reserved */
+#ifndef Tcl_SetMainLoop
+#define Tcl_SetMainLoop \
+ (tclStubsPtr->tcl_SetMainLoop) /* 284 */
+#endif
/* Slot 285 is reserved */
#ifndef Tcl_AppendObjToObj
#define Tcl_AppendObjToObj \
diff --git a/generic/tclMain.c b/generic/tclMain.c
index 6e846c7..5089a93 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -5,11 +5,12 @@
*
* Copyright (c) 1988-1994 The Regents of the University of California.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright (c) 2000 Ajuba Solutions.
*
* 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.7 1999/12/12 02:26:42 hobbs Exp $
+ * RCS: @(#) $Id: tclMain.c,v 1.8 2000/11/03 18:46:12 hobbs Exp $
*/
#include "tcl.h"
@@ -42,7 +43,27 @@ extern char * strcpy _ANSI_ARGS_((char *dst, CONST char *src));
static char *tclStartupScriptFileName = 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. */
+ int tty; /* Non-zero means standard input is a
+ * terminal-like device. Zero means it's
+ * a file. */
+} ThreadSpecificData;
+Tcl_ThreadDataKey dataKey;
+
+/*
+ * Forward declarations for procedures defined later in this file.
+ */
+
+static void Prompt _ANSI_ARGS_((Tcl_Interp *interp, int partial));
+static void StdinProc _ANSI_ARGS_((ClientData clientData,
+ int mask));
/*
@@ -101,7 +122,7 @@ char *TclGetStartupScriptFileName()
*
* Results:
* None. This procedure never returns (it exits the process when
- * it's done.
+ * it's done).
*
* Side effects:
* This procedure initializes the Tcl world and then starts
@@ -124,14 +145,18 @@ Tcl_Main(argc, argv, appInitProc)
Tcl_Obj *resultPtr;
Tcl_Obj *commandPtr = NULL;
char buffer[1000], *args;
- int code, gotPartial, tty, length;
+ int code, gotPartial, length;
int exitCode = 0;
Tcl_Channel inChannel, outChannel, errChannel;
Tcl_Interp *interp;
Tcl_DString argString;
+ ThreadSpecificData *tsdPtr;
+
+ tsdPtr = (ThreadSpecificData *)
+ Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
Tcl_FindExecutable(argv[0]);
- interp = Tcl_CreateInterp();
+ tsdPtr->interp = interp = Tcl_CreateInterp();
#ifdef TCL_MEM_DEBUG
Tcl_InitMemory(interp);
#endif
@@ -170,9 +195,9 @@ Tcl_Main(argc, argv, appInitProc)
* Set the "tcl_interactive" variable.
*/
- tty = isatty(0);
+ tsdPtr->tty = isatty(0);
Tcl_SetVar(interp, "tcl_interactive",
- ((tclStartupScriptFileName == NULL) && tty) ? "1" : "0",
+ ((tclStartupScriptFileName == NULL) && tsdPtr->tty) ? "1" : "0",
TCL_GLOBAL_ONLY);
/*
@@ -235,7 +260,7 @@ Tcl_Main(argc, argv, appInitProc)
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
gotPartial = 0;
while (1) {
- if (tty) {
+ if (tsdPtr->tty) {
Tcl_Obj *promptCmdPtr;
promptCmdPtr = Tcl_GetVar2Ex(interp,
@@ -299,7 +324,7 @@ Tcl_Main(argc, argv, appInitProc)
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
Tcl_WriteChars(errChannel, "\n", 1);
}
- } else if (tty) {
+ } else if (tsdPtr->tty) {
resultPtr = Tcl_GetObjResult(interp);
Tcl_GetStringFromObj(resultPtr, &length);
if ((length > 0) && outChannel) {
@@ -307,6 +332,27 @@ Tcl_Main(argc, argv, appInitProc)
Tcl_WriteChars(outChannel, "\n", 1);
}
}
+ 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.
+ */
+
+ if (inChannel) {
+ Tcl_CreateChannelHandler(inChannel, TCL_READABLE, StdinProc,
+ (ClientData) inChannel);
+ }
+ if (tsdPtr->tty) {
+ Prompt(interp, 0);
+ }
+ Tcl_DStringInit(&tsdPtr->command);
+ Tcl_DStringInit(&tsdPtr->line);
+
+ mainLoopProc();
+ mainLoopProc = NULL;
+ break;
+ }
#ifdef TCL_MEM_DEBUG
if (tclMemDumpFileName != NULL) {
Tcl_DecrRefCount(commandPtr);
@@ -323,9 +369,207 @@ Tcl_Main(argc, argv, appInitProc)
*/
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
+ * events at this point.
+ */
+
+ mainLoopProc();
+ }
if (commandPtr != NULL) {
Tcl_DecrRefCount(commandPtr);
}
sprintf(buffer, "exit %d", exitCode);
Tcl_Eval(interp, buffer);
}
+
+/*
+ *---------------------------------------------------------------
+ *
+ * Tcl_SetMainLoop --
+ *
+ * Sets an alternative main loop procedure.
+ *
+ * Results:
+ * Returns the previously defined main loop procedure.
+ *
+ * Side effects:
+ * This procedure will be called before Tcl exits, allowing for
+ * the creation of an event loop.
+ *
+ *---------------------------------------------------------------
+ */
+
+void
+Tcl_SetMainLoop(Tcl_MainLoopProc *proc)
+{
+ mainLoopProc = proc;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * StdinProc --
+ *
+ * This procedure is invoked by the event dispatcher whenever
+ * standard input becomes readable. It grabs the next line of
+ * input characters, adds them to a command being assembled, and
+ * executes the command if it's complete.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Could be almost arbitrary, depending on the command that's
+ * typed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+static void
+StdinProc(clientData, mask)
+ ClientData clientData; /* Not used. */
+ 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);
+ }
+ return;
+ }
+ }
+
+ (void) Tcl_DStringAppend(&tsdPtr->command, Tcl_DStringValue(
+ &tsdPtr->line), -1);
+ cmd = Tcl_DStringAppend(&tsdPtr->command, "\n", -1);
+ Tcl_DStringFree(&tsdPtr->line);
+ if (!Tcl_CommandComplete(cmd)) {
+ gotPartial = 1;
+ goto prompt;
+ }
+ gotPartial = 0;
+
+ /*
+ * Disable the stdin channel handler while evaluating the command;
+ * otherwise if the command re-enters the event loop we might
+ * process commands from stdin before the current command is
+ * finished. Among other things, this will trash the text of the
+ * 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, TCL_READABLE, StdinProc,
+ (ClientData) chan);
+ }
+ 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);
+ }
+ }
+ }
+
+ /*
+ * Output a prompt.
+ */
+
+ prompt:
+ if (tsdPtr->tty) {
+ Prompt(interp, gotPartial);
+ }
+ Tcl_ResetResult(interp);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Prompt --
+ *
+ * Issue a prompt on standard output, or invoke a script
+ * to issue the prompt.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * A prompt gets output, and a Tcl script may be evaluated
+ * in interp.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+Prompt(interp, partial)
+ Tcl_Interp *interp; /* Interpreter to use for prompting. */
+ int partial; /* Non-zero means there already
+ * exists a partial command, so use
+ * the secondary prompt. */
+{
+ char *promptCmd;
+ 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);
+ }
+ }
+ } else {
+ code = Tcl_Eval(interp, promptCmd);
+ 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);
+ if (errChannel != (Tcl_Channel) NULL) {
+ Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
+ Tcl_WriteChars(errChannel, "\n", 1);
+ }
+ goto defaultPrompt;
+ }
+ }
+ outChannel = Tcl_GetChannel(interp, "stdout", NULL);
+ if (outChannel != (Tcl_Channel) NULL) {
+ Tcl_Flush(outChannel);
+ }
+}
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index c716732..263e2a8 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.45 2000/09/28 06:38:22 hobbs Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.46 2000/11/03 18:46:12 hobbs Exp $
*/
#include "tclInt.h"
@@ -687,7 +687,7 @@ TclStubs tclStubs = {
Tcl_StackChannel, /* 281 */
Tcl_UnstackChannel, /* 282 */
Tcl_GetStackedChannel, /* 283 */
- NULL, /* 284 */
+ Tcl_SetMainLoop, /* 284 */
NULL, /* 285 */
Tcl_AppendObjToObj, /* 286 */
Tcl_CreateEncoding, /* 287 */