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