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

Diff of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tcliocmd.c

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

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

Legend:
Removed from v.64  
changed lines
  Added in v.71

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25