Symaptic: os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/unix/tclXtTest.c@260cb5ec6c19

     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  */

    14 #include <X11/Intrinsic.h>

    15 #include "tcl.h"

    17 static int	TesteventloopCmd _ANSI_ARGS_((ClientData clientData,

    18 		    Tcl_Interp *interp, int argc, CONST char **argv));

    19 extern void	InitNotifier _ANSI_ARGS_((void));

    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  */

    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 }

    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  */

    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. */

    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);

    96 	/*

    97 	 * Save the old stack frame pointer and set up the current frame.

    98 	 */

   100 	oldFramePtr = framePtr;

   101 	framePtr = &done;

   103 	/*

   104 	 * Enter an Xt event loop until the flag changes.

   105 	 * Note that we do not explicitly call Tcl_ServiceEvent().

   106 	 */

   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 }

author	sl
	Tue, 10 Jun 2014 14:32:02 +0200
changeset 1	260cb5ec6c19
permissions	-rw-r--r--