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

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25