diff options
author | phk <phk@FreeBSD.org> | 1997-07-25 19:27:55 +0000 |
---|---|---|
committer | phk <phk@FreeBSD.org> | 1997-07-25 19:27:55 +0000 |
commit | 30db38624722a51670556ef9b2dd7ccf4fb57387 (patch) | |
tree | d2f88b3e9ffa79ffb2cc1a0699dd3ee96c47c3e5 /contrib/tcl/unix/tclXtTest.c | |
parent | 4170733a21f58ada18a6760af477926f494b5b67 (diff) | |
download | FreeBSD-src-30db38624722a51670556ef9b2dd7ccf4fb57387.zip FreeBSD-src-30db38624722a51670556ef9b2dd7ccf4fb57387.tar.gz |
Import TCL release 8.0 beta 2.
Diffstat (limited to 'contrib/tcl/unix/tclXtTest.c')
-rw-r--r-- | contrib/tcl/unix/tclXtTest.c | 113 |
1 files changed, 113 insertions, 0 deletions
diff --git a/contrib/tcl/unix/tclXtTest.c b/contrib/tcl/unix/tclXtTest.c new file mode 100644 index 0000000..bb23256 --- /dev/null +++ b/contrib/tcl/unix/tclXtTest.c @@ -0,0 +1,113 @@ +/* + * tclXtTest.c -- + * + * Contains commands for Xt notifier specific tests on Unix. + * + * Copyright (c) 1997 by Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclXtTest.c 1.1 97/03/24 14:30:42 + */ + +#include <X11/Intrinsic.h> +#include "tcl.h" + +static int TesteventloopCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +/* + *---------------------------------------------------------------------- + * + * Tclxttest_Init -- + * + * This procedure performs application-specific initialization. + * Most applications, especially those that incorporate additional + * packages, will have their own version of this procedure. + * + * Results: + * Returns a standard Tcl completion code, and leaves an error + * message in interp->result if an error occurs. + * + * Side effects: + * Depends on the startup script. + * + *---------------------------------------------------------------------- + */ + +int +Tclxttest_Init(interp) + Tcl_Interp *interp; /* Interpreter for application. */ +{ + Tcl_CreateCommand(interp, "testeventloop", TesteventloopCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TesteventloopCmd -- + * + * This procedure implements the "testeventloop" command. It is + * used to test the Tcl notifier from an "external" event loop + * (i.e. not Tcl_DoOneEvent()). + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TesteventloopCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + static int *framePtr = NULL; /* Pointer to integer on stack frame of + * innermost invocation of the "wait" + * subcommand. */ + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " option ... \"", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[1], "done") == 0) { + *framePtr = 1; + } else if (strcmp(argv[1], "wait") == 0) { + int *oldFramePtr; + int done; + int oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL); + + /* + * Save the old stack frame pointer and set up the current frame. + */ + + oldFramePtr = framePtr; + framePtr = &done; + + /* + * Enter an Xt event loop until the flag changes. + * Note that we do not explicitly call Tcl_ServiceEvent(). + */ + + done = 0; + while (!done) { + XtProcessEvent(XtIMAll); + } + (void) Tcl_SetServiceMode(oldMode); + framePtr = oldFramePtr; + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be done or wait", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} |