/[dtapublic]/projs/ets/trunk/src/c_tcl_base_7_5_w_mods/tcliocmd.c
ViewVC logotype

Diff of /projs/ets/trunk/src/c_tcl_base_7_5_w_mods/tcliocmd.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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