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

Subversion Repositories or1k_old

[/] [or1k_old/] [trunk/] [insight/] [tcl/] [unix/] [tclUnixTest.c] - Blame information for rev 1782

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 578 markom
/*
2
 * tclUnixTest.c --
3
 *
4
 *      Contains platform specific test commands for the Unix platform.
5
 *
6
 * Copyright (c) 1996 Sun Microsystems, Inc.
7
 * Copyright (c) 1998 by Scriptics Corporation.
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
 * RCS: @(#) $Id: tclUnixTest.c,v 1.1.1.1 2002-01-16 10:25:37 markom Exp $
13
 */
14
 
15
#include "tclInt.h"
16
#include "tclPort.h"
17
 
18
/*
19
 * The headers are needed for the testalarm command that verifies the
20
 * use of SA_RESTART in signal handlers.
21
 */
22
 
23
#include <signal.h>
24
#include <sys/resource.h>
25
 
26
/*
27
 * The following macros convert between TclFile's and fd's.  The conversion
28
 * simple involves shifting fd's up by one to ensure that no valid fd is ever
29
 * the same as NULL.  Note that this code is duplicated from tclUnixPipe.c
30
 */
31
 
32
#define MakeFile(fd) ((TclFile)((fd)+1))
33
#define GetFd(file) (((int)file)-1)
34
 
35
/*
36
 * The stuff below is used to keep track of file handlers created and
37
 * exercised by the "testfilehandler" command.
38
 */
39
 
40
typedef struct Pipe {
41
    TclFile readFile;           /* File handle for reading from the
42
                                 * pipe.  NULL means pipe doesn't exist yet. */
43
    TclFile writeFile;          /* File handle for writing from the
44
                                 * pipe. */
45
    int readCount;              /* Number of times the file handler for
46
                                 * this file has triggered and the file
47
                                 * was readable. */
48
    int writeCount;             /* Number of times the file handler for
49
                                 * this file has triggered and the file
50
                                 * was writable. */
51
} Pipe;
52
 
53
#define MAX_PIPES 10
54
static Pipe testPipes[MAX_PIPES];
55
 
56
/*
57
 * The stuff below is used by the testalarm and testgotsig ommands.
58
 */
59
 
60
static char *gotsig = "0";
61
 
62
/*
63
 * Forward declarations of procedures defined later in this file:
64
 */
65
 
66
static void             TestFileHandlerProc _ANSI_ARGS_((ClientData clientData,
67
                            int mask));
68
static int              TestfilehandlerCmd _ANSI_ARGS_((ClientData dummy,
69
                            Tcl_Interp *interp, int argc, char **argv));
70
static int              TestfilewaitCmd _ANSI_ARGS_((ClientData dummy,
71
                            Tcl_Interp *interp, int argc, char **argv));
72
static int              TestfindexecutableCmd _ANSI_ARGS_((ClientData dummy,
73
                            Tcl_Interp *interp, int argc, char **argv));
74
static int              TestgetopenfileCmd _ANSI_ARGS_((ClientData dummy,
75
                            Tcl_Interp *interp, int argc, char **argv));
76
int                     TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp));
77
static int              TestalarmCmd _ANSI_ARGS_((ClientData dummy,
78
                            Tcl_Interp *interp, int argc, char **argv));
79
static int              TestgotsigCmd _ANSI_ARGS_((ClientData dummy,
80
                            Tcl_Interp *interp, int argc, char **argv));
81
static void             AlarmHandler _ANSI_ARGS_(());
82
 
83
/*
84
 *----------------------------------------------------------------------
85
 *
86
 * TclplatformtestInit --
87
 *
88
 *      Defines commands that test platform specific functionality for
89
 *      Unix platforms.
90
 *
91
 * Results:
92
 *      A standard Tcl result.
93
 *
94
 * Side effects:
95
 *      Defines new commands.
96
 *
97
 *----------------------------------------------------------------------
98
 */
99
 
100
int
101
TclplatformtestInit(interp)
102
    Tcl_Interp *interp;         /* Interpreter to add commands to. */
103
{
104
    Tcl_CreateCommand(interp, "testfilehandler", TestfilehandlerCmd,
105
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
106
    Tcl_CreateCommand(interp, "testfilewait", TestfilewaitCmd,
107
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
108
    Tcl_CreateCommand(interp, "testfindexecutable", TestfindexecutableCmd,
109
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
110
    Tcl_CreateCommand(interp, "testgetopenfile", TestgetopenfileCmd,
111
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
112
    Tcl_CreateCommand(interp, "testalarm", TestalarmCmd,
113
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
114
    Tcl_CreateCommand(interp, "testgotsig", TestgotsigCmd,
115
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
116
    return TCL_OK;
117
}
118
 
119
/*
120
 *----------------------------------------------------------------------
121
 *
122
 * TestfilehandlerCmd --
123
 *
124
 *      This procedure implements the "testfilehandler" command. It is
125
 *      used to test Tcl_CreateFileHandler, Tcl_DeleteFileHandler, and
126
 *      TclWaitForFile.
127
 *
128
 * Results:
129
 *      A standard Tcl result.
130
 *
131
 * Side effects:
132
 *      None.
133
 *
134
 *----------------------------------------------------------------------
135
 */
136
 
137
static int
138
TestfilehandlerCmd(clientData, interp, argc, argv)
139
    ClientData clientData;              /* Not used. */
140
    Tcl_Interp *interp;                 /* Current interpreter. */
141
    int argc;                           /* Number of arguments. */
142
    char **argv;                        /* Argument strings. */
143
{
144
    Pipe *pipePtr;
145
    int i, mask, timeout;
146
    static int initialized = 0;
147
    char buffer[4000];
148
    TclFile file;
149
 
150
    /*
151
     * NOTE: When we make this code work on Windows also, the following
152
     * variable needs to be made Unix-only.
153
     */
154
 
155
    if (!initialized) {
156
        for (i = 0; i < MAX_PIPES; i++) {
157
            testPipes[i].readFile = NULL;
158
        }
159
        initialized = 1;
160
    }
161
 
162
    if (argc < 2) {
163
        Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
164
                " option ... \"", (char *) NULL);
165
        return TCL_ERROR;
166
    }
167
    pipePtr = NULL;
168
    if (argc >= 3) {
169
        if (Tcl_GetInt(interp, argv[2], &i) != TCL_OK) {
170
            return TCL_ERROR;
171
        }
172
        if (i >= MAX_PIPES) {
173
            Tcl_AppendResult(interp, "bad index ", argv[2], (char *) NULL);
174
            return TCL_ERROR;
175
        }
176
        pipePtr = &testPipes[i];
177
    }
178
 
179
    if (strcmp(argv[1], "close") == 0) {
180
        for (i = 0; i < MAX_PIPES; i++) {
181
            if (testPipes[i].readFile != NULL) {
182
                TclpCloseFile(testPipes[i].readFile);
183
                testPipes[i].readFile = NULL;
184
                TclpCloseFile(testPipes[i].writeFile);
185
                testPipes[i].writeFile = NULL;
186
            }
187
        }
188
    } else if (strcmp(argv[1], "clear") == 0) {
189
        if (argc != 3) {
190
            Tcl_AppendResult(interp, "wrong # arguments: should be \"",
191
                    argv[0], " clear index\"", (char *) NULL);
192
            return TCL_ERROR;
193
        }
194
        pipePtr->readCount = pipePtr->writeCount = 0;
195
    } else if (strcmp(argv[1], "counts") == 0) {
196
        char buf[30];
197
 
198
        if (argc != 3) {
199
            Tcl_AppendResult(interp, "wrong # arguments: should be \"",
200
                    argv[0], " counts index\"", (char *) NULL);
201
            return TCL_ERROR;
202
        }
203
        sprintf(buf, "%d %d", pipePtr->readCount, pipePtr->writeCount);
204
        Tcl_SetResult(interp, buf, TCL_VOLATILE);
205
    } else if (strcmp(argv[1], "create") == 0) {
206
        if (argc != 5) {
207
            Tcl_AppendResult(interp, "wrong # arguments: should be \"",
208
                    argv[0], " create index readMode writeMode\"",
209
                    (char *) NULL);
210
            return TCL_ERROR;
211
        }
212
        if (pipePtr->readFile == NULL) {
213
            if (!TclpCreatePipe(&pipePtr->readFile, &pipePtr->writeFile)) {
214
                Tcl_AppendResult(interp, "couldn't open pipe: ",
215
                        Tcl_PosixError(interp), (char *) NULL);
216
                return TCL_ERROR;
217
            }
218
#ifdef O_NONBLOCK
219
            fcntl(GetFd(pipePtr->readFile), F_SETFL, O_NONBLOCK);
220
            fcntl(GetFd(pipePtr->writeFile), F_SETFL, O_NONBLOCK);
221
#else
222
            Tcl_SetResult(interp, "can't make pipes non-blocking",
223
                    TCL_STATIC);
224
            return TCL_ERROR;
225
#endif
226
        }
227
        pipePtr->readCount = 0;
228
        pipePtr->writeCount = 0;
229
 
230
        if (strcmp(argv[3], "readable") == 0) {
231
            Tcl_CreateFileHandler(GetFd(pipePtr->readFile), TCL_READABLE,
232
                    TestFileHandlerProc, (ClientData) pipePtr);
233
        } else if (strcmp(argv[3], "off") == 0) {
234
            Tcl_DeleteFileHandler(GetFd(pipePtr->readFile));
235
        } else if (strcmp(argv[3], "disabled") == 0) {
236
            Tcl_CreateFileHandler(GetFd(pipePtr->readFile), 0,
237
                    TestFileHandlerProc, (ClientData) pipePtr);
238
        } else {
239
            Tcl_AppendResult(interp, "bad read mode \"", argv[3], "\"",
240
                    (char *) NULL);
241
            return TCL_ERROR;
242
        }
243
        if (strcmp(argv[4], "writable") == 0) {
244
            Tcl_CreateFileHandler(GetFd(pipePtr->writeFile), TCL_WRITABLE,
245
                    TestFileHandlerProc, (ClientData) pipePtr);
246
        } else if (strcmp(argv[4], "off") == 0) {
247
            Tcl_DeleteFileHandler(GetFd(pipePtr->writeFile));
248
        } else if (strcmp(argv[4], "disabled") == 0) {
249
            Tcl_CreateFileHandler(GetFd(pipePtr->writeFile), 0,
250
                    TestFileHandlerProc, (ClientData) pipePtr);
251
        } else {
252
            Tcl_AppendResult(interp, "bad read mode \"", argv[4], "\"",
253
                    (char *) NULL);
254
            return TCL_ERROR;
255
        }
256
    } else if (strcmp(argv[1], "empty") == 0) {
257
        if (argc != 3) {
258
            Tcl_AppendResult(interp, "wrong # arguments: should be \"",
259
                    argv[0], " empty index\"", (char *) NULL);
260
            return TCL_ERROR;
261
        }
262
 
263
        while (read(GetFd(pipePtr->readFile), buffer, 4000) > 0) {
264
            /* Empty loop body. */
265
        }
266
    } else if (strcmp(argv[1], "fill") == 0) {
267
        if (argc != 3) {
268
            Tcl_AppendResult(interp, "wrong # arguments: should be \"",
269
                    argv[0], " empty index\"", (char *) NULL);
270
            return TCL_ERROR;
271
        }
272
 
273
        memset((VOID *) buffer, 'a', 4000);
274
        while (write(GetFd(pipePtr->writeFile), buffer, 4000) > 0) {
275
            /* Empty loop body. */
276
        }
277
    } else if (strcmp(argv[1], "fillpartial") == 0) {
278
        char buf[30];
279
 
280
        if (argc != 3) {
281
            Tcl_AppendResult(interp, "wrong # arguments: should be \"",
282
                    argv[0], " empty index\"", (char *) NULL);
283
            return TCL_ERROR;
284
        }
285
 
286
        memset((VOID *) buffer, 'b', 10);
287
        sprintf(buf, "%d", write(GetFd(pipePtr->writeFile), buffer, 10));
288
        Tcl_SetResult(interp, buf, TCL_VOLATILE);
289
    } else if (strcmp(argv[1], "oneevent") == 0) {
290
        Tcl_DoOneEvent(TCL_FILE_EVENTS|TCL_DONT_WAIT);
291
    } else if (strcmp(argv[1], "wait") == 0) {
292
        if (argc != 5) {
293
            Tcl_AppendResult(interp, "wrong # arguments: should be \"",
294
                    argv[0], " wait index readable/writable timeout\"",
295
                    (char *) NULL);
296
            return TCL_ERROR;
297
        }
298
        if (pipePtr->readFile == NULL) {
299
            Tcl_AppendResult(interp, "pipe ", argv[2], " doesn't exist",
300
                    (char *) NULL);
301
            return TCL_ERROR;
302
        }
303
        if (strcmp(argv[3], "readable") == 0) {
304
            mask = TCL_READABLE;
305
            file = pipePtr->readFile;
306
        } else {
307
            mask = TCL_WRITABLE;
308
            file = pipePtr->writeFile;
309
        }
310
        if (Tcl_GetInt(interp, argv[4], &timeout) != TCL_OK) {
311
            return TCL_ERROR;
312
        }
313
        i = TclUnixWaitForFile(GetFd(file), mask, timeout);
314
        if (i & TCL_READABLE) {
315
            Tcl_AppendElement(interp, "readable");
316
        }
317
        if (i & TCL_WRITABLE) {
318
            Tcl_AppendElement(interp, "writable");
319
        }
320
    } else if (strcmp(argv[1], "windowevent") == 0) {
321
        Tcl_DoOneEvent(TCL_WINDOW_EVENTS|TCL_DONT_WAIT);
322
    } else {
323
        Tcl_AppendResult(interp, "bad option \"", argv[1],
324
                "\": must be close, clear, counts, create, empty, fill, ",
325
                "fillpartial, oneevent, wait, or windowevent",
326
                (char *) NULL);
327
        return TCL_ERROR;
328
    }
329
    return TCL_OK;
330
}
331
 
332
static void TestFileHandlerProc(clientData, mask)
333
    ClientData clientData;      /* Points to a Pipe structure. */
334
    int mask;                   /* Indicates which events happened:
335
                                 * TCL_READABLE or TCL_WRITABLE. */
336
{
337
    Pipe *pipePtr = (Pipe *) clientData;
338
 
339
    if (mask & TCL_READABLE) {
340
        pipePtr->readCount++;
341
    }
342
    if (mask & TCL_WRITABLE) {
343
        pipePtr->writeCount++;
344
    }
345
}
346
 
347
/*
348
 *----------------------------------------------------------------------
349
 *
350
 * TestfilewaitCmd --
351
 *
352
 *      This procedure implements the "testfilewait" command. It is
353
 *      used to test TclUnixWaitForFile.
354
 *
355
 * Results:
356
 *      A standard Tcl result.
357
 *
358
 * Side effects:
359
 *      None.
360
 *
361
 *----------------------------------------------------------------------
362
 */
363
 
364
static int
365
TestfilewaitCmd(clientData, interp, argc, argv)
366
    ClientData clientData;              /* Not used. */
367
    Tcl_Interp *interp;                 /* Current interpreter. */
368
    int argc;                           /* Number of arguments. */
369
    char **argv;                        /* Argument strings. */
370
{
371
    int mask, result, timeout;
372
    Tcl_Channel channel;
373
    int fd;
374
    ClientData data;
375
 
376
    if (argc != 4) {
377
        Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
378
                " file readable|writable|both timeout\"", (char *) NULL);
379
        return TCL_ERROR;
380
    }
381
    channel = Tcl_GetChannel(interp, argv[1], NULL);
382
    if (channel == NULL) {
383
        return TCL_ERROR;
384
    }
385
    if (strcmp(argv[2], "readable") == 0) {
386
        mask = TCL_READABLE;
387
    } else if (strcmp(argv[2], "writable") == 0){
388
        mask = TCL_WRITABLE;
389
    } else if (strcmp(argv[2], "both") == 0){
390
        mask = TCL_WRITABLE|TCL_READABLE;
391
    } else {
392
        Tcl_AppendResult(interp, "bad argument \"", argv[2],
393
                "\": must be readable, writable, or both", (char *) NULL);
394
        return TCL_ERROR;
395
    }
396
    if (Tcl_GetChannelHandle(channel,
397
            (mask & TCL_READABLE) ? TCL_READABLE : TCL_WRITABLE,
398
            (ClientData*) &data) != TCL_OK) {
399
        Tcl_SetResult(interp, "couldn't get channel file", TCL_STATIC);
400
        return TCL_ERROR;
401
    }
402
    fd = (int) data;
403
    if (Tcl_GetInt(interp, argv[3], &timeout) != TCL_OK) {
404
        return TCL_ERROR;
405
    }
406
    result = TclUnixWaitForFile(fd, mask, timeout);
407
    if (result & TCL_READABLE) {
408
        Tcl_AppendElement(interp, "readable");
409
    }
410
    if (result & TCL_WRITABLE) {
411
        Tcl_AppendElement(interp, "writable");
412
    }
413
    return TCL_OK;
414
}
415
 
416
/*
417
 *----------------------------------------------------------------------
418
 *
419
 * TestfindexecutableCmd --
420
 *
421
 *      This procedure implements the "testfindexecutable" command. It is
422
 *      used to test Tcl_FindExecutable.
423
 *
424
 * Results:
425
 *      A standard Tcl result.
426
 *
427
 * Side effects:
428
 *      None.
429
 *
430
 *----------------------------------------------------------------------
431
 */
432
 
433
static int
434
TestfindexecutableCmd(clientData, interp, argc, argv)
435
    ClientData clientData;              /* Not used. */
436
    Tcl_Interp *interp;                 /* Current interpreter. */
437
    int argc;                           /* Number of arguments. */
438
    char **argv;                        /* Argument strings. */
439
{
440
    char *oldName;
441
 
442
    if (argc != 2) {
443
        Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
444
                " argv0\"", (char *) NULL);
445
        return TCL_ERROR;
446
    }
447
    oldName = tclExecutableName;
448
    tclExecutableName = NULL;
449
    Tcl_FindExecutable(argv[1]);
450
    if (tclExecutableName != NULL) {
451
        Tcl_SetResult(interp, tclExecutableName, TCL_VOLATILE);
452
        ckfree(tclExecutableName);
453
    }
454
    tclExecutableName = oldName;
455
    return TCL_OK;
456
}
457
 
458
/*
459
 *----------------------------------------------------------------------
460
 *
461
 * TestgetopenfileCmd --
462
 *
463
 *      This procedure implements the "testgetopenfile" command. It is
464
 *      used to get a FILE * value from a registered channel.
465
 *
466
 * Results:
467
 *      A standard Tcl result.
468
 *
469
 * Side effects:
470
 *      None.
471
 *
472
 *----------------------------------------------------------------------
473
 */
474
 
475
static int
476
TestgetopenfileCmd(clientData, interp, argc, argv)
477
    ClientData clientData;              /* Not used. */
478
    Tcl_Interp *interp;                 /* Current interpreter. */
479
    int argc;                           /* Number of arguments. */
480
    char **argv;                        /* Argument strings. */
481
{
482
    ClientData filePtr;
483
 
484
    if (argc != 3) {
485
        Tcl_AppendResult(interp,
486
                "wrong # args: should be \"", argv[0],
487
                " channelName forWriting\"",
488
                (char *) NULL);
489
        return TCL_ERROR;
490
    }
491
    if (Tcl_GetOpenFile(interp, argv[1], atoi(argv[2]), 1, &filePtr)
492
            == TCL_ERROR) {
493
        return TCL_ERROR;
494
    }
495
    if (filePtr == (ClientData) NULL) {
496
        Tcl_AppendResult(interp,
497
                "Tcl_GetOpenFile succeeded but FILE * NULL!", (char *) NULL);
498
        return TCL_ERROR;
499
    }
500
    return TCL_OK;
501
}
502
 
503
/*
504
 *----------------------------------------------------------------------
505
 * TestalarmCmd --
506
 *
507
 *      Test that EINTR is handled correctly by generating and
508
 *      handling a signal.  This requires using the SA_RESTART
509
 *      flag when registering the signal handler.
510
 *
511
 * Results:
512
 *      None.
513
 *
514
 * Side Effects:
515
 *      Sets up an signal and async handlers.
516
 *
517
 *----------------------------------------------------------------------
518
 */
519
 
520
static int
521
TestalarmCmd(clientData, interp, argc, argv)
522
    ClientData clientData;              /* Not used. */
523
    Tcl_Interp *interp;                 /* Current interpreter. */
524
    int argc;                           /* Number of arguments. */
525
    char **argv;                        /* Argument strings. */
526
{
527
#ifdef SA_RESTART
528
    unsigned int sec;
529
    struct sigaction action;
530
 
531
    if (argc > 1) {
532
        Tcl_GetInt(interp, argv[1], (int *)&sec);
533
    } else {
534
        sec = 1;
535
    }
536
 
537
    /*
538
     * Setup the signal handling that automatically retries
539
     * any interupted I/O system calls.
540
     */
541
    action.sa_handler = AlarmHandler;
542
    memset((void *)&action.sa_mask, 0, sizeof(sigset_t));
543
    action.sa_flags = SA_RESTART;
544
 
545
    if (sigaction(SIGALRM, &action, NULL) < 0) {
546
        Tcl_AppendResult(interp, "sigaction: ", Tcl_PosixError(interp), NULL);
547
        return TCL_ERROR;
548
    }
549
    if (alarm(sec) < 0) {
550
        Tcl_AppendResult(interp, "alarm: ", Tcl_PosixError(interp), NULL);
551
        return TCL_ERROR;
552
    }
553
    return TCL_OK;
554
#else
555
    Tcl_AppendResult(interp, "warning: sigaction SA_RESTART not support on this platform", NULL);
556
    return TCL_ERROR;
557
#endif
558
}
559
 
560
/*
561
 *----------------------------------------------------------------------
562
 *
563
 * AlarmHandler --
564
 *
565
 *      Signal handler for the alarm command.
566
 *
567
 * Results:
568
 *      None.
569
 *
570
 * Side effects:
571
 *      Calls the Tcl Async handler.
572
 *
573
 *----------------------------------------------------------------------
574
 */
575
 
576
static void
577
AlarmHandler()
578
{
579
    gotsig = "1";
580
}
581
 
582
/*
583
 *----------------------------------------------------------------------
584
 * TestgotsigCmd --
585
 *
586
 *      Verify the signal was handled after the testalarm command.
587
 *
588
 * Results:
589
 *      None.
590
 *
591
 * Side Effects:
592
 *      Resets the value of gotsig back to '0'.
593
 *
594
 *----------------------------------------------------------------------
595
 */
596
 
597
static int
598
TestgotsigCmd(clientData, interp, argc, argv)
599
    ClientData clientData;              /* Not used. */
600
    Tcl_Interp *interp;                 /* Current interpreter. */
601
    int argc;                           /* Number of arguments. */
602
    char **argv;                        /* Argument strings. */
603
{
604
    Tcl_AppendResult(interp, gotsig, (char *) NULL);
605
    gotsig = "0";
606
    return TCL_OK;
607
}

powered by: WebSVN 2.1.0

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