4 * Contains platform specific test commands for the Unix platform.
6 * Copyright (c) 1996-1997 Sun Microsystems, Inc.
7 * Copyright (c) 1998 by Scriptics Corporation.
9 * See the file "license.terms" for information on usage and redistribution
10 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
19 * The headers are needed for the testalarm command that verifies the
20 * use of SA_RESTART in signal handlers.
24 #include <sys/resource.h>
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
32 #define MakeFile(fd) ((TclFile)((fd)+1))
33 #define GetFd(file) (((int)file)-1)
36 * The stuff below is used to keep track of file handlers created and
37 * exercised by the "testfilehandler" command.
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
45 int readCount; /* Number of times the file handler for
46 * this file has triggered and the file
48 int writeCount; /* Number of times the file handler for
49 * this file has triggered and the file
54 static Pipe testPipes[MAX_PIPES];
57 * The stuff below is used by the testalarm and testgotsig ommands.
60 static char *gotsig = "0";
63 * Forward declarations of procedures defined later in this file:
66 static void TestFileHandlerProc _ANSI_ARGS_((ClientData clientData,
68 static int TestfilehandlerCmd _ANSI_ARGS_((ClientData dummy,
69 Tcl_Interp *interp, int argc, CONST char **argv));
70 static int TestfilewaitCmd _ANSI_ARGS_((ClientData dummy,
71 Tcl_Interp *interp, int argc, CONST char **argv));
72 static int TestfindexecutableCmd _ANSI_ARGS_((ClientData dummy,
73 Tcl_Interp *interp, int argc, CONST char **argv));
74 static int TestgetopenfileCmd _ANSI_ARGS_((ClientData dummy,
75 Tcl_Interp *interp, int argc, CONST char **argv));
76 static int TestgetdefencdirCmd _ANSI_ARGS_((ClientData dummy,
77 Tcl_Interp *interp, int argc, CONST char **argv));
78 static int TestsetdefencdirCmd _ANSI_ARGS_((ClientData dummy,
79 Tcl_Interp *interp, int argc, CONST char **argv));
80 int TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp));
81 static int TestalarmCmd _ANSI_ARGS_((ClientData dummy,
82 Tcl_Interp *interp, int argc, CONST char **argv));
83 static int TestgotsigCmd _ANSI_ARGS_((ClientData dummy,
84 Tcl_Interp *interp, int argc, CONST char **argv));
85 static void AlarmHandler _ANSI_ARGS_(());
88 *----------------------------------------------------------------------
90 * TclplatformtestInit --
92 * Defines commands that test platform specific functionality for
96 * A standard Tcl result.
99 * Defines new commands.
101 *----------------------------------------------------------------------
105 TclplatformtestInit(interp)
106 Tcl_Interp *interp; /* Interpreter to add commands to. */
108 Tcl_CreateCommand(interp, "testfilehandler", TestfilehandlerCmd,
109 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
110 Tcl_CreateCommand(interp, "testfilewait", TestfilewaitCmd,
111 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
112 Tcl_CreateCommand(interp, "testfindexecutable", TestfindexecutableCmd,
113 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
114 Tcl_CreateCommand(interp, "testgetopenfile", TestgetopenfileCmd,
115 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
116 Tcl_CreateCommand(interp, "testgetdefenc", TestgetdefencdirCmd,
117 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
118 Tcl_CreateCommand(interp, "testsetdefenc", TestsetdefencdirCmd,
119 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
120 Tcl_CreateCommand(interp, "testalarm", TestalarmCmd,
121 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
122 Tcl_CreateCommand(interp, "testgotsig", TestgotsigCmd,
123 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
128 *----------------------------------------------------------------------
130 * TestfilehandlerCmd --
132 * This procedure implements the "testfilehandler" command. It is
133 * used to test Tcl_CreateFileHandler, Tcl_DeleteFileHandler, and
137 * A standard Tcl result.
142 *----------------------------------------------------------------------
146 TestfilehandlerCmd(clientData, interp, argc, argv)
147 ClientData clientData; /* Not used. */
148 Tcl_Interp *interp; /* Current interpreter. */
149 int argc; /* Number of arguments. */
150 CONST char **argv; /* Argument strings. */
153 int i, mask, timeout;
154 static int initialized = 0;
159 * NOTE: When we make this code work on Windows also, the following
160 * variable needs to be made Unix-only.
164 for (i = 0; i < MAX_PIPES; i++) {
165 testPipes[i].readFile = NULL;
171 Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
172 " option ... \"", (char *) NULL);
177 if (Tcl_GetInt(interp, argv[2], &i) != TCL_OK) {
180 if (i >= MAX_PIPES) {
181 Tcl_AppendResult(interp, "bad index ", argv[2], (char *) NULL);
184 pipePtr = &testPipes[i];
187 if (strcmp(argv[1], "close") == 0) {
188 for (i = 0; i < MAX_PIPES; i++) {
189 if (testPipes[i].readFile != NULL) {
190 TclpCloseFile(testPipes[i].readFile);
191 testPipes[i].readFile = NULL;
192 TclpCloseFile(testPipes[i].writeFile);
193 testPipes[i].writeFile = NULL;
196 } else if (strcmp(argv[1], "clear") == 0) {
198 Tcl_AppendResult(interp, "wrong # arguments: should be \"",
199 argv[0], " clear index\"", (char *) NULL);
202 pipePtr->readCount = pipePtr->writeCount = 0;
203 } else if (strcmp(argv[1], "counts") == 0) {
204 char buf[TCL_INTEGER_SPACE * 2];
207 Tcl_AppendResult(interp, "wrong # arguments: should be \"",
208 argv[0], " counts index\"", (char *) NULL);
211 sprintf(buf, "%d %d", pipePtr->readCount, pipePtr->writeCount);
212 Tcl_SetResult(interp, buf, TCL_VOLATILE);
213 } else if (strcmp(argv[1], "create") == 0) {
215 Tcl_AppendResult(interp, "wrong # arguments: should be \"",
216 argv[0], " create index readMode writeMode\"",
220 if (pipePtr->readFile == NULL) {
221 if (!TclpCreatePipe(&pipePtr->readFile, &pipePtr->writeFile)) {
222 Tcl_AppendResult(interp, "couldn't open pipe: ",
223 Tcl_PosixError(interp), (char *) NULL);
227 fcntl(GetFd(pipePtr->readFile), F_SETFL, O_NONBLOCK);
228 fcntl(GetFd(pipePtr->writeFile), F_SETFL, O_NONBLOCK);
230 Tcl_SetResult(interp, "can't make pipes non-blocking",
235 pipePtr->readCount = 0;
236 pipePtr->writeCount = 0;
238 if (strcmp(argv[3], "readable") == 0) {
239 Tcl_CreateFileHandler(GetFd(pipePtr->readFile), TCL_READABLE,
240 TestFileHandlerProc, (ClientData) pipePtr);
241 } else if (strcmp(argv[3], "off") == 0) {
242 Tcl_DeleteFileHandler(GetFd(pipePtr->readFile));
243 } else if (strcmp(argv[3], "disabled") == 0) {
244 Tcl_CreateFileHandler(GetFd(pipePtr->readFile), 0,
245 TestFileHandlerProc, (ClientData) pipePtr);
247 Tcl_AppendResult(interp, "bad read mode \"", argv[3], "\"",
251 if (strcmp(argv[4], "writable") == 0) {
252 Tcl_CreateFileHandler(GetFd(pipePtr->writeFile), TCL_WRITABLE,
253 TestFileHandlerProc, (ClientData) pipePtr);
254 } else if (strcmp(argv[4], "off") == 0) {
255 Tcl_DeleteFileHandler(GetFd(pipePtr->writeFile));
256 } else if (strcmp(argv[4], "disabled") == 0) {
257 Tcl_CreateFileHandler(GetFd(pipePtr->writeFile), 0,
258 TestFileHandlerProc, (ClientData) pipePtr);
260 Tcl_AppendResult(interp, "bad read mode \"", argv[4], "\"",
264 } else if (strcmp(argv[1], "empty") == 0) {
266 Tcl_AppendResult(interp, "wrong # arguments: should be \"",
267 argv[0], " empty index\"", (char *) NULL);
271 while (read(GetFd(pipePtr->readFile), buffer, 4000) > 0) {
272 /* Empty loop body. */
274 } else if (strcmp(argv[1], "fill") == 0) {
276 Tcl_AppendResult(interp, "wrong # arguments: should be \"",
277 argv[0], " empty index\"", (char *) NULL);
281 memset((VOID *) buffer, 'a', 4000);
282 while (write(GetFd(pipePtr->writeFile), buffer, 4000) > 0) {
283 /* Empty loop body. */
285 } else if (strcmp(argv[1], "fillpartial") == 0) {
286 char buf[TCL_INTEGER_SPACE];
289 Tcl_AppendResult(interp, "wrong # arguments: should be \"",
290 argv[0], " empty index\"", (char *) NULL);
294 memset((VOID *) buffer, 'b', 10);
295 TclFormatInt(buf, write(GetFd(pipePtr->writeFile), buffer, 10));
296 Tcl_SetResult(interp, buf, TCL_VOLATILE);
297 } else if (strcmp(argv[1], "oneevent") == 0) {
298 Tcl_DoOneEvent(TCL_FILE_EVENTS|TCL_DONT_WAIT);
299 } else if (strcmp(argv[1], "wait") == 0) {
301 Tcl_AppendResult(interp, "wrong # arguments: should be \"",
302 argv[0], " wait index readable|writable timeout\"",
306 if (pipePtr->readFile == NULL) {
307 Tcl_AppendResult(interp, "pipe ", argv[2], " doesn't exist",
311 if (strcmp(argv[3], "readable") == 0) {
313 file = pipePtr->readFile;
316 file = pipePtr->writeFile;
318 if (Tcl_GetInt(interp, argv[4], &timeout) != TCL_OK) {
321 i = TclUnixWaitForFile(GetFd(file), mask, timeout);
322 if (i & TCL_READABLE) {
323 Tcl_AppendElement(interp, "readable");
325 if (i & TCL_WRITABLE) {
326 Tcl_AppendElement(interp, "writable");
328 } else if (strcmp(argv[1], "windowevent") == 0) {
329 Tcl_DoOneEvent(TCL_WINDOW_EVENTS|TCL_DONT_WAIT);
331 Tcl_AppendResult(interp, "bad option \"", argv[1],
332 "\": must be close, clear, counts, create, empty, fill, ",
333 "fillpartial, oneevent, wait, or windowevent",
340 static void TestFileHandlerProc(clientData, mask)
341 ClientData clientData; /* Points to a Pipe structure. */
342 int mask; /* Indicates which events happened:
343 * TCL_READABLE or TCL_WRITABLE. */
345 Pipe *pipePtr = (Pipe *) clientData;
347 if (mask & TCL_READABLE) {
348 pipePtr->readCount++;
350 if (mask & TCL_WRITABLE) {
351 pipePtr->writeCount++;
356 *----------------------------------------------------------------------
360 * This procedure implements the "testfilewait" command. It is
361 * used to test TclUnixWaitForFile.
364 * A standard Tcl result.
369 *----------------------------------------------------------------------
373 TestfilewaitCmd(clientData, interp, argc, argv)
374 ClientData clientData; /* Not used. */
375 Tcl_Interp *interp; /* Current interpreter. */
376 int argc; /* Number of arguments. */
377 CONST char **argv; /* Argument strings. */
379 int mask, result, timeout;
385 Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
386 " file readable|writable|both timeout\"", (char *) NULL);
389 channel = Tcl_GetChannel(interp, argv[1], NULL);
390 if (channel == NULL) {
393 if (strcmp(argv[2], "readable") == 0) {
395 } else if (strcmp(argv[2], "writable") == 0){
397 } else if (strcmp(argv[2], "both") == 0){
398 mask = TCL_WRITABLE|TCL_READABLE;
400 Tcl_AppendResult(interp, "bad argument \"", argv[2],
401 "\": must be readable, writable, or both", (char *) NULL);
404 if (Tcl_GetChannelHandle(channel,
405 (mask & TCL_READABLE) ? TCL_READABLE : TCL_WRITABLE,
406 (ClientData*) &data) != TCL_OK) {
407 Tcl_SetResult(interp, "couldn't get channel file", TCL_STATIC);
411 if (Tcl_GetInt(interp, argv[3], &timeout) != TCL_OK) {
414 result = TclUnixWaitForFile(fd, mask, timeout);
415 if (result & TCL_READABLE) {
416 Tcl_AppendElement(interp, "readable");
418 if (result & TCL_WRITABLE) {
419 Tcl_AppendElement(interp, "writable");
425 *----------------------------------------------------------------------
427 * TestfindexecutableCmd --
429 * This procedure implements the "testfindexecutable" command. It is
430 * used to test Tcl_FindExecutable.
433 * A standard Tcl result.
438 *----------------------------------------------------------------------
442 TestfindexecutableCmd(clientData, interp, argc, argv)
443 ClientData clientData; /* Not used. */
444 Tcl_Interp *interp; /* Current interpreter. */
445 int argc; /* Number of arguments. */
446 CONST char **argv; /* Argument strings. */
452 Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
453 " argv0\"", (char *) NULL);
457 oldName = tclExecutableName;
458 oldNativeName = tclNativeExecutableName;
460 tclExecutableName = NULL;
461 tclNativeExecutableName = NULL;
463 Tcl_FindExecutable(argv[1]);
464 if (tclExecutableName != NULL) {
465 Tcl_SetResult(interp, tclExecutableName, TCL_VOLATILE);
466 ckfree(tclExecutableName);
468 if (tclNativeExecutableName != NULL) {
469 ckfree(tclNativeExecutableName);
472 tclExecutableName = oldName;
473 tclNativeExecutableName = oldNativeName;
479 *----------------------------------------------------------------------
481 * TestgetopenfileCmd --
483 * This procedure implements the "testgetopenfile" command. It is
484 * used to get a FILE * value from a registered channel.
487 * A standard Tcl result.
492 *----------------------------------------------------------------------
496 TestgetopenfileCmd(clientData, interp, argc, argv)
497 ClientData clientData; /* Not used. */
498 Tcl_Interp *interp; /* Current interpreter. */
499 int argc; /* Number of arguments. */
500 CONST char **argv; /* Argument strings. */
505 Tcl_AppendResult(interp,
506 "wrong # args: should be \"", argv[0],
507 " channelName forWriting\"",
511 if (Tcl_GetOpenFile(interp, argv[1], atoi(argv[2]), 1, &filePtr)
515 if (filePtr == (ClientData) NULL) {
516 Tcl_AppendResult(interp,
517 "Tcl_GetOpenFile succeeded but FILE * NULL!", (char *) NULL);
524 *----------------------------------------------------------------------
526 * TestsetdefencdirCmd --
528 * This procedure implements the "testsetdefenc" command. It is
529 * used to set the value of tclDefaultEncodingDir.
532 * A standard Tcl result.
537 *----------------------------------------------------------------------
541 TestsetdefencdirCmd(clientData, interp, argc, argv)
542 ClientData clientData; /* Not used. */
543 Tcl_Interp *interp; /* Current interpreter. */
544 int argc; /* Number of arguments. */
545 CONST char **argv; /* Argument strings. */
548 Tcl_AppendResult(interp,
549 "wrong # args: should be \"", argv[0],
555 if (tclDefaultEncodingDir != NULL) {
556 ckfree(tclDefaultEncodingDir);
557 tclDefaultEncodingDir = NULL;
559 if (*argv[1] != '\0') {
560 tclDefaultEncodingDir = (char *)
561 ckalloc((unsigned) strlen(argv[1]) + 1);
562 strcpy(tclDefaultEncodingDir, argv[1]);
568 *----------------------------------------------------------------------
570 * TestgetdefencdirCmd --
572 * This procedure implements the "testgetdefenc" command. It is
573 * used to get the value of tclDefaultEncodingDir.
576 * A standard Tcl result.
581 *----------------------------------------------------------------------
585 TestgetdefencdirCmd(clientData, interp, argc, argv)
586 ClientData clientData; /* Not used. */
587 Tcl_Interp *interp; /* Current interpreter. */
588 int argc; /* Number of arguments. */
589 CONST char **argv; /* Argument strings. */
592 Tcl_AppendResult(interp,
593 "wrong # args: should be \"", argv[0],
598 if (tclDefaultEncodingDir != NULL) {
599 Tcl_AppendResult(interp, tclDefaultEncodingDir, (char *) NULL);
605 *----------------------------------------------------------------------
608 * Test that EINTR is handled correctly by generating and
609 * handling a signal. This requires using the SA_RESTART
610 * flag when registering the signal handler.
616 * Sets up an signal and async handlers.
618 *----------------------------------------------------------------------
622 TestalarmCmd(clientData, interp, argc, argv)
623 ClientData clientData; /* Not used. */
624 Tcl_Interp *interp; /* Current interpreter. */
625 int argc; /* Number of arguments. */
626 CONST char **argv; /* Argument strings. */
630 struct sigaction action;
633 Tcl_GetInt(interp, argv[1], (int *)&sec);
639 * Setup the signal handling that automatically retries
640 * any interupted I/O system calls.
642 action.sa_handler = AlarmHandler;
643 memset((void *)&action.sa_mask, 0, sizeof(sigset_t));
644 action.sa_flags = SA_RESTART;
646 if (sigaction(SIGALRM, &action, NULL) < 0) {
647 Tcl_AppendResult(interp, "sigaction: ", Tcl_PosixError(interp), NULL);
650 if (alarm(sec) < 0) {
651 Tcl_AppendResult(interp, "alarm: ", Tcl_PosixError(interp), NULL);
656 Tcl_AppendResult(interp, "warning: sigaction SA_RESTART not support on this platform", NULL);
662 *----------------------------------------------------------------------
666 * Signal handler for the alarm command.
672 * Calls the Tcl Async handler.
674 *----------------------------------------------------------------------
684 *----------------------------------------------------------------------
687 * Verify the signal was handled after the testalarm command.
693 * Resets the value of gotsig back to '0'.
695 *----------------------------------------------------------------------
699 TestgotsigCmd(clientData, interp, argc, argv)
700 ClientData clientData; /* Not used. */
701 Tcl_Interp *interp; /* Current interpreter. */
702 int argc; /* Number of arguments. */
703 CONST char **argv; /* Argument strings. */
705 Tcl_AppendResult(interp, gotsig, (char *) NULL);