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

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

Parent Directory Parent Directory | Revision Log Revision Log


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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25