1/*
2 * tclXtTest.c --
3 *
4 *	Contains commands for Xt notifier specific tests on Unix.
5 *
6 * Copyright (c) 1997 by Sun Microsystems, Inc.
7 *
8 * See the file "license.terms" for information on usage and redistribution
9 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
10 *
11 * RCS: @(#) $Id: tclXtTest.c,v 1.5 2002/08/05 03:24:41 dgp Exp $
12 */
13
14#include <X11/Intrinsic.h>
15#include "tcl.h"
16
17static int	TesteventloopCmd _ANSI_ARGS_((ClientData clientData,
18		    Tcl_Interp *interp, int argc, CONST char **argv));
19extern void	InitNotifier _ANSI_ARGS_((void));
20
21
22/*
23 *----------------------------------------------------------------------
24 *
25 * Tclxttest_Init --
26 *
27 *	This procedure performs application-specific initialization.
28 *	Most applications, especially those that incorporate additional
29 *	packages, will have their own version of this procedure.
30 *
31 * Results:
32 *	Returns a standard Tcl completion code, and leaves an error
33 *	message in the interp's result if an error occurs.
34 *
35 * Side effects:
36 *	Depends on the startup script.
37 *
38 *----------------------------------------------------------------------
39 */
40
41int
42Tclxttest_Init(interp)
43    Tcl_Interp *interp;		/* Interpreter for application. */
44{
45    if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
46	return TCL_ERROR;
47    }
48    XtToolkitInitialize();
49    InitNotifier();
50    Tcl_CreateCommand(interp, "testeventloop", TesteventloopCmd,
51            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
52    return TCL_OK;
53}
54
55/*
56 *----------------------------------------------------------------------
57 *
58 * TesteventloopCmd --
59 *
60 *	This procedure implements the "testeventloop" command. It is
61 *	used to test the Tcl notifier from an "external" event loop
62 *	(i.e. not Tcl_DoOneEvent()).
63 *
64 * Results:
65 *	A standard Tcl result.
66 *
67 * Side effects:
68 *	None.
69 *
70 *----------------------------------------------------------------------
71 */
72
73static int
74TesteventloopCmd(clientData, interp, argc, argv)
75    ClientData clientData;		/* Not used. */
76    Tcl_Interp *interp;			/* Current interpreter. */
77    int argc;				/* Number of arguments. */
78    CONST char **argv;			/* Argument strings. */
79{
80    static int *framePtr = NULL; /* Pointer to integer on stack frame of
81				  * innermost invocation of the "wait"
82				  * subcommand. */
83
84   if (argc < 2) {
85	Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
86                " option ... \"", (char *) NULL);
87        return TCL_ERROR;
88    }
89    if (strcmp(argv[1], "done") == 0) {
90	*framePtr = 1;
91    } else if (strcmp(argv[1], "wait") == 0) {
92	int *oldFramePtr;
93	int done;
94	int oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);
95
96	/*
97	 * Save the old stack frame pointer and set up the current frame.
98	 */
99
100	oldFramePtr = framePtr;
101	framePtr = &done;
102
103	/*
104	 * Enter an Xt event loop until the flag changes.
105	 * Note that we do not explicitly call Tcl_ServiceEvent().
106	 */
107
108	done = 0;
109	while (!done) {
110	    XtAppProcessEvent(TclSetAppContext(NULL), XtIMAll);
111	}
112	(void) Tcl_SetServiceMode(oldMode);
113	framePtr = oldFramePtr;
114    } else {
115	Tcl_AppendResult(interp, "bad option \"", argv[1],
116		"\": must be done or wait", (char *) NULL);
117	return TCL_ERROR;
118    }
119    return TCL_OK;
120}
121