OpenCores
URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tcl/] [win/] [tclWinTest.c] - Blame information for rev 1765

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 578 markom
/*
2
 * tclWinTest.c --
3
 *
4
 *      Contains commands for platform specific tests on Windows.
5
 *
6
 * Copyright (c) 1996 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: tclWinTest.c,v 1.1.1.1 2002-01-16 10:25:39 markom Exp $
12
 */
13
 
14
#include "tclInt.h"
15
#include "tclPort.h"
16
 
17
/*
18
 * Forward declarations of procedures defined later in this file:
19
 */
20
int                     TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp));
21
static int              TesteventloopCmd _ANSI_ARGS_((ClientData dummy,
22
                            Tcl_Interp *interp, int argc, char **argv));
23
 
24
/*
25
 *----------------------------------------------------------------------
26
 *
27
 * TclplatformtestInit --
28
 *
29
 *      Defines commands that test platform specific functionality for
30
 *      Unix platforms.
31
 *
32
 * Results:
33
 *      A standard Tcl result.
34
 *
35
 * Side effects:
36
 *      Defines new commands.
37
 *
38
 *----------------------------------------------------------------------
39
 */
40
 
41
int
42
TclplatformtestInit(interp)
43
    Tcl_Interp *interp;         /* Interpreter to add commands to. */
44
{
45
    /*
46
     * Add commands for platform specific tests for Windows here.
47
     */
48
 
49
    Tcl_CreateCommand(interp, "testeventloop", TesteventloopCmd,
50
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
51
    return TCL_OK;
52
}
53
 
54
/*
55
 *----------------------------------------------------------------------
56
 *
57
 * TesteventloopCmd --
58
 *
59
 *      This procedure implements the "testeventloop" command. It is
60
 *      used to test the Tcl notifier from an "external" event loop
61
 *      (i.e. not Tcl_DoOneEvent()).
62
 *
63
 * Results:
64
 *      A standard Tcl result.
65
 *
66
 * Side effects:
67
 *      None.
68
 *
69
 *----------------------------------------------------------------------
70
 */
71
 
72
static int
73
TesteventloopCmd(clientData, interp, argc, argv)
74
    ClientData clientData;              /* Not used. */
75
    Tcl_Interp *interp;                 /* Current interpreter. */
76
    int argc;                           /* Number of arguments. */
77
    char **argv;                        /* Argument strings. */
78
{
79
    static int *framePtr = NULL; /* Pointer to integer on stack frame of
80
                                  * innermost invocation of the "wait"
81
                                  * subcommand. */
82
 
83
   if (argc < 2) {
84
        Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
85
                " option ... \"", (char *) NULL);
86
        return TCL_ERROR;
87
    }
88
    if (strcmp(argv[1], "done") == 0) {
89
        *framePtr = 1;
90
    } else if (strcmp(argv[1], "wait") == 0) {
91
        int *oldFramePtr;
92
        int done;
93
        MSG msg;
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 a standard Windows 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
            if (!GetMessage(&msg, NULL, 0, 0)) {
111
                /*
112
                 * The application is exiting, so repost the quit message
113
                 * and start unwinding.
114
                 */
115
 
116
                PostQuitMessage(msg.wParam);
117
                break;
118
            }
119
            TranslateMessage(&msg);
120
            DispatchMessage(&msg);
121
        }
122
        (void) Tcl_SetServiceMode(oldMode);
123
        framePtr = oldFramePtr;
124
    } else {
125
        Tcl_AppendResult(interp, "bad option \"", argv[1],
126
                "\": must be done or wait", (char *) NULL);
127
        return TCL_ERROR;
128
    }
129
    return TCL_OK;
130
}

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.