1/* 2 * tclIOCmd.c -- 3 * 4 * Contains the definitions of most of the Tcl commands relating to IO. 5 * 6 * Copyright (c) 1995-1997 Sun Microsystems, Inc. 7 * 8 * See the file "license.terms" for information on usage and redistribution of 9 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 10 * 11 * RCS: @(#) $Id: tclIOCmd.c,v 1.51.2.3 2010/02/11 15:25:25 dkf Exp $ 12 */ 13 14#include "tclInt.h" 15 16/* 17 * Callback structure for accept callback in a TCP server. 18 */ 19 20typedef struct AcceptCallback { 21 char *script; /* Script to invoke. */ 22 Tcl_Interp *interp; /* Interpreter in which to run it. */ 23} AcceptCallback; 24 25/* 26 * Thread local storage used to maintain a per-thread stdout channel obj. 27 * It must be per-thread because of std channel limitations. 28 */ 29 30typedef struct ThreadSpecificData { 31 int initialized; /* Set to 1 when the module is initialized. */ 32 Tcl_Obj *stdoutObjPtr; /* Cached stdout channel Tcl_Obj */ 33} ThreadSpecificData; 34 35static Tcl_ThreadDataKey dataKey; 36 37/* 38 * Static functions for this file: 39 */ 40 41static void FinalizeIOCmdTSD(ClientData clientData); 42static void AcceptCallbackProc(ClientData callbackData, 43 Tcl_Channel chan, char *address, int port); 44static int ChanPendingObjCmd(ClientData unused, 45 Tcl_Interp *interp, int objc, 46 Tcl_Obj *const objv[]); 47static int ChanTruncateObjCmd(ClientData dummy, 48 Tcl_Interp *interp, int objc, 49 Tcl_Obj *const objv[]); 50static void RegisterTcpServerInterpCleanup(Tcl_Interp *interp, 51 AcceptCallback *acceptCallbackPtr); 52static void TcpAcceptCallbacksDeleteProc(ClientData clientData, 53 Tcl_Interp *interp); 54static void TcpServerCloseProc(ClientData callbackData); 55static void UnregisterTcpServerInterpCleanupProc( 56 Tcl_Interp *interp, 57 AcceptCallback *acceptCallbackPtr); 58 59/* 60 *---------------------------------------------------------------------- 61 * 62 * FinalizeIOCmdTSD -- 63 * 64 * Release the storage associated with the per-thread cache. 65 * 66 * Results: 67 * None. 68 * 69 * Side effects: 70 * None. 71 * 72 *---------------------------------------------------------------------- 73 */ 74 75static void 76FinalizeIOCmdTSD( 77 ClientData clientData) /* Not used. */ 78{ 79 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 80 81 if (tsdPtr->stdoutObjPtr != NULL) { 82 Tcl_DecrRefCount(tsdPtr->stdoutObjPtr); 83 tsdPtr->stdoutObjPtr = NULL; 84 } 85 tsdPtr->initialized = 0; 86} 87 88/* 89 *---------------------------------------------------------------------- 90 * 91 * Tcl_PutsObjCmd -- 92 * 93 * This function is invoked to process the "puts" Tcl command. See the 94 * user documentation for details on what it does. 95 * 96 * Results: 97 * A standard Tcl result. 98 * 99 * Side effects: 100 * Produces output on a channel. 101 * 102 *---------------------------------------------------------------------- 103 */ 104 105 /* ARGSUSED */ 106int 107Tcl_PutsObjCmd( 108 ClientData dummy, /* Not used. */ 109 Tcl_Interp *interp, /* Current interpreter. */ 110 int objc, /* Number of arguments. */ 111 Tcl_Obj *const objv[]) /* Argument objects. */ 112{ 113 Tcl_Channel chan; /* The channel to puts on. */ 114 Tcl_Obj *string; /* String to write. */ 115 Tcl_Obj *chanObjPtr = NULL; /* channel object. */ 116 int newline; /* Add a newline at end? */ 117 int result; /* Result of puts operation. */ 118 int mode; /* Mode in which channel is opened. */ 119 ThreadSpecificData *tsdPtr; 120 121 switch (objc) { 122 case 2: /* [puts $x] */ 123 string = objv[1]; 124 newline = 1; 125 break; 126 127 case 3: /* [puts -nonewline $x] or [puts $chan $x] */ 128 if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) { 129 newline = 0; 130 } else { 131 newline = 1; 132 chanObjPtr = objv[1]; 133 } 134 string = objv[2]; 135 break; 136 137 case 4: /* [puts -nonewline $chan $x] or [puts $chan $x nonewline] */ 138 if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) { 139 chanObjPtr = objv[2]; 140 string = objv[3]; 141 } else { 142 /* 143 * The code below provides backwards compatibility with an old 144 * form of the command that is no longer recommended or 145 * documented. 146 */ 147 148 char *arg; 149 int length; 150 151 arg = TclGetStringFromObj(objv[3], &length); 152 if ((length != 9) 153 || (strncmp(arg, "nonewline", (size_t) length) != 0)) { 154 Tcl_AppendResult(interp, "bad argument \"", arg, 155 "\": should be \"nonewline\"", NULL); 156 return TCL_ERROR; 157 } 158 chanObjPtr = objv[1]; 159 string = objv[2]; 160 } 161 newline = 0; 162 break; 163 164 default: 165 /* [puts] or [puts some bad number of arguments...] */ 166 Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string"); 167 return TCL_ERROR; 168 } 169 170 if (chanObjPtr == NULL) { 171 tsdPtr = TCL_TSD_INIT(&dataKey); 172 173 if (!tsdPtr->initialized) { 174 tsdPtr->initialized = 1; 175 TclNewLiteralStringObj(tsdPtr->stdoutObjPtr, "stdout"); 176 Tcl_IncrRefCount(tsdPtr->stdoutObjPtr); 177 Tcl_CreateThreadExitHandler(FinalizeIOCmdTSD, NULL); 178 } 179 chanObjPtr = tsdPtr->stdoutObjPtr; 180 } 181 if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { 182 return TCL_ERROR; 183 } 184 if ((mode & TCL_WRITABLE) == 0) { 185 Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), 186 "\" wasn't opened for writing", NULL); 187 return TCL_ERROR; 188 } 189 190 result = Tcl_WriteObj(chan, string); 191 if (result < 0) { 192 goto error; 193 } 194 if (newline != 0) { 195 result = Tcl_WriteChars(chan, "\n", 1); 196 if (result < 0) { 197 goto error; 198 } 199 } 200 return TCL_OK; 201 202 /* 203 * TIP #219. 204 * Capture error messages put by the driver into the bypass area and put 205 * them into the regular interpreter result. Fall back to the regular 206 * message if nothing was found in the bypass. 207 */ 208 209 error: 210 if (!TclChanCaughtErrorBypass(interp, chan)) { 211 Tcl_AppendResult(interp, "error writing \"", 212 TclGetString(chanObjPtr), "\": ", 213 Tcl_PosixError(interp), NULL); 214 } 215 return TCL_ERROR; 216} 217 218/* 219 *---------------------------------------------------------------------- 220 * 221 * Tcl_FlushObjCmd -- 222 * 223 * This function is called to process the Tcl "flush" command. See the 224 * user documentation for details on what it does. 225 * 226 * Results: 227 * A standard Tcl result. 228 * 229 * Side effects: 230 * May cause output to appear on the specified channel. 231 * 232 *---------------------------------------------------------------------- 233 */ 234 235 /* ARGSUSED */ 236int 237Tcl_FlushObjCmd( 238 ClientData dummy, /* Not used. */ 239 Tcl_Interp *interp, /* Current interpreter. */ 240 int objc, /* Number of arguments. */ 241 Tcl_Obj *const objv[]) /* Argument objects. */ 242{ 243 Tcl_Obj *chanObjPtr; 244 Tcl_Channel chan; /* The channel to flush on. */ 245 int mode; 246 247 if (objc != 2) { 248 Tcl_WrongNumArgs(interp, 1, objv, "channelId"); 249 return TCL_ERROR; 250 } 251 chanObjPtr = objv[1]; 252 if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { 253 return TCL_ERROR; 254 } 255 if ((mode & TCL_WRITABLE) == 0) { 256 Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), 257 "\" wasn't opened for writing", NULL); 258 return TCL_ERROR; 259 } 260 261 if (Tcl_Flush(chan) != TCL_OK) { 262 /* 263 * TIP #219. 264 * Capture error messages put by the driver into the bypass area and 265 * put them into the regular interpreter result. Fall back to the 266 * regular message if nothing was found in the bypass. 267 */ 268 269 if (!TclChanCaughtErrorBypass(interp, chan)) { 270 Tcl_AppendResult(interp, "error flushing \"", 271 TclGetString(chanObjPtr), "\": ", 272 Tcl_PosixError(interp), NULL); 273 } 274 return TCL_ERROR; 275 } 276 return TCL_OK; 277} 278 279/* 280 *---------------------------------------------------------------------- 281 * 282 * Tcl_GetsObjCmd -- 283 * 284 * This function is called to process the Tcl "gets" command. See the 285 * user documentation for details on what it does. 286 * 287 * Results: 288 * A standard Tcl result. 289 * 290 * Side effects: 291 * May consume input from channel. 292 * 293 *---------------------------------------------------------------------- 294 */ 295 296 /* ARGSUSED */ 297int 298Tcl_GetsObjCmd( 299 ClientData dummy, /* Not used. */ 300 Tcl_Interp *interp, /* Current interpreter. */ 301 int objc, /* Number of arguments. */ 302 Tcl_Obj *const objv[]) /* Argument objects. */ 303{ 304 Tcl_Channel chan; /* The channel to read from. */ 305 int lineLen; /* Length of line just read. */ 306 int mode; /* Mode in which channel is opened. */ 307 Tcl_Obj *linePtr, *chanObjPtr; 308 309 if ((objc != 2) && (objc != 3)) { 310 Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?"); 311 return TCL_ERROR; 312 } 313 chanObjPtr = objv[1]; 314 if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { 315 return TCL_ERROR; 316 } 317 if ((mode & TCL_READABLE) == 0) { 318 Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), 319 "\" wasn't opened for reading", NULL); 320 return TCL_ERROR; 321 } 322 323 linePtr = Tcl_NewObj(); 324 lineLen = Tcl_GetsObj(chan, linePtr); 325 if (lineLen < 0) { 326 if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) { 327 Tcl_DecrRefCount(linePtr); 328 329 /* 330 * TIP #219. Capture error messages put by the driver into the 331 * bypass area and put them into the regular interpreter result. 332 * Fall back to the regular message if nothing was found in the 333 * bypass. 334 */ 335 336 if (!TclChanCaughtErrorBypass(interp, chan)) { 337 Tcl_ResetResult(interp); 338 Tcl_AppendResult(interp, "error reading \"", 339 TclGetString(chanObjPtr), "\": ", 340 Tcl_PosixError(interp), NULL); 341 } 342 return TCL_ERROR; 343 } 344 lineLen = -1; 345 } 346 if (objc == 3) { 347 if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr, 348 TCL_LEAVE_ERR_MSG) == NULL) { 349 return TCL_ERROR; 350 } 351 Tcl_SetObjResult(interp, Tcl_NewIntObj(lineLen)); 352 return TCL_OK; 353 } else { 354 Tcl_SetObjResult(interp, linePtr); 355 } 356 return TCL_OK; 357} 358 359/* 360 *---------------------------------------------------------------------- 361 * 362 * Tcl_ReadObjCmd -- 363 * 364 * This function is invoked to process the Tcl "read" command. See the 365 * user documentation for details on what it does. 366 * 367 * Results: 368 * A standard Tcl result. 369 * 370 * Side effects: 371 * May consume input from channel. 372 * 373 *---------------------------------------------------------------------- 374 */ 375 376 /* ARGSUSED */ 377int 378Tcl_ReadObjCmd( 379 ClientData dummy, /* Not used. */ 380 Tcl_Interp *interp, /* Current interpreter. */ 381 int objc, /* Number of arguments. */ 382 Tcl_Obj *const objv[]) /* Argument objects. */ 383{ 384 Tcl_Channel chan; /* The channel to read from. */ 385 int newline, i; /* Discard newline at end? */ 386 int toRead; /* How many bytes to read? */ 387 int charactersRead; /* How many characters were read? */ 388 int mode; /* Mode in which channel is opened. */ 389 Tcl_Obj *resultPtr, *chanObjPtr; 390 391 if ((objc != 2) && (objc != 3)) { 392 Interp *iPtr; 393 394 argerror: 395 iPtr = (Interp *) interp; 396 Tcl_WrongNumArgs(interp, 1, objv, "channelId ?numChars?"); 397 398 /* 399 * Do not append directly; that makes ensembles using this command as 400 * a subcommand produce the wrong message. 401 */ 402 403 iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS; 404 Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? channelId"); 405 iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS; 406 return TCL_ERROR; 407 } 408 409 i = 1; 410 newline = 0; 411 if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) { 412 newline = 1; 413 i++; 414 } 415 416 if (i == objc) { 417 goto argerror; 418 } 419 420 chanObjPtr = objv[i]; 421 if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { 422 return TCL_ERROR; 423 } 424 if ((mode & TCL_READABLE) == 0) { 425 Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), 426 "\" wasn't opened for reading", NULL); 427 return TCL_ERROR; 428 } 429 i++; /* Consumed channel name. */ 430 431 /* 432 * Compute how many bytes to read, and see whether the final newline 433 * should be dropped. 434 */ 435 436 toRead = -1; 437 if (i < objc) { 438 char *arg; 439 440 arg = TclGetString(objv[i]); 441 if (isdigit(UCHAR(arg[0]))) { /* INTL: digit */ 442 if (TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK) { 443 return TCL_ERROR; 444 } 445 } else if (strcmp(arg, "nonewline") == 0) { 446 newline = 1; 447 } else { 448 Tcl_AppendResult(interp, "bad argument \"", arg, 449 "\": should be \"nonewline\"", NULL); 450 return TCL_ERROR; 451 } 452 } 453 454 resultPtr = Tcl_NewObj(); 455 Tcl_IncrRefCount(resultPtr); 456 charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0); 457 if (charactersRead < 0) { 458 /* 459 * TIP #219. 460 * Capture error messages put by the driver into the bypass area and 461 * put them into the regular interpreter result. Fall back to the 462 * regular message if nothing was found in the bypass. 463 */ 464 465 if (!TclChanCaughtErrorBypass(interp, chan)) { 466 Tcl_ResetResult(interp); 467 Tcl_AppendResult(interp, "error reading \"", 468 TclGetString(chanObjPtr), "\": ", 469 Tcl_PosixError(interp), NULL); 470 } 471 Tcl_DecrRefCount(resultPtr); 472 return TCL_ERROR; 473 } 474 475 /* 476 * If requested, remove the last newline in the channel if at EOF. 477 */ 478 479 if ((charactersRead > 0) && (newline != 0)) { 480 char *result; 481 int length; 482 483 result = TclGetStringFromObj(resultPtr, &length); 484 if (result[length - 1] == '\n') { 485 Tcl_SetObjLength(resultPtr, length - 1); 486 } 487 } 488 Tcl_SetObjResult(interp, resultPtr); 489 Tcl_DecrRefCount(resultPtr); 490 return TCL_OK; 491} 492 493/* 494 *---------------------------------------------------------------------- 495 * 496 * Tcl_SeekObjCmd -- 497 * 498 * This function is invoked to process the Tcl "seek" command. See the 499 * user documentation for details on what it does. 500 * 501 * Results: 502 * A standard Tcl result. 503 * 504 * Side effects: 505 * Moves the position of the access point on the specified channel. May 506 * flush queued output. 507 * 508 *---------------------------------------------------------------------- 509 */ 510 511 /* ARGSUSED */ 512int 513Tcl_SeekObjCmd( 514 ClientData clientData, /* Not used. */ 515 Tcl_Interp *interp, /* Current interpreter. */ 516 int objc, /* Number of arguments. */ 517 Tcl_Obj *const objv[]) /* Argument objects. */ 518{ 519 Tcl_Channel chan; /* The channel to tell on. */ 520 Tcl_WideInt offset; /* Where to seek? */ 521 int mode; /* How to seek? */ 522 Tcl_WideInt result; /* Of calling Tcl_Seek. */ 523 int optionIndex; 524 static const char *originOptions[] = { 525 "start", "current", "end", NULL 526 }; 527 static int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END}; 528 529 if ((objc != 3) && (objc != 4)) { 530 Tcl_WrongNumArgs(interp, 1, objv, "channelId offset ?origin?"); 531 return TCL_ERROR; 532 } 533 if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { 534 return TCL_ERROR; 535 } 536 if (Tcl_GetWideIntFromObj(interp, objv[2], &offset) != TCL_OK) { 537 return TCL_ERROR; 538 } 539 mode = SEEK_SET; 540 if (objc == 4) { 541 if (Tcl_GetIndexFromObj(interp, objv[3], originOptions, "origin", 0, 542 &optionIndex) != TCL_OK) { 543 return TCL_ERROR; 544 } 545 mode = modeArray[optionIndex]; 546 } 547 548 result = Tcl_Seek(chan, offset, mode); 549 if (result == Tcl_LongAsWide(-1)) { 550 /* 551 * TIP #219. 552 * Capture error messages put by the driver into the bypass area and 553 * put them into the regular interpreter result. Fall back to the 554 * regular message if nothing was found in the bypass. 555 */ 556 if (!TclChanCaughtErrorBypass(interp, chan)) { 557 Tcl_AppendResult(interp, "error during seek on \"", 558 TclGetString(objv[1]), "\": ", 559 Tcl_PosixError(interp), NULL); 560 } 561 return TCL_ERROR; 562 } 563 return TCL_OK; 564} 565 566/* 567 *---------------------------------------------------------------------- 568 * 569 * Tcl_TellObjCmd -- 570 * 571 * This function is invoked to process the Tcl "tell" command. See the 572 * user documentation for details on what it does. 573 * 574 * Results: 575 * A standard Tcl result. 576 * 577 * Side effects: 578 * None. 579 * 580 *---------------------------------------------------------------------- 581 */ 582 583 /* ARGSUSED */ 584int 585Tcl_TellObjCmd( 586 ClientData clientData, /* Not used. */ 587 Tcl_Interp *interp, /* Current interpreter. */ 588 int objc, /* Number of arguments. */ 589 Tcl_Obj *const objv[]) /* Argument objects. */ 590{ 591 Tcl_Channel chan; /* The channel to tell on. */ 592 Tcl_WideInt newLoc; 593 594 if (objc != 2) { 595 Tcl_WrongNumArgs(interp, 1, objv, "channelId"); 596 return TCL_ERROR; 597 } 598 599 /* 600 * Try to find a channel with the right name and permissions in the IO 601 * channel table of this interpreter. 602 */ 603 604 if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { 605 return TCL_ERROR; 606 } 607 608 newLoc = Tcl_Tell(chan); 609 610 /* 611 * TIP #219. 612 * Capture error messages put by the driver into the bypass area and put 613 * them into the regular interpreter result. 614 */ 615 616 if (TclChanCaughtErrorBypass(interp, chan)) { 617 return TCL_ERROR; 618 } 619 620 Tcl_SetObjResult(interp, Tcl_NewWideIntObj(newLoc)); 621 return TCL_OK; 622} 623 624/* 625 *---------------------------------------------------------------------- 626 * 627 * Tcl_CloseObjCmd -- 628 * 629 * This function is invoked to process the Tcl "close" command. See the 630 * user documentation for details on what it does. 631 * 632 * Results: 633 * A standard Tcl result. 634 * 635 * Side effects: 636 * May discard queued input; may flush queued output. 637 * 638 *---------------------------------------------------------------------- 639 */ 640 641 /* ARGSUSED */ 642int 643Tcl_CloseObjCmd( 644 ClientData clientData, /* Not used. */ 645 Tcl_Interp *interp, /* Current interpreter. */ 646 int objc, /* Number of arguments. */ 647 Tcl_Obj *const objv[]) /* Argument objects. */ 648{ 649 Tcl_Channel chan; /* The channel to close. */ 650 651 if (objc != 2) { 652 Tcl_WrongNumArgs(interp, 1, objv, "channelId"); 653 return TCL_ERROR; 654 } 655 656 if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { 657 return TCL_ERROR; 658 } 659 660 if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) { 661 /* 662 * If there is an error message and it ends with a newline, remove the 663 * newline. This is done for command pipeline channels where the error 664 * output from the subprocesses is stored in interp's result. 665 * 666 * NOTE: This is likely to not have any effect on regular error 667 * messages produced by drivers during the closing of a channel, 668 * because the Tcl convention is that such error messages do not have 669 * a terminating newline. 670 */ 671 672 Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); 673 char *string; 674 int len; 675 676 if (Tcl_IsShared(resultPtr)) { 677 resultPtr = Tcl_DuplicateObj(resultPtr); 678 Tcl_SetObjResult(interp, resultPtr); 679 } 680 string = TclGetStringFromObj(resultPtr, &len); 681 if ((len > 0) && (string[len - 1] == '\n')) { 682 Tcl_SetObjLength(resultPtr, len - 1); 683 } 684 return TCL_ERROR; 685 } 686 687 return TCL_OK; 688} 689 690/* 691 *---------------------------------------------------------------------- 692 * 693 * Tcl_FconfigureObjCmd -- 694 * 695 * This function is invoked to process the Tcl "fconfigure" command. See 696 * the user documentation for details on what it does. 697 * 698 * Results: 699 * A standard Tcl result. 700 * 701 * Side effects: 702 * May modify the behavior of an IO channel. 703 * 704 *---------------------------------------------------------------------- 705 */ 706 707 /* ARGSUSED */ 708int 709Tcl_FconfigureObjCmd( 710 ClientData clientData, /* Not used. */ 711 Tcl_Interp *interp, /* Current interpreter. */ 712 int objc, /* Number of arguments. */ 713 Tcl_Obj *const objv[]) /* Argument objects. */ 714{ 715 char *optionName, *valueName; 716 Tcl_Channel chan; /* The channel to set a mode on. */ 717 int i; /* Iterate over arg-value pairs. */ 718 719 if ((objc < 2) || (((objc % 2) == 1) && (objc != 3))) { 720 Tcl_WrongNumArgs(interp, 1, objv, 721 "channelId ?optionName? ?value? ?optionName value?..."); 722 return TCL_ERROR; 723 } 724 725 if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { 726 return TCL_ERROR; 727 } 728 729 if (objc == 2) { 730 Tcl_DString ds; /* DString to hold result of calling 731 * Tcl_GetChannelOption. */ 732 733 Tcl_DStringInit(&ds); 734 if (Tcl_GetChannelOption(interp, chan, NULL, &ds) != TCL_OK) { 735 Tcl_DStringFree(&ds); 736 return TCL_ERROR; 737 } 738 Tcl_DStringResult(interp, &ds); 739 return TCL_OK; 740 } else if (objc == 3) { 741 Tcl_DString ds; /* DString to hold result of calling 742 * Tcl_GetChannelOption. */ 743 744 Tcl_DStringInit(&ds); 745 optionName = TclGetString(objv[2]); 746 if (Tcl_GetChannelOption(interp, chan, optionName, &ds) != TCL_OK) { 747 Tcl_DStringFree(&ds); 748 return TCL_ERROR; 749 } 750 Tcl_DStringResult(interp, &ds); 751 return TCL_OK; 752 } 753 754 for (i = 3; i < objc; i += 2) { 755 optionName = TclGetString(objv[i-1]); 756 valueName = TclGetString(objv[i]); 757 if (Tcl_SetChannelOption(interp, chan, optionName, valueName) 758 != TCL_OK) { 759 return TCL_ERROR; 760 } 761 } 762 763 return TCL_OK; 764} 765 766/* 767 *--------------------------------------------------------------------------- 768 * 769 * Tcl_EofObjCmd -- 770 * 771 * This function is invoked to process the Tcl "eof" command. See the 772 * user documentation for details on what it does. 773 * 774 * Results: 775 * A standard Tcl result. 776 * 777 * Side effects: 778 * Sets interp's result to boolean true or false depending on whether the 779 * specified channel has an EOF condition. 780 * 781 *--------------------------------------------------------------------------- 782 */ 783 784 /* ARGSUSED */ 785int 786Tcl_EofObjCmd( 787 ClientData unused, /* Not used. */ 788 Tcl_Interp *interp, /* Current interpreter. */ 789 int objc, /* Number of arguments. */ 790 Tcl_Obj *const objv[]) /* Argument objects. */ 791{ 792 Tcl_Channel chan; 793 794 if (objc != 2) { 795 Tcl_WrongNumArgs(interp, 1, objv, "channelId"); 796 return TCL_ERROR; 797 } 798 799 if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { 800 return TCL_ERROR; 801 } 802 803 Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_Eof(chan))); 804 return TCL_OK; 805} 806 807/* 808 *---------------------------------------------------------------------- 809 * 810 * Tcl_ExecObjCmd -- 811 * 812 * This function is invoked to process the "exec" Tcl command. See the 813 * user documentation for details on what it does. 814 * 815 * Results: 816 * A standard Tcl result. 817 * 818 * Side effects: 819 * See the user documentation. 820 * 821 *---------------------------------------------------------------------- 822 */ 823 824 /* ARGSUSED */ 825int 826Tcl_ExecObjCmd( 827 ClientData dummy, /* Not used. */ 828 Tcl_Interp *interp, /* Current interpreter. */ 829 int objc, /* Number of arguments. */ 830 Tcl_Obj *const objv[]) /* Argument objects. */ 831{ 832 /* 833 * This function generates an argv array for the string arguments. It 834 * starts out with stack-allocated space but uses dynamically-allocated 835 * storage if needed. 836 */ 837 838 Tcl_Obj *resultPtr; 839 const char **argv; 840 char *string; 841 Tcl_Channel chan; 842 int argc, background, i, index, keepNewline, result, skip, length; 843 int ignoreStderr; 844 static const char *options[] = { 845 "-ignorestderr", "-keepnewline", "--", NULL 846 }; 847 enum options { 848 EXEC_IGNORESTDERR, EXEC_KEEPNEWLINE, EXEC_LAST 849 }; 850 851 /* 852 * Check for any leading option arguments. 853 */ 854 855 keepNewline = 0; 856 ignoreStderr = 0; 857 for (skip = 1; skip < objc; skip++) { 858 string = TclGetString(objv[skip]); 859 if (string[0] != '-') { 860 break; 861 } 862 if (Tcl_GetIndexFromObj(interp, objv[skip], options, "switch", 863 TCL_EXACT, &index) != TCL_OK) { 864 return TCL_ERROR; 865 } 866 if (index == EXEC_KEEPNEWLINE) { 867 keepNewline = 1; 868 } else if (index == EXEC_IGNORESTDERR) { 869 ignoreStderr = 1; 870 } else { 871 skip++; 872 break; 873 } 874 } 875 if (objc <= skip) { 876 Tcl_WrongNumArgs(interp, 1, objv, "?switches? arg ?arg ...?"); 877 return TCL_ERROR; 878 } 879 880 /* 881 * See if the command is to be run in background. 882 */ 883 884 background = 0; 885 string = TclGetString(objv[objc - 1]); 886 if ((string[0] == '&') && (string[1] == '\0')) { 887 objc--; 888 background = 1; 889 } 890 891 /* 892 * Create the string argument array "argv". Make sure argv is large enough 893 * to hold the argc arguments plus 1 extra for the zero end-of-argv word. 894 */ 895 896 argc = objc - skip; 897 argv = (const char **) 898 TclStackAlloc(interp, (unsigned)(argc + 1) * sizeof(char *)); 899 900 /* 901 * Copy the string conversions of each (post option) object into the 902 * argument vector. 903 */ 904 905 for (i = 0; i < argc; i++) { 906 argv[i] = TclGetString(objv[i + skip]); 907 } 908 argv[argc] = NULL; 909 chan = Tcl_OpenCommandChannel(interp, argc, argv, (background ? 0 : 910 (ignoreStderr ? TCL_STDOUT : TCL_STDOUT|TCL_STDERR))); 911 912 /* 913 * Free the argv array. 914 */ 915 916 TclStackFree(interp, (void *)argv); 917 918 if (chan == NULL) { 919 return TCL_ERROR; 920 } 921 922 if (background) { 923 /* 924 * Store the list of PIDs from the pipeline in interp's result and 925 * detach the PIDs (instead of waiting for them). 926 */ 927 928 TclGetAndDetachPids(interp, chan); 929 if (Tcl_Close(interp, chan) != TCL_OK) { 930 return TCL_ERROR; 931 } 932 return TCL_OK; 933 } 934 935 resultPtr = Tcl_NewObj(); 936 if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) { 937 if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) { 938 /* 939 * TIP #219. 940 * Capture error messages put by the driver into the bypass area 941 * and put them into the regular interpreter result. Fall back to 942 * the regular message if nothing was found in the bypass. 943 */ 944 945 if (!TclChanCaughtErrorBypass(interp, chan)) { 946 Tcl_ResetResult(interp); 947 Tcl_AppendResult(interp, "error reading output from command: ", 948 Tcl_PosixError(interp), NULL); 949 Tcl_DecrRefCount(resultPtr); 950 } 951 return TCL_ERROR; 952 } 953 } 954 955 /* 956 * If the process produced anything on stderr, it will have been returned 957 * in the interpreter result. It needs to be appended to the result 958 * string. 959 */ 960 961 result = Tcl_Close(interp, chan); 962 Tcl_AppendObjToObj(resultPtr, Tcl_GetObjResult(interp)); 963 964 /* 965 * If the last character of the result is a newline, then remove the 966 * newline character. 967 */ 968 969 if (keepNewline == 0) { 970 string = TclGetStringFromObj(resultPtr, &length); 971 if ((length > 0) && (string[length - 1] == '\n')) { 972 Tcl_SetObjLength(resultPtr, length - 1); 973 } 974 } 975 Tcl_SetObjResult(interp, resultPtr); 976 977 return result; 978} 979 980/* 981 *--------------------------------------------------------------------------- 982 * 983 * Tcl_FblockedObjCmd -- 984 * 985 * This function is invoked to process the Tcl "fblocked" command. See 986 * the user documentation for details on what it does. 987 * 988 * Results: 989 * A standard Tcl result. 990 * 991 * Side effects: 992 * Sets interp's result to boolean true or false depending on whether the 993 * preceeding input operation on the channel would have blocked. 994 * 995 *--------------------------------------------------------------------------- 996 */ 997 998 /* ARGSUSED */ 999int 1000Tcl_FblockedObjCmd( 1001 ClientData unused, /* Not used. */ 1002 Tcl_Interp *interp, /* Current interpreter. */ 1003 int objc, /* Number of arguments. */ 1004 Tcl_Obj *const objv[]) /* Argument objects. */ 1005{ 1006 Tcl_Channel chan; 1007 int mode; 1008 1009 if (objc != 2) { 1010 Tcl_WrongNumArgs(interp, 1, objv, "channelId"); 1011 return TCL_ERROR; 1012 } 1013 1014 if (TclGetChannelFromObj(interp, objv[1], &chan, &mode, 0) != TCL_OK) { 1015 return TCL_ERROR; 1016 } 1017 if ((mode & TCL_READABLE) == 0) { 1018 Tcl_AppendResult(interp, "channel \"", TclGetString(objv[1]), 1019 "\" wasn't opened for reading", NULL); 1020 return TCL_ERROR; 1021 } 1022 1023 Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_InputBlocked(chan))); 1024 return TCL_OK; 1025} 1026 1027/* 1028 *---------------------------------------------------------------------- 1029 * 1030 * Tcl_OpenObjCmd -- 1031 * 1032 * This function is invoked to process the "open" Tcl command. See the 1033 * user documentation for details on what it does. 1034 * 1035 * Results: 1036 * A standard Tcl result. 1037 * 1038 * Side effects: 1039 * See the user documentation. 1040 * 1041 *---------------------------------------------------------------------- 1042 */ 1043 1044 /* ARGSUSED */ 1045int 1046Tcl_OpenObjCmd( 1047 ClientData notUsed, /* Not used. */ 1048 Tcl_Interp *interp, /* Current interpreter. */ 1049 int objc, /* Number of arguments. */ 1050 Tcl_Obj *const objv[]) /* Argument objects. */ 1051{ 1052 int pipeline, prot; 1053 const char *modeString, *what; 1054 Tcl_Channel chan; 1055 1056 if ((objc < 2) || (objc > 4)) { 1057 Tcl_WrongNumArgs(interp, 1, objv, "fileName ?access? ?permissions?"); 1058 return TCL_ERROR; 1059 } 1060 prot = 0666; 1061 if (objc == 2) { 1062 modeString = "r"; 1063 } else { 1064 modeString = TclGetString(objv[2]); 1065 if (objc == 4) { 1066 char *permString = TclGetString(objv[3]); 1067 int code = TCL_ERROR; 1068 int scanned = TclParseAllWhiteSpace(permString, -1); 1069 1070 /* Support legacy octal numbers */ 1071 if ((permString[scanned] == '0') 1072 && (permString[scanned+1] >= '0') 1073 && (permString[scanned+1] <= '7')) { 1074 1075 Tcl_Obj *permObj; 1076 1077 TclNewLiteralStringObj(permObj, "0o"); 1078 Tcl_AppendToObj(permObj, permString+scanned+1, -1); 1079 code = TclGetIntFromObj(NULL, permObj, &prot); 1080 Tcl_DecrRefCount(permObj); 1081 } 1082 1083 if ((code == TCL_ERROR) 1084 && TclGetIntFromObj(interp, objv[3], &prot) != TCL_OK) { 1085 return TCL_ERROR; 1086 } 1087 } 1088 } 1089 1090 pipeline = 0; 1091 what = TclGetString(objv[1]); 1092 if (what[0] == '|') { 1093 pipeline = 1; 1094 } 1095 1096 /* 1097 * Open the file or create a process pipeline. 1098 */ 1099 1100 if (!pipeline) { 1101 chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot); 1102 } else { 1103 int mode, seekFlag, cmdObjc, binary; 1104 const char **cmdArgv; 1105 1106 if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) { 1107 return TCL_ERROR; 1108 } 1109 1110 mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary); 1111 if (mode == -1) { 1112 chan = NULL; 1113 } else { 1114 int flags = TCL_STDERR | TCL_ENFORCE_MODE; 1115 1116 switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { 1117 case O_RDONLY: 1118 flags |= TCL_STDOUT; 1119 break; 1120 case O_WRONLY: 1121 flags |= TCL_STDIN; 1122 break; 1123 case O_RDWR: 1124 flags |= (TCL_STDIN | TCL_STDOUT); 1125 break; 1126 default: 1127 Tcl_Panic("Tcl_OpenCmd: invalid mode value"); 1128 break; 1129 } 1130 chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags); 1131 if (binary && chan) { 1132 Tcl_SetChannelOption(interp, chan, "-translation", "binary"); 1133 } 1134 } 1135 ckfree((char *) cmdArgv); 1136 } 1137 if (chan == NULL) { 1138 return TCL_ERROR; 1139 } 1140 Tcl_RegisterChannel(interp, chan); 1141 Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL); 1142 return TCL_OK; 1143} 1144 1145/* 1146 *---------------------------------------------------------------------- 1147 * 1148 * TcpAcceptCallbacksDeleteProc -- 1149 * 1150 * Assocdata cleanup routine called when an interpreter is being deleted 1151 * to set the interp field of all the accept callback records registered 1152 * with the interpreter to NULL. This will prevent the interpreter from 1153 * being used in the future to eval accept scripts. 1154 * 1155 * Results: 1156 * None. 1157 * 1158 * Side effects: 1159 * Deallocates memory and sets the interp field of all the accept 1160 * callback records to NULL to prevent this interpreter from being used 1161 * subsequently to eval accept scripts. 1162 * 1163 *---------------------------------------------------------------------- 1164 */ 1165 1166 /* ARGSUSED */ 1167static void 1168TcpAcceptCallbacksDeleteProc( 1169 ClientData clientData, /* Data which was passed when the assocdata 1170 * was registered. */ 1171 Tcl_Interp *interp) /* Interpreter being deleted - not used. */ 1172{ 1173 Tcl_HashTable *hTblPtr = clientData; 1174 Tcl_HashEntry *hPtr; 1175 Tcl_HashSearch hSearch; 1176 1177 for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); 1178 hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { 1179 AcceptCallback *acceptCallbackPtr = Tcl_GetHashValue(hPtr); 1180 1181 acceptCallbackPtr->interp = NULL; 1182 } 1183 Tcl_DeleteHashTable(hTblPtr); 1184 ckfree((char *) hTblPtr); 1185} 1186 1187/* 1188 *---------------------------------------------------------------------- 1189 * 1190 * RegisterTcpServerInterpCleanup -- 1191 * 1192 * Registers an accept callback record to have its interp field set to 1193 * NULL when the interpreter is deleted. 1194 * 1195 * Results: 1196 * None. 1197 * 1198 * Side effects: 1199 * When, in the future, the interpreter is deleted, the interp field of 1200 * the accept callback data structure will be set to NULL. This will 1201 * prevent attempts to eval the accept script in a deleted interpreter. 1202 * 1203 *---------------------------------------------------------------------- 1204 */ 1205 1206static void 1207RegisterTcpServerInterpCleanup( 1208 Tcl_Interp *interp, /* Interpreter for which we want to be 1209 * informed of deletion. */ 1210 AcceptCallback *acceptCallbackPtr) 1211 /* The accept callback record whose interp 1212 * field we want set to NULL when the 1213 * interpreter is deleted. */ 1214{ 1215 Tcl_HashTable *hTblPtr; /* Hash table for accept callback records to 1216 * smash when the interpreter will be 1217 * deleted. */ 1218 Tcl_HashEntry *hPtr; /* Entry for this record. */ 1219 int isNew; /* Is the entry new? */ 1220 1221 hTblPtr = (Tcl_HashTable *) 1222 Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL); 1223 1224 if (hTblPtr == NULL) { 1225 hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable)); 1226 Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS); 1227 (void) Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks", 1228 TcpAcceptCallbacksDeleteProc, hTblPtr); 1229 } 1230 1231 hPtr = Tcl_CreateHashEntry(hTblPtr, (char *) acceptCallbackPtr, &isNew); 1232 if (!isNew) { 1233 Tcl_Panic("RegisterTcpServerCleanup: damaged accept record table"); 1234 } 1235 Tcl_SetHashValue(hPtr, acceptCallbackPtr); 1236} 1237 1238/* 1239 *---------------------------------------------------------------------- 1240 * 1241 * UnregisterTcpServerInterpCleanupProc -- 1242 * 1243 * Unregister a previously registered accept callback record. The interp 1244 * field of this record will no longer be set to NULL in the future when 1245 * the interpreter is deleted. 1246 * 1247 * Results: 1248 * None. 1249 * 1250 * Side effects: 1251 * Prevents the interp field of the accept callback record from being set 1252 * to NULL in the future when the interpreter is deleted. 1253 * 1254 *---------------------------------------------------------------------- 1255 */ 1256 1257static void 1258UnregisterTcpServerInterpCleanupProc( 1259 Tcl_Interp *interp, /* Interpreter in which the accept callback 1260 * record was registered. */ 1261 AcceptCallback *acceptCallbackPtr) 1262 /* The record for which to delete the 1263 * registration. */ 1264{ 1265 Tcl_HashTable *hTblPtr; 1266 Tcl_HashEntry *hPtr; 1267 1268 hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, 1269 "tclTCPAcceptCallbacks", NULL); 1270 if (hTblPtr == NULL) { 1271 return; 1272 } 1273 1274 hPtr = Tcl_FindHashEntry(hTblPtr, (char *) acceptCallbackPtr); 1275 if (hPtr != NULL) { 1276 Tcl_DeleteHashEntry(hPtr); 1277 } 1278} 1279 1280/* 1281 *---------------------------------------------------------------------- 1282 * 1283 * AcceptCallbackProc -- 1284 * 1285 * This callback is invoked by the TCP channel driver when it accepts a 1286 * new connection from a client on a server socket. 1287 * 1288 * Results: 1289 * None. 1290 * 1291 * Side effects: 1292 * Whatever the script does. 1293 * 1294 *---------------------------------------------------------------------- 1295 */ 1296 1297static void 1298AcceptCallbackProc( 1299 ClientData callbackData, /* The data stored when the callback was 1300 * created in the call to 1301 * Tcl_OpenTcpServer. */ 1302 Tcl_Channel chan, /* Channel for the newly accepted 1303 * connection. */ 1304 char *address, /* Address of client that was accepted. */ 1305 int port) /* Port of client that was accepted. */ 1306{ 1307 AcceptCallback *acceptCallbackPtr = (AcceptCallback *) callbackData; 1308 1309 /* 1310 * Check if the callback is still valid; the interpreter may have gone 1311 * away, this is signalled by setting the interp field of the callback 1312 * data to NULL. 1313 */ 1314 1315 if (acceptCallbackPtr->interp != NULL) { 1316 char portBuf[TCL_INTEGER_SPACE]; 1317 char *script = acceptCallbackPtr->script; 1318 Tcl_Interp *interp = acceptCallbackPtr->interp; 1319 int result; 1320 1321 Tcl_Preserve(script); 1322 Tcl_Preserve(interp); 1323 1324 TclFormatInt(portBuf, port); 1325 Tcl_RegisterChannel(interp, chan); 1326 1327 /* 1328 * Artificially bump the refcount to protect the channel from being 1329 * deleted while the script is being evaluated. 1330 */ 1331 1332 Tcl_RegisterChannel(NULL, chan); 1333 1334 result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan), 1335 " ", address, " ", portBuf, NULL); 1336 if (result != TCL_OK) { 1337 TclBackgroundException(interp, result); 1338 Tcl_UnregisterChannel(interp, chan); 1339 } 1340 1341 /* 1342 * Decrement the artificially bumped refcount. After this it is not 1343 * safe anymore to use "chan", because it may now be deleted. 1344 */ 1345 1346 Tcl_UnregisterChannel(NULL, chan); 1347 1348 Tcl_Release(interp); 1349 Tcl_Release(script); 1350 } else { 1351 /* 1352 * The interpreter has been deleted, so there is no useful way to 1353 * utilize the client socket - just close it. 1354 */ 1355 1356 Tcl_Close(NULL, chan); 1357 } 1358} 1359 1360/* 1361 *---------------------------------------------------------------------- 1362 * 1363 * TcpServerCloseProc -- 1364 * 1365 * This callback is called when the TCP server channel for which it was 1366 * registered is being closed. It informs the interpreter in which the 1367 * accept script is evaluated (if that interpreter still exists) that 1368 * this channel no longer needs to be informed if the interpreter is 1369 * deleted. 1370 * 1371 * Results: 1372 * None. 1373 * 1374 * Side effects: 1375 * In the future, if the interpreter is deleted this channel will no 1376 * longer be informed. 1377 * 1378 *---------------------------------------------------------------------- 1379 */ 1380 1381static void 1382TcpServerCloseProc( 1383 ClientData callbackData) /* The data passed in the call to 1384 * Tcl_CreateCloseHandler. */ 1385{ 1386 AcceptCallback *acceptCallbackPtr = (AcceptCallback *) callbackData; 1387 /* The actual data. */ 1388 1389 if (acceptCallbackPtr->interp != NULL) { 1390 UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp, 1391 acceptCallbackPtr); 1392 } 1393 Tcl_EventuallyFree(acceptCallbackPtr->script, TCL_DYNAMIC); 1394 ckfree((char *) acceptCallbackPtr); 1395} 1396 1397/* 1398 *---------------------------------------------------------------------- 1399 * 1400 * Tcl_SocketObjCmd -- 1401 * 1402 * This function is invoked to process the "socket" Tcl command. See the 1403 * user documentation for details on what it does. 1404 * 1405 * Results: 1406 * A standard Tcl result. 1407 * 1408 * Side effects: 1409 * Creates a socket based channel. 1410 * 1411 *---------------------------------------------------------------------- 1412 */ 1413 1414int 1415Tcl_SocketObjCmd( 1416 ClientData notUsed, /* Not used. */ 1417 Tcl_Interp *interp, /* Current interpreter. */ 1418 int objc, /* Number of arguments. */ 1419 Tcl_Obj *const objv[]) /* Argument objects. */ 1420{ 1421 static const char *socketOptions[] = { 1422 "-async", "-myaddr", "-myport","-server", NULL 1423 }; 1424 enum socketOptions { 1425 SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER 1426 }; 1427 int optionIndex, a, server = 0, port, myport = 0, async = 0; 1428 char *host, *script = NULL, *myaddr = NULL; 1429 Tcl_Channel chan; 1430 1431 if (TclpHasSockets(interp) != TCL_OK) { 1432 return TCL_ERROR; 1433 } 1434 1435 for (a = 1; a < objc; a++) { 1436 const char *arg = Tcl_GetString(objv[a]); 1437 1438 if (arg[0] != '-') { 1439 break; 1440 } 1441 if (Tcl_GetIndexFromObj(interp, objv[a], socketOptions, "option", 1442 TCL_EXACT, &optionIndex) != TCL_OK) { 1443 return TCL_ERROR; 1444 } 1445 switch ((enum socketOptions) optionIndex) { 1446 case SKT_ASYNC: 1447 if (server == 1) { 1448 Tcl_AppendResult(interp, 1449 "cannot set -async option for server sockets", NULL); 1450 return TCL_ERROR; 1451 } 1452 async = 1; 1453 break; 1454 case SKT_MYADDR: 1455 a++; 1456 if (a >= objc) { 1457 Tcl_AppendResult(interp, 1458 "no argument given for -myaddr option", NULL); 1459 return TCL_ERROR; 1460 } 1461 myaddr = TclGetString(objv[a]); 1462 break; 1463 case SKT_MYPORT: { 1464 char *myPortName; 1465 1466 a++; 1467 if (a >= objc) { 1468 Tcl_AppendResult(interp, 1469 "no argument given for -myport option", NULL); 1470 return TCL_ERROR; 1471 } 1472 myPortName = TclGetString(objv[a]); 1473 if (TclSockGetPort(interp, myPortName, "tcp", &myport) != TCL_OK) { 1474 return TCL_ERROR; 1475 } 1476 break; 1477 } 1478 case SKT_SERVER: 1479 if (async == 1) { 1480 Tcl_AppendResult(interp, 1481 "cannot set -async option for server sockets", NULL); 1482 return TCL_ERROR; 1483 } 1484 server = 1; 1485 a++; 1486 if (a >= objc) { 1487 Tcl_AppendResult(interp, 1488 "no argument given for -server option", NULL); 1489 return TCL_ERROR; 1490 } 1491 script = TclGetString(objv[a]); 1492 break; 1493 default: 1494 Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); 1495 } 1496 } 1497 if (server) { 1498 host = myaddr; /* NULL implies INADDR_ANY */ 1499 if (myport != 0) { 1500 Tcl_AppendResult(interp, "option -myport is not valid for servers", 1501 NULL); 1502 return TCL_ERROR; 1503 } 1504 } else if (a < objc) { 1505 host = TclGetString(objv[a]); 1506 a++; 1507 } else { 1508 Interp *iPtr; 1509 1510 wrongNumArgs: 1511 iPtr = (Interp *) interp; 1512 Tcl_WrongNumArgs(interp, 1, objv, 1513 "?-myaddr addr? ?-myport myport? ?-async? host port"); 1514 iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS; 1515 Tcl_WrongNumArgs(interp, 1, objv, 1516 "-server command ?-myaddr addr? port"); 1517 iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS; 1518 return TCL_ERROR; 1519 } 1520 1521 if (a == objc-1) { 1522 if (TclSockGetPort(interp, TclGetString(objv[a]), "tcp", 1523 &port) != TCL_OK) { 1524 return TCL_ERROR; 1525 } 1526 } else { 1527 goto wrongNumArgs; 1528 } 1529 1530 if (server) { 1531 AcceptCallback *acceptCallbackPtr = (AcceptCallback *) 1532 ckalloc((unsigned) sizeof(AcceptCallback)); 1533 unsigned len = strlen(script) + 1; 1534 char *copyScript = ckalloc(len); 1535 1536 memcpy(copyScript, script, len); 1537 acceptCallbackPtr->script = copyScript; 1538 acceptCallbackPtr->interp = interp; 1539 chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc, 1540 acceptCallbackPtr); 1541 if (chan == NULL) { 1542 ckfree(copyScript); 1543 ckfree((char *) acceptCallbackPtr); 1544 return TCL_ERROR; 1545 } 1546 1547 /* 1548 * Register with the interpreter to let us know when the interpreter 1549 * is deleted (by having the callback set the interp field of the 1550 * acceptCallbackPtr's structure to NULL). This is to avoid trying to 1551 * eval the script in a deleted interpreter. 1552 */ 1553 1554 RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr); 1555 1556 /* 1557 * Register a close callback. This callback will inform the 1558 * interpreter (if it still exists) that this channel does not need to 1559 * be informed when the interpreter is deleted. 1560 */ 1561 1562 Tcl_CreateCloseHandler(chan, TcpServerCloseProc, acceptCallbackPtr); 1563 } else { 1564 chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async); 1565 if (chan == NULL) { 1566 return TCL_ERROR; 1567 } 1568 } 1569 Tcl_RegisterChannel(interp, chan); 1570 Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL); 1571 1572 return TCL_OK; 1573} 1574 1575/* 1576 *---------------------------------------------------------------------- 1577 * 1578 * Tcl_FcopyObjCmd -- 1579 * 1580 * This function is invoked to process the "fcopy" Tcl command. See the 1581 * user documentation for details on what it does. 1582 * 1583 * Results: 1584 * A standard Tcl result. 1585 * 1586 * Side effects: 1587 * Moves data between two channels and possibly sets up a background copy 1588 * handler. 1589 * 1590 *---------------------------------------------------------------------- 1591 */ 1592 1593int 1594Tcl_FcopyObjCmd( 1595 ClientData dummy, /* Not used. */ 1596 Tcl_Interp *interp, /* Current interpreter. */ 1597 int objc, /* Number of arguments. */ 1598 Tcl_Obj *const objv[]) /* Argument objects. */ 1599{ 1600 Tcl_Channel inChan, outChan; 1601 int mode, i, toRead, index; 1602 Tcl_Obj *cmdPtr; 1603 static const char* switches[] = { "-size", "-command", NULL }; 1604 enum { FcopySize, FcopyCommand }; 1605 1606 if ((objc < 3) || (objc > 7) || (objc == 4) || (objc == 6)) { 1607 Tcl_WrongNumArgs(interp, 1, objv, 1608 "input output ?-size size? ?-command callback?"); 1609 return TCL_ERROR; 1610 } 1611 1612 /* 1613 * Parse the channel arguments and verify that they are readable or 1614 * writable, as appropriate. 1615 */ 1616 1617 if (TclGetChannelFromObj(interp, objv[1], &inChan, &mode, 0) != TCL_OK) { 1618 return TCL_ERROR; 1619 } 1620 if ((mode & TCL_READABLE) == 0) { 1621 Tcl_AppendResult(interp, "channel \"", TclGetString(objv[1]), 1622 "\" wasn't opened for reading", NULL); 1623 return TCL_ERROR; 1624 } 1625 if (TclGetChannelFromObj(interp, objv[2], &outChan, &mode, 0) != TCL_OK) { 1626 return TCL_ERROR; 1627 } 1628 if ((mode & TCL_WRITABLE) == 0) { 1629 Tcl_AppendResult(interp, "channel \"", TclGetString(objv[2]), 1630 "\" wasn't opened for writing", NULL); 1631 return TCL_ERROR; 1632 } 1633 1634 toRead = -1; 1635 cmdPtr = NULL; 1636 for (i = 3; i < objc; i += 2) { 1637 if (Tcl_GetIndexFromObj(interp, objv[i], switches, "switch", 0, 1638 &index) != TCL_OK) { 1639 return TCL_ERROR; 1640 } 1641 switch (index) { 1642 case FcopySize: 1643 if (TclGetIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) { 1644 return TCL_ERROR; 1645 } 1646 if (toRead<0) { 1647 /* 1648 * Handle all negative sizes like -1, meaning 'copy all'. By 1649 * resetting toRead we avoid changes in the core copying 1650 * functions (which explicitly check for -1 and crash on any 1651 * other negative value). 1652 */ 1653 toRead = -1; 1654 } 1655 break; 1656 case FcopyCommand: 1657 cmdPtr = objv[i+1]; 1658 break; 1659 } 1660 } 1661 1662 return TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr); 1663} 1664 1665/* 1666 *--------------------------------------------------------------------------- 1667 * 1668 * ChanPendingObjCmd -- 1669 * 1670 * This function is invoked to process the Tcl "chan pending" command 1671 * (TIP #287). See the user documentation for details on what it does. 1672 * 1673 * Results: 1674 * A standard Tcl result. 1675 * 1676 * Side effects: 1677 * Sets interp's result to the number of bytes of buffered input or 1678 * output (depending on whether the first argument is "input" or 1679 * "output"), or -1 if the channel wasn't opened for that mode. 1680 * 1681 *--------------------------------------------------------------------------- 1682 */ 1683 1684 /* ARGSUSED */ 1685static int 1686ChanPendingObjCmd( 1687 ClientData unused, /* Not used. */ 1688 Tcl_Interp *interp, /* Current interpreter. */ 1689 int objc, /* Number of arguments. */ 1690 Tcl_Obj *const objv[]) /* Argument objects. */ 1691{ 1692 Tcl_Channel chan; 1693 int index, mode; 1694 static const char *options[] = {"input", "output", NULL}; 1695 enum options {PENDING_INPUT, PENDING_OUTPUT}; 1696 1697 if (objc != 3) { 1698 Tcl_WrongNumArgs(interp, 1, objv, "mode channelId"); 1699 return TCL_ERROR; 1700 } 1701 1702 if (Tcl_GetIndexFromObj(interp, objv[1], options, "mode", 0, 1703 &index) != TCL_OK) { 1704 return TCL_ERROR; 1705 } 1706 1707 if (TclGetChannelFromObj(interp, objv[2], &chan, &mode, 0) != TCL_OK) { 1708 return TCL_ERROR; 1709 } 1710 1711 switch ((enum options) index) { 1712 case PENDING_INPUT: 1713 if ((mode & TCL_READABLE) == 0) { 1714 Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); 1715 } else { 1716 Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_InputBuffered(chan))); 1717 } 1718 break; 1719 case PENDING_OUTPUT: 1720 if ((mode & TCL_WRITABLE) == 0) { 1721 Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); 1722 } else { 1723 Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_OutputBuffered(chan))); 1724 } 1725 break; 1726 } 1727 return TCL_OK; 1728} 1729 1730/* 1731 *---------------------------------------------------------------------- 1732 * 1733 * ChanTruncateObjCmd -- 1734 * 1735 * This function is invoked to process the "chan truncate" Tcl command. 1736 * See the user documentation for details on what it does. 1737 * 1738 * Results: 1739 * A standard Tcl result. 1740 * 1741 * Side effects: 1742 * Truncates a channel (or rather a file underlying a channel). 1743 * 1744 *---------------------------------------------------------------------- 1745 */ 1746 1747static int 1748ChanTruncateObjCmd( 1749 ClientData dummy, /* Not used. */ 1750 Tcl_Interp *interp, /* Current interpreter. */ 1751 int objc, /* Number of arguments. */ 1752 Tcl_Obj *const objv[]) /* Argument objects. */ 1753{ 1754 Tcl_Channel chan; 1755 Tcl_WideInt length; 1756 1757 if ((objc < 2) || (objc > 3)) { 1758 Tcl_WrongNumArgs(interp, 1, objv, "channelId ?length?"); 1759 return TCL_ERROR; 1760 } 1761 if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { 1762 return TCL_ERROR; 1763 } 1764 1765 if (objc == 3) { 1766 /* 1767 * User is supplying an explicit length. 1768 */ 1769 1770 if (Tcl_GetWideIntFromObj(interp, objv[2], &length) != TCL_OK) { 1771 return TCL_ERROR; 1772 } 1773 if (length < 0) { 1774 Tcl_AppendResult(interp, 1775 "cannot truncate to negative length of file", NULL); 1776 return TCL_ERROR; 1777 } 1778 } else { 1779 /* 1780 * User wants to truncate to the current file position. 1781 */ 1782 1783 length = Tcl_Tell(chan); 1784 if (length == Tcl_WideAsLong(-1)) { 1785 Tcl_AppendResult(interp, 1786 "could not determine current location in \"", 1787 TclGetString(objv[1]), "\": ", 1788 Tcl_PosixError(interp), NULL); 1789 return TCL_ERROR; 1790 } 1791 } 1792 1793 if (Tcl_TruncateChannel(chan, length) != TCL_OK) { 1794 Tcl_AppendResult(interp, "error during truncate on \"", 1795 TclGetString(objv[1]), "\": ", 1796 Tcl_PosixError(interp), NULL); 1797 return TCL_ERROR; 1798 } 1799 1800 return TCL_OK; 1801} 1802 1803/* 1804 *---------------------------------------------------------------------- 1805 * 1806 * TclInitChanCmd -- 1807 * 1808 * This function is invoked to create the "chan" Tcl command. See the 1809 * user documentation for details on what it does. 1810 * 1811 * Results: 1812 * A Tcl command handle. 1813 * 1814 * Side effects: 1815 * None (since nothing is byte-compiled). 1816 * 1817 *---------------------------------------------------------------------- 1818 */ 1819 1820Tcl_Command 1821TclInitChanCmd( 1822 Tcl_Interp *interp) 1823{ 1824 /* 1825 * Most commands are plugged directly together, but some are done via 1826 * alias-like rewriting; [chan configure] is this way for security reasons 1827 * (want overwriting of [fconfigure] to control that nicely), and [chan 1828 * names] because the functionality isn't available as a separate command 1829 * function at the moment. 1830 */ 1831 static const EnsembleImplMap initMap[] = { 1832 {"blocked", Tcl_FblockedObjCmd}, 1833 {"close", Tcl_CloseObjCmd}, 1834 {"copy", Tcl_FcopyObjCmd}, 1835 {"create", TclChanCreateObjCmd}, /* TIP #219 */ 1836 {"eof", Tcl_EofObjCmd}, 1837 {"event", Tcl_FileEventObjCmd}, 1838 {"flush", Tcl_FlushObjCmd}, 1839 {"gets", Tcl_GetsObjCmd}, 1840 {"pending", ChanPendingObjCmd}, /* TIP #287 */ 1841 {"postevent", TclChanPostEventObjCmd}, /* TIP #219 */ 1842 {"puts", Tcl_PutsObjCmd}, 1843 {"read", Tcl_ReadObjCmd}, 1844 {"seek", Tcl_SeekObjCmd}, 1845 {"tell", Tcl_TellObjCmd}, 1846 {"truncate", ChanTruncateObjCmd}, /* TIP #208 */ 1847 {NULL} 1848 }; 1849 static const char *extras[] = { 1850 "configure", "::fconfigure", 1851 "names", "::file channels", 1852 NULL 1853 }; 1854 Tcl_Command ensemble; 1855 Tcl_Obj *mapObj; 1856 int i; 1857 1858 ensemble = TclMakeEnsemble(interp, "chan", initMap); 1859 Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj); 1860 for (i=0 ; extras[i] ; i+=2) { 1861 /* 1862 * Can assume that reference counts are all incremented. 1863 */ 1864 1865 Tcl_DictObjPut(NULL, mapObj, Tcl_NewStringObj(extras[i], -1), 1866 Tcl_NewStringObj(extras[i+1], -1)); 1867 } 1868 Tcl_SetEnsembleMappingDict(interp, ensemble, mapObj); 1869 return ensemble; 1870} 1871 1872/* 1873 * Local Variables: 1874 * mode: c 1875 * c-basic-offset: 4 1876 * fill-column: 78 1877 * End: 1878 */ 1879