tcl/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  * RCS: @(#) $Id$
  12  */
  13
  14 #include <X11/Intrinsic.h>
  15 #include "tcl.h"
  16
  17 static int      TesteventloopCmd _ANSI_ARGS_((ClientData clientData,
  18                     Tcl_Interp *interp, int argc, CONST char **argv));
  19 extern void     InitNotifier _ANSI_ARGS_((void));
  20
  21 \f
  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
  41 int
  42 Tclxttest_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 \f
  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
  73 static int
  74 TesteventloopCmd(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 }