tcl/unix/tclUnixTest.c

   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$
  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, 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_(());
  86 \f
  87 /*
  88  *----------------------------------------------------------------------
  89  *
  90  * TclplatformtestInit --
  91  *
  92  *      Defines commands that test platform specific functionality for
  93  *      Unix platforms.
  94  *
  95  * Results:
  96  *      A standard Tcl result.
  97  *
  98  * Side effects:
  99  *      Defines new commands.
 100  *
 101  *----------------------------------------------------------------------
 102  */
 103
 104 int
 105 TclplatformtestInit(interp)
 106     Tcl_Interp *interp;         /* Interpreter to add commands to. */
 107 {
 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);
 124     return TCL_OK;
 125 }
 126 \f
 127 /*
 128  *----------------------------------------------------------------------
 129  *
 130  * TestfilehandlerCmd --
 131  *
 132  *      This procedure implements the "testfilehandler" command. It is
 133  *      used to test Tcl_CreateFileHandler, Tcl_DeleteFileHandler, and
 134  *      TclWaitForFile.
 135  *
 136  * Results:
 137  *      A standard Tcl result.
 138  *
 139  * Side effects:
 140  *      None.
 141  *
 142  *----------------------------------------------------------------------
 143  */
 144
 145 static int
 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. */
 151 {
 152     Pipe *pipePtr;
 153     int i, mask, timeout;
 154     static int initialized = 0;
 155     char buffer[4000];
 156     TclFile file;
 157
 158     /*
 159      * NOTE: When we make this code work on Windows also, the following
 160      * variable needs to be made Unix-only.
 161      */
 162
 163     if (!initialized) {
 164         for (i = 0; i < MAX_PIPES; i++) {
 165             testPipes[i].readFile = NULL;
 166         }
 167         initialized = 1;
 168     }
 169
 170     if (argc < 2) {
 171         Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
 172                 " option ... \"", (char *) NULL);
 173         return TCL_ERROR;
 174     }
 175     pipePtr = NULL;
 176     if (argc >= 3) {
 177         if (Tcl_GetInt(interp, argv[2], &i) != TCL_OK) {
 178             return TCL_ERROR;
 179         }
 180         if (i >= MAX_PIPES) {
 181             Tcl_AppendResult(interp, "bad index ", argv[2], (char *) NULL);
 182             return TCL_ERROR;
 183         }
 184         pipePtr = &testPipes[i];
 185     }
 186
 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;
 194             }
 195         }
 196     } else if (strcmp(argv[1], "clear") == 0) {
 197         if (argc != 3) {
 198             Tcl_AppendResult(interp, "wrong # arguments: should be \"",
 199                     argv[0], " clear index\"", (char *) NULL);
 200             return TCL_ERROR;
 201         }
 202         pipePtr->readCount = pipePtr->writeCount = 0;
 203     } else if (strcmp(argv[1], "counts") == 0) {
 204         char buf[TCL_INTEGER_SPACE * 2];
 205
 206         if (argc != 3) {
 207             Tcl_AppendResult(interp, "wrong # arguments: should be \"",
 208                     argv[0], " counts index\"", (char *) NULL);
 209             return TCL_ERROR;
 210         }
 211         sprintf(buf, "%d %d", pipePtr->readCount, pipePtr->writeCount);
 212         Tcl_SetResult(interp, buf, TCL_VOLATILE);
 213     } else if (strcmp(argv[1], "create") == 0) {
 214         if (argc != 5) {
 215             Tcl_AppendResult(interp, "wrong # arguments: should be \"",
 216                     argv[0], " create index readMode writeMode\"",
 217                     (char *) NULL);
 218             return TCL_ERROR;
 219         }
 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);
 224                 return TCL_ERROR;
 225             }
 226 #ifdef O_NONBLOCK
 227             fcntl(GetFd(pipePtr->readFile), F_SETFL, O_NONBLOCK);
 228             fcntl(GetFd(pipePtr->writeFile), F_SETFL, O_NONBLOCK);
 229 #else
 230             Tcl_SetResult(interp, "can't make pipes non-blocking",
 231                     TCL_STATIC);
 232             return TCL_ERROR;
 233 #endif
 234         }
 235         pipePtr->readCount = 0;
 236         pipePtr->writeCount = 0;
 237
 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);
 246         } else {
 247             Tcl_AppendResult(interp, "bad read mode \"", argv[3], "\"",
 248                     (char *) NULL);
 249             return TCL_ERROR;
 250         }
 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);
 259         } else {
 260             Tcl_AppendResult(interp, "bad read mode \"", argv[4], "\"",
 261                     (char *) NULL);
 262             return TCL_ERROR;
 263         }
 264     } else if (strcmp(argv[1], "empty") == 0) {
 265         if (argc != 3) {
 266             Tcl_AppendResult(interp, "wrong # arguments: should be \"",
 267                     argv[0], " empty index\"", (char *) NULL);
 268             return TCL_ERROR;
 269         }
 270
 271         while (read(GetFd(pipePtr->readFile), buffer, 4000) > 0) {
 272             /* Empty loop body. */
 273         }
 274     } else if (strcmp(argv[1], "fill") == 0) {
 275         if (argc != 3) {
 276             Tcl_AppendResult(interp, "wrong # arguments: should be \"",
 277                     argv[0], " empty index\"", (char *) NULL);
 278             return TCL_ERROR;
 279         }
 280
 281         memset((VOID *) buffer, 'a', 4000);
 282         while (write(GetFd(pipePtr->writeFile), buffer, 4000) > 0) {
 283             /* Empty loop body. */
 284         }
 285     } else if (strcmp(argv[1], "fillpartial") == 0) {
 286         char buf[TCL_INTEGER_SPACE];
 287
 288         if (argc != 3) {
 289             Tcl_AppendResult(interp, "wrong # arguments: should be \"",
 290                     argv[0], " empty index\"", (char *) NULL);
 291             return TCL_ERROR;
 292         }
 293
 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) {
 300         if (argc != 5) {
 301             Tcl_AppendResult(interp, "wrong # arguments: should be \"",
 302                     argv[0], " wait index readable|writable timeout\"",
 303                     (char *) NULL);
 304             return TCL_ERROR;
 305         }
 306         if (pipePtr->readFile == NULL) {
 307             Tcl_AppendResult(interp, "pipe ", argv[2], " doesn't exist",
 308                     (char *) NULL);
 309             return TCL_ERROR;
 310         }
 311         if (strcmp(argv[3], "readable") == 0) {
 312             mask = TCL_READABLE;
 313             file = pipePtr->readFile;
 314         } else {
 315             mask = TCL_WRITABLE;
 316             file = pipePtr->writeFile;
 317         }
 318         if (Tcl_GetInt(interp, argv[4], &timeout) != TCL_OK) {
 319             return TCL_ERROR;
 320         }
 321         i = TclUnixWaitForFile(GetFd(file), mask, timeout);
 322         if (i & TCL_READABLE) {
 323             Tcl_AppendElement(interp, "readable");
 324         }
 325         if (i & TCL_WRITABLE) {
 326             Tcl_AppendElement(interp, "writable");
 327         }
 328     } else if (strcmp(argv[1], "windowevent") == 0) {
 329         Tcl_DoOneEvent(TCL_WINDOW_EVENTS|TCL_DONT_WAIT);
 330     } else {
 331         Tcl_AppendResult(interp, "bad option \"", argv[1],
 332                 "\": must be close, clear, counts, create, empty, fill, ",
 333                 "fillpartial, oneevent, wait, or windowevent",
 334                 (char *) NULL);
 335         return TCL_ERROR;
 336     }
 337     return TCL_OK;
 338 }
 339
 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. */
 344 {
 345     Pipe *pipePtr = (Pipe *) clientData;
 346
 347     if (mask & TCL_READABLE) {
 348         pipePtr->readCount++;
 349     }
 350     if (mask & TCL_WRITABLE) {
 351         pipePtr->writeCount++;
 352     }
 353 }
 354 \f
 355 /*
 356  *----------------------------------------------------------------------
 357  *
 358  * TestfilewaitCmd --
 359  *
 360  *      This procedure implements the "testfilewait" command. It is
 361  *      used to test TclUnixWaitForFile.
 362  *
 363  * Results:
 364  *      A standard Tcl result.
 365  *
 366  * Side effects:
 367  *      None.
 368  *
 369  *----------------------------------------------------------------------
 370  */
 371
 372 static int
 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. */
 378 {
 379     int mask, result, timeout;
 380     Tcl_Channel channel;
 381     int fd;
 382     ClientData data;
 383
 384     if (argc != 4) {
 385         Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
 386                 " file readable|writable|both timeout\"", (char *) NULL);
 387         return TCL_ERROR;
 388     }
 389     channel = Tcl_GetChannel(interp, argv[1], NULL);
 390     if (channel == NULL) {
 391         return TCL_ERROR;
 392     }
 393     if (strcmp(argv[2], "readable") == 0) {
 394         mask = TCL_READABLE;
 395     } else if (strcmp(argv[2], "writable") == 0){
 396         mask = TCL_WRITABLE;
 397     } else if (strcmp(argv[2], "both") == 0){
 398         mask = TCL_WRITABLE|TCL_READABLE;
 399     } else {
 400         Tcl_AppendResult(interp, "bad argument \"", argv[2],
 401                 "\": must be readable, writable, or both", (char *) NULL);
 402         return TCL_ERROR;
 403     }
 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);
 408         return TCL_ERROR;
 409     }
 410     fd = (int) data;
 411     if (Tcl_GetInt(interp, argv[3], &timeout) != TCL_OK) {
 412         return TCL_ERROR;
 413     }
 414     result = TclUnixWaitForFile(fd, mask, timeout);
 415     if (result & TCL_READABLE) {
 416         Tcl_AppendElement(interp, "readable");
 417     }
 418     if (result & TCL_WRITABLE) {
 419         Tcl_AppendElement(interp, "writable");
 420     }
 421     return TCL_OK;
 422 }
 423 \f
 424 /*
 425  *----------------------------------------------------------------------
 426  *
 427  * TestfindexecutableCmd --
 428  *
 429  *      This procedure implements the "testfindexecutable" command. It is
 430  *      used to test Tcl_FindExecutable.
 431  *
 432  * Results:
 433  *      A standard Tcl result.
 434  *
 435  * Side effects:
 436  *      None.
 437  *
 438  *----------------------------------------------------------------------
 439  */
 440
 441 static int
 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. */
 447 {
 448     char *oldName;
 449     char *oldNativeName;
 450
 451     if (argc != 2) {
 452         Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
 453                 " argv0\"", (char *) NULL);
 454         return TCL_ERROR;
 455     }
 456
 457     oldName       = tclExecutableName;
 458     oldNativeName = tclNativeExecutableName;
 459
 460     tclExecutableName       = NULL;
 461     tclNativeExecutableName = NULL;
 462
 463     Tcl_FindExecutable(argv[1]);
 464     if (tclExecutableName != NULL) {
 465         Tcl_SetResult(interp, tclExecutableName, TCL_VOLATILE);
 466         ckfree(tclExecutableName);
 467     }
 468     if (tclNativeExecutableName != NULL) {
 469         ckfree(tclNativeExecutableName);
 470     }
 471
 472     tclExecutableName       = oldName;
 473     tclNativeExecutableName = oldNativeName;
 474
 475     return TCL_OK;
 476 }
 477 \f
 478 /*
 479  *----------------------------------------------------------------------
 480  *
 481  * TestgetopenfileCmd --
 482  *
 483  *      This procedure implements the "testgetopenfile" command. It is
 484  *      used to get a FILE * value from a registered channel.
 485  *
 486  * Results:
 487  *      A standard Tcl result.
 488  *
 489  * Side effects:
 490  *      None.
 491  *
 492  *----------------------------------------------------------------------
 493  */
 494
 495 static int
 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. */
 501 {
 502     ClientData filePtr;
 503
 504     if (argc != 3) {
 505         Tcl_AppendResult(interp,
 506                 "wrong # args: should be \"", argv[0],
 507                 " channelName forWriting\"",
 508                 (char *) NULL);
 509         return TCL_ERROR;
 510     }
 511     if (Tcl_GetOpenFile(interp, argv[1], atoi(argv[2]), 1, &filePtr)
 512             == TCL_ERROR) {
 513         return TCL_ERROR;
 514     }
 515     if (filePtr == (ClientData) NULL) {
 516         Tcl_AppendResult(interp,
 517                 "Tcl_GetOpenFile succeeded but FILE * NULL!", (char *) NULL);
 518         return TCL_ERROR;
 519     }
 520     return TCL_OK;
 521 }
 522 \f
 523 /*
 524  *----------------------------------------------------------------------
 525  *
 526  * TestsetdefencdirCmd --
 527  *
 528  *      This procedure implements the "testsetdefenc" command. It is
 529  *      used to set the value of tclDefaultEncodingDir.
 530  *
 531  * Results:
 532  *      A standard Tcl result.
 533  *
 534  * Side effects:
 535  *      None.
 536  *
 537  *----------------------------------------------------------------------
 538  */
 539
 540 static int
 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. */
 546 {
 547     if (argc != 2) {
 548         Tcl_AppendResult(interp,
 549                 "wrong # args: should be \"", argv[0],
 550                 " defaultDir\"",
 551                 (char *) NULL);
 552         return TCL_ERROR;
 553     }
 554
 555     if (tclDefaultEncodingDir != NULL) {
 556         ckfree(tclDefaultEncodingDir);
 557         tclDefaultEncodingDir = NULL;
 558     }
 559     if (*argv[1] != '\0') {
 560         tclDefaultEncodingDir = (char *)
 561             ckalloc((unsigned) strlen(argv[1]) + 1);
 562         strcpy(tclDefaultEncodingDir, argv[1]);
 563     }
 564     return TCL_OK;
 565 }
 566 \f
 567 /*
 568  *----------------------------------------------------------------------
 569  *
 570  * TestgetdefencdirCmd --
 571  *
 572  *      This procedure implements the "testgetdefenc" command. It is
 573  *      used to get the value of tclDefaultEncodingDir.
 574  *
 575  * Results:
 576  *      A standard Tcl result.
 577  *
 578  * Side effects:
 579  *      None.
 580  *
 581  *----------------------------------------------------------------------
 582  */
 583
 584 static int
 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. */
 590 {
 591     if (argc != 1) {
 592         Tcl_AppendResult(interp,
 593                 "wrong # args: should be \"", argv[0],
 594                 (char *) NULL);
 595         return TCL_ERROR;
 596     }
 597
 598     if (tclDefaultEncodingDir != NULL) {
 599         Tcl_AppendResult(interp, tclDefaultEncodingDir, (char *) NULL);
 600     }
 601     return TCL_OK;
 602 }
 603 \f
 604 /*
 605  *----------------------------------------------------------------------
 606  * TestalarmCmd --
 607  *
 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.
 611  *
 612  * Results:
 613  *      None.
 614  *
 615  * Side Effects:
 616  *      Sets up an signal and async handlers.
 617  *
 618  *----------------------------------------------------------------------
 619  */
 620
 621 static int
 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. */
 627 {
 628 #ifdef SA_RESTART
 629     unsigned int sec;
 630     struct sigaction action;
 631
 632     if (argc > 1) {
 633         Tcl_GetInt(interp, argv[1], (int *)&sec);
 634     } else {
 635         sec = 1;
 636     }
 637
 638     /*
 639      * Setup the signal handling that automatically retries
 640      * any interupted I/O system calls.
 641      */
 642     action.sa_handler = AlarmHandler;
 643     memset((void *)&action.sa_mask, 0, sizeof(sigset_t));
 644     action.sa_flags = SA_RESTART;
 645
 646     if (sigaction(SIGALRM, &action, NULL) < 0) {
 647         Tcl_AppendResult(interp, "sigaction: ", Tcl_PosixError(interp), NULL);
 648         return TCL_ERROR;
 649     }
 650     if (alarm(sec) < 0) {
 651         Tcl_AppendResult(interp, "alarm: ", Tcl_PosixError(interp), NULL);
 652         return TCL_ERROR;
 653     }
 654     return TCL_OK;
 655 #else
 656     Tcl_AppendResult(interp, "warning: sigaction SA_RESTART not support on this platform", NULL);
 657     return TCL_ERROR;
 658 #endif
 659 }
 660 \f
 661 /*
 662  *----------------------------------------------------------------------
 663  *
 664  * AlarmHandler --
 665  *
 666  *      Signal handler for the alarm command.
 667  *
 668  * Results:
 669  *      None.
 670  *
 671  * Side effects:
 672  *      Calls the Tcl Async handler.
 673  *
 674  *----------------------------------------------------------------------
 675  */
 676
 677 static void
 678 AlarmHandler()
 679 {
 680     gotsig = "1";
 681 }
 682 \f
 683 /*
 684  *----------------------------------------------------------------------
 685  * TestgotsigCmd --
 686  *
 687  *      Verify the signal was handled after the testalarm command.
 688  *
 689  * Results:
 690  *      None.
 691  *
 692  * Side Effects:
 693  *      Resets the value of gotsig back to '0'.
 694  *
 695  *----------------------------------------------------------------------
 696  */
 697
 698 static int
 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. */
 704 {
 705     Tcl_AppendResult(interp, gotsig, (char *) NULL);
 706     gotsig = "0";
 707     return TCL_OK;
 708 }