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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 25 - (show annotations) (download)
Sat Oct 8 06:43:03 2016 UTC (8 years, 2 months ago) by dashley
Original Path: sf_code/esrgpcpj/shared/tcl_base/tcliocmd.c
File MIME type: text/plain
File size: 45125 byte(s)
Initial commit.
1 /* $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