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