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