Tcl Source Code

Check-in [52f2afaf4f]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:merge trunk
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | dgp-trunk-read
Files: files | file ages | folders
SHA1:52f2afaf4fabbabbf2cbea4230d261fefd3c24ae
User & Date: dgp 2014-05-01 15:00:40
Context
2014-05-02
15:58
merge trunk check-in: 8940c7f376 user: dgp tags: dgp-trunk-read
2014-05-01
15:00
merge trunk check-in: 52f2afaf4f user: dgp tags: dgp-trunk-read
14:36
We must Preserve channels if we're going to use TclChanCaughtErrorBypass() to get error information ... check-in: 4c9bb6c772 user: dgp tags: trunk
2014-04-24
18:21
merge trunk check-in: 63b6268aeb user: dgp tags: dgp-trunk-read
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to doc/fcopy.n.

42
43
44
45
46
47
48
49
50



51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
...
145
146
147
148
149
150
151


















152
153
154
155
error string associated with the error.
With a background copy,
it is not necessary to put \fIinchan\fR or \fIoutchan\fR into
non-blocking mode; the \fBfcopy\fR command takes care of that automatically.
However, it is necessary to enter the event loop by using
the \fBvwait\fR command or by using Tk.
.PP
You are not allowed to do other I/O operations with
\fIinchan\fR or \fIoutchan\fR during a background \fBfcopy\fR.



If either \fIinchan\fR or \fIoutchan\fR get closed
while the copy is in progress, the current copy is stopped
and the command callback is \fInot\fR made.
If \fIinchan\fR is closed,
then all data already queued for \fIoutchan\fR is written out.
.PP
Note that \fIinchan\fR can become readable during a background copy.
You should turn off any \fBfileevent\fR handlers during a background
copy so those handlers do not interfere with the copy.
Any I/O attempted by a \fBfileevent\fR handler will get a
.QW "channel busy"
error.
.PP
\fBFcopy\fR translates end-of-line sequences in \fIinchan\fR and \fIoutchan\fR
according to the \fB\-translation\fR option
for these channels.
See the manual entry for \fBfconfigure\fR for details on the
................................................................................
set out [socket $server $port]
set chunk 1024
set total 0
\fBfcopy\fR $in $out -size $chunk \e
        -command [list CopyMore $in $out $chunk]
vwait done
.CE


















.SH "SEE ALSO"
eof(n), fblocked(n), fconfigure(n), file(n)
.SH KEYWORDS
blocking, channel, end of line, end of file, nonblocking, read, translation







|
|
>
>
>









|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>




42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
...
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
error string associated with the error.
With a background copy,
it is not necessary to put \fIinchan\fR or \fIoutchan\fR into
non-blocking mode; the \fBfcopy\fR command takes care of that automatically.
However, it is necessary to enter the event loop by using
the \fBvwait\fR command or by using Tk.
.PP
You are not allowed to do other input operations with \fIinchan\fR, or
output operations with \fIoutchan\fR, during a background
\fBfcopy\fR. The converse is entirely legitimate, as exhibited by the
bidirectional fcopy example below.
.PP
If either \fIinchan\fR or \fIoutchan\fR get closed
while the copy is in progress, the current copy is stopped
and the command callback is \fInot\fR made.
If \fIinchan\fR is closed,
then all data already queued for \fIoutchan\fR is written out.
.PP
Note that \fIinchan\fR can become readable during a background copy.
You should turn off any \fBfileevent\fR handlers during a background
copy so those handlers do not interfere with the copy.
Any wrong-sided I/O attempted (by a \fBfileevent\fR handler or otherwise) will get a
.QW "channel busy"
error.
.PP
\fBFcopy\fR translates end-of-line sequences in \fIinchan\fR and \fIoutchan\fR
according to the \fB\-translation\fR option
for these channels.
See the manual entry for \fBfconfigure\fR for details on the
................................................................................
set out [socket $server $port]
set chunk 1024
set total 0
\fBfcopy\fR $in $out -size $chunk \e
        -command [list CopyMore $in $out $chunk]
vwait done
.CE
.PP
The fourth example starts an asynchronous, bidirectional fcopy between
two sockets. Those could also be pipes from two [open "|hal 9000" r+]
(though their conversation would remain secret to the script, since
all four fileevent slots are busy).
.PP
.CS
set flows 2
proc Done {dir args} {
     global flows done
     puts "$dir is over."
     incr flows -1
     if {$flows<=0} {set done 1}
}
\fBfcopy\fR $sok1 $sok2 -command [list Done UP]
\fBfcopy\fR $sok2 $sok1 -command [list Done DOWN]
vwait done
.CE
.SH "SEE ALSO"
eof(n), fblocked(n), fconfigure(n), file(n)
.SH KEYWORDS
blocking, channel, end of line, end of file, nonblocking, read, translation

Changes to generic/tclExecute.c.

5698
5699
5700
5701
5702
5703
5704
5705







5706
5707
5708
5709




5710
5711
5712
5713
5714
5715
5716
	} else if (Tcl_IsShared(value3Ptr)) {
	    objResultPtr = Tcl_DuplicateObj(value3Ptr);
	    if (toIdx < length) {
		Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1,
			length - toIdx);
	    }
	} else {
	    objResultPtr = value3Ptr;







	    if (toIdx < length) {
		Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1,
			length - toIdx);
	    }




	}
	TclDecrRefCount(value3Ptr);
	TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
	NEXT_INST_F(1, 1, 1);

    case INST_STR_MAP:
	valuePtr = OBJ_AT_TOS;		/* "Main" string. */







<
>
>
>
>
>
>
>

|


>
>
>
>







5698
5699
5700
5701
5702
5703
5704

5705
5706
5707
5708
5709
5710
5711
5712
5713
5714
5715
5716
5717
5718
5719
5720
5721
5722
5723
5724
5725
5726
	} else if (Tcl_IsShared(value3Ptr)) {
	    objResultPtr = Tcl_DuplicateObj(value3Ptr);
	    if (toIdx < length) {
		Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1,
			length - toIdx);
	    }
	} else {

	    /*
	     * Be careful with splicing the stack in this case; we have a
	     * refCount:1 object in value3Ptr and we want to append to it and
	     * make it be the refCount:1 object at the top of the stack
	     * afterwards. [Bug 82e7f67325]
	     */

	    if (toIdx < length) {
		Tcl_AppendUnicodeToObj(value3Ptr, ustring1 + toIdx + 1,
			length - toIdx);
	    }
	    TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr)));
	    TclDecrRefCount(valuePtr);
	    OBJ_AT_TOS = value3Ptr;	/* Tricky! */
	    NEXT_INST_F(1, 0, 0);
	}
	TclDecrRefCount(value3Ptr);
	TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
	NEXT_INST_F(1, 1, 1);

    case INST_STR_MAP:
	valuePtr = OBJ_AT_TOS;		/* "Main" string. */

Changes to generic/tclIO.c.

162
163
164
165
166
167
168

169
170
171
172
173
174
175
....
2308
2309
2310
2311
2312
2313
2314







2315
2316
2317
2318
2319
2320
2321
....
2338
2339
2340
2341
2342
2343
2344



2345
2346
2347
2348
2349
2350
2351
....
3200
3201
3202
3203
3204
3205
3206
3207

3208
3209
3210
3211
3212
3213
3214
....
4570
4571
4572
4573
4574
4575
4576
4577
4578

4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
....
4716
4717
4718
4719
4720
4721
4722



4723
4724
4725
4726
4727
4728
4729
....
4828
4829
4830
4831
4832
4833
4834
4835
4836

4837
4838
4839
4840
4841
4842
4843
4844
4845
4846
4847
....
4988
4989
4990
4991
4992
4993
4994





4995
4996
4997
4998
4999
5000
5001
....
7659
7660
7661
7662
7663
7664
7665
7666

7667
7668
7669
7670
7671
7672
7673
/*
 * Static functions in this file:
 */

static ChannelBuffer *	AllocChannelBuffer(int length);
static void		PreserveChannelBuffer(ChannelBuffer *bufPtr);
static void		ReleaseChannelBuffer(ChannelBuffer *bufPtr);

static void		ChannelTimerProc(ClientData clientData);
static int		CheckChannelErrors(ChannelState *statePtr,
			    int direction);
static int		CheckForDeadChannel(Tcl_Interp *interp,
			    ChannelState *statePtr);
static void		CheckForStdChannelsBeingClosed(Tcl_Channel chan);
static void		CleanupChannelHandlers(Tcl_Interp *interp,
................................................................................
    ChannelBuffer *bufPtr)
{
    if (--bufPtr->refCount) {
	return;
    }
    ckfree(bufPtr);
}







 
/*
 *----------------------------------------------------------------------
 *
 * RecycleBuffer --
 *
 *	Helper function to recycle input and output buffers. Ensures that two
................................................................................
    ChannelBuffer *bufPtr,	/* The buffer to recycle. */
    int mustDiscard)		/* If nonzero, free the buffer to the OS,
				 * always. */
{
    /*
     * Do we have to free the buffer to the OS?
     */




    if (mustDiscard) {
	ReleaseChannelBuffer(bufPtr);
	return;
    }

    /*
................................................................................
    /*
     * When the channel has an escape sequence driven encoding such as
     * iso2022, the terminated escape sequence must write to the buffer.
     */

    stickyError = 0;

    if ((statePtr->encoding != NULL) && (statePtr->curOutPtr != NULL)

	    && (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) {
	statePtr->outputEncodingFlags |= TCL_ENCODING_END;
	if (WriteChars(chanPtr, "", 0) < 0) {
	    stickyError = Tcl_GetErrno();
	}

	/*
................................................................................
     * Regenerate the top channel, in case it was changed due to
     * self-modifying reflected transforms.
     */
    /*
    chanPtr = statePtr->topChanPtr;
     */
    bufPtr = statePtr->inQueueHead;
    if (bufPtr == NULL) {
	Tcl_Panic("Tcl_GetsObj: restore reached with bufPtr==NULL");

    }
    bufPtr->nextRemoved = oldRemoved;

    for (bufPtr = bufPtr->nextPtr; bufPtr != NULL; bufPtr = bufPtr->nextPtr) {
	bufPtr->nextRemoved = BUFFER_PADDING;
    }
    CommonGetsCleanup(chanPtr);

    statePtr->inputEncodingState = oldState;
    statePtr->inputEncodingFlags = oldFlags;
    Tcl_SetObjLength(objPtr, oldLength);
................................................................................
		}
		ResetFlag(statePtr, CHANNEL_BLOCKED);
	    }
	    if (GetInput(chanPtr) != 0) {
		goto restore;
	    }
	    bufPtr = statePtr->inQueueTail;



	}

	dst = (unsigned char *) RemovePoint(bufPtr);
	dstEnd = dst + BytesLeft(bufPtr);

	/*
	 * Remember if EOF char is seen, then look for EOL anyhow, because the
................................................................................
     * Couldn't get a complete line. This only happens if we get a error
     * reading from the channel or we are non-blocking and there wasn't an EOL
     * or EOF in the data available.
     */

  restore:
    bufPtr = statePtr->inQueueHead;
    if (bufPtr == NULL) {
	Tcl_Panic("TclGetsObjBinary: restore reached with bufPtr==NULL");

    }
    bufPtr->nextRemoved = oldRemoved;

    for (bufPtr = bufPtr->nextPtr; bufPtr != NULL; bufPtr = bufPtr->nextPtr) {
	bufPtr->nextRemoved = BUFFER_PADDING;
    }
    CommonGetsCleanup(chanPtr);

    statePtr->inputEncodingFlags = oldFlags;
    byteArray = Tcl_SetByteArrayLength(objPtr, oldLength);

................................................................................
	if (GetInput(chanPtr) != 0) {
	    gsPtr->charsWrote = 0;
	    gsPtr->rawRead = 0;
	    return -1;
	}
	bufPtr = statePtr->inQueueTail;
	gsPtr->bufPtr = bufPtr;





    }

    /*
     * Convert some of the bytes from the channel buffer to UTF-8. Space in
     * objPtr's string rep is used to hold the UTF-8 characters. Grow the
     * string rep if we need more space.
     */
................................................................................
	}

	/*
	 * When the channel has an escape sequence driven encoding such as
	 * iso2022, the terminated escape sequence must write to the buffer.
	 */

	if ((statePtr->encoding != NULL) && (statePtr->curOutPtr != NULL)

		&& (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) {
	    statePtr->outputEncodingFlags |= TCL_ENCODING_END;
	    WriteChars(chanPtr, "", 0);
	}
	Tcl_FreeEncoding(statePtr->encoding);
	statePtr->encoding = encoding;
	statePtr->inputEncodingState = NULL;







>







 







>
>
>
>
>
>
>







 







>
>
>







 







|
>







 







|
|
>

<

|







 







>
>
>







 







|
|
>

<

|







 







>
>
>
>
>







 







|
>







162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
....
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
....
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
....
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
....
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592

4593
4594
4595
4596
4597
4598
4599
4600
4601
....
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
4740
4741
4742
4743
4744
....
4843
4844
4845
4846
4847
4848
4849
4850
4851
4852
4853

4854
4855
4856
4857
4858
4859
4860
4861
4862
....
5003
5004
5005
5006
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
....
7679
7680
7681
7682
7683
7684
7685
7686
7687
7688
7689
7690
7691
7692
7693
7694
/*
 * Static functions in this file:
 */

static ChannelBuffer *	AllocChannelBuffer(int length);
static void		PreserveChannelBuffer(ChannelBuffer *bufPtr);
static void		ReleaseChannelBuffer(ChannelBuffer *bufPtr);
static int		IsShared(ChannelBuffer *bufPtr);
static void		ChannelTimerProc(ClientData clientData);
static int		CheckChannelErrors(ChannelState *statePtr,
			    int direction);
static int		CheckForDeadChannel(Tcl_Interp *interp,
			    ChannelState *statePtr);
static void		CheckForStdChannelsBeingClosed(Tcl_Channel chan);
static void		CleanupChannelHandlers(Tcl_Interp *interp,
................................................................................
    ChannelBuffer *bufPtr)
{
    if (--bufPtr->refCount) {
	return;
    }
    ckfree(bufPtr);
}

static int
IsShared(
    ChannelBuffer *bufPtr)
{
    return bufPtr->refCount > 1;
}
 
/*
 *----------------------------------------------------------------------
 *
 * RecycleBuffer --
 *
 *	Helper function to recycle input and output buffers. Ensures that two
................................................................................
    ChannelBuffer *bufPtr,	/* The buffer to recycle. */
    int mustDiscard)		/* If nonzero, free the buffer to the OS,
				 * always. */
{
    /*
     * Do we have to free the buffer to the OS?
     */
    if (IsShared(bufPtr)) {
	mustDiscard = 1;
    }

    if (mustDiscard) {
	ReleaseChannelBuffer(bufPtr);
	return;
    }

    /*
................................................................................
    /*
     * When the channel has an escape sequence driven encoding such as
     * iso2022, the terminated escape sequence must write to the buffer.
     */

    stickyError = 0;

    if ((statePtr->encoding != NULL)
	    && !(statePtr->outputEncodingFlags & TCL_ENCODING_START)
	    && (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) {
	statePtr->outputEncodingFlags |= TCL_ENCODING_END;
	if (WriteChars(chanPtr, "", 0) < 0) {
	    stickyError = Tcl_GetErrno();
	}

	/*
................................................................................
     * Regenerate the top channel, in case it was changed due to
     * self-modifying reflected transforms.
     */
    /*
    chanPtr = statePtr->topChanPtr;
     */
    bufPtr = statePtr->inQueueHead;
    if (bufPtr != NULL) {
	bufPtr->nextRemoved = oldRemoved;
	bufPtr = bufPtr->nextPtr;
    }


    for ( ; bufPtr != NULL; bufPtr = bufPtr->nextPtr) {
	bufPtr->nextRemoved = BUFFER_PADDING;
    }
    CommonGetsCleanup(chanPtr);

    statePtr->inputEncodingState = oldState;
    statePtr->inputEncodingFlags = oldFlags;
    Tcl_SetObjLength(objPtr, oldLength);
................................................................................
		}
		ResetFlag(statePtr, CHANNEL_BLOCKED);
	    }
	    if (GetInput(chanPtr) != 0) {
		goto restore;
	    }
	    bufPtr = statePtr->inQueueTail;
	    if (bufPtr == NULL) {
		goto restore;
	    }
	}

	dst = (unsigned char *) RemovePoint(bufPtr);
	dstEnd = dst + BytesLeft(bufPtr);

	/*
	 * Remember if EOF char is seen, then look for EOL anyhow, because the
................................................................................
     * Couldn't get a complete line. This only happens if we get a error
     * reading from the channel or we are non-blocking and there wasn't an EOL
     * or EOF in the data available.
     */

  restore:
    bufPtr = statePtr->inQueueHead;
    if (bufPtr) {
	bufPtr->nextRemoved = oldRemoved;
	bufPtr = bufPtr->nextPtr;
    }


    for ( ; bufPtr != NULL; bufPtr = bufPtr->nextPtr) {
	bufPtr->nextRemoved = BUFFER_PADDING;
    }
    CommonGetsCleanup(chanPtr);

    statePtr->inputEncodingFlags = oldFlags;
    byteArray = Tcl_SetByteArrayLength(objPtr, oldLength);

................................................................................
	if (GetInput(chanPtr) != 0) {
	    gsPtr->charsWrote = 0;
	    gsPtr->rawRead = 0;
	    return -1;
	}
	bufPtr = statePtr->inQueueTail;
	gsPtr->bufPtr = bufPtr;
	if (bufPtr == NULL) {
	    gsPtr->charsWrote = 0;
	    gsPtr->rawRead = 0;
	    return -1;
	}
    }

    /*
     * Convert some of the bytes from the channel buffer to UTF-8. Space in
     * objPtr's string rep is used to hold the UTF-8 characters. Grow the
     * string rep if we need more space.
     */
................................................................................
	}

	/*
	 * When the channel has an escape sequence driven encoding such as
	 * iso2022, the terminated escape sequence must write to the buffer.
	 */

	if ((statePtr->encoding != NULL)
		&& !(statePtr->outputEncodingFlags & TCL_ENCODING_START)
		&& (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) {
	    statePtr->outputEncodingFlags |= TCL_ENCODING_END;
	    WriteChars(chanPtr, "", 0);
	}
	Tcl_FreeEncoding(statePtr->encoding);
	statePtr->encoding = encoding;
	statePtr->inputEncodingState = NULL;

Changes to generic/tclIOCmd.c.

177
178
179
180
181
182
183

184
185
186
187
188
189
190
191
192
193

194
195
196
197
198
199
200
...
201
202
203
204
205
206
207

208
209
210
211
212
213
214
...
248
249
250
251
252
253
254

255
256
257
258
259
260
261
262
263
264
265
266
267

268
269

270
271
272
273
274
275
276
...
295
296
297
298
299
300
301

302
303
304
305
306
307
308
...
311
312
313
314
315
316
317

318
319
320
321
322
323
324
...
329
330
331
332
333
334
335
336

337
338
339
340
341
342
343
344
345
346
347
348


349
350
351
352
353
354
355
356
...
543
544
545
546
547
548
549

550
551
552
553
554
555
556
...
557
558
559
560
561
562
563

564
565

566
567
568
569
570
571
572
...
589
590
591
592
593
594
595

596
597
598
599
600
601
602
...
604
605
606
607
608
609
610

611
612
613
614
615
616
617
618

619


620
621
622
623
624
625
626
    if (!(mode & TCL_WRITABLE)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"channel \"%s\" wasn't opened for writing",
		TclGetString(chanObjPtr)));
	return TCL_ERROR;
    }


    result = Tcl_WriteObj(chan, string);
    if (result < 0) {
	goto error;
    }
    if (newline != 0) {
	result = Tcl_WriteChars(chan, "\n", 1);
	if (result < 0) {
	    goto error;
	}
    }

    return TCL_OK;

    /*
     * TIP #219.
     * Capture error messages put by the driver into the bypass area and put
     * them into the regular interpreter result. Fall back to the regular
     * message if nothing was found in the bypass.
................................................................................
     */

  error:
    if (!TclChanCaughtErrorBypass(interp, chan)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf("error writing \"%s\": %s",
		TclGetString(chanObjPtr), Tcl_PosixError(interp)));
    }

    return TCL_ERROR;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_FlushObjCmd --
................................................................................
    if (!(mode & TCL_WRITABLE)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"channel \"%s\" wasn't opened for writing",
		TclGetString(chanObjPtr)));
	return TCL_ERROR;
    }


    if (Tcl_Flush(chan) != TCL_OK) {
	/*
	 * TIP #219.
	 * Capture error messages put by the driver into the bypass area and
	 * put them into the regular interpreter result. Fall back to the
	 * regular message if nothing was found in the bypass.
	 */

	if (!TclChanCaughtErrorBypass(interp, chan)) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "error flushing \"%s\": %s",
		    TclGetString(chanObjPtr), Tcl_PosixError(interp)));
	}

	return TCL_ERROR;
    }

    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetsObjCmd --
................................................................................
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Channel chan;		/* The channel to read from. */
    int lineLen;		/* Length of line just read. */
    int mode;			/* Mode in which channel is opened. */
    Tcl_Obj *linePtr, *chanObjPtr;


    if ((objc != 2) && (objc != 3)) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?");
	return TCL_ERROR;
    }
    chanObjPtr = objv[1];
    if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) {
................................................................................
    if (!(mode & TCL_READABLE)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"channel \"%s\" wasn't opened for reading",
		TclGetString(chanObjPtr)));
	return TCL_ERROR;
    }


    linePtr = Tcl_NewObj();
    lineLen = Tcl_GetsObj(chan, linePtr);
    if (lineLen < 0) {
	if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) {
	    Tcl_DecrRefCount(linePtr);

	    /*
................................................................................
	     */

	    if (!TclChanCaughtErrorBypass(interp, chan)) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"error reading \"%s\": %s",
			TclGetString(chanObjPtr), Tcl_PosixError(interp)));
	    }
	    return TCL_ERROR;

	}
	lineLen = -1;
    }
    if (objc == 3) {
	if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr,
		TCL_LEAVE_ERR_MSG) == NULL) {
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, Tcl_NewIntObj(lineLen));
    } else {
	Tcl_SetObjResult(interp, linePtr);
    }


    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_ReadObjCmd --
 *
................................................................................
	if (Tcl_GetIndexFromObj(interp, objv[3], originOptions, "origin", 0,
		&optionIndex) != TCL_OK) {
	    return TCL_ERROR;
	}
	mode = modeArray[optionIndex];
    }


    result = Tcl_Seek(chan, offset, mode);
    if (result == Tcl_LongAsWide(-1)) {
	/*
	 * TIP #219.
	 * Capture error messages put by the driver into the bypass area and
	 * put them into the regular interpreter result. Fall back to the
	 * regular message if nothing was found in the bypass.
................................................................................
	 */

	if (!TclChanCaughtErrorBypass(interp, chan)) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "error during seek on \"%s\": %s",
		    TclGetString(objv[1]), Tcl_PosixError(interp)));
	}

	return TCL_ERROR;
    }

    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_TellObjCmd --
................................................................................
    ClientData clientData,	/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Channel chan;		/* The channel to tell on. */
    Tcl_WideInt newLoc;


    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId");
	return TCL_ERROR;
    }

    /*
................................................................................
     * channel table of this interpreter.
     */

    if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) {
	return TCL_ERROR;
    }


    newLoc = Tcl_Tell(chan);

    /*
     * TIP #219.
     * Capture error messages put by the driver into the bypass area and put
     * them into the regular interpreter result.
     */


    if (TclChanCaughtErrorBypass(interp, chan)) {


	return TCL_ERROR;
    }

    Tcl_SetObjResult(interp, Tcl_NewWideIntObj(newLoc));
    return TCL_OK;
}
 







>










>







 







>







 







>













>


>







 







>







 







>







 







|
>












>
>
|







 







>







 







>


>







 







>







 







>








>
|
>
>







177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
...
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
...
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
...
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
...
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
...
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
...
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
...
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
...
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
...
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
    if (!(mode & TCL_WRITABLE)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"channel \"%s\" wasn't opened for writing",
		TclGetString(chanObjPtr)));
	return TCL_ERROR;
    }

    Tcl_Preserve(chan);
    result = Tcl_WriteObj(chan, string);
    if (result < 0) {
	goto error;
    }
    if (newline != 0) {
	result = Tcl_WriteChars(chan, "\n", 1);
	if (result < 0) {
	    goto error;
	}
    }
    Tcl_Release(chan);
    return TCL_OK;

    /*
     * TIP #219.
     * Capture error messages put by the driver into the bypass area and put
     * them into the regular interpreter result. Fall back to the regular
     * message if nothing was found in the bypass.
................................................................................
     */

  error:
    if (!TclChanCaughtErrorBypass(interp, chan)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf("error writing \"%s\": %s",
		TclGetString(chanObjPtr), Tcl_PosixError(interp)));
    }
    Tcl_Release(chan);
    return TCL_ERROR;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_FlushObjCmd --
................................................................................
    if (!(mode & TCL_WRITABLE)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"channel \"%s\" wasn't opened for writing",
		TclGetString(chanObjPtr)));
	return TCL_ERROR;
    }

    Tcl_Preserve(chan);
    if (Tcl_Flush(chan) != TCL_OK) {
	/*
	 * TIP #219.
	 * Capture error messages put by the driver into the bypass area and
	 * put them into the regular interpreter result. Fall back to the
	 * regular message if nothing was found in the bypass.
	 */

	if (!TclChanCaughtErrorBypass(interp, chan)) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "error flushing \"%s\": %s",
		    TclGetString(chanObjPtr), Tcl_PosixError(interp)));
	}
	Tcl_Release(chan);
	return TCL_ERROR;
    }
    Tcl_Release(chan);
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetsObjCmd --
................................................................................
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Channel chan;		/* The channel to read from. */
    int lineLen;		/* Length of line just read. */
    int mode;			/* Mode in which channel is opened. */
    Tcl_Obj *linePtr, *chanObjPtr;
    int code = TCL_OK;

    if ((objc != 2) && (objc != 3)) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?");
	return TCL_ERROR;
    }
    chanObjPtr = objv[1];
    if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) {
................................................................................
    if (!(mode & TCL_READABLE)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"channel \"%s\" wasn't opened for reading",
		TclGetString(chanObjPtr)));
	return TCL_ERROR;
    }

    Tcl_Preserve(chan);
    linePtr = Tcl_NewObj();
    lineLen = Tcl_GetsObj(chan, linePtr);
    if (lineLen < 0) {
	if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) {
	    Tcl_DecrRefCount(linePtr);

	    /*
................................................................................
	     */

	    if (!TclChanCaughtErrorBypass(interp, chan)) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"error reading \"%s\": %s",
			TclGetString(chanObjPtr), Tcl_PosixError(interp)));
	    }
	    code = TCL_ERROR;
	    goto done;
	}
	lineLen = -1;
    }
    if (objc == 3) {
	if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr,
		TCL_LEAVE_ERR_MSG) == NULL) {
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, Tcl_NewIntObj(lineLen));
    } else {
	Tcl_SetObjResult(interp, linePtr);
    }
  done:
    Tcl_Release(chan);
    return code;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_ReadObjCmd --
 *
................................................................................
	if (Tcl_GetIndexFromObj(interp, objv[3], originOptions, "origin", 0,
		&optionIndex) != TCL_OK) {
	    return TCL_ERROR;
	}
	mode = modeArray[optionIndex];
    }

    Tcl_Preserve(chan);
    result = Tcl_Seek(chan, offset, mode);
    if (result == Tcl_LongAsWide(-1)) {
	/*
	 * TIP #219.
	 * Capture error messages put by the driver into the bypass area and
	 * put them into the regular interpreter result. Fall back to the
	 * regular message if nothing was found in the bypass.
................................................................................
	 */

	if (!TclChanCaughtErrorBypass(interp, chan)) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "error during seek on \"%s\": %s",
		    TclGetString(objv[1]), Tcl_PosixError(interp)));
	}
	Tcl_Release(chan);
	return TCL_ERROR;
    }
    Tcl_Release(chan);
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_TellObjCmd --
................................................................................
    ClientData clientData,	/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Channel chan;		/* The channel to tell on. */
    Tcl_WideInt newLoc;
    int code;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId");
	return TCL_ERROR;
    }

    /*
................................................................................
     * channel table of this interpreter.
     */

    if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) {
	return TCL_ERROR;
    }

    Tcl_Preserve(chan);
    newLoc = Tcl_Tell(chan);

    /*
     * TIP #219.
     * Capture error messages put by the driver into the bypass area and put
     * them into the regular interpreter result.
     */


    code  = TclChanCaughtErrorBypass(interp, chan);
    Tcl_Release(chan);
    if (code) {
	return TCL_ERROR;
    }

    Tcl_SetObjResult(interp, Tcl_NewWideIntObj(newLoc));
    return TCL_OK;
}
 

Changes to tests/ioCmd.test.

840
841
842
843
844
845
846

































847
848
849
850
851
852
853
    set ch [chan create read foo]
} -body {
    read $ch 1
} -returnCodes error -cleanup {
    catch {close $ch}
    rename foo {}
} -match glob -result {*invalid argument*}


































# --- --- --- --------- --------- ---------
# Helper commands to record the arguments to handler methods.

# Stored in a script so that the threads and interpreters needing this
# code do not need their own copy but can access this variable.








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
    set ch [chan create read foo]
} -body {
    read $ch 1
} -returnCodes error -cleanup {
    catch {close $ch}
    rename foo {}
} -match glob -result {*invalid argument*}
test iocmd-21.23 {[close] in [gets] segfaults} -setup {
    proc foo {method chan args} {
	switch -- $method initialize {
	    return {initialize finalize watch read}
	} finalize {} watch {} read {
	    catch {close $chan}
	    return \n
	}
    }
    set ch [chan create read foo]
} -body {
    gets $ch
} -cleanup {
    catch {close $ch}
    rename foo {}
} -result {}
test iocmd-21.24 {[close] in binary [gets] segfaults} -setup {
    proc foo {method chan args} {
	switch -- $method initialize {
	    return {initialize finalize watch read}
	} finalize {} watch {} read {
	    catch {close $chan}
	    return \n
	}
    }
    set ch [chan create read foo]
} -body {
    chan configure $ch -translation binary
    gets $ch
} -cleanup {
    catch {close $ch}
    rename foo {}
} -result {}

# --- --- --- --------- --------- ---------
# Helper commands to record the arguments to handler methods.

# Stored in a script so that the threads and interpreters needing this
# code do not need their own copy but can access this variable.

Changes to tests/stringComp.test.

22
23
24
25
26
27
28
















29
30
31
32
33
34
35
...
683
684
685
686
687
688
689
690
















691
692
693
694
695
696
697

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

# Some tests require the testobj command

testConstraint testobj [expr {[info commands testobj] != {}}]
















 
test stringComp-1.1 {error conditions} {
    proc foo {} {string gorp a b}
    list [catch {foo} msg] $msg
} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test stringComp-1.2 {error conditions} {
    proc foo {} {string}
................................................................................
    }} 12345
} {}

## string repeat
## not yet bc

## string replace
## not yet bc

















## string tolower
## not yet bc

## string toupper
## not yet bc








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
...
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

# Some tests require the testobj command

testConstraint testobj [expr {[info commands testobj] != {}}]
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
    proc getbytes {} {
	set lines [split [memory info] \n]
	return [lindex $lines 3 3]
    }
    proc leaktest {script {iterations 3}} {
	set end [getbytes]
	for {set i 0} {$i < $iterations} {incr i} {
	    uplevel 1 $script
	    set tmp $end
	    set end [getbytes]
	}
	return [expr {$end - $tmp}]
    }
}
 
test stringComp-1.1 {error conditions} {
    proc foo {} {string gorp a b}
    list [catch {foo} msg] $msg
} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test stringComp-1.2 {error conditions} {
    proc foo {} {string}
................................................................................
    }} 12345
} {}

## string repeat
## not yet bc

## string replace
test stringComp-14.1 {Bug 82e7f67325} {
    apply {x {
	set a [join $x {}]
	lappend b [string length [string replace ___! 0 2 $a]]
	lappend b [string length [string replace ___! 0 2 $a[unset a]]]
    }} {a b}
} {3 3}
test stringComp-14.2 {Bug 82e7f67325} memory {
    # As in stringComp-14.1, but make sure we don't retain too many refs
    leaktest {
	apply {x {
	    set a [join $x {}]
	    lappend b [string length [string replace ___! 0 2 $a]]
	    lappend b [string length [string replace ___! 0 2 $a[unset a]]]
	}} {a b}
    }
} {0}

## string tolower
## not yet bc

## string toupper
## not yet bc