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

Properties

Name Value
svn:eol-style native
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25