diff options
| -rw-r--r-- | ChangeLog | 13 | ||||
| -rw-r--r-- | generic/tcl.decls | 10 | ||||
| -rw-r--r-- | generic/tcl.h | 3 | ||||
| -rw-r--r-- | generic/tclDecls.h | 12 | ||||
| -rw-r--r-- | generic/tclMain.c | 260 | ||||
| -rw-r--r-- | generic/tclStubInit.c | 4 |
6 files changed, 284 insertions, 18 deletions
@@ -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 */ |