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