sl@0: /* 
sl@0:  * tclXtTest.c --
sl@0:  *
sl@0:  *	Contains commands for Xt notifier specific tests on Unix.
sl@0:  *
sl@0:  * Copyright (c) 1997 by Sun Microsystems, Inc.
sl@0:  *
sl@0:  * See the file "license.terms" for information on usage and redistribution
sl@0:  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
sl@0:  *
sl@0:  * RCS: @(#) $Id: tclXtTest.c,v 1.5 2002/08/05 03:24:41 dgp Exp $
sl@0:  */
sl@0: 
sl@0: #include <X11/Intrinsic.h>
sl@0: #include "tcl.h"
sl@0: 
sl@0: static int	TesteventloopCmd _ANSI_ARGS_((ClientData clientData,
sl@0: 		    Tcl_Interp *interp, int argc, CONST char **argv));
sl@0: extern void	InitNotifier _ANSI_ARGS_((void));
sl@0: 
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * Tclxttest_Init --
sl@0:  *
sl@0:  *	This procedure performs application-specific initialization.
sl@0:  *	Most applications, especially those that incorporate additional
sl@0:  *	packages, will have their own version of this procedure.
sl@0:  *
sl@0:  * Results:
sl@0:  *	Returns a standard Tcl completion code, and leaves an error
sl@0:  *	message in the interp's result if an error occurs.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Depends on the startup script.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: int
sl@0: Tclxttest_Init(interp)
sl@0:     Tcl_Interp *interp;		/* Interpreter for application. */
sl@0: {
sl@0:     if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0:     XtToolkitInitialize();
sl@0:     InitNotifier();
sl@0:     Tcl_CreateCommand(interp, "testeventloop", TesteventloopCmd,
sl@0:             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0:     return TCL_OK;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TesteventloopCmd --
sl@0:  *
sl@0:  *	This procedure implements the "testeventloop" command. It is
sl@0:  *	used to test the Tcl notifier from an "external" event loop
sl@0:  *	(i.e. not Tcl_DoOneEvent()).
sl@0:  *
sl@0:  * Results:
sl@0:  *	A standard Tcl result.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	None.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static int
sl@0: TesteventloopCmd(clientData, interp, argc, argv)
sl@0:     ClientData clientData;		/* Not used. */
sl@0:     Tcl_Interp *interp;			/* Current interpreter. */
sl@0:     int argc;				/* Number of arguments. */
sl@0:     CONST char **argv;			/* Argument strings. */
sl@0: {
sl@0:     static int *framePtr = NULL; /* Pointer to integer on stack frame of
sl@0: 				  * innermost invocation of the "wait"
sl@0: 				  * subcommand. */
sl@0: 
sl@0:    if (argc < 2) {
sl@0: 	Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
sl@0:                 " option ... \"", (char *) NULL);
sl@0:         return TCL_ERROR;
sl@0:     }
sl@0:     if (strcmp(argv[1], "done") == 0) {
sl@0: 	*framePtr = 1;
sl@0:     } else if (strcmp(argv[1], "wait") == 0) {
sl@0: 	int *oldFramePtr;
sl@0: 	int done;
sl@0: 	int oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);
sl@0: 
sl@0: 	/*
sl@0: 	 * Save the old stack frame pointer and set up the current frame.
sl@0: 	 */
sl@0: 
sl@0: 	oldFramePtr = framePtr;
sl@0: 	framePtr = &done;
sl@0: 
sl@0: 	/*
sl@0: 	 * Enter an Xt event loop until the flag changes.
sl@0: 	 * Note that we do not explicitly call Tcl_ServiceEvent().
sl@0: 	 */
sl@0: 
sl@0: 	done = 0;
sl@0: 	while (!done) {
sl@0: 	    XtAppProcessEvent(TclSetAppContext(NULL), XtIMAll);
sl@0: 	}
sl@0: 	(void) Tcl_SetServiceMode(oldMode);
sl@0: 	framePtr = oldFramePtr;
sl@0:     } else {
sl@0: 	Tcl_AppendResult(interp, "bad option \"", argv[1],
sl@0: 		"\": must be done or wait", (char *) NULL);
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0:     return TCL_OK;
sl@0: }