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