1/*
2 * tclUnixTest.c --
3 *
4 *	Contains platform specific test commands for the Unix platform.
5 *
6 * Copyright (c) 1996-1997 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.14.2.2 2006/03/19 22:47:30 vincentdarley 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
40typedef 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
54static Pipe testPipes[MAX_PIPES];
55
56/*
57 * The stuff below is used by the testalarm and testgotsig ommands.
58 */
59
60static char *gotsig = "0";
61
62/*
63 * Forward declarations of procedures defined later in this file:
64 */
65
66static void		TestFileHandlerProc _ANSI_ARGS_((ClientData clientData,
67			    int mask));
68static int		TestfilehandlerCmd _ANSI_ARGS_((ClientData dummy,
69			    Tcl_Interp *interp, int argc, CONST char **argv));
70static int		TestfilewaitCmd _ANSI_ARGS_((ClientData dummy,
71			    Tcl_Interp *interp, int argc, CONST char **argv));
72static int		TestfindexecutableCmd _ANSI_ARGS_((ClientData dummy,
73			    Tcl_Interp *interp, int argc, CONST char **argv));
74static int		TestgetopenfileCmd _ANSI_ARGS_((ClientData dummy,
75			    Tcl_Interp *interp, int argc, CONST char **argv));
76static int		TestgetdefencdirCmd _ANSI_ARGS_((ClientData dummy,
77			    Tcl_Interp *interp, int argc, CONST char **argv));
78static int		TestsetdefencdirCmd _ANSI_ARGS_((ClientData dummy,
79			    Tcl_Interp *interp, int argc, CONST char **argv));
80int			TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp));
81static int		TestalarmCmd _ANSI_ARGS_((ClientData dummy,
82			    Tcl_Interp *interp, int argc, CONST char **argv));
83static int		TestgotsigCmd _ANSI_ARGS_((ClientData dummy,
84			    Tcl_Interp *interp, int argc, CONST char **argv));
85static void 		AlarmHandler _ANSI_ARGS_(());
86static int		TestchmodCmd _ANSI_ARGS_((ClientData dummy,
87			    Tcl_Interp *interp, int argc, CONST char **argv));
88
89/*
90 *----------------------------------------------------------------------
91 *
92 * TclplatformtestInit --
93 *
94 *	Defines commands that test platform specific functionality for
95 *	Unix platforms.
96 *
97 * Results:
98 *	A standard Tcl result.
99 *
100 * Side effects:
101 *	Defines new commands.
102 *
103 *----------------------------------------------------------------------
104 */
105
106int
107TclplatformtestInit(interp)
108    Tcl_Interp *interp;		/* Interpreter to add commands to. */
109{
110    Tcl_CreateCommand(interp, "testchmod", TestchmodCmd,
111	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
112    Tcl_CreateCommand(interp, "testfilehandler", TestfilehandlerCmd,
113            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
114    Tcl_CreateCommand(interp, "testfilewait", TestfilewaitCmd,
115            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
116    Tcl_CreateCommand(interp, "testfindexecutable", TestfindexecutableCmd,
117            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
118    Tcl_CreateCommand(interp, "testgetopenfile", TestgetopenfileCmd,
119            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
120    Tcl_CreateCommand(interp, "testgetdefenc", TestgetdefencdirCmd,
121            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
122    Tcl_CreateCommand(interp, "testsetdefenc", TestsetdefencdirCmd,
123            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
124    Tcl_CreateCommand(interp, "testalarm", TestalarmCmd,
125            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
126    Tcl_CreateCommand(interp, "testgotsig", TestgotsigCmd,
127            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
128    return TCL_OK;
129}
130
131/*
132 *----------------------------------------------------------------------
133 *
134 * TestfilehandlerCmd --
135 *
136 *	This procedure implements the "testfilehandler" command. It is
137 *	used to test Tcl_CreateFileHandler, Tcl_DeleteFileHandler, and
138 *	TclWaitForFile.
139 *
140 * Results:
141 *	A standard Tcl result.
142 *
143 * Side effects:
144 *	None.
145 *
146 *----------------------------------------------------------------------
147 */
148
149static int
150TestfilehandlerCmd(clientData, interp, argc, argv)
151    ClientData clientData;		/* Not used. */
152    Tcl_Interp *interp;			/* Current interpreter. */
153    int argc;				/* Number of arguments. */
154    CONST char **argv;			/* Argument strings. */
155{
156    Pipe *pipePtr;
157    int i, mask, timeout;
158    static int initialized = 0;
159    char buffer[4000];
160    TclFile file;
161
162    /*
163     * NOTE: When we make this code work on Windows also, the following
164     * variable needs to be made Unix-only.
165     */
166
167    if (!initialized) {
168	for (i = 0; i < MAX_PIPES; i++) {
169	    testPipes[i].readFile = NULL;
170	}
171	initialized = 1;
172    }
173
174    if (argc < 2) {
175	Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
176                " option ... \"", (char *) NULL);
177        return TCL_ERROR;
178    }
179    pipePtr = NULL;
180    if (argc >= 3) {
181	if (Tcl_GetInt(interp, argv[2], &i) != TCL_OK) {
182	    return TCL_ERROR;
183	}
184	if (i >= MAX_PIPES) {
185	    Tcl_AppendResult(interp, "bad index ", argv[2], (char *) NULL);
186	    return TCL_ERROR;
187	}
188	pipePtr = &testPipes[i];
189    }
190
191    if (strcmp(argv[1], "close") == 0) {
192	for (i = 0; i < MAX_PIPES; i++) {
193	    if (testPipes[i].readFile != NULL) {
194		TclpCloseFile(testPipes[i].readFile);
195		testPipes[i].readFile = NULL;
196		TclpCloseFile(testPipes[i].writeFile);
197		testPipes[i].writeFile = NULL;
198	    }
199	}
200    } else if (strcmp(argv[1], "clear") == 0) {
201	if (argc != 3) {
202	    Tcl_AppendResult(interp, "wrong # arguments: should be \"",
203                    argv[0], " clear index\"", (char *) NULL);
204	    return TCL_ERROR;
205	}
206	pipePtr->readCount = pipePtr->writeCount = 0;
207    } else if (strcmp(argv[1], "counts") == 0) {
208	char buf[TCL_INTEGER_SPACE * 2];
209
210	if (argc != 3) {
211	    Tcl_AppendResult(interp, "wrong # arguments: should be \"",
212                    argv[0], " counts index\"", (char *) NULL);
213	    return TCL_ERROR;
214	}
215	sprintf(buf, "%d %d", pipePtr->readCount, pipePtr->writeCount);
216	Tcl_SetResult(interp, buf, TCL_VOLATILE);
217    } else if (strcmp(argv[1], "create") == 0) {
218	if (argc != 5) {
219	    Tcl_AppendResult(interp, "wrong # arguments: should be \"",
220                    argv[0], " create index readMode writeMode\"",
221                    (char *) NULL);
222	    return TCL_ERROR;
223	}
224	if (pipePtr->readFile == NULL) {
225	    if (!TclpCreatePipe(&pipePtr->readFile, &pipePtr->writeFile)) {
226		Tcl_AppendResult(interp, "couldn't open pipe: ",
227			Tcl_PosixError(interp), (char *) NULL);
228		return TCL_ERROR;
229	    }
230#ifdef O_NONBLOCK
231	    fcntl(GetFd(pipePtr->readFile), F_SETFL, O_NONBLOCK);
232	    fcntl(GetFd(pipePtr->writeFile), F_SETFL, O_NONBLOCK);
233#else
234	    Tcl_SetResult(interp, "can't make pipes non-blocking",
235		    TCL_STATIC);
236	    return TCL_ERROR;
237#endif
238	}
239	pipePtr->readCount = 0;
240	pipePtr->writeCount = 0;
241
242	if (strcmp(argv[3], "readable") == 0) {
243	    Tcl_CreateFileHandler(GetFd(pipePtr->readFile), TCL_READABLE,
244		    TestFileHandlerProc, (ClientData) pipePtr);
245	} else if (strcmp(argv[3], "off") == 0) {
246	    Tcl_DeleteFileHandler(GetFd(pipePtr->readFile));
247	} else if (strcmp(argv[3], "disabled") == 0) {
248	    Tcl_CreateFileHandler(GetFd(pipePtr->readFile), 0,
249		    TestFileHandlerProc, (ClientData) pipePtr);
250	} else {
251	    Tcl_AppendResult(interp, "bad read mode \"", argv[3], "\"",
252		    (char *) NULL);
253	    return TCL_ERROR;
254	}
255	if (strcmp(argv[4], "writable") == 0) {
256	    Tcl_CreateFileHandler(GetFd(pipePtr->writeFile), TCL_WRITABLE,
257		    TestFileHandlerProc, (ClientData) pipePtr);
258	} else if (strcmp(argv[4], "off") == 0) {
259	    Tcl_DeleteFileHandler(GetFd(pipePtr->writeFile));
260	} else if (strcmp(argv[4], "disabled") == 0) {
261	    Tcl_CreateFileHandler(GetFd(pipePtr->writeFile), 0,
262		    TestFileHandlerProc, (ClientData) pipePtr);
263	} else {
264	    Tcl_AppendResult(interp, "bad read mode \"", argv[4], "\"",
265		    (char *) NULL);
266	    return TCL_ERROR;
267	}
268    } else if (strcmp(argv[1], "empty") == 0) {
269	if (argc != 3) {
270	    Tcl_AppendResult(interp, "wrong # arguments: should be \"",
271                    argv[0], " empty index\"", (char *) NULL);
272	    return TCL_ERROR;
273	}
274
275        while (read(GetFd(pipePtr->readFile), buffer, 4000) > 0) {
276            /* Empty loop body. */
277        }
278    } else if (strcmp(argv[1], "fill") == 0) {
279	if (argc != 3) {
280	    Tcl_AppendResult(interp, "wrong # arguments: should be \"",
281                    argv[0], " fill index\"", (char *) NULL);
282	    return TCL_ERROR;
283	}
284
285	memset((VOID *) buffer, 'a', 4000);
286        while (write(GetFd(pipePtr->writeFile), buffer, 4000) > 0) {
287            /* Empty loop body. */
288        }
289    } else if (strcmp(argv[1], "fillpartial") == 0) {
290	char buf[TCL_INTEGER_SPACE];
291
292	if (argc != 3) {
293	    Tcl_AppendResult(interp, "wrong # arguments: should be \"",
294                    argv[0], " fillpartial index\"", (char *) NULL);
295	    return TCL_ERROR;
296	}
297
298	memset((VOID *) buffer, 'b', 10);
299	TclFormatInt(buf, write(GetFd(pipePtr->writeFile), buffer, 10));
300	Tcl_SetResult(interp, buf, TCL_VOLATILE);
301    } else if (strcmp(argv[1], "oneevent") == 0) {
302	Tcl_DoOneEvent(TCL_FILE_EVENTS|TCL_DONT_WAIT);
303    } else if (strcmp(argv[1], "wait") == 0) {
304	if (argc != 5) {
305	    Tcl_AppendResult(interp, "wrong # arguments: should be \"",
306                    argv[0], " wait index readable|writable timeout\"",
307                    (char *) NULL);
308	    return TCL_ERROR;
309	}
310	if (pipePtr->readFile == NULL) {
311	    Tcl_AppendResult(interp, "pipe ", argv[2], " doesn't exist",
312		    (char *) NULL);
313	    return TCL_ERROR;
314	}
315	if (strcmp(argv[3], "readable") == 0) {
316	    mask = TCL_READABLE;
317	    file = pipePtr->readFile;
318	} else {
319	    mask = TCL_WRITABLE;
320	    file = pipePtr->writeFile;
321	}
322	if (Tcl_GetInt(interp, argv[4], &timeout) != TCL_OK) {
323	    return TCL_ERROR;
324	}
325	i = TclUnixWaitForFile(GetFd(file), mask, timeout);
326	if (i & TCL_READABLE) {
327	    Tcl_AppendElement(interp, "readable");
328	}
329	if (i & TCL_WRITABLE) {
330	    Tcl_AppendElement(interp, "writable");
331	}
332    } else if (strcmp(argv[1], "windowevent") == 0) {
333	Tcl_DoOneEvent(TCL_WINDOW_EVENTS|TCL_DONT_WAIT);
334    } else {
335	Tcl_AppendResult(interp, "bad option \"", argv[1],
336		"\": must be close, clear, counts, create, empty, fill, ",
337		"fillpartial, oneevent, wait, or windowevent",
338		(char *) NULL);
339	return TCL_ERROR;
340    }
341    return TCL_OK;
342}
343
344static void TestFileHandlerProc(clientData, mask)
345    ClientData clientData;	/* Points to a Pipe structure. */
346    int mask;			/* Indicates which events happened:
347				 * TCL_READABLE or TCL_WRITABLE. */
348{
349    Pipe *pipePtr = (Pipe *) clientData;
350
351    if (mask & TCL_READABLE) {
352	pipePtr->readCount++;
353    }
354    if (mask & TCL_WRITABLE) {
355	pipePtr->writeCount++;
356    }
357}
358
359/*
360 *----------------------------------------------------------------------
361 *
362 * TestfilewaitCmd --
363 *
364 *	This procedure implements the "testfilewait" command. It is
365 *	used to test TclUnixWaitForFile.
366 *
367 * Results:
368 *	A standard Tcl result.
369 *
370 * Side effects:
371 *	None.
372 *
373 *----------------------------------------------------------------------
374 */
375
376static int
377TestfilewaitCmd(clientData, interp, argc, argv)
378    ClientData clientData;		/* Not used. */
379    Tcl_Interp *interp;			/* Current interpreter. */
380    int argc;				/* Number of arguments. */
381    CONST char **argv;			/* Argument strings. */
382{
383    int mask, result, timeout;
384    Tcl_Channel channel;
385    int fd;
386    ClientData data;
387
388    if (argc != 4) {
389	Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
390		" file readable|writable|both timeout\"", (char *) NULL);
391	return TCL_ERROR;
392    }
393    channel = Tcl_GetChannel(interp, argv[1], NULL);
394    if (channel == NULL) {
395	return TCL_ERROR;
396    }
397    if (strcmp(argv[2], "readable") == 0) {
398	mask = TCL_READABLE;
399    } else if (strcmp(argv[2], "writable") == 0){
400	mask = TCL_WRITABLE;
401    } else if (strcmp(argv[2], "both") == 0){
402	mask = TCL_WRITABLE|TCL_READABLE;
403    } else {
404	Tcl_AppendResult(interp, "bad argument \"", argv[2],
405		"\": must be readable, writable, or both", (char *) NULL);
406	return TCL_ERROR;
407    }
408    if (Tcl_GetChannelHandle(channel,
409	    (mask & TCL_READABLE) ? TCL_READABLE : TCL_WRITABLE,
410	    (ClientData*) &data) != TCL_OK) {
411	Tcl_SetResult(interp, "couldn't get channel file", TCL_STATIC);
412	return TCL_ERROR;
413    }
414    fd = (int) data;
415    if (Tcl_GetInt(interp, argv[3], &timeout) != TCL_OK) {
416	return TCL_ERROR;
417    }
418    result = TclUnixWaitForFile(fd, mask, timeout);
419    if (result & TCL_READABLE) {
420	Tcl_AppendElement(interp, "readable");
421    }
422    if (result & TCL_WRITABLE) {
423	Tcl_AppendElement(interp, "writable");
424    }
425    return TCL_OK;
426}
427
428/*
429 *----------------------------------------------------------------------
430 *
431 * TestfindexecutableCmd --
432 *
433 *	This procedure implements the "testfindexecutable" command. It is
434 *	used to test Tcl_FindExecutable.
435 *
436 * Results:
437 *	A standard Tcl result.
438 *
439 * Side effects:
440 *	None.
441 *
442 *----------------------------------------------------------------------
443 */
444
445static int
446TestfindexecutableCmd(clientData, interp, argc, argv)
447    ClientData clientData;		/* Not used. */
448    Tcl_Interp *interp;			/* Current interpreter. */
449    int argc;				/* Number of arguments. */
450    CONST char **argv;			/* Argument strings. */
451{
452    char *oldName;
453    char *oldNativeName;
454
455    if (argc != 2) {
456	Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
457		" argv0\"", (char *) NULL);
458	return TCL_ERROR;
459    }
460
461    oldName       = tclExecutableName;
462    oldNativeName = tclNativeExecutableName;
463
464    tclExecutableName       = NULL;
465    tclNativeExecutableName = NULL;
466
467    Tcl_FindExecutable(argv[1]);
468    if (tclExecutableName != NULL) {
469	Tcl_SetResult(interp, tclExecutableName, TCL_VOLATILE);
470	ckfree(tclExecutableName);
471    }
472    if (tclNativeExecutableName != NULL) {
473	ckfree(tclNativeExecutableName);
474    }
475
476    tclExecutableName       = oldName;
477    tclNativeExecutableName = oldNativeName;
478
479    return TCL_OK;
480}
481
482/*
483 *----------------------------------------------------------------------
484 *
485 * TestgetopenfileCmd --
486 *
487 *	This procedure implements the "testgetopenfile" command. It is
488 *	used to get a FILE * value from a registered channel.
489 *
490 * Results:
491 *	A standard Tcl result.
492 *
493 * Side effects:
494 *	None.
495 *
496 *----------------------------------------------------------------------
497 */
498
499static int
500TestgetopenfileCmd(clientData, interp, argc, argv)
501    ClientData clientData;		/* Not used. */
502    Tcl_Interp *interp;			/* Current interpreter. */
503    int argc;				/* Number of arguments. */
504    CONST char **argv;			/* Argument strings. */
505{
506    ClientData filePtr;
507
508    if (argc != 3) {
509        Tcl_AppendResult(interp,
510                "wrong # args: should be \"", argv[0],
511                " channelName forWriting\"",
512                (char *) NULL);
513        return TCL_ERROR;
514    }
515    if (Tcl_GetOpenFile(interp, argv[1], atoi(argv[2]), 1, &filePtr)
516            == TCL_ERROR) {
517        return TCL_ERROR;
518    }
519    if (filePtr == (ClientData) NULL) {
520        Tcl_AppendResult(interp,
521                "Tcl_GetOpenFile succeeded but FILE * NULL!", (char *) NULL);
522        return TCL_ERROR;
523    }
524    return TCL_OK;
525}
526
527/*
528 *----------------------------------------------------------------------
529 *
530 * TestsetdefencdirCmd --
531 *
532 *	This procedure implements the "testsetdefenc" command. It is
533 *	used to set the value of tclDefaultEncodingDir.
534 *
535 * Results:
536 *	A standard Tcl result.
537 *
538 * Side effects:
539 *	None.
540 *
541 *----------------------------------------------------------------------
542 */
543
544static int
545TestsetdefencdirCmd(clientData, interp, argc, argv)
546    ClientData clientData;		/* Not used. */
547    Tcl_Interp *interp;			/* Current interpreter. */
548    int argc;				/* Number of arguments. */
549    CONST char **argv;			/* Argument strings. */
550{
551    if (argc != 2) {
552        Tcl_AppendResult(interp,
553                "wrong # args: should be \"", argv[0],
554                " defaultDir\"",
555                (char *) NULL);
556        return TCL_ERROR;
557    }
558
559    if (tclDefaultEncodingDir != NULL) {
560	ckfree(tclDefaultEncodingDir);
561	tclDefaultEncodingDir = NULL;
562    }
563    if (*argv[1] != '\0') {
564	tclDefaultEncodingDir = (char *)
565	    ckalloc((unsigned) strlen(argv[1]) + 1);
566	strcpy(tclDefaultEncodingDir, argv[1]);
567    }
568    return TCL_OK;
569}
570
571/*
572 *----------------------------------------------------------------------
573 *
574 * TestgetdefencdirCmd --
575 *
576 *	This procedure implements the "testgetdefenc" command. It is
577 *	used to get the value of tclDefaultEncodingDir.
578 *
579 * Results:
580 *	A standard Tcl result.
581 *
582 * Side effects:
583 *	None.
584 *
585 *----------------------------------------------------------------------
586 */
587
588static int
589TestgetdefencdirCmd(clientData, interp, argc, argv)
590    ClientData clientData;		/* Not used. */
591    Tcl_Interp *interp;			/* Current interpreter. */
592    int argc;				/* Number of arguments. */
593    CONST char **argv;			/* Argument strings. */
594{
595    if (argc != 1) {
596        Tcl_AppendResult(interp,
597                "wrong # args: should be \"", argv[0],
598                (char *) NULL);
599        return TCL_ERROR;
600    }
601
602    if (tclDefaultEncodingDir != NULL) {
603        Tcl_AppendResult(interp, tclDefaultEncodingDir, (char *) NULL);
604    }
605    return TCL_OK;
606}
607
608/*
609 *----------------------------------------------------------------------
610 * TestalarmCmd --
611 *
612 *	Test that EINTR is handled correctly by generating and
613 *	handling a signal.  This requires using the SA_RESTART
614 *	flag when registering the signal handler.
615 *
616 * Results:
617 *	None.
618 *
619 * Side Effects:
620 *	Sets up an signal and async handlers.
621 *
622 *----------------------------------------------------------------------
623 */
624
625static int
626TestalarmCmd(clientData, interp, argc, argv)
627    ClientData clientData;		/* Not used. */
628    Tcl_Interp *interp;			/* Current interpreter. */
629    int argc;				/* Number of arguments. */
630    CONST char **argv;			/* Argument strings. */
631{
632#ifdef SA_RESTART
633    unsigned int sec;
634    struct sigaction action;
635
636    if (argc > 1) {
637	Tcl_GetInt(interp, argv[1], (int *)&sec);
638    } else {
639	sec = 1;
640    }
641
642    /*
643     * Setup the signal handling that automatically retries
644     * any interupted I/O system calls.
645     */
646    action.sa_handler = AlarmHandler;
647    memset((void *)&action.sa_mask, 0, sizeof(sigset_t));
648    action.sa_flags = SA_RESTART;
649
650    if (sigaction(SIGALRM, &action, NULL) < 0) {
651	Tcl_AppendResult(interp, "sigaction: ", Tcl_PosixError(interp), NULL);
652	return TCL_ERROR;
653    }
654    (void)alarm(sec);
655    return TCL_OK;
656#else
657    Tcl_AppendResult(interp, "warning: sigaction SA_RESTART not support on this platform", NULL);
658    return TCL_ERROR;
659#endif
660}
661
662/*
663 *----------------------------------------------------------------------
664 *
665 * AlarmHandler --
666 *
667 *	Signal handler for the alarm command.
668 *
669 * Results:
670 *	None.
671 *
672 * Side effects:
673 * 	Calls the Tcl Async handler.
674 *
675 *----------------------------------------------------------------------
676 */
677
678static void
679AlarmHandler()
680{
681    gotsig = "1";
682}
683
684/*
685 *----------------------------------------------------------------------
686 * TestgotsigCmd --
687 *
688 * 	Verify the signal was handled after the testalarm command.
689 *
690 * Results:
691 *	None.
692 *
693 * Side Effects:
694 *	Resets the value of gotsig back to '0'.
695 *
696 *----------------------------------------------------------------------
697 */
698
699static int
700TestgotsigCmd(clientData, interp, argc, argv)
701    ClientData clientData;		/* Not used. */
702    Tcl_Interp *interp;			/* Current interpreter. */
703    int argc;				/* Number of arguments. */
704    CONST char **argv;			/* Argument strings. */
705{
706    Tcl_AppendResult(interp, gotsig, (char *) NULL);
707    gotsig = "0";
708    return TCL_OK;
709}
710
711/*
712 *---------------------------------------------------------------------------
713 *
714 * TestchmodCmd --
715 *
716 *	Implements the "testchmod" cmd.  Used when testing "file" command.
717 *	The only attribute used by the Windows platform is the user write
718 *	flag; if this is not set, the file is made read-only.  Otehrwise, the
719 *	file is made read-write.
720 *
721 * Results:
722 *	A standard Tcl result.
723 *
724 * Side effects:
725 *	Changes permissions of specified files.
726 *
727 *---------------------------------------------------------------------------
728 */
729
730static int
731TestchmodCmd(dummy, interp, argc, argv)
732    ClientData dummy;			/* Not used. */
733    Tcl_Interp *interp;			/* Current interpreter. */
734    int argc;				/* Number of arguments. */
735    CONST char **argv;			/* Argument strings. */
736{
737    int i, mode;
738    char *rest;
739
740    if (argc < 2) {
741	usage:
742	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
743		" mode file ?file ...?", NULL);
744	return TCL_ERROR;
745    }
746
747    mode = (int) strtol(argv[1], &rest, 8);
748    if ((rest == argv[1]) || (*rest != '\0')) {
749	goto usage;
750    }
751
752    for (i = 2; i < argc; i++) {
753	Tcl_DString buffer;
754	CONST char *translated;
755
756	translated = Tcl_TranslateFileName(interp, argv[i], &buffer);
757	if (translated == NULL) {
758	    return TCL_ERROR;
759	}
760	if (chmod(translated, (unsigned) mode) != 0) {
761	    Tcl_AppendResult(interp, translated, ": ", Tcl_PosixError(interp),
762		    NULL);
763	    return TCL_ERROR;
764	}
765	Tcl_DStringFree(&buffer);
766    }
767    return TCL_OK;
768}
769