home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tcltk805.zip / tcl805s.zip / tcl8.0.5 / os2 / tclOS2Test.c < prev    next >
C/C++ Source or Header  |  2001-02-09  |  4KB  |  128 lines
  1. /* 
  2.  * tclOS2Test.c --
  3.  *
  4.  *    Contains commands for platform specific tests on OS/2.
  5.  *
  6.  * Copyright (c) 1996 Sun Microsystems, Inc.
  7.  * Copyright (c) 1996-2001 Illya Vaes
  8.  *
  9.  * See the file "license.terms" for information on usage and redistribution
  10.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11.  *
  12.  */
  13.  
  14. #include "tclOS2Int.h"
  15.  
  16. /*
  17.  * Forward declarations of procedures defined later in this file:
  18.  */
  19. int            TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp));
  20. static int              TesteventloopCmd _ANSI_ARGS_((ClientData dummy,
  21.                             Tcl_Interp *interp, int argc, char **argv));
  22.  
  23. /*
  24.  *----------------------------------------------------------------------
  25.  *
  26.  * TclplatformtestInit --
  27.  *
  28.  *    Defines commands that test platform specific functionality for
  29.  *    OS/2 platforms.
  30.  *
  31.  * Results:
  32.  *    A standard Tcl result.
  33.  *
  34.  * Side effects:
  35.  *    Defines new commands.
  36.  *
  37.  *----------------------------------------------------------------------
  38.  */
  39.  
  40. int
  41. TclplatformtestInit(interp)
  42.     Tcl_Interp *interp;        /* Interpreter to add commands to. */
  43. {
  44.     /*
  45.      * Add commands for platform specific tests for OS/2 here.
  46.      */
  47.  
  48.     Tcl_CreateCommand(interp, "testeventloop", TesteventloopCmd,
  49.             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  50.     return TCL_OK;
  51. }
  52.  
  53. /*
  54.  *----------------------------------------------------------------------
  55.  *
  56.  * TesteventloopCmd --
  57.  *
  58.  *      This procedure implements the "testeventloop" command. It is
  59.  *      used to test the Tcl notifier from an "external" event loop
  60.  *      (i.e. not Tcl_DoOneEvent()).
  61.  *
  62.  * Results:
  63.  *      A standard Tcl result.
  64.  *
  65.  * Side effects:
  66.  *      None.
  67.  *
  68.  *----------------------------------------------------------------------
  69.  */
  70.  
  71. static int
  72. TesteventloopCmd(clientData, interp, argc, argv)
  73.     ClientData clientData;              /* Not used. */
  74.     Tcl_Interp *interp;                 /* Current interpreter. */
  75.     int argc;                           /* Number of arguments. */
  76.     char **argv;                        /* Argument strings. */
  77. {
  78.     static int *framePtr = NULL; /* Pointer to integer on stack frame of
  79.                                   * innermost invocation of the "wait"
  80.                                   * subcommand. */
  81.  
  82.    if (argc < 2) {
  83.         Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
  84.                 " option ... \"", (char *) NULL);
  85.         return TCL_ERROR;
  86.     }
  87.     if (strcmp(argv[1], "done") == 0) {
  88.         *framePtr = 1;
  89.     } else if (strcmp(argv[1], "wait") == 0) {
  90.         int *oldFramePtr;
  91.         int done;
  92.         QMSG msg;
  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 a standard OS/2 PM event loop until the flag changes.
  104.          * Note that we do not explicitly call Tcl_ServiceEvent().
  105.          */
  106.  
  107.         done = 0;
  108.         while (!done) {
  109.             if (!WinGetMsg(TclOS2GetHAB(), &msg, NULLHANDLE, 0, 0)) {
  110.                 /*
  111.                  * The application is exiting, so repost the quit message
  112.                  * and start unwinding.
  113.                  */
  114.  
  115.                 break;
  116.             }
  117.             WinDispatchMsg(TclOS2GetHAB(), &msg);
  118.         }
  119.         (void) Tcl_SetServiceMode(oldMode);
  120.         framePtr = oldFramePtr;
  121.     } else {
  122.         Tcl_AppendResult(interp, "bad option \"", argv[1],
  123.                 "\": must be done or wait", (char *) NULL);
  124.         return TCL_ERROR;
  125.     }
  126.     return TCL_OK;
  127. }
  128.