Tcl Source Code

Changes On Branch tip-220
Login
Bounty program for improvements to Tcl and certain Tcl packages.

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

Changes In Branch tip-220 Excluding Merge-Ins

This is equivalent to a diff from d19ee61498 to 3c1f042d02

2022-09-26
07:34
TIP #220: Escalate Privileges in VFS Close Callback check-in: 2af94cda95 user: jan.nijtmans tags: core-8-branch
2022-09-08
16:44
Merge http-bugfixes-2022H2 - workaround for bug [824251] (async client sockets block for DNS). check-in: 608f2fbab4 user: kjnash tags: core-8-branch
14:56
Merge 8.7 Closed-Leaf check-in: 3c1f042d02 user: jan.nijtmans tags: tip-220
14:56
Merge 8.7 check-in: 194684822d user: kjnash tags: http-bugfixes-2022H2
14:54
Merge 8.7 check-in: 5ed7ab6b87 user: jan.nijtmans tags: tip-618
14:53
Mrge 8.7. Make it work with C++, adapt win/Makefile.in to make it build on Windows with gcc check-in: d2353bc1fb user: jan.nijtmans tags: abstractlist-with-625
14:20
Merge 8.7 Closed-Leaf check-in: 49fe365e3e user: jan.nijtmans tags: rfe-655300
14:19
Merge 8.7 check-in: 04e160b7a7 user: jan.nijtmans tags: tip-629
14:18
Merge 8.7 check-in: 2d527d2c3e user: jan.nijtmans tags: tip-344
14:16
Merge 8.7 Closed-Leaf check-in: 450cb4123c user: jan.nijtmans tags: tip-594
14:14
Merge 8.7 check-in: eabc05de29 user: jan.nijtmans tags: trunk, main
14:06
Combine flags and testFlags in TcpState. That should unbreak socket testcase failure check-in: d19ee61498 user: jan.nijtmans tags: core-8-branch
2022-09-07
11:45
Revive TIP #220 implementation: Escalate Privileges in VFS Close Callback check-in: afc95211b0 user: jan.nijtmans tags: tip-220
07:42
Merge 8.6 check-in: cecb37eb5e user: jan.nijtmans tags: core-8-branch

Changes to doc/CrtChannel.3.

31
32
33
34
35
36
37





38
39
40
41
42
43
44
.sp
Tcl_ThreadId
\fBTcl_GetChannelThread\fR(\fIchannel\fR)
.sp
int
\fBTcl_GetChannelMode\fR(\fIchannel\fR)
.sp





int
\fBTcl_GetChannelBufferSize\fR(\fIchannel\fR)
.sp
\fBTcl_SetChannelBufferSize\fR(\fIchannel, size\fR)
.sp
\fBTcl_NotifyChannel\fR(\fIchannel, mask\fR)
.sp






>
>
>
>
>







31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
.sp
Tcl_ThreadId
\fBTcl_GetChannelThread\fR(\fIchannel\fR)
.sp
int
\fBTcl_GetChannelMode\fR(\fIchannel\fR)
.sp
.VS 8.7
int
\fBTcl_RemoveChannelMode\fR(\fIinterp, channel, mode\fR)
.VE 8.7
.sp
int
\fBTcl_GetChannelBufferSize\fR(\fIchannel\fR)
.sp
\fBTcl_SetChannelBufferSize\fR(\fIchannel, size\fR)
.sp
\fBTcl_NotifyChannel\fR(\fIchannel, mask\fR)
.sp
238
239
240
241
242
243
244










245
246
247
248
249
250
251
\fBTcl_GetChannelThread\fR returns the id of the thread currently managing
the specified \fIchannel\fR. This allows channel drivers to send their file
events to the correct event queue even for a multi-threaded core.
.PP
\fBTcl_GetChannelMode\fR returns an OR-ed combination of \fBTCL_READABLE\fR
and \fBTCL_WRITABLE\fR, indicating whether the channel is open for input
and output.










.PP
\fBTcl_GetChannelBufferSize\fR returns the size, in bytes, of buffers
allocated to store input or output in \fIchannel\fR. If the value was not set
by a previous call to \fBTcl_SetChannelBufferSize\fR, described below, then
the default value of 4096 is returned.
.PP
\fBTcl_SetChannelBufferSize\fR sets the size, in bytes, of buffers that






>
>
>
>
>
>
>
>
>
>







243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
\fBTcl_GetChannelThread\fR returns the id of the thread currently managing
the specified \fIchannel\fR. This allows channel drivers to send their file
events to the correct event queue even for a multi-threaded core.
.PP
\fBTcl_GetChannelMode\fR returns an OR-ed combination of \fBTCL_READABLE\fR
and \fBTCL_WRITABLE\fR, indicating whether the channel is open for input
and output.
.PP
.VS 8.7
.PP
\fBTcl_RemoveChannelMode\fR removes an access privilege from the
channel, either \fBTCL_READABLE\fR or \fBTCL_WRITABLE\fR, and returns
a regular Tcl result code, \fBTCL_OK\fR, or \fBTCL_ERROR\fR. The
function throws an error if either an invalid mode is specified or the
result of the removal would be an inaccessible channel. In that case
an error message is left in the interp argument, if not NULL.
.VE 8.7
.PP
\fBTcl_GetChannelBufferSize\fR returns the size, in bytes, of buffers
allocated to store input or output in \fIchannel\fR. If the value was not set
by a previous call to \fBTcl_SetChannelBufferSize\fR, described below, then
the default value of 4096 is returned.
.PP
\fBTcl_SetChannelBufferSize\fR sets the size, in bytes, of buffers that

Changes to generic/tcl.decls.

2519
2520
2521
2522
2523
2524
2525





2526
2527
2528
2529
2530
2531
2532
	    Tcl_ObjCmdProc2 *nreProc2, void *clientData,
	    Tcl_CmdDeleteProc *deleteProc)
}
declare 679 {
    int Tcl_NRCallObjProc2(Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2,
	    void *clientData, size_t objc, Tcl_Obj *const objv[])
}






# ----- BASELINE -- FOR -- 8.7.0 ----- #

##############################################################################

# Define the platform specific public Tcl interface. These functions are only
# available on the designated platform.






>
>
>
>
>







2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
	    Tcl_ObjCmdProc2 *nreProc2, void *clientData,
	    Tcl_CmdDeleteProc *deleteProc)
}
declare 679 {
    int Tcl_NRCallObjProc2(Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2,
	    void *clientData, size_t objc, Tcl_Obj *const objv[])
}

# TIP #220.
declare 680 {
    int Tcl_RemoveChannelMode(Tcl_Interp *interp, Tcl_Channel chan, int mode)
}

# ----- BASELINE -- FOR -- 8.7.0 ----- #

##############################################################################

# Define the platform specific public Tcl interface. These functions are only
# available on the designated platform.

Changes to generic/tclDecls.h.

1992
1993
1994
1995
1996
1997
1998



1999
2000
2001
2002
2003
2004
2005
				const char *cmdName, Tcl_ObjCmdProc2 *proc,
				Tcl_ObjCmdProc2 *nreProc2, void *clientData,
				Tcl_CmdDeleteProc *deleteProc);
/* 679 */
EXTERN int		Tcl_NRCallObjProc2(Tcl_Interp *interp,
				Tcl_ObjCmdProc2 *objProc2, void *clientData,
				size_t objc, Tcl_Obj *const objv[]);




typedef struct {
    const struct TclPlatStubs *tclPlatStubs;
    const struct TclIntStubs *tclIntStubs;
    const struct TclIntPlatStubs *tclIntPlatStubs;
} TclStubHooks;







>
>
>







1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
				const char *cmdName, Tcl_ObjCmdProc2 *proc,
				Tcl_ObjCmdProc2 *nreProc2, void *clientData,
				Tcl_CmdDeleteProc *deleteProc);
/* 679 */
EXTERN int		Tcl_NRCallObjProc2(Tcl_Interp *interp,
				Tcl_ObjCmdProc2 *objProc2, void *clientData,
				size_t objc, Tcl_Obj *const objv[]);
/* 680 */
EXTERN int		Tcl_RemoveChannelMode(Tcl_Interp *interp,
				Tcl_Channel chan, int mode);

typedef struct {
    const struct TclPlatStubs *tclPlatStubs;
    const struct TclIntStubs *tclIntStubs;
    const struct TclIntPlatStubs *tclIntPlatStubs;
} TclStubHooks;

2707
2708
2709
2710
2711
2712
2713

2714
2715
2716
2717
2718
2719
2720
    int (*tclGetUniChar) (Tcl_Obj *objPtr, int index); /* 673 */
    void (*reserved674)(void);
    void (*reserved675)(void);
    Tcl_Command (*tcl_CreateObjCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 676 */
    Tcl_Trace (*tcl_CreateObjTrace2) (Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 677 */
    Tcl_Command (*tcl_NRCreateCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc, Tcl_ObjCmdProc2 *nreProc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 678 */
    int (*tcl_NRCallObjProc2) (Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2, void *clientData, size_t objc, Tcl_Obj *const objv[]); /* 679 */

} TclStubs;

extern const TclStubs *tclStubsPtr;

#ifdef __cplusplus
}
#endif






>







2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
    int (*tclGetUniChar) (Tcl_Obj *objPtr, int index); /* 673 */
    void (*reserved674)(void);
    void (*reserved675)(void);
    Tcl_Command (*tcl_CreateObjCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 676 */
    Tcl_Trace (*tcl_CreateObjTrace2) (Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 677 */
    Tcl_Command (*tcl_NRCreateCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc, Tcl_ObjCmdProc2 *nreProc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 678 */
    int (*tcl_NRCallObjProc2) (Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2, void *clientData, size_t objc, Tcl_Obj *const objv[]); /* 679 */
    int (*tcl_RemoveChannelMode) (Tcl_Interp *interp, Tcl_Channel chan, int mode); /* 680 */
} TclStubs;

extern const TclStubs *tclStubsPtr;

#ifdef __cplusplus
}
#endif
4095
4096
4097
4098
4099
4100
4101


4102
4103
4104
4105
4106
4107
4108
	(tclStubsPtr->tcl_CreateObjCommand2) /* 676 */
#define Tcl_CreateObjTrace2 \
	(tclStubsPtr->tcl_CreateObjTrace2) /* 677 */
#define Tcl_NRCreateCommand2 \
	(tclStubsPtr->tcl_NRCreateCommand2) /* 678 */
#define Tcl_NRCallObjProc2 \
	(tclStubsPtr->tcl_NRCallObjProc2) /* 679 */



#endif /* defined(USE_TCL_STUBS) */

/* !END!: Do not edit above this line. */

#undef TclUnusedStubEntry
#if defined(USE_TCL_STUBS)






>
>







4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
	(tclStubsPtr->tcl_CreateObjCommand2) /* 676 */
#define Tcl_CreateObjTrace2 \
	(tclStubsPtr->tcl_CreateObjTrace2) /* 677 */
#define Tcl_NRCreateCommand2 \
	(tclStubsPtr->tcl_NRCreateCommand2) /* 678 */
#define Tcl_NRCallObjProc2 \
	(tclStubsPtr->tcl_NRCallObjProc2) /* 679 */
#define Tcl_RemoveChannelMode \
	(tclStubsPtr->tcl_RemoveChannelMode) /* 680 */

#endif /* defined(USE_TCL_STUBS) */

/* !END!: Do not edit above this line. */

#undef TclUnusedStubEntry
#if defined(USE_TCL_STUBS)

Changes to generic/tclIO.c.

1677
1678
1679
1680
1681
1682
1683

1684
1685
1686
1687
1688
1689
1690
	strcpy(tmp, chanName);
    } else {
	tmp = (char *)ckalloc(7);
	tmp[0] = '\0';
    }
    statePtr->channelName = tmp;
    statePtr->flags = mask;


    /*
     * Set the channel to system default encoding.
     *
     * Note the strange bit of protection taking place here. If the system
     * encoding name is reported back as "binary", something weird is
     * happening. Tcl provides no "binary" encoding, so someone else has






>







1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
	strcpy(tmp, chanName);
    } else {
	tmp = (char *)ckalloc(7);
	tmp[0] = '\0';
    }
    statePtr->channelName = tmp;
    statePtr->flags = mask;
    statePtr->maxPerms = mask; /* Save max privileges for close callback */

    /*
     * Set the channel to system default encoding.
     *
     * Note the strange bit of protection taking place here. If the system
     * encoding name is reported back as "binary", something weird is
     * happening. Tcl provides no "binary" encoding, so someone else has
2162
2163
2164
2165
2166
2167
2168

2169
2170


2171
2172
2173
2174
2175
2176
2177
	/*
	 * Leave this link intact for closeproc
	 *  chanPtr->downChanPtr = NULL;
	 */

	/*
	 * Close and free the channel driver state.

	 */



	result = ChanClose(chanPtr, interp);
	ChannelFree(chanPtr);

	UpdateInterest(statePtr->topChanPtr);

	if (result != 0) {
	    Tcl_SetErrno(result);






>


>
>







2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
	/*
	 * Leave this link intact for closeproc
	 *  chanPtr->downChanPtr = NULL;
	 */

	/*
	 * Close and free the channel driver state.
	 * TIP #220: This is done with maximum privileges (as created).
	 */

	statePtr->flags &= ~(TCL_READABLE|TCL_WRITABLE);
	statePtr->flags |= statePtr->maxPerms;
	result = ChanClose(chanPtr, interp);
	ChannelFree(chanPtr);

	UpdateInterest(statePtr->topChanPtr);

	if (result != 0) {
	    Tcl_SetErrno(result);
2441
2442
2443
2444
2445
2446
2447
















































2448
2449
2450
2451
2452
2453
2454
    result = chanPtr->typePtr->getHandleProc(chanPtr->instanceData, direction,
	    &handle);
    if (handlePtr) {
	*handlePtr = handle;
    }
    return result;
}

















































/*
 *---------------------------------------------------------------------------
 *
 * AllocChannelBuffer --
 *
 *	A channel buffer has BUFFER_PADDING bytes extra at beginning to hold






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







2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
    result = chanPtr->typePtr->getHandleProc(chanPtr->instanceData, direction,
	    &handle);
    if (handlePtr) {
	*handlePtr = handle;
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RemoveChannelMode --
 *
 *	Remove either read or write privileges from the channel.
 *
 * Results:
 *	A standard Tcl result code.
 *
 * Side effects:
 *	May change the access mode of the channel.
 *	May leave an error message in the interp.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_RemoveChannelMode(
     Tcl_Interp* interp,        /* The interp for an error message. Allowed to be NULL. */
     Tcl_Channel chan,		/* The channel which is modified. */
     int         mode)          /* The access mode to drop from the channel */
{
    const char* emsg;
    ChannelState *statePtr = ((Channel *) chan)->state;
					/* State of actual channel. */

    if ((mode != TCL_READABLE) && (mode != TCL_WRITABLE)) {
        emsg = "Illegal mode value.";
	goto error;
    }
    if (0 == (statePtr->flags & (TCL_READABLE | TCL_WRITABLE) & ~mode)) {
        emsg = "Bad mode, would make channel inacessible";
	goto error;
    }

    statePtr->flags &= ~mode;
    return TCL_OK;

 error:
    if (interp != NULL) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"Tcl_RemoveChannelMode error: %s. Channel: \"%s\"",
		emsg, Tcl_GetChannelName((Tcl_Channel) chan)));
    }
    return TCL_ERROR;
}

/*
 *---------------------------------------------------------------------------
 *
 * AllocChannelBuffer --
 *
 *	A channel buffer has BUFFER_PADDING bytes extra at beginning to hold

Changes to generic/tclIO.h.

212
213
214
215
216
217
218


219
220
221
222
223
224
225
    Tcl_Obj* chanMsg;
    Tcl_Obj* unreportedMsg;     /* Non-NULL if an error report was deferred
				 * because it happened in the background. The
				 * value is the chanMg, if any. #219's
				 * companion to 'unreportedError'. */
    size_t epoch;		/* Used to test validity of stored channelname
				 * lookup results. */


} ChannelState;

/*
 * Values for the flags field in Channel. Any ORed combination of the
 * following flags can be stored in the field. These flags record various
 * options and state bits about the channel. In addition to the flags below,
 * the channel can also have TCL_READABLE (1<<1) and TCL_WRITABLE (1<<2) set.






>
>







212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
    Tcl_Obj* chanMsg;
    Tcl_Obj* unreportedMsg;     /* Non-NULL if an error report was deferred
				 * because it happened in the background. The
				 * value is the chanMg, if any. #219's
				 * companion to 'unreportedError'. */
    size_t epoch;		/* Used to test validity of stored channelname
				 * lookup results. */
    int maxPerms;		/* TIP #220: Max access privileges
				 * the channel was created with. */
} ChannelState;

/*
 * Values for the flags field in Channel. Any ORed combination of the
 * following flags can be stored in the field. These flags record various
 * options and state bits about the channel. In addition to the flags below,
 * the channel can also have TCL_READABLE (1<<1) and TCL_WRITABLE (1<<2) set.

Changes to generic/tclStubInit.c.

2038
2039
2040
2041
2042
2043
2044

2045
2046
2047
    TclGetUniChar, /* 673 */
    0, /* 674 */
    0, /* 675 */
    Tcl_CreateObjCommand2, /* 676 */
    Tcl_CreateObjTrace2, /* 677 */
    Tcl_NRCreateCommand2, /* 678 */
    Tcl_NRCallObjProc2, /* 679 */

};

/* !END!: Do not edit above this line. */






>



2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
    TclGetUniChar, /* 673 */
    0, /* 674 */
    0, /* 675 */
    Tcl_CreateObjCommand2, /* 676 */
    Tcl_CreateObjTrace2, /* 677 */
    Tcl_NRCreateCommand2, /* 678 */
    Tcl_NRCallObjProc2, /* 679 */
    Tcl_RemoveChannelMode, /* 680 */
};

/* !END!: Do not edit above this line. */

Changes to generic/tclTest.c.

6036
6037
6038
6039
6040
6041
6042







































6043
6044
6045
6046
6047
6048
6049
	if (statePtr->flags & TCL_WRITABLE) {
	    Tcl_AppendElement(interp, "write");
	} else {
	    Tcl_AppendElement(interp, "");
	}
	return TCL_OK;
    }








































    if ((cmdName[0] == 'm') && (strncmp(cmdName, "mthread", len) == 0)) {
	if (argc != 3) {
	    Tcl_AppendResult(interp, "channel name required", NULL);
	    return TCL_ERROR;
	}







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







6036
6037
6038
6039
6040
6041
6042
6043
6044
6045
6046
6047
6048
6049
6050
6051
6052
6053
6054
6055
6056
6057
6058
6059
6060
6061
6062
6063
6064
6065
6066
6067
6068
6069
6070
6071
6072
6073
6074
6075
6076
6077
6078
6079
6080
6081
6082
6083
6084
6085
6086
6087
6088
	if (statePtr->flags & TCL_WRITABLE) {
	    Tcl_AppendElement(interp, "write");
	} else {
	    Tcl_AppendElement(interp, "");
	}
	return TCL_OK;
    }

    if ((cmdName[0] == 'm') && (strncmp(cmdName, "maxmode", len) == 0)) {
	if (argc != 3) {
	    Tcl_AppendResult(interp, "channel name required", NULL);
	    return TCL_ERROR;
	}

	if (statePtr->maxPerms & TCL_READABLE) {
	    Tcl_AppendElement(interp, "read");
	} else {
	    Tcl_AppendElement(interp, "");
	}
	if (statePtr->maxPerms & TCL_WRITABLE) {
	    Tcl_AppendElement(interp, "write");
	} else {
	    Tcl_AppendElement(interp, "");
	}
	return TCL_OK;
    }

    if ((cmdName[0] == 'm') && (strncmp(cmdName, "mremove-rd", len) == 0)) {
        if (argc != 3) {
            Tcl_AppendResult(interp, "channel name required",
                    (char *) NULL);
            return TCL_ERROR;
        }

	return Tcl_RemoveChannelMode(interp, chan, TCL_READABLE);
    }

    if ((cmdName[0] == 'm') && (strncmp(cmdName, "mremove-wr", len) == 0)) {
        if (argc != 3) {
            Tcl_AppendResult(interp, "channel name required",
                    (char *) NULL);
            return TCL_ERROR;
        }

	return Tcl_RemoveChannelMode(interp, chan, TCL_WRITABLE);
    }

    if ((cmdName[0] == 'm') && (strncmp(cmdName, "mthread", len) == 0)) {
	if (argc != 3) {
	    Tcl_AppendResult(interp, "channel name required", NULL);
	    return TCL_ERROR;
	}

Changes to tests/io.test.

8950
8951
8952
8953
8954
8955
8956






















































































































8957
8958
8959
8960
8961
8962
8963
8964
8965
    interp delete child
    testobj freeallvars
    removeFile io-74.1
} -returnCodes error -match glob -result {can not find channel named "*"}

# ### ### ### ######### ######### #########























































































































# cleanup
foreach file [list fooBar longfile script script2 output test1 pipe my_script \
	test2 test3 cat stdout kyrillic.txt utf8-fcopy.txt utf8-rp.txt] {
    removeFile $file
}
cleanupTests
}
namespace delete ::tcl::test::io
return






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









8950
8951
8952
8953
8954
8955
8956
8957
8958
8959
8960
8961
8962
8963
8964
8965
8966
8967
8968
8969
8970
8971
8972
8973
8974
8975
8976
8977
8978
8979
8980
8981
8982
8983
8984
8985
8986
8987
8988
8989
8990
8991
8992
8993
8994
8995
8996
8997
8998
8999
9000
9001
9002
9003
9004
9005
9006
9007
9008
9009
9010
9011
9012
9013
9014
9015
9016
9017
9018
9019
9020
9021
9022
9023
9024
9025
9026
9027
9028
9029
9030
9031
9032
9033
9034
9035
9036
9037
9038
9039
9040
9041
9042
9043
9044
9045
9046
9047
9048
9049
9050
9051
9052
9053
9054
9055
9056
9057
9058
9059
9060
9061
9062
9063
9064
9065
9066
9067
9068
9069
9070
9071
9072
9073
9074
9075
9076
9077
9078
9079
9080
9081
9082
9083
    interp delete child
    testobj freeallvars
    removeFile io-74.1
} -returnCodes error -match glob -result {can not find channel named "*"}

# ### ### ### ######### ######### #########



test io-75.0 {channel modes} -setup {
    set datafile [makeFile {some characters} dummy]
    set f [open $datafile r]
} -constraints testchannel -body {
    testchannel mode $f
} -cleanup {
    close $f
    removeFile dummy
} -result {read {}}

test io-75.1 {channel modes} -setup {
    set datafile [makeFile {some characters} dummy]
    set f [open $datafile w]
} -constraints testchannel -body {
    testchannel mode $f
} -cleanup {
    close $f
    removeFile dummy
} -result {{} write}

test io-75.2 {channel modes} -setup {
    set datafile [makeFile {some characters} dummy]
    set f [open $datafile r+]
} -constraints testchannel -body {
    testchannel mode $f
} -cleanup {
    close $f
    removeFile dummy
} -result {read write}

test io-75.3 {channel mode dropping} -setup {
    set datafile [makeFile {some characters} dummy]
    set f [open $datafile r]
} -constraints testchannel -body {
    testchannel mremove-wr $f
    list [testchannel mode $f] [testchannel maxmode $f]
} -cleanup {
    close $f
    removeFile dummy
} -result {{read {}} {read {}}}

test io-75.4 {channel mode dropping} -setup {
    set datafile [makeFile {some characters} dummy]
    set f [open $datafile r]
} -constraints testchannel -body {
    testchannel mremove-rd $f
} -returnCodes error -cleanup {
    close $f
    removeFile dummy
} -match glob -result {Tcl_RemoveChannelMode error: Bad mode, would make channel inacessible. Channel: "*"}

test io-75.5 {channel mode dropping} -setup {
    set datafile [makeFile {some characters} dummy]
    set f [open $datafile w]
} -constraints testchannel -body {
    testchannel mremove-rd $f
    list [testchannel mode $f] [testchannel maxmode $f]
} -cleanup {
    close $f
    removeFile dummy
} -result {{{} write} {{} write}}

test io-75.6 {channel mode dropping} -setup {
    set datafile [makeFile {some characters} dummy]
    set f [open $datafile w]
} -constraints testchannel -body {
    testchannel mremove-wr $f
} -returnCodes error -cleanup {
    close $f
    removeFile dummy
} -match glob -result {Tcl_RemoveChannelMode error: Bad mode, would make channel inacessible. Channel: "*"}

test io-75.7 {channel mode dropping} -setup {
    set datafile [makeFile {some characters} dummy]
    set f [open $datafile r+]
} -constraints testchannel -body {
    testchannel mremove-rd $f
    list [testchannel mode $f] [testchannel maxmode $f]
} -cleanup {
    close $f
    removeFile dummy
} -result {{{} write} {read write}}

test io-75.8 {channel mode dropping} -setup {
    set datafile [makeFile {some characters} dummy]
    set f [open $datafile r+]
} -constraints testchannel -body {
    testchannel mremove-wr $f
    list [testchannel mode $f] [testchannel maxmode $f]
} -cleanup {
    close $f
    removeFile dummy
} -result {{read {}} {read write}}

test io-75.9 {channel mode dropping} -setup {
    set datafile [makeFile {some characters} dummy]
    set f [open $datafile r+]
} -constraints testchannel -body {
    testchannel mremove-wr $f
    testchannel mremove-rd $f
} -returnCodes error -cleanup {
    close $f
    removeFile dummy
} -match glob -result {Tcl_RemoveChannelMode error: Bad mode, would make channel inacessible. Channel: "*"}

test io-75.10 {channel mode dropping} -setup {
    set datafile [makeFile {some characters} dummy]
    set f [open $datafile r+]
} -constraints testchannel -body {
    testchannel mremove-rd $f
    testchannel mremove-wr $f
} -returnCodes error -cleanup {
    close $f
    removeFile dummy
} -match glob -result {Tcl_RemoveChannelMode error: Bad mode, would make channel inacessible. Channel: "*"}

# cleanup
foreach file [list fooBar longfile script script2 output test1 pipe my_script \
	test2 test3 cat stdout kyrillic.txt utf8-fcopy.txt utf8-rp.txt] {
    removeFile $file
}
cleanupTests
}
namespace delete ::tcl::test::io
return