开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Windows编程 > 通讯编程 > 查看源码
tclIOCmd.c
资源名称：ns-allinone-2.33.tar.gz　[点击查看]
上传用户：rrhhcc
上传日期：2015-12-11
资源大小：54129k
文件大小：43k
源码类别：

通讯编程

开发平台：

Visual C++

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