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