util/src/TclTk/tcl8.6.12/unix/tclXtTest.c

   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
  12 #ifndef USE_TCL_STUBS
  13 #   define USE_TCL_STUBS
  14 #endif
  15 #include <X11/Intrinsic.h>
  16 #include "tcl.h"
  17
  18 static Tcl_ObjCmdProc TesteventloopCmd;
  19
  20 /*
  21  * Functions defined in tclXtNotify.c for use by users of the Xt Notifier:
  22  */
  23
  24 extern void     InitNotifier(void);
  25 extern XtAppContext     TclSetAppContext(XtAppContext ctx);
  26 \f
  27 /*
  28  *----------------------------------------------------------------------
  29  *
  30  * Tclxttest_Init --
  31  *
  32  *      This procedure performs application-specific initialization. Most
  33  *      applications, especially those that incorporate additional packages,
  34  *      will have their own version of this procedure.
  35  *
  36  * Results:
  37  *      Returns a standard Tcl completion code, and leaves an error message in
  38  *      the interp's result if an error occurs.
  39  *
  40  * Side effects:
  41  *      Depends on the startup script.
  42  *
  43  *----------------------------------------------------------------------
  44  */
  45
  46 DLLEXPORT int
  47 Tclxttest_Init(
  48     Tcl_Interp *interp)         /* Interpreter for application. */
  49 {
  50     if (Tcl_InitStubs(interp, "8.1", 0) == NULL) {
  51         return TCL_ERROR;
  52     }
  53     XtToolkitInitialize();
  54     InitNotifier();
  55     Tcl_CreateObjCommand(interp, "testeventloop", TesteventloopCmd,
  56             NULL, NULL);
  57     return TCL_OK;
  58 }
  59 \f
  60 /*
  61  *----------------------------------------------------------------------
  62  *
  63  * TesteventloopCmd --
  64  *
  65  *      This procedure implements the "testeventloop" command. It is used to
  66  *      test the Tcl notifier from an "external" event loop (i.e. not
  67  *      Tcl_DoOneEvent()).
  68  *
  69  * Results:
  70  *      A standard Tcl result.
  71  *
  72  * Side effects:
  73  *      None.
  74  *
  75  *----------------------------------------------------------------------
  76  */
  77
  78 static int
  79 TesteventloopCmd(
  80     ClientData clientData,      /* Not used. */
  81     Tcl_Interp *interp,         /* Current interpreter. */
  82     int objc,                   /* Number of arguments. */
  83     Tcl_Obj *const objv[])      /* Argument objects. */
  84 {
  85     static int *framePtr = NULL;/* Pointer to integer on stack frame of
  86                                  * innermost invocation of the "wait"
  87                                  * subcommand. */
  88
  89     if (objc < 2) {
  90         Tcl_WrongNumArgs(interp, 1, objv, "option ...");
  91         return TCL_ERROR;
  92     }
  93     if (strcmp(Tcl_GetString(objv[1]), "done") == 0) {
  94         *framePtr = 1;
  95     } else if (strcmp(Tcl_GetString(objv[1]), "wait") == 0) {
  96         int *oldFramePtr;
  97         int done;
  98         int oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);
  99
 100         /*
 101          * Save the old stack frame pointer and set up the current frame.
 102          */
 103
 104         oldFramePtr = framePtr;
 105         framePtr = &done;
 106
 107         /*
 108          * Enter an Xt event loop until the flag changes. Note that we do not
 109          * explicitly call Tcl_ServiceEvent().
 110          */
 111
 112         done = 0;
 113         while (!done) {
 114             XtAppProcessEvent(TclSetAppContext(NULL), XtIMAll);
 115         }
 116         (void) Tcl_SetServiceMode(oldMode);
 117         framePtr = oldFramePtr;
 118     } else {
 119         Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]),
 120                 "\": must be done or wait", NULL);
 121         return TCL_ERROR;
 122     }
 123     return TCL_OK;
 124 }
 125 \f
 126 /*
 127  * Local Variables:
 128  * mode: c
 129  * c-basic-offset: 4
 130  * fill-column: 78
 131  * tab-width: 8
 132  * End:
 133  */