OpenCores
URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tcl/] [generic/] [tclIOCmd.c] - Blame information for rev 1765

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.