summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2005-08-25 15:46:30 (GMT)
committerdgp <dgp@users.sourceforge.net>2005-08-25 15:46:30 (GMT)
commit7937b78b247368beaf75e2f37177f5134e7a31f2 (patch)
treefdcd3ee887ab56c564f1152c99099a5197b0548a
parent7d8a3fabe0153588abc0daa0e13b085e22f2cad2 (diff)
downloadtcl-7937b78b247368beaf75e2f37177f5134e7a31f2.zip
tcl-7937b78b247368beaf75e2f37177f5134e7a31f2.tar.gz
tcl-7937b78b247368beaf75e2f37177f5134e7a31f2.tar.bz2
[kennykb-numerics-branch] Merge updates from HEAD
* generic/tclExecute.c: Bug fix. INST_*SHIFT* opcodes stack management. [expr 0<<6] should be 0, not 6.
-rw-r--r--ChangeLog76
-rw-r--r--doc/SetChanErr.3155
-rw-r--r--generic/tcl.decls17
-rw-r--r--generic/tclBasic.c25
-rw-r--r--generic/tclDecls.h46
-rw-r--r--generic/tclEvent.c20
-rw-r--r--generic/tclExecute.c11
-rw-r--r--generic/tclIO.c469
-rw-r--r--generic/tclIO.h16
-rw-r--r--generic/tclIOCmd.c95
-rw-r--r--generic/tclIORChan.c2668
-rw-r--r--generic/tclInt.h53
-rw-r--r--generic/tclObj.c4
-rw-r--r--generic/tclStubInit.c10
-rw-r--r--generic/tclTest.c116
-rw-r--r--generic/tclThreadTest.c8
-rw-r--r--library/init.tcl39
-rwxr-xr-xlibrary/msgs/af_za.msg (renamed from library/msgs/af_ZA.msg)0
-rwxr-xr-xlibrary/msgs/ar_in.msg (renamed from library/msgs/ar_IN.msg)0
-rwxr-xr-xlibrary/msgs/ar_jo.msg (renamed from library/msgs/ar_JO.msg)0
-rwxr-xr-xlibrary/msgs/ar_lb.msg (renamed from library/msgs/ar_LB.msg)0
-rwxr-xr-xlibrary/msgs/ar_sy.msg (renamed from library/msgs/ar_SY.msg)0
-rwxr-xr-xlibrary/msgs/bn_in.msg (renamed from library/msgs/bn_IN.msg)0
-rwxr-xr-xlibrary/msgs/de_at.msg (renamed from library/msgs/de_AT.msg)0
-rwxr-xr-xlibrary/msgs/de_be.msg (renamed from library/msgs/de_BE.msg)0
-rwxr-xr-xlibrary/msgs/en_au.msg (renamed from library/msgs/en_AU.msg)0
-rwxr-xr-xlibrary/msgs/en_be.msg (renamed from library/msgs/en_BE.msg)0
-rwxr-xr-xlibrary/msgs/en_bw.msg (renamed from library/msgs/en_BW.msg)0
-rwxr-xr-xlibrary/msgs/en_ca.msg (renamed from library/msgs/en_CA.msg)0
-rwxr-xr-xlibrary/msgs/en_gb.msg (renamed from library/msgs/en_GB.msg)0
-rwxr-xr-xlibrary/msgs/en_hk.msg (renamed from library/msgs/en_HK.msg)0
-rwxr-xr-xlibrary/msgs/en_ie.msg (renamed from library/msgs/en_IE.msg)0
-rwxr-xr-xlibrary/msgs/en_in.msg (renamed from library/msgs/en_IN.msg)0
-rwxr-xr-xlibrary/msgs/en_nz.msg (renamed from library/msgs/en_NZ.msg)0
-rwxr-xr-xlibrary/msgs/en_ph.msg (renamed from library/msgs/en_PH.msg)0
-rwxr-xr-xlibrary/msgs/en_sg.msg (renamed from library/msgs/en_SG.msg)0
-rwxr-xr-xlibrary/msgs/en_za.msg (renamed from library/msgs/en_ZA.msg)0
-rwxr-xr-xlibrary/msgs/en_zw.msg (renamed from library/msgs/en_ZW.msg)0
-rwxr-xr-xlibrary/msgs/es_ar.msg (renamed from library/msgs/es_AR.msg)0
-rwxr-xr-xlibrary/msgs/es_bo.msg (renamed from library/msgs/es_BO.msg)0
-rwxr-xr-xlibrary/msgs/es_cl.msg (renamed from library/msgs/es_CL.msg)0
-rwxr-xr-xlibrary/msgs/es_co.msg (renamed from library/msgs/es_CO.msg)0
-rwxr-xr-xlibrary/msgs/es_cr.msg (renamed from library/msgs/es_CR.msg)0
-rwxr-xr-xlibrary/msgs/es_do.msg (renamed from library/msgs/es_DO.msg)0
-rwxr-xr-xlibrary/msgs/es_ec.msg (renamed from library/msgs/es_EC.msg)0
-rwxr-xr-xlibrary/msgs/es_gt.msg (renamed from library/msgs/es_GT.msg)0
-rwxr-xr-xlibrary/msgs/es_hn.msg (renamed from library/msgs/es_HN.msg)0
-rwxr-xr-xlibrary/msgs/es_mx.msg (renamed from library/msgs/es_MX.msg)0
-rwxr-xr-xlibrary/msgs/es_ni.msg (renamed from library/msgs/es_NI.msg)0
-rwxr-xr-xlibrary/msgs/es_pa.msg (renamed from library/msgs/es_PA.msg)0
-rwxr-xr-xlibrary/msgs/es_pe.msg (renamed from library/msgs/es_PE.msg)0
-rwxr-xr-xlibrary/msgs/es_pr.msg (renamed from library/msgs/es_PR.msg)0
-rwxr-xr-xlibrary/msgs/es_py.msg (renamed from library/msgs/es_PY.msg)0
-rwxr-xr-xlibrary/msgs/es_sv.msg (renamed from library/msgs/es_SV.msg)0
-rwxr-xr-xlibrary/msgs/es_uy.msg (renamed from library/msgs/es_UY.msg)0
-rwxr-xr-xlibrary/msgs/es_ve.msg (renamed from library/msgs/es_VE.msg)0
-rwxr-xr-xlibrary/msgs/eu_es.msg (renamed from library/msgs/eu_ES.msg)0
-rwxr-xr-xlibrary/msgs/fa_in.msg (renamed from library/msgs/fa_IN.msg)0
-rwxr-xr-xlibrary/msgs/fa_ir.msg (renamed from library/msgs/fa_IR.msg)0
-rwxr-xr-xlibrary/msgs/fo_fo.msg (renamed from library/msgs/fo_FO.msg)0
-rwxr-xr-xlibrary/msgs/fr_be.msg (renamed from library/msgs/fr_BE.msg)0
-rwxr-xr-xlibrary/msgs/fr_ca.msg (renamed from library/msgs/fr_CA.msg)0
-rwxr-xr-xlibrary/msgs/fr_ch.msg (renamed from library/msgs/fr_CH.msg)0
-rwxr-xr-xlibrary/msgs/ga_ie.msg (renamed from library/msgs/ga_IE.msg)0
-rwxr-xr-xlibrary/msgs/gl_es.msg (renamed from library/msgs/gl_ES.msg)0
-rwxr-xr-xlibrary/msgs/gv_gb.msg (renamed from library/msgs/gv_GB.msg)0
-rwxr-xr-xlibrary/msgs/hi_in.msg (renamed from library/msgs/hi_IN.msg)0
-rwxr-xr-xlibrary/msgs/id_id.msg (renamed from library/msgs/id_ID.msg)0
-rwxr-xr-xlibrary/msgs/it_ch.msg (renamed from library/msgs/it_CH.msg)0
-rwxr-xr-xlibrary/msgs/kl_gl.msg (renamed from library/msgs/kl_GL.msg)0
-rwxr-xr-xlibrary/msgs/ko_kr.msg (renamed from library/msgs/ko_KR.msg)0
-rwxr-xr-xlibrary/msgs/kok_in.msg (renamed from library/msgs/kok_IN.msg)0
-rwxr-xr-xlibrary/msgs/kw_gb.msg (renamed from library/msgs/kw_GB.msg)0
-rwxr-xr-xlibrary/msgs/mr_in.msg (renamed from library/msgs/mr_IN.msg)0
-rwxr-xr-xlibrary/msgs/ms_my.msg (renamed from library/msgs/ms_MY.msg)0
-rwxr-xr-xlibrary/msgs/nl_be.msg (renamed from library/msgs/nl_BE.msg)0
-rwxr-xr-xlibrary/msgs/pt_br.msg (renamed from library/msgs/pt_BR.msg)0
-rwxr-xr-xlibrary/msgs/ru_ua.msg (renamed from library/msgs/ru_UA.msg)0
-rwxr-xr-xlibrary/msgs/ta_in.msg (renamed from library/msgs/ta_IN.msg)0
-rwxr-xr-xlibrary/msgs/te_in.msg (renamed from library/msgs/te_IN.msg)0
-rwxr-xr-xlibrary/msgs/zh_cn.msg (renamed from library/msgs/zh_CN.msg)0
-rwxr-xr-xlibrary/msgs/zh_hk.msg (renamed from library/msgs/zh_HK.msg)0
-rwxr-xr-xlibrary/msgs/zh_sg.msg (renamed from library/msgs/zh_SG.msg)0
-rwxr-xr-xlibrary/msgs/zh_tw.msg (renamed from library/msgs/zh_TW.msg)0
-rw-r--r--tests/binary.test4
-rw-r--r--tests/chan.test9
-rw-r--r--tests/clock.test38
-rw-r--r--tests/expr.test221
-rw-r--r--tests/io.test277
-rw-r--r--tests/ioCmd.test3078
-rw-r--r--unix/Makefile.in8
-rw-r--r--unix/configure.in4
-rw-r--r--unix/tclConfig.h.in9
-rw-r--r--win/Makefile.in3
-rwxr-xr-xwin/configure6
-rw-r--r--win/configure.in4
-rw-r--r--win/makefile.vc3
97 files changed, 7106 insertions, 386 deletions
diff --git a/ChangeLog b/ChangeLog
index b2ab980..d1a7f4b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,10 +1,54 @@
+2005-08-25 Donal K. Fellows <donal.k.fellows@man.ac.uk>
+
+ * generic/tclExecute.c (TEBC:INST_DICT_LAPPEND): Stop dropping a
+ duplicated object on the floor, which was a memory leak (and a wrong
+ result too). Thanks to Andreas Kupries for reporting this.
+
2005-08-25 Don Porter <dgp@users.sourceforge.net>
- [kennykb-numerics-branch]
+ [kennykb-numerics-branch] Merge updates from HEAD
+
+ * generic/tclExecute.c: Bug fix. INST_*SHIFT* opcodes stack
+ management. [expr 0<<6] should be 0, not 6.
* generic/tclBasic.c: Extended the domain of round(.) to all
non-Inf, non-NaN doubles, using bignums for the result as needed.
+2005-08-24 Andreas Kupries <andreask@activestate.com>
+
+ TIP#219 IMPLEMENTATION
+
+ * doc/SetChanErr.3: ** New File **. Documentation of the new
+ channel API functions.
+ * generic/tcl.decls: Stub declarations of the new channel API.
+ * generic/tclDecls.h: Regenerated
+ * generic/tclStubInit.c:
+
+ * tclIORChan.c: ** New File **. Implementation of the reflected
+ channel.
+ * generic/tclInt.h: Integration of reflected channel and new error
+ * generic/tclIO.c: propagation into the generic I/O core.
+ * generic/tclIOCmd.c:
+ * generic/tclIO.h:
+ * library/init.tcl:
+
+ * tests/io.test: Extended testsuite.
+ * tests/ioCmd.test:
+ * tests/chan.test:
+ * generic/tclTest.c:
+ * generic/tclThreadTest.c:
+
+ * unix/Makefile.in: Integration into the build machinery.
+ * win/Makefile.in:
+ * win/Makefile.vc:
+
+2005-08-24 Kevin Kenny <kennykb@acm.org>
+
+ * generic/tclStrToD.c (Tcl_DoubleDigits): Fixed the corner cases of
+ * tests/binary.test (binary-65.*) formatting floating
+ point numbers with the largest and smallest possible significands,
+ and added test cases for them.
+
2005-08-24 Kevin Kenny <kennykb@users.sourceforge.net>
[kennykb-numerics-branch]
@@ -36,6 +80,13 @@
comparison operators so that they form proper equivalence classes
over the set of numeric strings.
+2005-08-23 Mo DeJong <mdejong@users.sourceforge.net>
+
+ * unix/configure.in:
+ * win/configure: Regen.
+ * win/configure.in: Update minimum autoconf version
+ to 2.59.
+
2005-08-23 Kevin Kenny <kennykb@users.sourceforge.net>
[kennykb-numerics-branch]
@@ -95,6 +146,10 @@
* generic/tclStrToD.c:
* generic/tclUtil.c:
+2005-08-22 Daniel Steffen <das@users.sourceforge.net>
+
+ * unix/tclConfig.h.in: autoheader-2.59.
+
2005-08-22 Don Porter <dgp@users.sourceforge.net>
[kennykb-numerics-branch]
@@ -190,6 +245,23 @@
* generic/tclInt.h: TclIncrObj static -> internal
* generic/tclExecute.c:
+2005-08-17 George Peter Staplin <GeorgePS@XMission.com>
+
+ * generic/tclBasic.c: eliminate a namespace clash caused by
+ BuiltinFuncTable not being static.
+
+ * generic/tclObj.c: fix a namespace clash caused by a missing
+ static for pendingObjData.
+
+2005-08-17 Kevin Kenny <kennykb@acm.org>
+
+ * generic/tclEvent.c (Tcl_Finalize): Removed a copy-and-paste
+ accident that caused a (mostly harmless) double finalize of the
+ load and filesystem subsystems.
+ * tests/clock.test: Eliminated the bad test clock-43.1, and split
+ clock-50.1 into two tests, with a more permissive check on the
+ error message for an out-of-range value.
+
2005-08-17 Kevin Kenny <kennykb@users.sourceforge.net>
[kennykb-numerics-branch]
@@ -364,7 +436,7 @@
* tests/expr.test (expr-3.8): 'unix' because they get
stack overflows on Win32
threaded builds,
-
+
2005-08-09 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclPathObj.c: fix to [file rootname] bug in optimized
diff --git a/doc/SetChanErr.3 b/doc/SetChanErr.3
new file mode 100644
index 0000000..b176c48
--- /dev/null
+++ b/doc/SetChanErr.3
@@ -0,0 +1,155 @@
+'\"
+'\" Copyright (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+'\" RCS: @(#) $Id: SetChanErr.3,v 1.1.2.2 2005/08/25 15:46:30 dgp Exp $
+.so man.macros
+.TH Tcl_SetChannelError 3 8.5 Tcl "Tcl Library Procedures"
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+Tcl_SetChannelError, Tcl_SetChannelErrorInterp, Tcl_GetChannelError, Tcl_GetChannelErrorInterp \- functions to create/intercept Tcl errors by channel drivers.
+.SH SYNOPSIS
+.nf
+\fB#include <tcl.h>\fR
+.sp
+void
+\fBTcl_SetChannelError\fR(\fIchan, msg\fR)
+.sp
+void
+\fBTcl_SetChannelErrorInterp\fR(\fIinterp, msg\fR)
+.sp
+void
+\fBTcl_GetChannelError\fR(\fIchan, msgPtr\fR)
+.sp
+void
+\fBTcl_GetChannelErrorInterp\fR(\fIinterp, msgPtr\fR)
+.sp
+.SH ARGUMENTS
+.AS Tcl_Channel chan
+.AP Tcl_Channel chan in
+Refers to the Tcl channel whose bypass area is accessed.
+.AP Tcl_Interp* interp in
+Refers to the Tcl interpreter whose bypass area is accessed.
+.AP Tcl_Obj* msg in
+Error message put into a bypass area. A list of return options and
+values, followed by a string message. Both message and the
+option/value information are optional.
+.AP Tcl_Obj** msgPtr out
+Reference to a place where the message stored in the accessed bypass
+area can be stored in.
+.BE
+.SH DESCRIPTION
+.PP
+The current definition of a Tcl channel driver does not permit the
+direct return of arbitrary error messages, except for the setting and
+retrieval of channel options. All other functions are restricted to
+POSIX error codes.
+.PP
+The functions described here overcome this limitation. Channel drivers
+are allowed to use \fBTcl_SetChannelError\fR and
+\fBTcl_SetChannelErrorInterp\fR to place arbitrary error messages in
+\fBbypass areas\fI defined for channels and interpreters. And the
+generic I/O layer uses \fBTcl_GetChannelError\fR and
+\fBTcl_GetChannelErrorInterp\fR to look for messages in the bypass
+areas and arrange for their return as errors. The posix error codes
+set by a driver are used now if and only if no messages are present.
+.PP
+\fBTcl_SetChannelError\fR stores error information in the bypass area
+of the specified channel. The number of references to the \fBmsg\fI
+object goes up by one. Previously stored information will be
+discarded, by releasing the reference held by the channel. The channel
+reference must not be NULL.
+.PP
+\fBTcl_SetChannelErrorInterp\fR stores error information in the bypass
+area of the specified interpreter. The number of references to the
+\fBmsg\fI object goes up by one. Previously stored information will be
+discarded, by releasing the reference held by the interpreter. The
+interpreter reference must not be NULL.
+.PP
+\fBTcl_GetChannelError\fR places either the error message held in the
+bypass area of the specified channel into \fImsgPtr\fR, or NULL; and
+resets the bypass. I.e. after an invokation all following invokations
+will return NULL, until an intervening invokation of
+\fBTcl_SetChannelError\fR with a non-NULL message. The \fImsgPtr\fR
+must not be NULL. The reference count of the message is not touched.
+The reference previously held by the channel is now held by the caller
+of the function and it is its responsibility to release that reference
+when it is done with the object.
+.PP
+\fBTcl_GetChannelErrorInterp\fR places either the error message held
+in the bypass area of the specified interpreter into \fImsgPtr\fR, or
+NULL; and resets the bypass. I.e. after an invokation all following
+invokations will return NULL, until an intervening invokation of
+\fBTcl_SetChannelErrorInterp\fR with a non-NULL message. The
+\fImsgPtr\fR must not be NULL. The reference count of the message is
+not touched. The reference previously held by the interpreter is now
+held by the caller of the function and it is its responsibility to
+release that reference when it is done with the object.
+.PP
+Which functions of a channel driver are allowed to use which bypass
+function is listed below, as is which functions of the public channel
+API may leave a messages in the bypass areas.
+.PP
+.IP \fBTcl_DriverCloseProc\fR
+May use \fBTcl_SetChannelErrorInterp\fR, and only this function.
+.IP \fBTcl_DriverInputProc\fR
+May use \fBTcl_SetChannelError\fR, and only this function.
+.IP \fBTcl_DriverOutputProc\fR
+May use \fBTcl_SetChannelError\fR, and only this function.
+.IP \fBTcl_DriverSeekProc\fR
+May use \fBTcl_SetChannelError\fR, and only this function.
+.IP \fBTcl_DriverWideSeekProc
+May use \fBTcl_SetChannelError\fR, and only this function.
+.IP \fBTcl_DriverSetOptionProc\fR
+Has already the ability to pass arbitrary error messages. Must
+\fBnot\fR use any of the new functions.
+.IP \fBTcl_DriverGetOptionProc\fR
+Has already the ability to pass arbitrary error messages. Must
+\fBnot\fR use any of the new functions.
+.IP \fBTcl_DriverWatchProc\fR
+Must \fBnot\fR use any of the new functions. Is internally called and
+has no ability to return any type of error whatsoever.
+.IP \fBTcl_DriverBlockModeProc\fR
+May use \fBTcl_SetChannelError\fR, and only this function.
+.IP \fBTcl_DriverGetHandleProc\fR
+Must \fBnot\fR use any of the new functions. It is only a low-level
+function, and not used by Tcl commands.
+.IP \fBTcl_DriverHandlerProc\fR
+Must \fBnot\fR use any of the new functions. Is internally called and
+has no ability to return any type of error whatsoever.
+.PP
+Given the information above the following public functions of the Tcl
+C API are affected by these changes. I.e. when these functions are
+called the channel may now contain a stored arbitrary error message
+requiring processing by the caller.
+.PP
+.IP \fBTcl_StackChannel\fR
+.IP \fBTcl_Seek\fR
+.IP \fBTcl_Tell\fR
+.IP \fBTcl_ReadRaw\fR
+.IP \fBTcl_Read\fR
+.IP \fBTcl_ReadChars\fR
+.IP \fBTcl_Gets\fR
+.IP \fBTcl_GetsObj\fR
+.IP \fBTcl_Flush\fR
+.IP \fBTcl_WriteRaw\fR
+.IP \fBTcl_WriteObj\fR
+.IP \fBTcl_Write\fR
+.IP \fBTcl_WriteChars\fR
+.PP
+All other API functions are unchanged. Especially the functions below
+leave all their error information in the interpreter result.
+.PP
+.IP \fBTcl_Close\fR
+.IP \fBTcl_UnregisterChannel\fR
+.IP \fBTcl_UnstackChannel\fR
+.PP
+
+.SH "SEE ALSO"
+Tcl_Close(3), Tcl_OpenFileChannel(3), Tcl_SetErrno(3)
+
+.SH KEYWORDS
+channel driver, error messages, channel type
diff --git a/generic/tcl.decls b/generic/tcl.decls
index 982c240..89e0c54 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -11,7 +11,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: tcl.decls,v 1.105.2.7 2005/07/12 20:36:17 kennykb Exp $
+# RCS: @(#) $Id: tcl.decls,v 1.105.2.8 2005/08/25 15:46:30 dgp Exp $
library tcl
@@ -2013,6 +2013,21 @@ declare 560 generic {
Tcl_ChannelType *chanTypePtr)
}
+# TIP#219 (Tcl Channel Reflection API) akupries
+
+declare 561 generic {
+ void Tcl_SetChannelErrorInterp (Tcl_Interp* interp, Tcl_Obj* msg)
+}
+declare 562 generic {
+ void Tcl_GetChannelErrorInterp (Tcl_Interp* interp, Tcl_Obj** msg)
+}
+declare 563 generic {
+ void Tcl_SetChannelError (Tcl_Channel chan, Tcl_Obj* msg)
+}
+declare 564 generic {
+ void Tcl_GetChannelError (Tcl_Channel chan, Tcl_Obj** msg)
+}
+
##############################################################################
# Define the platform specific public Tcl interface. These functions are
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 8372ba7..63b381e 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBasic.c,v 1.136.2.28 2005/08/25 14:58:07 dgp Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.136.2.29 2005/08/25 15:46:30 dgp Exp $
*/
#include "tclInt.h"
@@ -243,7 +243,7 @@ typedef struct {
Tcl_ObjCmdProc* objCmdProc; /* Procedure that evaluates the function */
ClientData clientData; /* Client data for the procedure */
} BuiltinFuncDef;
-BuiltinFuncDef BuiltinFuncTable[] = {
+static BuiltinFuncDef BuiltinFuncTable[] = {
{ "::tcl::mathfunc::abs", ExprAbsFunc, NULL },
{ "::tcl::mathfunc::acos", ExprUnaryFunc, (ClientData) acos },
{ "::tcl::mathfunc::asin", ExprUnaryFunc, (ClientData) asin },
@@ -400,6 +400,9 @@ Tcl_CreateInterp()
iPtr->execEnvPtr = TclCreateExecEnv(interp);
+ /* TIP #219, Tcl Channel Reflection API */
+ iPtr->chanMsg = NULL;
+
/*
* Initialize the compilation and execution statistics kept for this
* interpreter.
@@ -526,9 +529,18 @@ Tcl_CreateInterp()
Tcl_CreateObjCommand(interp, "::tcl::clock::Oldscan",
TclClockOldscanObjCmd, (ClientData) NULL,
(Tcl_CmdDeleteProc*) NULL);
+ /* TIP #208 */
Tcl_CreateObjCommand(interp, "::tcl::chan::Truncate",
TclChanTruncateObjCmd, (ClientData) NULL,
(Tcl_CmdDeleteProc*) NULL);
+ /* TIP #219 */
+ Tcl_CreateObjCommand(interp, "::tcl::chan::rCreate",
+ TclChanCreateObjCmd, (ClientData) NULL,
+ (Tcl_CmdDeleteProc*) NULL);
+
+ Tcl_CreateObjCommand(interp, "::tcl::chan::rPostevent",
+ TclChanPostEventObjCmd, (ClientData) NULL,
+ (Tcl_CmdDeleteProc*) NULL);
/*
* Register the built-in functions
@@ -971,6 +983,15 @@ Tcl_DeleteInterp(interp)
iPtr->flags |= DELETED;
iPtr->compileEpoch++;
+ /* TIP #219, Tcl Channel Reflection API.
+ * Discard a leftover state.
+ */
+
+ if (iPtr->chanMsg != NULL) {
+ Tcl_DecrRefCount (iPtr->chanMsg);
+ iPtr->chanMsg = NULL;
+ }
+
/*
* Ensure that the interpreter is eventually deleted.
*/
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 85ea3e1..2a7f29e 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclDecls.h,v 1.107.2.6 2005/07/12 20:36:25 kennykb Exp $
+ * RCS: @(#) $Id: tclDecls.h,v 1.107.2.7 2005/08/25 15:46:30 dgp Exp $
*/
#ifndef _TCLDECLS
@@ -3496,6 +3496,30 @@ EXTERN int Tcl_TruncateChannel _ANSI_ARGS_((Tcl_Channel chan,
EXTERN Tcl_DriverTruncateProc * Tcl_ChannelTruncateProc _ANSI_ARGS_((
Tcl_ChannelType * chanTypePtr));
#endif
+#ifndef Tcl_SetChannelErrorInterp_TCL_DECLARED
+#define Tcl_SetChannelErrorInterp_TCL_DECLARED
+/* 561 */
+EXTERN void Tcl_SetChannelErrorInterp _ANSI_ARGS_((
+ Tcl_Interp* interp, Tcl_Obj* msg));
+#endif
+#ifndef Tcl_GetChannelErrorInterp_TCL_DECLARED
+#define Tcl_GetChannelErrorInterp_TCL_DECLARED
+/* 562 */
+EXTERN void Tcl_GetChannelErrorInterp _ANSI_ARGS_((
+ Tcl_Interp* interp, Tcl_Obj** msg));
+#endif
+#ifndef Tcl_SetChannelError_TCL_DECLARED
+#define Tcl_SetChannelError_TCL_DECLARED
+/* 563 */
+EXTERN void Tcl_SetChannelError _ANSI_ARGS_((Tcl_Channel chan,
+ Tcl_Obj* msg));
+#endif
+#ifndef Tcl_GetChannelError_TCL_DECLARED
+#define Tcl_GetChannelError_TCL_DECLARED
+/* 564 */
+EXTERN void Tcl_GetChannelError _ANSI_ARGS_((Tcl_Channel chan,
+ Tcl_Obj** msg));
+#endif
typedef struct TclStubHooks {
struct TclPlatStubs *tclPlatStubs;
@@ -4098,6 +4122,10 @@ typedef struct TclStubs {
int (*tcl_GetBignumFromObj) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value)); /* 558 */
int (*tcl_TruncateChannel) _ANSI_ARGS_((Tcl_Channel chan, Tcl_WideInt length)); /* 559 */
Tcl_DriverTruncateProc * (*tcl_ChannelTruncateProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 560 */
+ void (*tcl_SetChannelErrorInterp) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* msg)); /* 561 */
+ void (*tcl_GetChannelErrorInterp) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj** msg)); /* 562 */
+ void (*tcl_SetChannelError) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj* msg)); /* 563 */
+ void (*tcl_GetChannelError) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj** msg)); /* 564 */
} TclStubs;
#ifdef __cplusplus
@@ -6382,6 +6410,22 @@ extern TclStubs *tclStubsPtr;
#define Tcl_ChannelTruncateProc \
(tclStubsPtr->tcl_ChannelTruncateProc) /* 560 */
#endif
+#ifndef Tcl_SetChannelErrorInterp
+#define Tcl_SetChannelErrorInterp \
+ (tclStubsPtr->tcl_SetChannelErrorInterp) /* 561 */
+#endif
+#ifndef Tcl_GetChannelErrorInterp
+#define Tcl_GetChannelErrorInterp \
+ (tclStubsPtr->tcl_GetChannelErrorInterp) /* 562 */
+#endif
+#ifndef Tcl_SetChannelError
+#define Tcl_SetChannelError \
+ (tclStubsPtr->tcl_SetChannelError) /* 563 */
+#endif
+#ifndef Tcl_GetChannelError
+#define Tcl_GetChannelError \
+ (tclStubsPtr->tcl_GetChannelError) /* 564 */
+#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index bc0ef9d..ef284d3 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclEvent.c,v 1.54.2.7 2005/08/15 18:13:58 dgp Exp $
+ * RCS: @(#) $Id: tclEvent.c,v 1.54.2.8 2005/08/25 15:46:30 dgp Exp $
*/
#include "tclInt.h"
@@ -973,24 +973,6 @@ Tcl_Finalize()
TclResetFilesystem();
/*
- * We defer unloading of packages until very late to avoid memory
- * access issues. Both exit callbacks and synchronization variables
- * may be stored in packages.
- *
- * Note that TclFinalizeLoad unloads packages in the reverse of the
- * order they were loaded in (i.e. last to be loaded is the first to
- * be unloaded). This can be important for correct unloading when
- * dependencies exist.
- *
- * Once load has been finalized, we will have deleted any temporary
- * copies of shared libraries and can therefore reset the filesystem
- * to its original state.
- */
-
- TclFinalizeLoad();
- TclResetFilesystem();
-
- /*
* At this point, there should no longer be any ckalloc'ed memory.
*/
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index c69b2f4..a22e3af 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclExecute.c,v 1.167.2.36 2005/08/24 18:56:32 kennykb Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.167.2.37 2005/08/25 15:46:30 dgp Exp $
*/
#include "tclInt.h"
@@ -3842,7 +3842,7 @@ TclExecuteByteCode(interp, codePtr)
/* Zero shifted any integral number of bits either way is zero */
mp_clear(&big1);
TRACE(("0 %s => 0\n", O2S(value2Ptr)));
- NEXT_INST_F(1, 0, 0);
+ NEXT_INST_F(1, 1, 0);
}
result = Tcl_GetIntFromObj(NULL, value2Ptr, &shift);
if (result != TCL_OK) {
@@ -5875,11 +5875,10 @@ TclExecuteByteCode(interp, codePtr)
if (valPtr == NULL) {
valPtr = Tcl_NewListObj(1, tosPtr);
} else if (Tcl_IsShared(valPtr)) {
- Tcl_Obj *dupPtr = Tcl_DuplicateObj(valPtr);
-
- result = Tcl_ListObjAppendElement(interp, dupPtr, *tosPtr);
+ valPtr = Tcl_DuplicateObj(valPtr);
+ result = Tcl_ListObjAppendElement(interp, valPtr, *tosPtr);
if (result != TCL_OK) {
- Tcl_DecrRefCount(dupPtr);
+ Tcl_DecrRefCount(valPtr);
if (allocateDict) {
Tcl_DecrRefCount(dictPtr);
}
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 7f0ad57..19973a7 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIO.c,v 1.81.2.7 2005/08/15 18:13:58 dgp Exp $
+ * RCS: @(#) $Id: tclIO.c,v 1.81.2.8 2005/08/25 15:46:31 dgp Exp $
*/
#include "tclInt.h"
@@ -136,6 +136,7 @@ static int WriteBytes _ANSI_ARGS_((Channel *chanPtr,
CONST char *src, int srcLen));
static int WriteChars _ANSI_ARGS_((Channel *chanPtr,
CONST char *src, int srcLen));
+static Tcl_Obj* FixLevelCode _ANSI_ARGS_ ((Tcl_Obj* msg));
/*
*---------------------------------------------------------------------------
@@ -743,7 +744,7 @@ Tcl_RegisterChannel(interp, chan)
hPtr = Tcl_CreateHashEntry(hTblPtr, statePtr->channelName, &new);
if (new == 0) {
if (chan == (Tcl_Channel) Tcl_GetHashValue(hPtr)) {
- return;
+ return;
}
Tcl_Panic("Tcl_RegisterChannel: duplicate channel names");
@@ -1182,6 +1183,10 @@ Tcl_CreateChannel(typePtr, chanName, instanceData, mask)
chanPtr->inQueueHead = (ChannelBuffer *) NULL;
chanPtr->inQueueTail = (ChannelBuffer *) NULL;
+ /* TIP #219, Tcl Channel Reflection API */
+ statePtr->chanMsg = NULL;
+ statePtr->unreportedMsg = NULL;
+
/*
* Link the channel into the list of all channels; create an on-exit
* handler if there is not one already, to close off all the channels in
@@ -1400,7 +1405,7 @@ Tcl_StackChannel(interp, typePtr, instanceData, mask, prevChan)
*
* Side effects:
* If TCL_ERROR is returned, the posix error code will be set with
- * Tcl_SetErrno.
+ * Tcl_SetErrno. May leave a message in interp result as well.
*
*----------------------------------------------------------------------
*/
@@ -1446,9 +1451,17 @@ Tcl_UnstackChannel(interp, chan)
if (Tcl_Flush((Tcl_Channel) chanPtr) != TCL_OK) {
statePtr->csPtr = csPtr;
- Tcl_AppendResult(interp, "could not flush channel \"",
- Tcl_GetChannelName((Tcl_Channel) chanPtr), "\"",
- (char *) NULL);
+ /* TIP #219, Tcl Channel Reflection API.
+ * Move error messages put by the driver into the chan/ip
+ * bypass area into the regular interpreter result. Fall back
+ * to the regular message if nothing was found in the
+ * bypasses.
+ */
+ if (!TclChanCaughtErrorBypass (interp, chan)) {
+ Tcl_AppendResult(interp, "could not flush channel \"",
+ Tcl_GetChannelName((Tcl_Channel) chanPtr), "\"",
+ (char *) NULL);
+ }
return TCL_ERROR;
}
@@ -1517,6 +1530,11 @@ Tcl_UnstackChannel(interp, chan)
if (result != 0) {
Tcl_SetErrno(result);
+ /* TIP #219, Tcl Channel Reflection API.
+ * Move error messages put by the driver into the chan/ip bypass
+ * area into the regular interpreter result.
+ */
+ TclChanCaughtErrorBypass (interp, chan);
return TCL_ERROR;
}
} else {
@@ -1527,6 +1545,10 @@ Tcl_UnstackChannel(interp, chan)
if (statePtr->refCount <= 0) {
if (Tcl_Close(interp, chan) != TCL_OK) {
+ /* TIP #219, Tcl Channel Reflection API.
+ * "TclChanCaughtErrorBypass" is not required here, it was
+ * done already by "Tcl_Close".
+ */
return TCL_ERROR;
}
}
@@ -1959,7 +1981,7 @@ CheckForDeadChannel(interp, statePtr)
*
* Results:
* 0 if successful, else the error code that was returned by the channel
- * type operation.
+ * type operation. May leave a message in the interp result.
*
* Side effects:
* May produce output on a channel. May block indefinitely if the channel
@@ -2099,22 +2121,53 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush)
*/
if (calledFromAsyncFlush) {
+ /* TIP #219, Tcl Channel Reflection API.
+ * When defering the error copy a message from the bypass into
+ * the unreported area. Or discard it if the new error is to be
+ * ignored in favor of an earlier defered error.
+ */
+
+ Tcl_Obj* msg = statePtr->chanMsg;
+
if (statePtr->unreportedError == 0) {
statePtr->unreportedError = errorCode;
+ statePtr->unreportedMsg = msg;
+ if (msg != NULL) {
+ Tcl_IncrRefCount (msg);
+ }
+ } else {
+ /* An old unreported error is kept, and this error
+ * thrown away.
+ */
+ statePtr->chanMsg = NULL;
+ if (msg != NULL) {
+ Tcl_DecrRefCount (msg);
+ }
}
} else {
+ /* TIP #219, Tcl Channel Reflection API.
+ * Move error messages put by the driver into the chan bypass
+ * area into the regular interpreter result. Fall back to the
+ * regular message if nothing was found in the bypasses.
+ */
+
Tcl_SetErrno(errorCode);
if (interp != NULL) {
+ if (!TclChanCaughtErrorBypass (interp, (Tcl_Channel) chanPtr)) {
+ /*
+ * Casting away CONST here is safe because the
+ * TCL_VOLATILE flag guarantees CONST treatment
+ * of the Posix error string.
+ */
- /*
- * Casting away CONST here is safe because the
- * TCL_VOLATILE flag guarantees CONST treatment of the
- * Posix error string.
- */
-
- Tcl_SetResult(interp,
- (char *) Tcl_PosixError(interp), TCL_VOLATILE);
+ Tcl_SetResult(interp,
+ (char *) Tcl_PosixError(interp),
+ TCL_VOLATILE);
+ }
}
+ /* An unreportable bypassed message is kept, for the
+ * caller of Tcl_Seek, Tcl_Write, etc.
+ */
}
/*
@@ -2191,7 +2244,7 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush)
* TOP channel, including the data structure itself.
*
* Results:
- * 1 if the channel was stacked, 0 otherwise.
+ * Error code from an unreported error or the driver close operation.
*
* Side effects:
* May close the actual channel, may free memory, may change the value of
@@ -2251,6 +2304,19 @@ CloseChannel(interp, chanPtr, errorCode)
(chanPtr->typePtr->outputProc) (chanPtr->instanceData, &c, 1, &dummy);
}
+ /* TIP #219, Tcl Channel Reflection API.
+ * Move a leftover error message in the channel bypass into the
+ * interpreter bypass. Just clear it if there is no interpreter.
+ */
+
+ if (statePtr->chanMsg != NULL) {
+ if (interp != NULL) {
+ Tcl_SetChannelErrorInterp (interp,statePtr->chanMsg);
+ }
+ Tcl_DecrRefCount (statePtr->chanMsg);
+ statePtr->chanMsg = NULL;
+ }
+
/*
* Remove this channel from of the list of all channels.
*/
@@ -2259,6 +2325,7 @@ CloseChannel(interp, chanPtr, errorCode)
/*
* Close and free the channel driver state.
+ * This may leave a TIP #219 error message in the interp.
*/
if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) {
@@ -2293,6 +2360,17 @@ CloseChannel(interp, chanPtr, errorCode)
if (statePtr->unreportedError != 0) {
errorCode = statePtr->unreportedError;
+
+ /* TIP #219, Tcl Channel Reflection API.
+ * Move an error message found in the unreported area into the regular
+ * bypass (interp). This kills any message in the channel bypass area.
+ */
+
+ if (statePtr->chanMsg != NULL) {
+ Tcl_DecrRefCount (statePtr->chanMsg);
+ statePtr->chanMsg = NULL;
+ }
+ Tcl_SetChannelErrorInterp (interp,statePtr->unreportedMsg);
}
if (errorCode == 0) {
errorCode = result;
@@ -2500,6 +2578,7 @@ Tcl_Close(interp, chan)
Channel *chanPtr; /* The real IO channel. */
ChannelState *statePtr; /* State of real IO channel. */
int result; /* Of calling FlushChannel. */
+ int flushcode;
if (chan == (Tcl_Channel) NULL) {
return TCL_OK;
@@ -2543,6 +2622,19 @@ Tcl_Close(interp, chan)
&& (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) {
statePtr->outputEncodingFlags |= TCL_ENCODING_END;
WriteChars(chanPtr, "", 0);
+
+ /* TIP #219, Tcl Channel Reflection API.
+ * Move an error message found in the channel bypass into the
+ * interpreter bypass. Just clear it if there is no interpreter.
+ */
+
+ if (statePtr->chanMsg != NULL) {
+ if (interp != NULL) {
+ Tcl_SetChannelErrorInterp (interp,statePtr->chanMsg);
+ }
+ Tcl_DecrRefCount (statePtr->chanMsg);
+ statePtr->chanMsg = NULL;
+ }
}
Tcl_ClearChannelHandlers(chan);
@@ -2588,7 +2680,25 @@ Tcl_Close(interp, chan)
*/
statePtr->flags |= CHANNEL_CLOSED;
- if ((FlushChannel(interp, chanPtr, 0) != 0) || (result != 0)) {
+
+ flushcode = FlushChannel(interp, chanPtr, 0);
+
+ /* TIP #219.
+ * Capture error messages put by the driver into the bypass area and put
+ * them into the regular interpreter result.
+ *
+ * Notes: Due to the assertion of CHANNEL_CLOSED in the flags
+ * "FlushChannel" has called "CloseChannel" and thus freed all the channel
+ * structures. We must not try to access "chan" anymore, hence the NULL
+ * argument in the call below. The only place which may still contain a
+ * message is the interpreter itself, and "CloseChannel" made sure to lift
+ * any channel message it generated into it.
+ */
+ if (TclChanCaughtErrorBypass (interp, NULL)) {
+ result = EINVAL;
+ }
+
+ if ((flushcode != 0) || (result != 0)) {
return TCL_ERROR;
}
return TCL_OK;
@@ -5831,6 +5941,16 @@ CheckChannelErrors(statePtr, flags)
if (statePtr->unreportedError != 0) {
Tcl_SetErrno(statePtr->unreportedError);
statePtr->unreportedError = 0;
+
+ /* TIP #219, Tcl Channel Reflection API.
+ * Move a defered error message back into the channel bypass.
+ */
+
+ if (statePtr->chanMsg != NULL) {
+ Tcl_DecrRefCount (statePtr->chanMsg);
+ }
+ statePtr->chanMsg = statePtr->unreportedMsg;
+ statePtr->unreportedMsg = NULL;
return -1;
}
@@ -7725,6 +7845,7 @@ CopyData(csPtr, mask)
{
Tcl_Interp *interp;
Tcl_Obj *cmdPtr, *errObj = NULL, *bufObj = NULL;
+ Tcl_Obj* msg = NULL;
Tcl_Channel inChan, outChan;
ChannelState *inStatePtr, *outStatePtr;
int result = TCL_OK, size, total, sizeb;
@@ -7762,12 +7883,14 @@ CopyData(csPtr, mask)
* Check for unreported background errors.
*/
- if (inStatePtr->unreportedError != 0) {
+ Tcl_GetChannelError (inChan, &msg);
+ if ((inStatePtr->unreportedError != 0) || (msg != NULL)) {
Tcl_SetErrno(inStatePtr->unreportedError);
inStatePtr->unreportedError = 0;
goto readError;
}
- if (outStatePtr->unreportedError != 0) {
+ Tcl_GetChannelError (outChan, &msg);
+ if ((outStatePtr->unreportedError != 0) || (msg != NULL)) {
Tcl_SetErrno(outStatePtr->unreportedError);
outStatePtr->unreportedError = 0;
goto writeError;
@@ -7794,8 +7917,15 @@ CopyData(csPtr, mask)
readError:
TclNewObj(errObj);
Tcl_AppendStringsToObj(errObj, "error reading \"",
- Tcl_GetChannelName(inChan), "\": ",
- Tcl_PosixError(interp), (char *) NULL);
+ Tcl_GetChannelName(inChan), "\": ",
+ (char *) NULL);
+ if (msg != NULL) {
+ Tcl_AppendObjToObj(errObj,msg);
+ } else {
+ Tcl_AppendStringsToObj(errObj,
+ Tcl_PosixError(interp),
+ (char *) NULL);
+ }
break;
} else if (underflow) {
/*
@@ -7850,8 +7980,15 @@ CopyData(csPtr, mask)
writeError:
TclNewObj(errObj);
Tcl_AppendStringsToObj(errObj, "error writing \"",
- Tcl_GetChannelName(outChan), "\": ",
- Tcl_PosixError(interp), (char *) NULL);
+ Tcl_GetChannelName(outChan), "\": ",
+ (char *) NULL);
+ if (msg != NULL) {
+ Tcl_AppendObjToObj(errObj,msg);
+ } else {
+ Tcl_AppendStringsToObj(errObj,
+ Tcl_PosixError(interp),
+ (char *) NULL);
+ }
break;
}
@@ -8693,8 +8830,26 @@ SetBlockMode(interp, chanPtr, mode)
result = StackSetBlockMode(chanPtr, mode);
if (result != 0) {
if (interp != (Tcl_Interp *) NULL) {
- Tcl_AppendResult(interp, "error setting blocking mode: ",
- Tcl_PosixError(interp), (char *) NULL);
+ /* TIP #219.
+ * Move 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.
+ *
+ * Note that we cannot have a message in the interpreter bypass
+ * area, StackSetBlockMode is restricted to the channel bypass.
+ * We still need the interp as the destination of the move.
+ */
+ if (!TclChanCaughtErrorBypass (interp, (Tcl_Channel) chanPtr)) {
+ Tcl_AppendResult(interp, "error setting blocking mode: ",
+ Tcl_PosixError(interp), (char *) NULL);
+ }
+ } else {
+ /* TIP #219.
+ * If we have no interpreter to put a bypass message into we have
+ * to clear it, to prevent its propagation and use in other places
+ * unrelated to the actual occurence of the problem.
+ */
+ Tcl_SetChannelError ((Tcl_Channel) chanPtr, NULL);
}
return TCL_ERROR;
}
@@ -9376,6 +9531,270 @@ Tcl_ChannelThreadActionProc(chanTypePtr)
/*
*----------------------------------------------------------------------
*
+ * Tcl_SetChannelErrorInterp --
+ *
+ * TIP #219, Tcl Channel Reflection API.
+ * Store an error message for the I/O system.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Discards a previously stored message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_SetChannelErrorInterp (interp, msg)
+ Tcl_Interp* interp; /* Interp to store the data into. */
+ Tcl_Obj* msg; /* Error message to store. */
+{
+ Interp* iPtr = (Interp*) interp;
+
+ if (iPtr->chanMsg != NULL) {
+ Tcl_DecrRefCount (iPtr->chanMsg);
+ iPtr->chanMsg = NULL;
+ }
+
+ if (msg != NULL) {
+ iPtr->chanMsg = FixLevelCode (msg);
+ Tcl_IncrRefCount (iPtr->chanMsg);
+ }
+ return;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetChannelError --
+ *
+ * TIP #219, Tcl Channel Reflection API.
+ * Store an error message for the I/O system.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Discards a previously stored message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_SetChannelError (chan, msg)
+ Tcl_Channel chan; /* Channel to store the data into. */
+ Tcl_Obj* msg; /* Error message to store. */
+{
+ ChannelState* statePtr = ((Channel*) chan)->state;
+
+ if (statePtr->chanMsg != NULL) {
+ Tcl_DecrRefCount (statePtr->chanMsg);
+ statePtr->chanMsg = NULL;
+ }
+
+ if (msg != NULL) {
+ statePtr->chanMsg = FixLevelCode (msg);
+ Tcl_IncrRefCount (statePtr->chanMsg);
+ }
+ return;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FixLevelCode --
+ *
+ * TIP #219, Tcl Channel Reflection API.
+ * Scans an error message for bad -code / -level
+ * directives. Returns a modified copy with such
+ * directives corrected, and the input if it had
+ * no problems.
+ *
+ * Results:
+ * A Tcl_Obj*
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_Obj*
+FixLevelCode (msg)
+Tcl_Obj* msg;
+{
+ int lc;
+ Tcl_Obj** lv;
+ int explicitResult;
+ int numOptions;
+ int lcn;
+ Tcl_Obj** lvn;
+ int res, i, j, val, lignore, cignore;
+ Tcl_Obj* newlevel = NULL;
+ Tcl_Obj* newcode = NULL;
+
+ /* ASSERT msg != NULL */
+
+ /* Process the caught message.
+ *
+ * Syntax = (option value)... ?message?
+ *
+ * Bad syntax causes a panic. Because the other side uses
+ * Tcl_GetReturnOptions and list construction functions to marshall the
+ * information.
+ */
+
+ res = Tcl_ListObjGetElements (NULL, msg, &lc, &lv);
+ if (res != TCL_OK) {
+ Tcl_Panic ("Tcl_SetChannelError(Interp): Bad syntax of message");
+ }
+
+ explicitResult = (1 == (lc % 2));
+ numOptions = lc - explicitResult;
+
+ /* No options, nothing to do.
+ */
+
+ if (numOptions == 0) {
+ return msg;
+ }
+
+ /* Check for -code x, x != 1|error, and -level x, x != 0 */
+
+ for (i = 0; i < numOptions; i += 2) {
+ if (0 == strcmp (Tcl_GetString (lv [i]), "-code")) {
+ /* !"error", !integer, integer != 1 (numeric code for error) */
+
+ res = Tcl_GetIntFromObj (NULL, lv [i+1], &val);
+ if (((res == TCL_OK) && (val != 1)) ||
+ ((res != TCL_OK) && (0 != strcmp (Tcl_GetString (lv [i+1]), "error")))) {
+ newcode = Tcl_NewIntObj (1);
+ }
+ } else if (0 == strcmp (Tcl_GetString (lv [i]), "-level")) {
+ /* !integer, integer != 0 */
+ res = Tcl_GetIntFromObj (NULL, lv [i+1], &val);
+ if ((res != TCL_OK) || (val != 0)) {
+ newlevel = Tcl_NewIntObj (0);
+ }
+ }
+ }
+
+ /* -code, -level are either not present or ok. Nothing to do.
+ */
+
+ if (!newlevel && !newcode) {
+ return msg;
+ }
+
+ lcn = numOptions;
+ if (explicitResult) lcn ++;
+ if (newlevel) lcn += 2;
+ if (newcode) lcn += 2;
+
+ lvn = (Tcl_Obj**) ckalloc (lcn * sizeof (Tcl_Obj*));
+
+ /* New level/code information is spliced into the first occurence of
+ * -level, -code, further occurences are ignored. The options cannot be
+ * not present, we would not come here. Options which are ok are simply
+ * copied over.
+ */
+
+ lignore = cignore = 0;
+ for (i = 0, j = 0; i < numOptions; i += 2) {
+ if (0 == strcmp (Tcl_GetString (lv [i]), "-level")) {
+ if (newlevel) {
+ lvn [j] = lv [i]; j++;
+ lvn [j] = newlevel; j++;
+ newlevel = NULL;
+ lignore = 1;
+ continue;
+ } else if (lignore) {
+ continue;
+ }
+ } else if (0 == strcmp (Tcl_GetString (lv [i]), "-code")) {
+ if (newcode) {
+ lvn [j] = lv [i]; j++;
+ lvn [j] = newcode; j++;
+ newcode = NULL;
+ cignore = 1;
+ continue;
+ } else if (cignore) {
+ continue;
+ }
+ }
+ /* Keep everything else, possibly copied down */
+ lvn [j] = lv [i]; j++;
+ lvn [j] = lv [i+1]; j++;
+ }
+
+ if (explicitResult) {
+ lvn [j] = lv [i]; j++;
+ }
+
+ msg = Tcl_NewListObj (j, lvn);
+
+ ckfree ((char*) lvn);
+ return msg;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetChannelErrorInterp --
+ *
+ * TIP #219, Tcl Channel Reflection API.
+ * Return the message stored by the channel driver.
+ *
+ * Results:
+ * Tcl error message object.
+ *
+ * Side effects:
+ * Resets the stored data to NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void Tcl_GetChannelErrorInterp (interp, msg)
+ Tcl_Interp* interp; /* Interp to query. */
+ Tcl_Obj** msg; /* Place for error message. */
+{
+ Interp* iPtr = (Interp*) interp;
+
+ *msg = iPtr->chanMsg;
+ iPtr->chanMsg = NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetChannelError --
+ *
+ * TIP #219, Tcl Channel Reflection API.
+ * Return the message stored by the channel driver.
+ *
+ * Results:
+ * Tcl error message object.
+ *
+ * Side effects:
+ * Resets the stored data to NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void Tcl_GetChannelError (chan, msg)
+ Tcl_Channel chan; /* Channel to query. */
+ Tcl_Obj** msg; /* Place for error message. */
+{
+ ChannelState* statePtr = ((Channel*) chan)->state;
+
+ *msg = statePtr->chanMsg;
+ statePtr->chanMsg = NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_ChannelTruncateProc --
*
* TIP #208 (subsection relating to truncation, based on TIP #206).
diff --git a/generic/tclIO.h b/generic/tclIO.h
index c0abec2..c6c9915 100644
--- a/generic/tclIO.h
+++ b/generic/tclIO.h
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIO.h,v 1.7 2004/07/15 20:46:49 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclIO.h,v 1.7.2.1 2005/08/25 15:46:31 dgp Exp $
*/
/*
@@ -235,6 +235,20 @@ typedef struct ChannelState {
/* Next in list of channels currently open. */
Tcl_ThreadId managingThread; /* TIP #10: Id of the thread managing
* this stack of channels. */
+
+ /* TIP #219 ... Info for the I/O system ...
+ * Error message set by channel drivers, for the propagation of
+ * arbitrary Tcl errors. This information, if present (chanMsg not
+ * NULL), takes precedence over a posix error code returned by a
+ * channel operation.
+ */
+
+ 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'. */
} ChannelState;
/*
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index 1c1ce58..c1513f4 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIOCmd.c,v 1.22.2.3 2005/08/02 18:15:32 dgp Exp $
+ * RCS: @(#) $Id: tclIOCmd.c,v 1.22.2.4 2005/08/25 15:46:31 dgp Exp $
*/
#include "tclInt.h"
@@ -141,8 +141,15 @@ Tcl_PutsObjCmd(dummy, interp, objc, objv)
return TCL_OK;
error:
- Tcl_AppendResult(interp, "error writing \"", channelId, "\": ",
- Tcl_PosixError(interp), (char *) NULL);
+ /* 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_AppendResult(interp, "error writing \"", channelId, "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
+ }
return TCL_ERROR;
}
@@ -191,8 +198,15 @@ Tcl_FlushObjCmd(dummy, interp, objc, objv)
}
if (Tcl_Flush(chan) != TCL_OK) {
- Tcl_AppendResult(interp, "error flushing \"", channelId, "\": ",
- Tcl_PosixError(interp), (char *) NULL);
+ /* 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_AppendResult(interp, "error flushing \"", channelId, "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
+ }
return TCL_ERROR;
}
return TCL_OK;
@@ -250,9 +264,17 @@ Tcl_GetsObjCmd(dummy, interp, objc, objv)
if (lineLen < 0) {
if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) {
Tcl_DecrRefCount(linePtr);
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "error reading \"", name, "\": ",
- Tcl_PosixError(interp), (char *) NULL);
+
+ /* 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_ResetResult(interp);
+ Tcl_AppendResult(interp, "error reading \"", name, "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
+ }
return TCL_ERROR;
}
lineLen = -1;
@@ -372,10 +394,17 @@ Tcl_ReadObjCmd(dummy, interp, objc, objv)
Tcl_IncrRefCount(resultPtr);
charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0);
if (charactersRead < 0) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "error reading \"", name, "\": ",
- Tcl_PosixError(interp), (char *) NULL);
- Tcl_DecrRefCount(resultPtr);
+ /* 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_ResetResult(interp);
+ Tcl_AppendResult(interp, "error reading \"", name, "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
+ Tcl_DecrRefCount(resultPtr);
+ }
return TCL_ERROR;
}
@@ -457,8 +486,16 @@ Tcl_SeekObjCmd(clientData, interp, objc, objv)
result = Tcl_Seek(chan, offset, mode);
if (result == Tcl_LongAsWide(-1)) {
- Tcl_AppendResult(interp, "error during seek on \"",
- chanName, "\": ", Tcl_PosixError(interp), (char *) NULL);
+ /* 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_AppendResult(interp, "error during seek on \"",
+ chanName, "\": ", Tcl_PosixError(interp),
+ (char *) NULL);
+ }
return TCL_ERROR;
}
return TCL_OK;
@@ -491,6 +528,7 @@ Tcl_TellObjCmd(clientData, interp, objc, objv)
{
Tcl_Channel chan; /* The channel to tell on. */
char *chanName;
+ Tcl_WideInt newLoc;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "channelId");
@@ -507,7 +545,18 @@ Tcl_TellObjCmd(clientData, interp, objc, objv)
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_Tell(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.
+ */
+ if (TclChanCaughtErrorBypass (interp, chan)) {
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(newLoc));
return TCL_OK;
}
@@ -833,10 +882,17 @@ Tcl_ExecObjCmd(dummy, interp, objc, objv)
resultPtr = Tcl_NewObj();
if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) {
if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "error reading output from command: ",
- Tcl_PosixError(interp), (char *) NULL);
- Tcl_DecrRefCount(resultPtr);
+ /* 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_ResetResult(interp);
+ Tcl_AppendResult(interp, "error reading output from command: ",
+ Tcl_PosixError(interp), (char *) NULL);
+ Tcl_DecrRefCount(resultPtr);
+ }
return TCL_ERROR;
}
}
@@ -1630,3 +1686,4 @@ TclChanTruncateObjCmd(dummy, interp, objc, objv)
* fill-column: 78
* End:
*/
+
diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
new file mode 100644
index 0000000..9c79de0
--- /dev/null
+++ b/generic/tclIORChan.c
@@ -0,0 +1,2668 @@
+/*
+ * tclIORChan.c --
+ *
+ * This file contains the implementation of Tcl's generic
+ * channel reflection code, which allows the implementation
+ * of Tcl channels in Tcl code.
+ *
+ * Parts of this file are based on code contributed by
+ * Jean-Claude Wippler.
+ *
+ * See TIP #219 for the specification of this functionality.
+ *
+ * Copyright (c) 2004-2005 ActiveState, a divison of Sophos
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclIORChan.c,v 1.1.2.2 2005/08/25 15:46:31 dgp Exp $
+ */
+
+#include <tclInt.h>
+#include <tclIO.h>
+#include <assert.h>
+
+#ifndef EINVAL
+#define EINVAL 9
+#endif
+#ifndef EOK
+#define EOK 0
+#endif
+
+/*
+ * Signatures of all functions used in the C layer of the reflection.
+ */
+
+/* Required */
+static int RcClose _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp));
+
+/* Required, "read" is optional despite this. */
+static int RcInput _ANSI_ARGS_((ClientData clientData,
+ char *buf, int toRead, int *errorCodePtr));
+
+/* Required, "write" is optional despite this. */
+static int RcOutput _ANSI_ARGS_((ClientData clientData,
+ CONST char *buf, int toWrite, int *errorCodePtr));
+
+/* Required */
+static void RcWatch _ANSI_ARGS_((ClientData clientData, int mask));
+
+/* NULL'able - "blocking", is optional */
+static int RcBlock _ANSI_ARGS_((ClientData clientData,
+ int mode));
+
+/* NULL'able - "seek", is optional */
+static Tcl_WideInt RcSeekWide _ANSI_ARGS_((ClientData clientData,
+ Tcl_WideInt offset,
+ int mode, int *errorCodePtr));
+
+static int RcSeek _ANSI_ARGS_((ClientData clientData,
+ long offset, int mode, int *errorCodePtr));
+
+/* NULL'able - "cget" / "cgetall", are optional */
+static int RcGetOption _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp* interp,
+ CONST char *optionName,
+ Tcl_DString *dsPtr));
+
+/* NULL'able - "configure", is optional */
+static int RcSetOption _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp* interp,
+ CONST char *optionName,
+ CONST char *newValue));
+
+
+/*
+ * The C layer channel type/driver definition used by the reflection.
+ * This is a version 3 structure.
+ */
+
+static Tcl_ChannelType tclRChannelType = {
+ "tclrchannel", /* Type name. */
+ TCL_CHANNEL_VERSION_3,
+ RcClose, /* Close channel, clean instance data */
+ RcInput, /* Handle read request */
+ RcOutput, /* Handle write request */
+ RcSeek, /* Move location of access point. NULL'able */
+ RcSetOption, /* Set options. NULL'able */
+ RcGetOption, /* Get options. NULL'able */
+ RcWatch, /* Initialize notifier */
+ NULL, /* Get OS handle from the channel. NULL'able */
+ NULL, /* No close2 support. NULL'able */
+ RcBlock, /* Set blocking/nonblocking. NULL'able */
+ NULL, /* Flush channel. Not used by core. NULL'able */
+ NULL, /* Handle events. NULL'able */
+ RcSeekWide /* Move access point (64 bit). NULL'able */
+};
+
+/*
+ * Instance data for a reflected channel. ===========================
+ */
+
+typedef struct {
+ Tcl_Channel chan; /* Back reference to generic channel structure.
+ */
+ Tcl_Interp* interp; /* Reference to the interpreter containing the
+ * Tcl level part of the channel. */
+#ifdef TCL_THREADS
+ Tcl_ThreadId thread; /* Thread the 'interp' belongs to. */
+#endif
+
+ /* See [==] as well.
+ * Storage for the command prefix and the additional words required
+ * for the invocation of methods in the command handler.
+ *
+ * argv [0] ... [.] | [argc-2] [argc-1] | [argc] [argc+2]
+ * cmd ... pfx | method chan | detail1 detail2
+ * ~~~~ CT ~~~ ~~ CT ~~
+ *
+ * CT = Belongs to the 'Command handler Thread'.
+ */
+
+ int argc; /* Number of preallocated words - 2 */
+ Tcl_Obj** argv; /* Preallocated array for calling the handler.
+ * args [0] is placeholder for cmd word.
+ * Followed by the arguments in the prefix,
+ * plus 4 placeholders for method, channel,
+ * and at most two varying (method specific)
+ * words.
+ */
+
+ int methods; /* Bitmask of supported methods */
+
+ /* ---------------------------------------- */
+
+ /* NOTE (9): Should we have predefined shared literals
+ * NOTE (9): for the method names ?
+ */
+
+ /* ---------------------------------------- */
+
+ int mode; /* Mask of R/W mode */
+ int interest; /* Mask of events the channel is interested in. */
+
+ /* Note regarding the usage of timers.
+ *
+ * Most channel implementations need a timer in the
+ * C level to ensure that data in buffers is flushed
+ * out through the generation of fake file events.
+ *
+ * See 'rechan', 'memchan', etc.
+ *
+ * Here this is _not_ required. Interest in events is
+ * posted to the Tcl level via 'watch'. And posting of
+ * events is possible from the Tcl level as well, via
+ * 'chan postevent'. This means that the generation of
+ * all events, fake or not, timer based or not, is
+ * completely in the hands of the Tcl level. Therefore
+ * no timer here.
+ */
+
+} ReflectingChannel;
+
+/*
+ * Event literals. ==================================================
+ */
+
+static CONST char *eventOptions[] = {
+ "read", "write", (char *) NULL
+};
+typedef enum {
+ EVENT_READ, EVENT_WRITE
+} EventOption;
+
+/*
+ * Method literals. ==================================================
+ */
+
+static CONST char *methodNames[] = {
+ "blocking", /* OPT */
+ "cget", /* OPT \/ Together or none */
+ "cgetall", /* OPT /\ of these two */
+ "configure", /* OPT */
+ "finalize", /* */
+ "initialize", /* */
+ "read", /* OPT */
+ "seek", /* OPT */
+ "watch", /* */
+ "write", /* OPT */
+ (char *) NULL
+};
+typedef enum {
+ METH_BLOCKING,
+ METH_CGET,
+ METH_CGETALL,
+ METH_CONFIGURE,
+ METH_FINAL,
+ METH_INIT,
+ METH_READ,
+ METH_SEEK,
+ METH_WATCH,
+ METH_WRITE,
+} MethodName;
+
+#define FLAG(m) (1 << (m))
+#define REQUIRED_METHODS (FLAG (METH_INIT) | FLAG (METH_FINAL) | FLAG (METH_WATCH))
+#define NULLABLE_METHODS (FLAG (METH_BLOCKING) | FLAG (METH_SEEK) | \
+ FLAG (METH_CONFIGURE) | FLAG (METH_CGET) | FLAG (METH_CGETALL))
+
+#define RANDW (TCL_READABLE|TCL_WRITABLE)
+
+#define IMPLIES(a,b) ((!(a)) || (b))
+#define NEGIMPL(a,b)
+#define HAS(x,f) (x & FLAG(f))
+
+
+#ifdef TCL_THREADS
+/*
+ * Thread specific types and structures.
+ *
+ * We are here essentially creating a very specific implementation of
+ * 'thread send'.
+ */
+
+/*
+ * Enumeration of all operations which can be forwarded.
+ */
+
+typedef enum {
+ RcOpClose,
+ RcOpInput,
+ RcOpOutput,
+ RcOpSeek,
+ RcOpWatch,
+ RcOpBlock,
+ RcOpSetOpt,
+ RcOpGetOpt,
+ RcOpGetOptAll
+} RcOperation;
+
+/*
+ * Event used to forward driver invocations to the thread actually
+ * managing the channel. We cannot construct the command to execute
+ * and forward that. Because then it will contain a mixture of
+ * Tcl_Obj's belonging to both the command handler thread (CT), and
+ * the thread managing the channel (MT), executed in CT. Tcl_Obj's are
+ * not allowed to cross thread boundaries. So we forward an operation
+ * code, the argument details ,and reference to results. The command
+ * is assembled in the CT and belongs fully to that thread. No sharing
+ * problems.
+ */
+
+typedef struct RcForwardParamBase {
+ int code; /* O: Ok/Fail of the cmd handler */
+ char* msg; /* O: Error message for handler failure */
+ int vol; /* O: True - msg is allocated, False - msg is static */
+} RcForwardParamBase;
+
+/*
+ * Operation specific parameter/result structures.
+ */
+
+typedef struct RcForwardParamClose {
+ RcForwardParamBase b;
+} RcForwardParamClose;
+
+typedef struct RcForwardParamInput {
+ RcForwardParamBase b;
+ char* buf; /* O: Where to store the read bytes */
+ int toRead; /* I: #bytes to read,
+ * O: #bytes actually read */
+} RcForwardParamInput;
+
+typedef struct RcForwardParamOutput {
+ RcForwardParamBase b;
+ CONST char* buf; /* I: Where the bytes to write come from */
+ int toWrite; /* I: #bytes to write,
+ * O: #bytes actually written */
+} RcForwardParamOutput;
+
+typedef struct RcForwardParamSeek {
+ RcForwardParamBase b;
+ int seekMode; /* I: How to seek */
+ Tcl_WideInt offset; /* I: Where to seek,
+ * O: New location */
+} RcForwardParamSeek;
+
+typedef struct RcForwardParamWatch {
+ RcForwardParamBase b;
+ int mask; /* I: What events to watch for */
+} RcForwardParamWatch;
+
+typedef struct RcForwardParamBlock {
+ RcForwardParamBase b;
+ int nonblocking; /* I: What mode to activate */
+} RcForwardParamBlock;
+
+typedef struct RcForwardParamSetOpt {
+ RcForwardParamBase b;
+ CONST char* name; /* Name of option to set */
+ CONST char* value; /* Value to set */
+} RcForwardParamSetOpt;
+
+typedef struct RcForwardParamGetOpt {
+ RcForwardParamBase b;
+ CONST char* name; /* Name of option to get, maybe NULL */
+ Tcl_DString* value; /* Result */
+} RcForwardParamGetOpt;
+
+/*
+ * General event structure, with reference to
+ * operation specific data.
+ */
+
+typedef struct RcForwardingEvent {
+ Tcl_Event event; /* Basic event data, has to be first item */
+ struct RcForwardingResult* resultPtr;
+
+ RcOperation op; /* Forwarded driver operation */
+ ReflectingChannel* rcPtr; /* Channel instance */
+ CONST RcForwardParamBase* param; /* Arguments, a RcForwardParamXXX pointer */
+} RcForwardingEvent;
+
+/*
+ * Structure to manage the result of the forwarding. This is not the
+ * result of the operation itself, but about the success of the
+ * forward event itself. The event can be successful, even if the
+ * operation which was forwarded failed. It is also there to manage
+ * the synchronization between the involved threads.
+ */
+
+typedef struct RcForwardingResult {
+
+ Tcl_ThreadId src; /* Originating thread. */
+ Tcl_ThreadId dst; /* Thread the op was forwarded to. */
+ Tcl_Condition done; /* Condition variable the forwarder blocks on. */
+ int result; /* TCL_OK or TCL_ERROR */
+
+ struct RcForwardingEvent* evPtr; /* Event the result belongs to. */
+
+ struct RcForwardingResult* prevPtr; /* Links into the list of pending */
+ struct RcForwardingResult* nextPtr; /* forwarded results. */
+
+} RcForwardingResult;
+
+/*
+ * List of forwarded operations which have not completed yet, plus the
+ * mutex to protect the access to this process global list.
+ */
+
+static RcForwardingResult* forwardList = (RcForwardingResult*) NULL;
+TCL_DECLARE_MUTEX (rcForwardMutex)
+
+/*
+ * Function containing the generic code executing a forward, and
+ * wrapper macros for the actual operations we wish to forward.
+ */
+
+static void
+RcForwardOp _ANSI_ARGS_ ((ReflectingChannel* rcPtr, RcOperation op,
+ Tcl_ThreadId dst, CONST VOID* param));
+
+/*
+ * The event function executed by the thread receiving a forwarding
+ * event. Executes the appropriate function and collects the result,
+ * if any.
+ */
+
+static int
+RcForwardProc _ANSI_ARGS_ ((Tcl_Event *evPtr, int mask));
+
+/*
+ * Helpers which intercept when threads are going away, and clean up
+ * after pending forwarding events. Different actions depending on
+ * which thread went away, originator (src), or receiver (dst).
+ */
+
+static void
+RcSrcExitProc _ANSI_ARGS_ ((ClientData clientData));
+
+static void
+RcDstExitProc _ANSI_ARGS_ ((ClientData clientData));
+
+#define RcFreeReceivedError(pb) \
+ if ((pb).vol) {ckfree ((pb).msg);}
+
+#define RcPassReceivedErrorInterp(i,pb) \
+ if ((i)) {Tcl_SetChannelErrorInterp ((i), Tcl_NewStringObj ((pb).msg,-1));} \
+ RcFreeReceivedError (pb)
+
+#define RcPassReceivedError(c,pb) \
+ Tcl_SetChannelError ((c), Tcl_NewStringObj ((pb).msg,-1)); \
+ RcFreeReceivedError (pb)
+
+#define RcForwardSetStaticError(p,emsg) \
+ (p)->code = TCL_ERROR; (p)->vol = 0; (p)->msg = (char*) (emsg);
+
+#define RcForwardSetDynError(p,emsg) \
+ (p)->code = TCL_ERROR; (p)->vol = 1; (p)->msg = (char*) (emsg);
+
+static void
+RcForwardSetObjError _ANSI_ARGS_ ((RcForwardParamBase* p,
+ Tcl_Obj* obj));
+
+#endif /* TCL_THREADS */
+
+#define RcSetChannelErrorStr(c,msg) \
+ Tcl_SetChannelError ((c), Tcl_NewStringObj ((msg),-1))
+
+static Tcl_Obj* RcErrorMarshall _ANSI_ARGS_ ((Tcl_Interp *interp));
+static void RcErrorReturn _ANSI_ARGS_ ((Tcl_Interp* interp, Tcl_Obj* msg));
+
+
+
+/*
+ * Static functions for this file:
+ */
+
+static int RcEncodeEventMask _ANSI_ARGS_((Tcl_Interp* interp,
+ CONST char* objName, Tcl_Obj* obj,
+ int* mask));
+
+static Tcl_Obj* RcDecodeEventMask _ANSI_ARGS_ ((int mask));
+
+static ReflectingChannel* RcNew _ANSI_ARGS_ ((Tcl_Interp* interp,
+ Tcl_Obj* cmdpfxObj, int mode,
+ Tcl_Obj* id));
+
+static Tcl_Obj* RcNewHandle _ANSI_ARGS_ ((void));
+
+static void RcFree _ANSI_ARGS_ ((ReflectingChannel* rcPtr));
+
+static void
+RcInvokeTclMethod _ANSI_ARGS_((ReflectingChannel* rcPtr,
+ CONST char* method, Tcl_Obj* argone, Tcl_Obj* argtwo,
+ int* result, Tcl_Obj** resultObj, int capture));
+
+#define NO_CAPTURE (0)
+#define DO_CAPTURE (1)
+
+/*
+ * Global constant strings (messages). ==================
+ * These string are used directly as bypass errors, thus they have to be valid
+ * Tcl lists where the last element is the message itself. Hence the
+ * list-quoting to keep the words of the message together. See also [x].
+ */
+
+static CONST char* msg_read_unsup = "{read not supported by Tcl driver}";
+static CONST char* msg_read_toomuch = "{read delivered more than requested}";
+static CONST char* msg_write_unsup = "{write not supported by Tcl driver}";
+static CONST char* msg_write_toomuch = "{write wrote more than requested}";
+static CONST char* msg_seek_beforestart = "{Tried to seek before origin}";
+
+#ifdef TCL_THREADS
+static CONST char* msg_send_originlost = "{Origin thread lost}";
+static CONST char* msg_send_dstlost = "{Destination thread lost}";
+#endif /* TCL_THREADS */
+
+/*
+ * Main methods to plug into the 'chan' ensemble'. ==================
+ */
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclChanCreateObjCmd --
+ *
+ * This procedure is invoked to process the "chan create" Tcl
+ * command. See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ * The handle of the new channel is placed in the interp result.
+ *
+ * Side effects:
+ * Creates a new channel.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclChanCreateObjCmd (/*ignored*/ clientData, interp, objc, objv)
+ ClientData clientData;
+ Tcl_Interp* interp;
+ int objc;
+ Tcl_Obj* CONST* objv;
+{
+ ReflectingChannel* rcPtr; /* Instance data of the new channel */
+ Tcl_Obj* rcId; /* Handle of the new channel */
+ int mode; /* R/W mode of new channel. Has to
+ * match abilities of handler commands */
+ Tcl_Obj* cmdObj; /* Command prefix, list of words */
+ Tcl_Obj* cmdNameObj; /* Command name */
+ Tcl_Channel chan; /* Token for the new channel */
+ Tcl_Obj* modeObj; /* mode in obj form for method call */
+ int listc; /* Result of 'initialize', and of */
+ Tcl_Obj** listv; /* its sublist in the 2nd element */
+ int methIndex; /* Encoded method name */
+ int res; /* Result code for 'initialize' */
+ Tcl_Obj* resObj; /* Result data for 'initialize' */
+ int methods; /* Bitmask for supported methods. */
+ Channel* chanPtr; /* 'chan' resolved to internal struct. */
+
+ /* Syntax: chan create MODE CMDPREFIX
+ * [0] [1] [2] [3]
+ *
+ * Actually: rCreate MODE CMDPREFIX
+ * [0] [1] [2]
+ */
+
+#define MODE (1)
+#define CMD (2)
+
+ /* Number of arguments ... */
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "mode cmdprefix");
+ return TCL_ERROR;
+ }
+
+ /* First argument is a list of modes. Allowed entries are "read",
+ * "write". Expect at least one list element. Abbreviations are
+ * ok.
+ */
+
+ modeObj = objv [MODE];
+ if (RcEncodeEventMask (interp, "mode", objv [MODE], &mode) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /* Second argument is command prefix, i.e. list of words, first
+ * word is name of handler command, other words are fixed
+ * arguments. Run 'initialize' method to get the list of supported
+ * methods. Validate this.
+ */
+
+ cmdObj = objv [CMD];
+
+ /* Basic check that the command prefix truly is a list. */
+
+ if (Tcl_ListObjIndex(interp, cmdObj, 0, &cmdNameObj) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /* Now create the channel.
+ */
+
+ rcId = RcNewHandle ();
+ rcPtr = RcNew (interp, cmdObj, mode, rcId);
+ chan = Tcl_CreateChannel (&tclRChannelType,
+ Tcl_GetString (rcId),
+ rcPtr, mode);
+ rcPtr->chan = chan;
+ chanPtr = (Channel*) chan;
+
+ /* Invoke 'initialize' and validate that the handler
+ * is present and ok. Squash the channel if not.
+ */
+
+ /* Note: The conversion of 'mode' back into a Tcl_Obj ensures that
+ * 'initialize' is invoked with canonical mode names, and no
+ * abbreviations. Using modeObj directly could feed abbreviations
+ * into the handler, and the handler is not specified to handle
+ * such.
+ */
+
+ modeObj = RcDecodeEventMask (mode);
+ RcInvokeTclMethod (rcPtr, "initialize", modeObj, NULL,
+ &res, &resObj, NO_CAPTURE);
+ Tcl_DecrRefCount (modeObj);
+
+ if (res != TCL_OK) {
+ Tcl_Obj* err = Tcl_NewStringObj ("Initialize failure: ",-1);
+
+ Tcl_AppendObjToObj(err,resObj);
+ Tcl_SetObjResult (interp,err);
+ Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
+ goto error;
+ }
+
+ /* Verify the result.
+ * - List, of method names. Convert to mask.
+ * Check for non-optionals through the mask.
+ * Compare open mode against optional r/w.
+ */
+
+ Tcl_AppendResult (interp, "Initialize failure: ", (char*) NULL);
+
+ if (Tcl_ListObjGetElements (interp, resObj,
+ &listc, &listv) != TCL_OK) {
+ /* The function above replaces my prefix in case of an error,
+ * so more work for us to get the prefix back into the error
+ * message
+ */
+
+ Tcl_Obj* err = Tcl_NewStringObj ("Initialize failure: ",-1);
+
+ Tcl_AppendObjToObj(err,Tcl_GetObjResult (interp));
+ Tcl_SetObjResult (interp,err);
+ goto error;
+ }
+
+ methods = 0;
+ while (listc > 0) {
+ if (Tcl_GetIndexFromObj (interp, listv [listc-1],
+ methodNames, "method", TCL_EXACT, &methIndex) != TCL_OK) {
+ Tcl_Obj* err = Tcl_NewStringObj ("Initialize failure: ",-1);
+
+ Tcl_AppendObjToObj(err,Tcl_GetObjResult (interp));
+ Tcl_SetObjResult (interp,err);
+ goto error;
+ }
+
+ methods |= FLAG (methIndex);
+ listc --;
+ }
+
+ if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) {
+ Tcl_AppendResult (interp, "Not all required methods supported",
+ (char*) NULL);
+ goto error;
+ }
+
+ if ((mode & TCL_READABLE) && !HAS(methods,METH_READ)) {
+ Tcl_AppendResult (interp, "Reading not supported, but requested",
+ (char*) NULL);
+ goto error;
+ }
+
+ if ((mode & TCL_WRITABLE) && !HAS(methods,METH_WRITE)) {
+ Tcl_AppendResult (interp, "Writing not supported, but requested",
+ (char*) NULL);
+ goto error;
+ }
+
+ if (!IMPLIES (HAS(methods,METH_CGET), HAS(methods,METH_CGETALL))) {
+ Tcl_AppendResult (interp, "'cgetall' not supported, but should be, as 'cget' is",
+ (char*) NULL);
+ goto error;
+ }
+
+ if (!IMPLIES (HAS(methods,METH_CGETALL),HAS(methods,METH_CGET))) {
+ Tcl_AppendResult (interp, "'cget' not supported, but should be, as 'cgetall' is",
+ (char*) NULL);
+ goto error;
+ }
+
+ Tcl_ResetResult (interp);
+
+ /* Everything is fine now */
+
+ rcPtr->methods = methods;
+
+ if ((methods & NULLABLE_METHODS) != NULLABLE_METHODS) {
+ /* Some of the nullable methods are not supported. We clone
+ * the channel type, null the associated C functions, and use
+ * the result as the actual channel type.
+ */
+
+ Tcl_ChannelType* clonePtr = (Tcl_ChannelType*) ckalloc (sizeof (Tcl_ChannelType));
+ if (clonePtr == (Tcl_ChannelType*) NULL) {
+ Tcl_Panic ("Out of memory in Tcl_RcCreate");
+ }
+
+ memcpy (clonePtr, &tclRChannelType, sizeof (Tcl_ChannelType));
+
+ if (!(methods & FLAG (METH_CONFIGURE))) {
+ clonePtr->setOptionProc = NULL;
+ }
+
+ if (
+ !(methods & FLAG (METH_CGET)) &&
+ !(methods & FLAG (METH_CGETALL))
+ ) {
+ clonePtr->getOptionProc = NULL;
+ }
+ if (!(methods & FLAG (METH_BLOCKING))) {
+ clonePtr->blockModeProc = NULL;
+ }
+ if (!(methods & FLAG (METH_SEEK))) {
+ clonePtr->seekProc = NULL;
+ clonePtr->wideSeekProc = NULL;
+ }
+
+ chanPtr->typePtr = clonePtr;
+ }
+
+ Tcl_RegisterChannel (interp, chan);
+
+ /* Return handle as result of command */
+
+ Tcl_SetObjResult (interp, rcId);
+ return TCL_OK;
+
+ error:
+ /* Signal to RcClose to not call 'finalize' */
+ rcPtr->methods = 0;
+ Tcl_Close (interp, chan);
+ return TCL_ERROR;
+
+#undef MODE
+#undef CMD
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclChanPostEventObjCmd --
+ *
+ * This procedure is invoked to process the "chan postevent"
+ * Tcl command. See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Posts events to a reflected channel, invokes event handlers.
+ * The latter implies that arbitrary side effects are possible.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclChanPostEventObjCmd (/*ignored*/ clientData, interp, objc, objv)
+ ClientData clientData;
+ Tcl_Interp* interp;
+ int objc;
+ Tcl_Obj* CONST* objv;
+{
+ /* Syntax: chan postevent CHANNEL EVENTSPEC
+ * [0] [1] [2] [3]
+ *
+ * Actually: rPostevent CHANNEL EVENTSPEC
+ * [0] [1] [2]
+ *
+ * where EVENTSPEC = {read write ...} (Abbreviations allowed as well.
+ */
+
+#define CHAN (1)
+#define EVENT (2)
+
+ CONST char* chanId; /* Tcl level channel handle */
+ Tcl_Channel chan; /* Channel associated to the handle */
+ Tcl_ChannelType* chanTypePtr; /* Its associated driver structure */
+ ReflectingChannel* rcPtr; /* Associated instance data */
+ int mode; /* Dummy, r|w mode of the channel */
+ int events; /* Mask of events to post */
+
+ /* Number of arguments ... */
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "channel eventspec");
+ return TCL_ERROR;
+ }
+
+ /* First argument is a channel, a reflected channel, and the call
+ * of this command is done from the interp defining the channel
+ * handler cmd.
+ */
+
+ chanId = Tcl_GetString (objv [CHAN]);
+ chan = Tcl_GetChannel(interp, chanId, &mode);
+
+ if (chan == (Tcl_Channel) NULL) {
+ return TCL_ERROR;
+ }
+
+ chanTypePtr = Tcl_GetChannelType (chan);
+
+ /* We use a function referenced by the channel type as our cookie
+ * to detect calls to non-reflecting channels. The channel type
+ * itself is not suitable, as it might not be the static
+ * definition in this file, but a clone thereof. And while we have
+ * reserved the name of the type nothing in the core checks
+ * against violation, so someone else might have created a channel
+ * type using our name, clashing with ourselves.
+ */
+
+ if (chanTypePtr->watchProc != &RcWatch) {
+ Tcl_AppendResult(interp, "channel \"", chanId,
+ "\" is not a reflected channel",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ rcPtr = (ReflectingChannel*) Tcl_GetChannelInstanceData (chan);
+
+ if (rcPtr->interp != interp) {
+ Tcl_AppendResult(interp, "postevent for channel \"", chanId,
+ "\" called from outside interpreter",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ /* Second argument is a list of events. Allowed entries are
+ * "read", "write". Expect at least one list element.
+ * Abbreviations are ok.
+ */
+
+ if (RcEncodeEventMask (interp, "event", objv [EVENT], &events) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /* Check that the channel is actually interested in the provided
+ * events.
+ */
+
+ if (events & ~rcPtr->interest) {
+ Tcl_AppendResult(interp, "tried to post events channel \"", chanId,
+ "\" is not interested in",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ /* We have the channel and the events to post.
+ */
+
+ Tcl_NotifyChannel (chan, events);
+
+ /* Squash interp results left by the event script.
+ */
+
+ Tcl_ResetResult (interp);
+ return TCL_OK;
+
+#undef CHAN
+#undef EVENT
+}
+
+
+static Tcl_Obj*
+RcErrorMarshall (interp)
+ Tcl_Interp *interp;
+{
+ /* Capture the result status of the interpreter into a string.
+ * => List of options and values, followed by the error message.
+ * The result has refCount 0.
+ */
+
+ Tcl_Obj* returnOpt = Tcl_GetReturnOptions (interp, TCL_ERROR);
+
+ /* => returnOpt.refCount == 0. We can append directly.
+ */
+
+ Tcl_ListObjAppendElement (NULL, returnOpt, Tcl_GetObjResult (interp));
+ return returnOpt;
+}
+
+static void
+RcErrorReturn (interp, msg)
+ Tcl_Interp *interp;
+ Tcl_Obj *msg;
+{
+ int res;
+ int lc;
+ Tcl_Obj** lv;
+ int explicitResult;
+ int numOptions;
+
+ /* Process the caught message.
+ *
+ * Syntax = (option value)... ?message?
+ *
+ * Bad syntax causes a panic. Because the other side uses
+ * Tcl_GetReturnOptions and list construction functions to marshall the
+ * information.
+ */
+
+ res = Tcl_ListObjGetElements (interp, msg, &lc, &lv);
+ if (res != TCL_OK) {
+ Tcl_Panic ("TclChanCaughtErrorBypass: Bad syntax of caught result");
+ }
+
+ explicitResult = (1 == (lc % 2));
+ numOptions = lc - explicitResult;
+
+ if (explicitResult) {
+ Tcl_SetObjResult (interp, lv [lc-1]);
+ }
+
+ (void) Tcl_SetReturnOptions(interp, Tcl_NewListObj (numOptions, lv));
+}
+
+int
+TclChanCaughtErrorBypass (interp, chan)
+ Tcl_Interp *interp;
+ Tcl_Channel chan;
+{
+ Tcl_Obj* msgc = NULL;
+ Tcl_Obj* msgi = NULL;
+ Tcl_Obj* msg = NULL;
+
+ /* Get a bypassed error message from channel and/or interpreter, save the
+ * reference, then kill the returned objects, if there were any. If there
+ * are messages in both the channel has preference.
+ */
+
+ if ((chan == NULL) && (interp == NULL)) {
+ return 0;
+ }
+
+ if (chan != NULL) {
+ Tcl_GetChannelError (chan, &msgc);
+ }
+ if (interp != NULL) {
+ Tcl_GetChannelErrorInterp (interp, &msgi);
+ }
+
+ if (msgc != NULL) {
+ msg = msgc;
+ Tcl_IncrRefCount (msg);
+ } else if (msgi != NULL) {
+ msg = msgi;
+ Tcl_IncrRefCount (msg);
+ }
+
+ if (msgc != NULL) {
+ Tcl_DecrRefCount (msgc);
+ }
+ if (msgi != NULL) {
+ Tcl_DecrRefCount (msgi);
+ }
+
+ /* No message returned, nothing caught.
+ */
+
+ if (msg == NULL) {
+ return 0;
+ }
+
+ RcErrorReturn (interp, msg);
+
+ Tcl_DecrRefCount (msg);
+ return 1;
+}
+
+/*
+ * Driver functions. ================================================
+ */
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * RcClose --
+ *
+ * This function is invoked when the channel is closed, to delete
+ * the driver specific instance data.
+ *
+ * Results:
+ * A posix error.
+ *
+ * Side effects:
+ * Releases memory. Arbitrary, as it calls upon a script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+RcClose (clientData, interp)
+ ClientData clientData;
+ Tcl_Interp* interp;
+{
+ ReflectingChannel* rcPtr = (ReflectingChannel*) clientData;
+ int res; /* Result code for 'close' */
+ Tcl_Obj* resObj; /* Result data for 'close' */
+
+ if (interp == (Tcl_Interp*) NULL) {
+ /* This call comes from TclFinalizeIOSystem. There are no
+ * interpreters, and therefore we cannot call upon the handler
+ * command anymore. Threading is irrelevant as well. We
+ * simply clean up all our C level data structures and leave
+ * the Tcl level to the other finalization functions.
+ */
+
+ /* THREADED => Forward this to the origin thread */
+ /* Note: Have a thread delete handler for the origin
+ * thread. Use this to clean up the structure!
+ */
+
+#ifdef TCL_THREADS
+ /* Are we in the correct thread ?
+ */
+
+ if (rcPtr->thread != Tcl_GetCurrentThread ()) {
+ RcForwardParamClose p;
+
+ RcForwardOp (rcPtr, RcOpClose, rcPtr->thread, &p);
+ res = p.b.code;
+
+ /* RcFree is done in the forwarded operation!,
+ * in the other thread. rcPtr here is gone!
+ */
+
+ if (res != TCL_OK) {
+ RcFreeReceivedError (p.b);
+ }
+ } else {
+#endif
+ RcFree (rcPtr);
+#ifdef TCL_THREADS
+ }
+#endif
+ return EOK;
+ }
+
+ /* -------- */
+
+ /* -- No -- ASSERT rcPtr->methods & FLAG (METH_FINAL) */
+
+ /* A cleaned method mask here implies that the channel creation
+ * was aborted, and "finalize" must not be called.
+ */
+
+ if (rcPtr->methods == 0) {
+ RcFree (rcPtr);
+ return EOK;
+ } else {
+#ifdef TCL_THREADS
+ /* Are we in the correct thread ?
+ */
+
+ if (rcPtr->thread != Tcl_GetCurrentThread ()) {
+ RcForwardParamClose p;
+
+ RcForwardOp (rcPtr, RcOpClose, rcPtr->thread, &p);
+ res = p.b.code;
+
+ /* RcFree is done in the forwarded operation!,
+ * in the other thread. rcPtr here is gone!
+ */
+
+ if (res != TCL_OK) {
+ RcPassReceivedErrorInterp (interp, p.b);
+ }
+ } else {
+#endif
+ RcInvokeTclMethod (rcPtr, "finalize", NULL, NULL,
+ &res, &resObj, DO_CAPTURE);
+
+ if ((res != TCL_OK) && (interp != NULL)) {
+ Tcl_SetChannelErrorInterp (interp, resObj);
+ }
+
+ Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
+#ifdef TCL_THREADS
+ RcFree (rcPtr);
+ }
+#endif
+ return (res == TCL_OK) ? EOK : EINVAL;
+ }
+
+ Tcl_Panic ("Should not be reached");
+ return EINVAL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * RcInput --
+ *
+ * This function is invoked when more data is requested from the
+ * channel.
+ *
+ * Results:
+ * The number of bytes read.
+ *
+ * Side effects:
+ * Allocates memory. Arbitrary, as it calls upon a script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+RcInput (clientData, buf, toRead, errorCodePtr)
+ ClientData clientData;
+ char* buf;
+ int toRead;
+ int* errorCodePtr;
+{
+ ReflectingChannel* rcPtr = (ReflectingChannel*) clientData;
+ Tcl_Obj* toReadObj;
+ int bytec; /* Number of returned bytes */
+ unsigned char* bytev; /* Array of returned bytes */
+ int res; /* Result code for 'read' */
+ Tcl_Obj* resObj; /* Result data for 'read' */
+
+ /* The following check can be done before thread redirection,
+ * because we are reading from an item which is readonly, i.e.
+ * will never change during the lifetime of the channel.
+ */
+
+ if (!(rcPtr->methods & FLAG (METH_READ))) {
+ RcSetChannelErrorStr (rcPtr->chan, msg_read_unsup);
+ *errorCodePtr = EINVAL;
+ return -1;
+ }
+
+#ifdef TCL_THREADS
+ /* Are we in the correct thread ?
+ */
+
+ if (rcPtr->thread != Tcl_GetCurrentThread ()) {
+ RcForwardParamInput p;
+
+ p.buf = buf;
+ p.toRead = toRead;
+
+ RcForwardOp (rcPtr, RcOpInput, rcPtr->thread, &p);
+
+ if (p.b.code != TCL_OK) {
+ RcPassReceivedError (rcPtr->chan, p.b);
+ *errorCodePtr = EINVAL;
+ } else {
+ *errorCodePtr = EOK;
+ }
+
+ return p.toRead;
+ }
+#endif
+
+ /* -------- */
+
+ /* ASSERT: rcPtr->method & FLAG (METH_READ) */
+ /* ASSERT: rcPtr->mode & TCL_READABLE */
+
+ toReadObj = Tcl_NewIntObj(toRead);
+ if (toReadObj == (Tcl_Obj*) NULL) {
+ Tcl_Panic ("Out of memory in RcInput");
+ }
+
+ RcInvokeTclMethod (rcPtr, "read", toReadObj, NULL,
+ &res, &resObj, DO_CAPTURE);
+
+ if (res != TCL_OK) {
+ Tcl_SetChannelError (rcPtr->chan, resObj);
+ Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
+ *errorCodePtr = EINVAL;
+ return -1;
+ }
+
+ bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
+
+ if (toRead < bytec) {
+ Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
+ RcSetChannelErrorStr (rcPtr->chan, msg_read_toomuch);
+ *errorCodePtr = EINVAL;
+ return -1;
+ }
+
+ *errorCodePtr = EOK;
+
+ if (bytec > 0) {
+ memcpy (buf, bytev, bytec);
+ }
+
+ Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
+ return bytec;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * RcOutput --
+ *
+ * This function is invoked when data is writen to the
+ * channel.
+ *
+ * Results:
+ * The number of bytes actually written.
+ *
+ * Side effects:
+ * Allocates memory. Arbitrary, as it calls upon a script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+RcOutput (clientData, buf, toWrite, errorCodePtr)
+ ClientData clientData;
+ CONST char* buf;
+ int toWrite;
+ int* errorCodePtr;
+{
+ ReflectingChannel* rcPtr = (ReflectingChannel*) clientData;
+ Tcl_Obj* bufObj;
+ int res; /* Result code for 'write' */
+ Tcl_Obj* resObj; /* Result data for 'write' */
+ int written;
+
+ /* The following check can be done before thread redirection,
+ * because we are reading from an item which is readonly, i.e.
+ * will never change during the lifetime of the channel.
+ */
+
+ if (!(rcPtr->methods & FLAG (METH_WRITE))) {
+ RcSetChannelErrorStr (rcPtr->chan, msg_write_unsup);
+ *errorCodePtr = EINVAL;
+ return -1;
+ }
+
+#ifdef TCL_THREADS
+ /* Are we in the correct thread ?
+ */
+
+ if (rcPtr->thread != Tcl_GetCurrentThread ()) {
+ RcForwardParamOutput p;
+
+ p.buf = buf;
+ p.toWrite = toWrite;
+
+ RcForwardOp (rcPtr, RcOpOutput, rcPtr->thread, &p);
+
+ if (p.b.code != TCL_OK) {
+ RcPassReceivedError (rcPtr->chan, p.b);
+ *errorCodePtr = EINVAL;
+ } else {
+ *errorCodePtr = EOK;
+ }
+
+ return p.toWrite;
+ }
+#endif
+
+ /* -------- */
+
+ /* ASSERT: rcPtr->method & FLAG (METH_WRITE) */
+ /* ASSERT: rcPtr->mode & TCL_WRITABLE */
+
+ bufObj = Tcl_NewByteArrayObj((unsigned char*) buf, toWrite);
+ if (bufObj == (Tcl_Obj*) NULL) {
+ Tcl_Panic ("Out of memory in RcOutput");
+ }
+
+ RcInvokeTclMethod (rcPtr, "write", bufObj, NULL,
+ &res, &resObj, DO_CAPTURE);
+
+ if (res != TCL_OK) {
+ Tcl_SetChannelError (rcPtr->chan, resObj);
+ Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
+ *errorCodePtr = EINVAL;
+ return -1;
+ }
+
+ res = Tcl_GetIntFromObj (rcPtr->interp, resObj, &written);
+ if (res != TCL_OK) {
+ Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
+ Tcl_SetChannelError (rcPtr->chan, RcErrorMarshall (rcPtr->interp));
+ *errorCodePtr = EINVAL;
+ return -1;
+ }
+
+ Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
+
+ if ((written == 0) || (toWrite < written)) {
+ /* The handler claims to have written more than it was given.
+ * That is bad. Note that the I/O core would crash if we were
+ * to return this information, trying to write -nnn bytes in
+ * the next iteration.
+ */
+
+ RcSetChannelErrorStr (rcPtr->chan, msg_write_toomuch);
+ *errorCodePtr = EINVAL;
+ return -1;
+ }
+
+ *errorCodePtr = EOK;
+ return written;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * RcSeekWide / RcSeek --
+ *
+ * This function is invoked when the user wishes to seek on
+ * the channel.
+ *
+ * Results:
+ * The new location of the access point.
+ *
+ * Side effects:
+ * Allocates memory. Arbitrary, as it calls upon a script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_WideInt
+RcSeekWide (clientData, offset, seekMode, errorCodePtr)
+ ClientData clientData;
+ Tcl_WideInt offset;
+ int seekMode;
+ int* errorCodePtr;
+{
+ ReflectingChannel* rcPtr = (ReflectingChannel*) clientData;
+ Tcl_Obj* offObj;
+ Tcl_Obj* baseObj;
+ int res; /* Result code for 'seek' */
+ Tcl_Obj* resObj; /* Result data for 'seek' */
+ Tcl_WideInt newLoc;
+
+#ifdef TCL_THREADS
+ /* Are we in the correct thread ?
+ */
+
+ if (rcPtr->thread != Tcl_GetCurrentThread ()) {
+ RcForwardParamSeek p;
+
+ p.seekMode = seekMode;
+ p.offset = offset;
+
+ RcForwardOp (rcPtr, RcOpSeek, rcPtr->thread, &p);
+
+ if (p.b.code != TCL_OK) {
+ RcPassReceivedError (rcPtr->chan, p.b);
+ *errorCodePtr = EINVAL;
+ } else {
+ *errorCodePtr = EOK;
+ }
+
+ return p.offset;
+ }
+#endif
+
+ /* -------- */
+
+ /* ASSERT: rcPtr->method & FLAG (METH_SEEK) */
+
+ offObj = Tcl_NewWideIntObj(offset);
+ if (offObj == (Tcl_Obj*) NULL) {
+ Tcl_Panic ("Out of memory in RcSeekWide");
+ }
+
+ baseObj = Tcl_NewStringObj((seekMode == SEEK_SET) ?
+ "start" :
+ ((seekMode == SEEK_CUR) ?
+ "current" :
+ "end"), -1);
+
+ if (baseObj == (Tcl_Obj*) NULL) {
+ Tcl_Panic ("Out of memory in RcSeekWide");
+ }
+
+ RcInvokeTclMethod (rcPtr, "seek", offObj, baseObj,
+ &res, &resObj, DO_CAPTURE);
+
+ if (res != TCL_OK) {
+ Tcl_SetChannelError (rcPtr->chan, resObj);
+ Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
+ *errorCodePtr = EINVAL;
+ return -1;
+ }
+
+ res = Tcl_GetWideIntFromObj (rcPtr->interp, resObj, &newLoc);
+ if (res != TCL_OK) {
+ Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
+ Tcl_SetChannelError (rcPtr->chan, RcErrorMarshall (rcPtr->interp));
+ *errorCodePtr = EINVAL;
+ return -1;
+ }
+
+ Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
+
+ if (newLoc < Tcl_LongAsWide (0)) {
+ RcSetChannelErrorStr (rcPtr->chan, msg_seek_beforestart);
+ *errorCodePtr = EINVAL;
+ return -1;
+ }
+
+ *errorCodePtr = EOK;
+ return newLoc;
+}
+
+static int
+RcSeek (clientData, offset, seekMode, errorCodePtr)
+ ClientData clientData;
+ long offset;
+ int seekMode;
+ int* errorCodePtr;
+{
+ /* This function can be invoked from a transformation which is based
+ * on standard seeking, i.e. non-wide. Because o this we have to
+ * implement it, a dummy is not enough. We simply delegate the call
+ * to the wide routine.
+ */
+
+ return (int) RcSeekWide (clientData, Tcl_LongAsWide (offset),
+ seekMode, errorCodePtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * RcWatch --
+ *
+ * This function is invoked to tell the channel what events
+ * the I/O system is interested in.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Allocates memory. Arbitrary, as it calls upon a script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+RcWatch (clientData, mask)
+ ClientData clientData;
+ int mask;
+{
+ ReflectingChannel* rcPtr = (ReflectingChannel*) clientData;
+ Tcl_Obj* maskObj;
+
+ /* ASSERT rcPtr->methods & FLAG (METH_WATCH) */
+
+ /* We restrict the interest to what the channel can support
+ * IOW there will never be write events for a channel which is
+ * not writable. Analoguous for read events.
+ */
+
+ mask = mask & rcPtr->mode;
+
+ if (mask == rcPtr->interest) {
+ /* Same old, same old, why should we do something ? */
+ return;
+ }
+
+ rcPtr->interest = mask;
+
+#ifdef TCL_THREADS
+ /* Are we in the correct thread ?
+ */
+
+ if (rcPtr->thread != Tcl_GetCurrentThread ()) {
+ RcForwardParamWatch p;
+
+ p.mask = mask;
+
+ RcForwardOp (rcPtr, RcOpWatch, rcPtr->thread, &p);
+
+ /* Any failure from the forward is ignored. We have no place to
+ * put this.
+ */
+ return;
+ }
+#endif
+
+ /* -------- */
+
+ maskObj = RcDecodeEventMask (mask);
+ RcInvokeTclMethod (rcPtr, "watch", maskObj, NULL,
+ NULL, NULL, NO_CAPTURE);
+ Tcl_DecrRefCount (maskObj);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * RcBlock --
+ *
+ * This function is invoked to tell the channel which blocking
+ * behaviour is required of it.
+ *
+ * Results:
+ * A posix error number.
+ *
+ * Side effects:
+ * Allocates memory. Arbitrary, as it calls upon a script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+RcBlock (clientData, nonblocking)
+ ClientData clientData;
+ int nonblocking;
+{
+ ReflectingChannel* rcPtr = (ReflectingChannel*) clientData;
+ Tcl_Obj* blockObj;
+ int res; /* Result code for 'blocking' */
+ Tcl_Obj* resObj; /* Result data for 'blocking' */
+
+#ifdef TCL_THREADS
+ /* Are we in the correct thread ?
+ */
+
+ if (rcPtr->thread != Tcl_GetCurrentThread ()) {
+ RcForwardParamBlock p;
+
+ p.nonblocking = nonblocking;
+
+ RcForwardOp (rcPtr, RcOpBlock, rcPtr->thread, &p);
+
+ if (p.b.code != TCL_OK) {
+ RcPassReceivedError (rcPtr->chan, p.b);
+ return EINVAL;
+ } else {
+ return EOK;
+ }
+ }
+#endif
+
+ /* -------- */
+
+ blockObj = Tcl_NewBooleanObj(!nonblocking);
+ if (blockObj == (Tcl_Obj*) NULL) {
+ Tcl_Panic ("Out of memory in RcBlock");
+ }
+
+ RcInvokeTclMethod (rcPtr, "blocking", blockObj, NULL,
+ &res, &resObj, DO_CAPTURE);
+
+ if (res != TCL_OK) {
+ Tcl_SetChannelError (rcPtr->chan, resObj);
+ res = EINVAL;
+ } else {
+ res = EOK;
+ }
+
+ Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
+ return res;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * RcSetOption --
+ *
+ * This function is invoked to configure a channel option.
+ *
+ * Results:
+ * A standard Tcl result code.
+ *
+ * Side effects:
+ * Arbitrary, as it calls upon a Tcl script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+RcSetOption (clientData, interp, optionName, newValue)
+ ClientData clientData; /* Channel to query */
+ Tcl_Interp *interp; /* Interpreter to leave error messages in */
+ CONST char *optionName; /* Name of requested option */
+ CONST char *newValue; /* The new value */
+{
+ ReflectingChannel* rcPtr = (ReflectingChannel*) clientData;
+ Tcl_Obj* optionObj;
+ Tcl_Obj* valueObj;
+ int res; /* Result code for 'configure' */
+ Tcl_Obj* resObj; /* Result data for 'configure' */
+
+#ifdef TCL_THREADS
+ /* Are we in the correct thread ?
+ */
+
+ if (rcPtr->thread != Tcl_GetCurrentThread ()) {
+ RcForwardParamSetOpt p;
+
+ p.name = optionName;
+ p.value = newValue;
+
+ RcForwardOp (rcPtr, RcOpSetOpt, rcPtr->thread, &p);
+
+ if (p.b.code != TCL_OK) {
+ Tcl_Obj* err = Tcl_NewStringObj (p.b.msg, -1);
+
+ RcErrorReturn (interp, err);
+
+ Tcl_DecrRefCount (err);
+ if (p.b.vol) {ckfree (p.b.msg);}
+ }
+
+ return p.b.code;
+ }
+#endif
+
+ /* -------- */
+
+ optionObj = Tcl_NewStringObj(optionName,-1);
+ if (optionObj == (Tcl_Obj*) NULL) {
+ Tcl_Panic ("Out of memory in RcSetOption");
+ }
+
+ valueObj = Tcl_NewStringObj(newValue,-1);
+ if (valueObj == (Tcl_Obj*) NULL) {
+ Tcl_Panic ("Out of memory in RcSetOption");
+ }
+
+ RcInvokeTclMethod (rcPtr, "configure", optionObj, valueObj,
+ &res, &resObj, DO_CAPTURE);
+
+ if (res != TCL_OK) {
+ RcErrorReturn (interp, resObj);
+ }
+
+ Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
+ return res;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * RcGetOption --
+ *
+ * This function is invoked to retrieve all or a channel option.
+ *
+ * Results:
+ * A standard Tcl result code.
+ *
+ * Side effects:
+ * Arbitrary, as it calls upon a Tcl script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+RcGetOption (clientData, interp, optionName, dsPtr)
+ ClientData clientData; /* Channel to query */
+ Tcl_Interp* interp; /* Interpreter to leave error messages in */
+ CONST char* optionName; /* Name of reuqested option */
+ Tcl_DString* dsPtr; /* String to place the result into */
+{
+ /* This code is special. It has regular passing of Tcl result, and
+ * errors. The bypass functions are not required.
+ */
+
+ ReflectingChannel* rcPtr = (ReflectingChannel*) clientData;
+ Tcl_Obj* optionObj;
+ int res; /* Result code for 'configure' */
+ Tcl_Obj* resObj; /* Result data for 'configure' */
+ int listc;
+ Tcl_Obj** listv;
+ const char* method;
+
+#ifdef TCL_THREADS
+ /* Are we in the correct thread ?
+ */
+
+ if (rcPtr->thread != Tcl_GetCurrentThread ()) {
+ int opcode;
+ RcForwardParamGetOpt p;
+
+ p.name = optionName;
+ p.value = dsPtr;
+
+ if (optionName == (char*) NULL) {
+ opcode = RcOpGetOptAll;
+ } else {
+ opcode = RcOpGetOpt;
+ }
+
+ RcForwardOp (rcPtr, opcode, rcPtr->thread, &p);
+
+ if (p.b.code != TCL_OK) {
+ Tcl_Obj* err = Tcl_NewStringObj (p.b.msg, -1);
+
+ RcErrorReturn (interp, err);
+
+ Tcl_DecrRefCount (err);
+ if (p.b.vol) {ckfree (p.b.msg);}
+ }
+
+ return p.b.code;
+ }
+#endif
+
+ /* -------- */
+
+ if (optionName == (char*) NULL) {
+ /* Retrieve all options. */
+ method = "cgetall";
+ optionObj = NULL;
+ } else {
+ /* Retrieve the value of one option */
+
+ method = "cget";
+ optionObj = Tcl_NewStringObj(optionName,-1);
+ if (optionObj == (Tcl_Obj*) NULL) {
+ Tcl_Panic ("Out of memory in RcGetOption");
+ }
+ }
+
+ RcInvokeTclMethod (rcPtr, method, optionObj, NULL,
+ &res, &resObj, DO_CAPTURE);
+
+ if (res != TCL_OK) {
+ RcErrorReturn (interp, resObj);
+ Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
+ return res;
+ }
+
+ /* The result has to go into the 'dsPtr' for propagation to the
+ * caller of the driver.
+ */
+
+ if (optionObj != NULL) {
+ Tcl_DStringAppend (dsPtr, Tcl_GetString (resObj), -1);
+ Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
+ return res;
+ }
+
+ /* Extract the list and append each item as element.
+ */
+
+ /* NOTE (4): If we extract the string rep we can assume a
+ * NOTE (4): properly quoted string. Together with a separating
+ * NOTE (4): space this way of simply appending the whole string
+ * NOTE (4): rep might be faster. It also doesn't check if the
+ * NOTE (4): result is a valid list. Nor that the list has an
+ * NOTE (4): even number elements.
+ * NOTE (4): ---
+ */
+
+ res = Tcl_ListObjGetElements (interp, resObj, &listc, &listv);
+
+ if (res != TCL_OK) {
+ Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
+ return res;
+ }
+
+ if ((listc % 2) == 1) {
+ /* Odd number of elements is wrong.
+ */
+
+ char buf [20];
+
+ sprintf (buf, "%d", listc);
+ Tcl_ResetResult (interp);
+ Tcl_AppendResult (interp,
+ "Expected list with even number of elements, got ",
+ buf, (listc == 1 ? " element" : " elements"),
+ " instead", (char*) NULL);
+
+ Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
+ return TCL_ERROR;
+ }
+
+
+ {
+ int len;
+ char* str = Tcl_GetStringFromObj (resObj, &len);
+
+ if (len) {
+ Tcl_DStringAppend (dsPtr, " ", 1);
+ Tcl_DStringAppend (dsPtr, str, len);
+ }
+ }
+ Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
+ return res;
+}
+
+/*
+ * Helpers. =========================================================
+ */
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * RcEncodeEventMask --
+ *
+ * This function takes a list of event items and constructs the
+ * equivalent internal bitmask. The list has to contain at
+ * least one element. Elements are "read", "write", or any unique
+ * abbreviation thereof. Note that the bitmask is not changed if
+ * problems are encountered.
+ *
+ * Results:
+ * A standard Tcl error code. A bitmask where TCL_READABLE
+ * and/or TCL_WRITABLE can be set.
+ *
+ * Side effects:
+ * May shimmer 'obj' to a list representation. May place an
+ * error message into the interp result.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+RcEncodeEventMask (interp, objName, obj, mask)
+ Tcl_Interp* interp;
+ CONST char* objName;
+ Tcl_Obj* obj;
+ int* mask;
+{
+ int events; /* Mask of events to post */
+ int listc; /* #elements in eventspec list */
+ Tcl_Obj** listv; /* Elements of eventspec list */
+ int evIndex; /* Id of event for an element of the
+ * eventspec list */
+
+ if (Tcl_ListObjGetElements (interp, obj,
+ &listc, &listv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (listc < 1) {
+ Tcl_AppendResult(interp, "bad ", objName, " list: is empty",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ events = 0;
+ while (listc > 0) {
+ if (Tcl_GetIndexFromObj (interp, listv [listc-1],
+ eventOptions, objName, 0, &evIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (evIndex) {
+ case EVENT_READ: events |= TCL_READABLE; break;
+ case EVENT_WRITE: events |= TCL_WRITABLE; break;
+ }
+ listc --;
+ }
+
+ *mask = events;
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * RcDecodeEventMask --
+ *
+ * This function takes an internal bitmask of events and
+ * constructs the equivalent list of event items.
+ *
+ * Results:
+ * A Tcl_Obj reference. The object will have a refCount of
+ * one. The user has to decrement it to release the object.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_Obj*
+RcDecodeEventMask (mask)
+{
+ Tcl_Obj* evObj = Tcl_NewStringObj (((mask & RANDW) == RANDW) ?
+ "read write" :
+ ((mask & TCL_READABLE) ?
+ "read" :
+ ((mask & TCL_WRITABLE) ?
+ "write" : "")), -1);
+ if (evObj == (Tcl_Obj*) NULL) {
+ Tcl_Panic ("Out of memory in RcDecodeEventMask");
+ }
+
+ Tcl_IncrRefCount (evObj);
+ return evObj;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * RcNew --
+ *
+ * This function is invoked to allocate and initialize the
+ * instance data of a new reflected channel.
+ *
+ * Results:
+ * A heap-allocated channel instance.
+ *
+ * Side effects:
+ * Allocates memory.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static ReflectingChannel*
+RcNew (interp, cmdpfxObj, mode, id)
+ Tcl_Interp* interp;
+ Tcl_Obj* cmdpfxObj;
+ int mode;
+ Tcl_Obj* id;
+{
+ ReflectingChannel* rcPtr;
+ int listc;
+ Tcl_Obj** listv;
+ Tcl_Obj* word;
+ int i;
+
+ rcPtr = (ReflectingChannel*) ckalloc (sizeof(ReflectingChannel));
+
+ /* rcPtr->chan : Assigned by caller. Dummy data here. */
+ /* rcPtr->methods : Assigned by caller. Dummy data here. */
+
+ rcPtr->chan = (Tcl_Channel) NULL;
+ rcPtr->methods = 0;
+ rcPtr->interp = interp;
+#ifdef TCL_THREADS
+ rcPtr->thread = Tcl_GetCurrentThread ();
+#endif
+ rcPtr->mode = mode;
+ rcPtr->interest = 0; /* Initially no interest registered */
+
+ /* Method placeholder */
+
+ /* ASSERT: cmdpfxObj is a Tcl List */
+
+ Tcl_ListObjGetElements (interp, cmdpfxObj, &listc, &listv);
+
+ /* See [==] as well.
+ * Storage for the command prefix and the additional words required
+ * for the invocation of methods in the command handler.
+ *
+ * listv [0] [listc-1] | [listc] [listc+1] |
+ * argv [0] ... [.] | [argc-2] [argc-1] | [argc] [argc+2]
+ * cmd ... pfx | method chan | detail1 detail2
+ */
+
+ rcPtr->argc = listc + 2;
+ rcPtr->argv = (Tcl_Obj**) ckalloc (sizeof (Tcl_Obj*) * (listc+4));
+
+ for (i = 0; i < listc ; i++) {
+ word = rcPtr->argv [i] = listv [i];
+ Tcl_IncrRefCount (word);
+ }
+
+ i++; /* Skip placeholder for method */
+
+ rcPtr->argv [i] = id ; Tcl_IncrRefCount (id);
+
+ /* The next two objects are kept empty, varying arguments */
+
+ /* Initialization complete */
+ return rcPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * RcNewHandle --
+ *
+ * This function is invoked to generate a channel handle for
+ * a new reflected channel.
+ *
+ * Results:
+ * A Tcl_Obj containing the string of the new channel handle.
+ * The refcount of the returned object is -- zero --.
+ *
+ * Side effects:
+ * May allocate memory. Mutex protected critical section
+ * locks out other threads for a short time.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj*
+RcNewHandle ()
+{
+ /* Count number of generated reflected channels. Used for id
+ * generation. Ids are never reclaimed and there is no dealing
+ * with wrap around. On the other hand, "unsigned long" should be
+ * big enough except for absolute longrunners (generate a 100 ids
+ * per second => overflow will occur in 1 1/3 years).
+ */
+
+#ifdef TCL_THREADS
+ TCL_DECLARE_MUTEX (rcCounterMutex)
+#endif
+ static unsigned long rcCounter = 0;
+
+ char channelName [50];
+ Tcl_Obj* res = Tcl_NewStringObj ("rc", -1);
+
+#ifdef TCL_THREADS
+ Tcl_MutexLock (&rcCounterMutex);
+#endif
+
+ sprintf (channelName, "%lu", (unsigned long) rcCounter);
+ rcCounter ++;
+
+#ifdef TCL_THREADS
+ Tcl_MutexUnlock (&rcCounterMutex);
+#endif
+
+ Tcl_AppendStringsToObj (res, channelName, (char*) NULL);
+ return res;
+}
+
+
+static void
+RcFree (rcPtr)
+ ReflectingChannel* rcPtr;
+{
+ Channel* chanPtr = (Channel*) rcPtr->chan;
+ int i, n;
+
+ if (chanPtr->typePtr != &tclRChannelType) {
+ /* Delete a cloned ChannelType structure. */
+ ckfree ((char*) chanPtr->typePtr);
+ }
+
+ n = rcPtr->argc - 2;
+ for (i = 0; i < n; i++) {
+ Tcl_DecrRefCount (rcPtr->argv[i]);
+ }
+
+ ckfree ((char*) rcPtr->argv);
+ ckfree ((char*) rcPtr);
+ return;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * RcInvokeTclMethod --
+ *
+ * This function is used to invoke the Tcl level of a reflected
+ * channel. It handles all the command assembly, invokation, and
+ * generic state and result mgmt.
+ *
+ * Results:
+ * Result code and data as returned by the method.
+ *
+ * Side effects:
+ * Arbitrary, as it calls upo na Tcl script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+RcInvokeTclMethod (rcPtr, method, argone, argtwo, result, resultObj, capture)
+ ReflectingChannel* rcPtr;
+ CONST char* method;
+ Tcl_Obj* argone; /* NULL'able */
+ Tcl_Obj* argtwo; /* NULL'able */
+ int* result; /* NULL'able */
+ Tcl_Obj** resultObj; /* NULL'able */
+ int capture;
+{
+ /* Thread redirection was done by higher layers */
+ /* ASSERT: Tcl_GetCurrentThread () == rcPtr->thread */
+
+ int cmdc; /* #words in constructed command */
+ Tcl_Obj* methObj = NULL; /* Method name in object form */
+ Tcl_InterpState sr; /* State of handler interp */
+ int res; /* Result code of method invokation */
+ Tcl_Obj* resObj = NULL; /* Result of method invokation. */
+
+ /* NOTE (5): Decide impl. issue: Cache objects with method names ?
+ * NOTE (5): Requires TSD data as reflections can be created in
+ * NOTE (5): many different threads.
+ * NOTE (5): ---
+ */
+
+ /* Insert method into the pre-allocated area, after the command
+ * prefix, before the channel id.
+ */
+
+ methObj = Tcl_NewStringObj (method, -1);
+ if (methObj == (Tcl_Obj*) NULL) {
+ Tcl_Panic ("Out of memory in RcInvokeTclMethod");
+ }
+ Tcl_IncrRefCount (methObj);
+ rcPtr->argv [rcPtr->argc - 2] = methObj;
+
+ /* Append the additional argument containing method specific
+ * details behind the channel id. If specified.
+ */
+
+ cmdc = rcPtr->argc ;
+ if (argone) {
+ Tcl_IncrRefCount (argone);
+ rcPtr->argv [cmdc] = argone;
+ cmdc++;
+ }
+ if (argtwo) {
+ Tcl_IncrRefCount (argtwo);
+ rcPtr->argv [cmdc] = argtwo;
+ cmdc++;
+ }
+
+ /* And run the handler ... This is done in auch a manner which
+ * leaves any existing state intact.
+ */
+
+ sr = Tcl_SaveInterpState (rcPtr->interp, 0 /* Dummy */);
+ res = Tcl_EvalObjv (rcPtr->interp, cmdc, rcPtr->argv, TCL_EVAL_GLOBAL);
+
+ /* We do not try to extract the result information if the caller has no
+ * interest in it. I.e. there is no need to put effort into creating
+ * something which is discarded immediately after.
+ */
+
+ if (resultObj) {
+ if ((res == TCL_OK) || !capture) {
+ /* Ok result taken as is, also if the caller requests that there
+ * is no capture.
+ */
+
+ resObj = Tcl_GetObjResult (rcPtr->interp);
+ } else {
+ /* Non-ok ressult is always treated as an error.
+ * We have to capture the full state of the result,
+ * including additional options.
+ */
+
+ res = TCL_ERROR;
+ resObj = RcErrorMarshall (rcPtr->interp);
+ }
+ Tcl_IncrRefCount(resObj);
+ }
+ Tcl_RestoreInterpState (rcPtr->interp, sr);
+
+ /* ... */
+
+ /* Cleanup of the dynamic parts of the command */
+
+ Tcl_DecrRefCount (methObj);
+ if (argone) {Tcl_DecrRefCount (argone);}
+ if (argtwo) {Tcl_DecrRefCount (argtwo);}
+
+ /* The resObj has a ref count of 1 at this location. This means
+ * that the caller of RcInvoke has to dispose of it (but only if
+ * it was returned to it).
+ */
+
+ if (result) {
+ *result = res;
+ }
+ if (resultObj) {
+ *resultObj = resObj;
+ }
+ /* There no need to handle the case where nothing is returned, because for
+ * that case resObj was not set anyway.
+ */
+}
+
+#ifdef TCL_THREADS
+static void
+RcForwardOp (rcPtr, op, dst, param)
+ ReflectingChannel* rcPtr; /* Channel instance */
+ RcOperation op; /* Forwarded driver operation */
+ Tcl_ThreadId dst; /* Destination thread */
+ CONST VOID* param; /* Arguments */
+{
+ RcForwardingEvent* evPtr;
+ RcForwardingResult* resultPtr;
+ int result;
+
+ /* Create and initialize the event and data structures */
+
+ evPtr = (RcForwardingEvent*) ckalloc (sizeof (RcForwardingEvent));
+ resultPtr = (RcForwardingResult*) ckalloc (sizeof (RcForwardingResult));
+
+ evPtr->event.proc = RcForwardProc;
+ evPtr->resultPtr = resultPtr;
+ evPtr->op = op;
+ evPtr->rcPtr = rcPtr;
+ evPtr->param = param;
+
+ resultPtr->src = Tcl_GetCurrentThread ();
+ resultPtr->dst = dst;
+ resultPtr->done = (Tcl_Condition) NULL;
+ resultPtr->result = -1;
+ resultPtr->evPtr = evPtr;
+
+ /* Now execute the forward */
+
+ Tcl_MutexLock(&rcForwardMutex);
+ TclSpliceIn(resultPtr, forwardList);
+
+ /*
+ * Ensure cleanup of the event if any of the two involved threads
+ * exits while this event is pending or in progress.
+ */
+
+ Tcl_CreateThreadExitHandler(RcSrcExitProc, (ClientData) evPtr);
+ Tcl_CreateThreadExitHandler(RcDstExitProc, (ClientData) evPtr);
+
+ /*
+ * Queue the event and poke the other thread's notifier.
+ */
+
+ Tcl_ThreadQueueEvent(dst, (Tcl_Event*)evPtr, TCL_QUEUE_TAIL);
+ Tcl_ThreadAlert(dst);
+
+ /*
+ * (*) Block until the other thread has either processed the transfer
+ * or rejected it.
+ */
+
+ while (resultPtr->result < 0) {
+ /* NOTE (1): Is it possible that the current thread goes away while waiting here ?
+ * NOTE (1): IOW Is it possible that "RcSrcExitProc" is called while we are here ?
+ * NOTE (1): See complementary note (2) in "RcSrcExitProc"
+ * NOTE (1): ---
+ */
+
+ Tcl_ConditionWait(&resultPtr->done, &rcForwardMutex, NULL);
+ }
+
+ /*
+ * Unlink result from the forwarder list.
+ */
+
+ TclSpliceOut(resultPtr, forwardList);
+
+ resultPtr->nextPtr = NULL;
+ resultPtr->prevPtr = NULL;
+
+ Tcl_MutexUnlock(&rcForwardMutex);
+ Tcl_ConditionFinalize(&resultPtr->done);
+
+ /*
+ * Kill the cleanup handlers now, and the result structure as well,
+ * before returning the success code.
+ *
+ * Note: The event structure has already been deleted.
+ */
+
+ Tcl_DeleteThreadExitHandler(RcSrcExitProc, (ClientData) evPtr);
+ Tcl_DeleteThreadExitHandler(RcDstExitProc, (ClientData) evPtr);
+
+ result = resultPtr->result;
+ ckfree ((char*) resultPtr);
+}
+
+static int
+RcForwardProc (evGPtr, mask)
+ Tcl_Event *evGPtr;
+ int mask;
+{
+ /* Notes regarding access to the referenced data.
+ *
+ * In principle the data belongs to the originating thread (see
+ * evPtr->src), however this thread is currently blocked at (*),
+ * i.e. quiescent. Because of this we can treat the data as
+ * belonging to us, without fear of race conditions. I.e. we can
+ * read and write as we like.
+ *
+ * The only thing we cannot be sure of is the resultPtr. This can be
+ * be NULLed if the originating thread went away while the event
+ * is handled here now.
+ */
+
+ RcForwardingEvent* evPtr = (RcForwardingEvent*) evGPtr;
+ RcForwardingResult* resultPtr = evPtr->resultPtr;
+ ReflectingChannel* rcPtr = evPtr->rcPtr;
+ Tcl_Interp* interp = rcPtr->interp;
+ RcForwardParamBase* paramPtr = (RcForwardParamBase*) evPtr->param;
+ int res = TCL_OK; /* Result code of RcInvokeTclMethod */
+ Tcl_Obj* resObj = NULL; /* Interp result of RcInvokeTclMethod */
+
+ /* Ignore the event if no one is waiting for its result anymore.
+ */
+
+ if (!resultPtr) {
+ return 1;
+ }
+
+ paramPtr->code = TCL_OK;
+ paramPtr->msg = NULL;
+ paramPtr->vol = 0;
+
+ switch (evPtr->op) {
+ /* The destination thread for the following operations is
+ * rcPtr->thread, which contains rcPtr->interp, the interp
+ * we have to call upon for the driver.
+ */
+
+ case RcOpClose:
+ {
+ /* No parameters/results */
+ RcInvokeTclMethod (rcPtr, "finalize", NULL, NULL,
+ &res, &resObj, DO_CAPTURE);
+
+ if (res != TCL_OK) {
+ RcForwardSetObjError (paramPtr, resObj);
+ }
+
+ /* Freeing is done here, in the origin thread, because the
+ * argv[] objects belong to this thread. Deallocating them
+ * in a different thread is not allowed
+ */
+
+ RcFree (rcPtr);
+ }
+ break;
+
+ case RcOpInput:
+ {
+ RcForwardParamInput* p = (RcForwardParamInput*) paramPtr;
+ Tcl_Obj* toReadObj = Tcl_NewIntObj (p->toRead);
+
+ if (toReadObj == (Tcl_Obj*) NULL) {
+ Tcl_Panic ("Out of memory in RcInput");
+ }
+
+ RcInvokeTclMethod (rcPtr, "read", toReadObj, NULL,
+ &res, &resObj, DO_CAPTURE);
+
+ if (res != TCL_OK) {
+ RcForwardSetObjError (paramPtr, resObj);
+ p->toRead = -1;
+ } else {
+ /* Process a regular result. */
+
+ int bytec; /* Number of returned bytes */
+ unsigned char* bytev; /* Array of returned bytes */
+
+ bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
+
+ if (p->toRead < bytec) {
+ RcForwardSetStaticError (paramPtr, msg_read_toomuch);
+ p->toRead = -1;
+
+ } else {
+ if (bytec > 0) {
+ memcpy (p->buf, bytev, bytec);
+ }
+
+ p->toRead = bytec;
+ }
+ }
+ }
+ break;
+
+ case RcOpOutput:
+ {
+ RcForwardParamOutput* p = (RcForwardParamOutput*) paramPtr;
+ Tcl_Obj* bufObj = Tcl_NewByteArrayObj((unsigned char*) p->buf, p->toWrite);
+
+ if (bufObj == (Tcl_Obj*) NULL) {
+ Tcl_Panic ("Out of memory in RcOutput");
+ }
+
+ RcInvokeTclMethod (rcPtr, "write", bufObj, NULL,
+ &res, &resObj, DO_CAPTURE);
+
+ if (res != TCL_OK) {
+ RcForwardSetObjError (paramPtr, resObj);
+ p->toWrite = -1;
+ } else {
+ /* Process a regular result. */
+
+ int written;
+
+ res = Tcl_GetIntFromObj (interp, resObj, &written);
+ if (res != TCL_OK) {
+
+ RcForwardSetObjError (paramPtr, RcErrorMarshall (interp));
+ p->toWrite = -1;
+
+ } else if ((written == 0) || (p->toWrite < written)) {
+
+ RcForwardSetStaticError (paramPtr, msg_write_toomuch);
+ p->toWrite = -1;
+
+ } else {
+ p->toWrite = written;
+ }
+ }
+ }
+ break;
+
+ case RcOpSeek:
+ {
+ RcForwardParamSeek* p = (RcForwardParamSeek*) paramPtr;
+
+ Tcl_Obj* offObj;
+ Tcl_Obj* baseObj;
+
+ offObj = Tcl_NewWideIntObj(p->offset);
+ if (offObj == (Tcl_Obj*) NULL) {
+ Tcl_Panic ("Out of memory in RcSeekWide");
+ }
+
+ baseObj = Tcl_NewStringObj((p->seekMode == SEEK_SET) ?
+ "start" :
+ ((p->seekMode == SEEK_CUR) ?
+ "current" :
+ "end"), -1);
+
+ if (baseObj == (Tcl_Obj*) NULL) {
+ Tcl_Panic ("Out of memory in RcSeekWide");
+ }
+
+ RcInvokeTclMethod (rcPtr, "seek", offObj, baseObj,
+ &res, &resObj, DO_CAPTURE);
+
+ if (res != TCL_OK) {
+ RcForwardSetObjError (paramPtr, resObj);
+ p->offset = -1;
+ } else {
+ /* Process a regular result. If the type is wrong this
+ * may change into an error.
+ */
+
+ Tcl_WideInt newLoc;
+ res = Tcl_GetWideIntFromObj (interp, resObj, &newLoc);
+
+ if (res == TCL_OK) {
+ if (newLoc < Tcl_LongAsWide (0)) {
+ RcForwardSetStaticError (paramPtr, msg_seek_beforestart);
+ p->offset = -1;
+ } else {
+ p->offset = newLoc;
+ }
+ } else {
+ RcForwardSetObjError (paramPtr, RcErrorMarshall (interp));
+ p->offset = -1;
+ }
+ }
+ }
+ break;
+
+ case RcOpWatch:
+ {
+ RcForwardParamWatch* p = (RcForwardParamWatch*) paramPtr;
+
+ Tcl_Obj* maskObj = RcDecodeEventMask (p->mask);
+ RcInvokeTclMethod (rcPtr, "watch", maskObj, NULL,
+ NULL, NULL, NO_CAPTURE);
+ Tcl_DecrRefCount (maskObj);
+ }
+ break;
+
+ case RcOpBlock:
+ {
+ RcForwardParamBlock* p = (RcForwardParamBlock*) evPtr->param;
+ Tcl_Obj* blockObj = Tcl_NewBooleanObj(!p->nonblocking);
+
+ if (blockObj == (Tcl_Obj*) NULL) {
+ Tcl_Panic ("Out of memory in RcBlock");
+ }
+
+ RcInvokeTclMethod (rcPtr, "blocking", blockObj, NULL,
+ &res, &resObj, DO_CAPTURE);
+
+ if (res != TCL_OK) {
+ RcForwardSetObjError (paramPtr, resObj);
+ }
+ }
+ break;
+
+ case RcOpSetOpt:
+ {
+ RcForwardParamSetOpt* p = (RcForwardParamSetOpt*) paramPtr;
+ Tcl_Obj* optionObj;
+ Tcl_Obj* valueObj;
+
+ optionObj = Tcl_NewStringObj(p->name,-1);
+ if (optionObj == (Tcl_Obj*) NULL) {
+ Tcl_Panic ("Out of memory in RcSetOption");
+ }
+
+ valueObj = Tcl_NewStringObj(p->value,-1);
+ if (valueObj == (Tcl_Obj*) NULL) {
+ Tcl_Panic ("Out of memory in RcSetOption");
+ }
+
+ RcInvokeTclMethod (rcPtr, "configure", optionObj, valueObj,
+ &res, &resObj, DO_CAPTURE);
+
+ if (res != TCL_OK) {
+ RcForwardSetObjError (paramPtr, resObj);
+ }
+ }
+ break;
+
+ case RcOpGetOpt:
+ {
+ /* Retrieve the value of one option */
+
+ RcForwardParamGetOpt* p = (RcForwardParamGetOpt*) paramPtr;
+ Tcl_Obj* optionObj;
+
+ optionObj = Tcl_NewStringObj(p->name,-1);
+ if (optionObj == (Tcl_Obj*) NULL) {
+ Tcl_Panic ("Out of memory in RcGetOption");
+ }
+
+ RcInvokeTclMethod (rcPtr, "cget", optionObj, NULL,
+ &res, &resObj, DO_CAPTURE);
+
+ if (res != TCL_OK) {
+ RcForwardSetObjError (paramPtr, resObj);
+ } else {
+ Tcl_DStringAppend (p->value, Tcl_GetString (resObj), -1);
+ }
+ }
+ break;
+
+ case RcOpGetOptAll:
+ {
+ /* Retrieve all options. */
+
+ RcForwardParamGetOpt* p = (RcForwardParamGetOpt*) paramPtr;
+
+ RcInvokeTclMethod (rcPtr, "cgetall", NULL, NULL,
+ &res, &resObj, DO_CAPTURE);
+
+ if (res != TCL_OK) {
+ RcForwardSetObjError (paramPtr, resObj);
+ } else {
+ /* Extract list, validate that it is a list, and
+ * #elements. See NOTE (4) as well.
+ */
+
+ int listc;
+ Tcl_Obj** listv;
+
+ res = Tcl_ListObjGetElements (interp, resObj, &listc, &listv);
+ if (res != TCL_OK) {
+ RcForwardSetObjError (paramPtr, RcErrorMarshall (interp));
+
+ } else if ((listc % 2) == 1) {
+ /* Odd number of elements is wrong.
+ * [x].
+ */
+
+ char* buf = ckalloc (200);
+ sprintf (buf,
+ "{Expected list with even number of elements, got %d %s instead}",
+ listc,
+ (listc == 1 ? "element" : "elements"));
+
+ RcForwardSetDynError (paramPtr, buf);
+ } else {
+ int len;
+ char* str = Tcl_GetStringFromObj (resObj, &len);
+
+ if (len) {
+ Tcl_DStringAppend (p->value, " ", 1);
+ Tcl_DStringAppend (p->value, str, len);
+ }
+ }
+ }
+ }
+ break;
+
+ default:
+ /* Bad operation code */
+ Tcl_Panic ("Bad operation code in RcForwardProc");
+ break;
+ }
+
+ /* Remove the reference we held on the result of the invoke, if we had
+ * such
+ */
+ if (resObj != NULL) {
+ Tcl_DecrRefCount (resObj);
+ }
+
+ if (resultPtr) {
+ /*
+ * Report the forwarding result synchronously to the waiting
+ * caller. This unblocks (*) as well. This is wrapped into a
+ * conditional because the caller may have exited in the mean
+ * time.
+ */
+
+ Tcl_MutexLock(&rcForwardMutex);
+ resultPtr->result = TCL_OK;
+ Tcl_ConditionNotify(&resultPtr->done);
+ Tcl_MutexUnlock(&rcForwardMutex);
+ }
+
+ return 1;
+}
+
+
+static void
+RcSrcExitProc (clientData)
+ ClientData clientData;
+{
+ RcForwardingEvent* evPtr = (RcForwardingEvent*) clientData;
+ RcForwardingResult* resultPtr;
+ RcForwardParamBase* paramPtr;
+
+ /* NOTE (2): Can this handler be called with the originator blocked ?
+ * NOTE (2): ---
+ */
+
+ /* The originator for the event exited. It is not sure if this
+ * can happen, as the originator should be blocked at (*) while
+ * the event is in transit/pending.
+ */
+
+ /*
+ * We make sure that the event cannot refer to the result anymore,
+ * remove it from the list of pending results and free the
+ * structure. Locking the access ensures that we cannot get in
+ * conflict with "RcForwardProc", should it already execute the
+ * event.
+ */
+
+ Tcl_MutexLock(&rcForwardMutex);
+
+ resultPtr = evPtr->resultPtr;
+ paramPtr = (RcForwardParamBase*) evPtr->param;
+
+ evPtr->resultPtr = NULL;
+ resultPtr->evPtr = NULL;
+ resultPtr->result = TCL_ERROR;
+
+ RcForwardSetStaticError (paramPtr, msg_send_originlost);
+
+ /* See below: TclSpliceOut(resultPtr, forwardList); */
+
+ Tcl_MutexUnlock(&rcForwardMutex);
+
+ /*
+ * This unlocks (*). The structure will be spliced out and freed by
+ * "RcForwardProc". Maybe.
+ */
+
+ Tcl_ConditionNotify(&resultPtr->done);
+}
+
+
+static void
+RcDstExitProc (clientData)
+ ClientData clientData;
+{
+ RcForwardingEvent* evPtr = (RcForwardingEvent*) clientData;
+ RcForwardingResult* resultPtr = evPtr->resultPtr;
+ RcForwardParamBase* paramPtr = (RcForwardParamBase*) evPtr->param;
+
+ /* NOTE (3): It is not clear if the event still exists when this handler is called..
+ * NOTE (3): We might have to use 'resultPtr' as our clientData instead.
+ * NOTE (3): ---
+ */
+
+ /* The receiver for the event exited, before processing the
+ * event. We detach the result now, wake the originator up
+ * and signal failure.
+ */
+
+ evPtr->resultPtr = NULL;
+ resultPtr->evPtr = NULL;
+ resultPtr->result = TCL_ERROR;
+
+ RcForwardSetStaticError (paramPtr, msg_send_dstlost);
+
+ Tcl_ConditionNotify(&resultPtr->done);
+}
+
+
+static void
+RcForwardSetObjError (p,obj)
+ RcForwardParamBase* p;
+ Tcl_Obj* obj;
+{
+ int len;
+ char* msg;
+
+ msg = Tcl_GetStringFromObj (obj, &len);
+
+ p->code = TCL_ERROR;
+ p->vol = 1;
+ p->msg = strcpy(ckalloc (1+len), msg);
+}
+#endif
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 74d4eb2..027f7c6 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.202.2.33 2005/08/24 21:49:22 dgp Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.202.2.34 2005/08/25 15:46:31 dgp Exp $
*/
#ifndef _TCLINT
@@ -1530,6 +1530,15 @@ typedef struct Interp {
* inserted by an ensemble. */
} ensembleRewrite;
+ /* TIP #219 ... Global info for the I/O system ...
+ * Error message set by channel drivers, for the propagation of
+ * arbitrary Tcl errors. This information, if present (chanMsg not
+ * NULL), takes precedence over a posix error code returned by a
+ * channel operation.
+ */
+
+ Tcl_Obj* chanMsg;
+
/*
* Statistical information about the bytecode compiler and interpreter's
* operation.
@@ -1542,6 +1551,42 @@ typedef struct Interp {
} Interp;
/*
+ * General list of interpreters. Doubly linked for easier
+ * removal of items deep in the list.
+ */
+
+typedef struct InterpList {
+ Interp* interpPtr;
+ struct InterpList* prevPtr;
+ struct InterpList* nextPtr;
+} InterpList;
+
+/*
+ * Macros for splicing into and out of doubly linked lists.
+ * They assume existence of struct items 'prevPtr' and 'nextPtr'.
+ *
+ * a = element to add or remove.
+ * b = list head.
+ *
+ * TclSpliceIn adds to the head of the list.
+ */
+
+#define TclSpliceIn(a,b) \
+ (a)->nextPtr = (b); \
+ if ((b) != NULL) \
+ (b)->prevPtr = (a); \
+ (a)->prevPtr = NULL, (b) = (a);
+
+#define TclSpliceOut(a,b) \
+ if ((a)->prevPtr != NULL) \
+ (a)->prevPtr->nextPtr = (a)->nextPtr; \
+ else \
+ (b) = (a)->nextPtr; \
+ if ((a)->nextPtr != NULL) \
+ (a)->nextPtr->prevPtr = (a)->prevPtr;
+
+
+/*
* EvalFlag bits for Interp structures:
*
* TCL_ALLOW_EXCEPTIONS 1 means it's OK for the script to terminate with
@@ -1969,6 +2014,12 @@ MODULE_SCOPE double TclBignumToDouble _ANSI_ARGS_((mp_int* bignum));
MODULE_SCOPE double TclCeil _ANSI_ARGS_((mp_int* a));
MODULE_SCOPE int TclCheckBadOctal _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *value));
+MODULE_SCOPE int TclChanCreateObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+MODULE_SCOPE int TclChanPostEventObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+MODULE_SCOPE int TclChanCaughtErrorBypass _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Channel chan));
MODULE_SCOPE void TclCleanupLiteralTable _ANSI_ARGS_((
Tcl_Interp* interp, LiteralTable* tablePtr));
MODULE_SCOPE int TclDoubleDigits _ANSI_ARGS_((char* buf,
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 83dfc88..4895bd0 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclObj.c,v 1.72.2.30 2005/08/23 18:28:51 kennykb Exp $
+ * RCS: @(#) $Id: tclObj.c,v 1.72.2.31 2005/08/25 15:46:31 dgp Exp $
*/
#include "tclInt.h"
@@ -129,7 +129,7 @@ typedef struct PendingObjData {
* Macro to set up the local reference to the deletion context.
*/
#ifndef TCL_THREADS
-PendingObjData pendingObjData;
+static PendingObjData pendingObjData;
#define ObjInitDeletionContext(contextPtr) \
PendingObjData *CONST contextPtr = &pendingObjData
#else
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index ace7938..d53692f 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -8,11 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
-<<<<<<< tclStubInit.c
- * RCS: @(#) $Id: tclStubInit.c,v 1.109.2.15 2005/08/23 06:15:21 dgp Exp $
-=======
- * RCS: @(#) $Id: tclStubInit.c,v 1.109.2.15 2005/08/23 06:15:21 dgp Exp $
->>>>>>> 1.121
+ * RCS: @(#) $Id: tclStubInit.c,v 1.109.2.16 2005/08/25 15:46:31 dgp Exp $
*/
#include "tclInt.h"
@@ -988,6 +984,10 @@ TclStubs tclStubs = {
Tcl_GetBignumFromObj, /* 558 */
Tcl_TruncateChannel, /* 559 */
Tcl_ChannelTruncateProc, /* 560 */
+ Tcl_SetChannelErrorInterp, /* 561 */
+ Tcl_GetChannelErrorInterp, /* 562 */
+ Tcl_SetChannelError, /* 563 */
+ Tcl_GetChannelError, /* 564 */
};
/* !END!: Do not edit above this line. */
diff --git a/generic/tclTest.c b/generic/tclTest.c
index d89a14f..ff8d896 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclTest.c,v 1.86.2.5 2005/08/17 19:12:10 kennykb Exp $
+ * RCS: @(#) $Id: tclTest.c,v 1.86.2.6 2005/08/25 15:46:31 dgp Exp $
*/
#define TCL_TEST
@@ -121,6 +121,20 @@ typedef struct TestEvent {
Tcl_Obj* tag; /* Tag for this event used to delete it */
} TestEvent;
+
+/*
+ * Simple detach/attach facility for testchannel cut|splice.
+ * Allow testing of channel transfer in core testsuite.
+ */
+
+typedef struct TestChannel {
+ Tcl_Channel chan; /* Detached channel */
+ struct TestChannel* nextPtr; /* Next in pool of detached channels */
+} TestChannel;
+
+static TestChannel* firstDetached;
+
+
/*
* Forward declarations for procedures defined later in this file:
*/
@@ -5495,10 +5509,33 @@ TestChannelCmd(clientData, interp, argc, argv)
chanPtr = (Channel *) NULL;
if (argc > 2) {
- chan = Tcl_GetChannel(interp, argv[2], &mode);
- if (chan == (Tcl_Channel) NULL) {
- return TCL_ERROR;
- }
+ if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) {
+ /* For splice access the pool of detached channels.
+ * Locate channel, remove from the list.
+ */
+
+ TestChannel** nextPtrPtr;
+ TestChannel* curPtr;
+
+ chan = (Tcl_Channel) NULL;
+ for (nextPtrPtr = &firstDetached, curPtr = firstDetached;
+ curPtr != NULL;
+ nextPtrPtr = &(curPtr->nextPtr), curPtr = curPtr->nextPtr) {
+
+ if (strcmp (argv[2], Tcl_GetChannelName (curPtr->chan)) == 0) {
+ *nextPtrPtr = curPtr->nextPtr;
+ curPtr->nextPtr = NULL;
+ chan = curPtr->chan;
+ ckfree ((char*) curPtr);
+ break;
+ }
+ }
+ } else {
+ chan = Tcl_GetChannel(interp, argv[2], &mode);
+ }
+ if (chan == (Tcl_Channel) NULL) {
+ return TCL_ERROR;
+ }
chanPtr = (Channel *) chan;
statePtr = chanPtr->state;
chanPtr = statePtr->topChanPtr;
@@ -5509,13 +5546,62 @@ TestChannelCmd(clientData, interp, argc, argv)
chan = NULL;
}
+ if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerror", len) == 0)) {
+
+ Tcl_Obj* msg = Tcl_NewStringObj (argv [3],-1);
+
+ Tcl_IncrRefCount (msg);
+ Tcl_SetChannelError (chan, msg);
+ Tcl_DecrRefCount (msg);
+
+ Tcl_GetChannelError (chan, &msg);
+ Tcl_SetObjResult (interp, msg);
+ Tcl_DecrRefCount (msg);
+ return TCL_OK;
+ }
+ if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerrorinterp", len) == 0)) {
+
+ Tcl_Obj* msg = Tcl_NewStringObj (argv [3],-1);
+
+ Tcl_IncrRefCount (msg);
+ Tcl_SetChannelErrorInterp (interp, msg);
+ Tcl_DecrRefCount (msg);
+
+ Tcl_GetChannelErrorInterp (interp, &msg);
+ Tcl_SetObjResult (interp, msg);
+ Tcl_DecrRefCount (msg);
+ return TCL_OK;
+ }
+
+ /*
+ * "cut" is actually more a simplified detach facility as provided
+ * by the Thread package. Without the safeguards of a regular
+ * command (no checking that the command is truly cut'able, no
+ * mutexes for thread-safety). Its complementary command is
+ * "splice", see below.
+ */
+
if ((cmdName[0] == 'c') && (strncmp(cmdName, "cut", len) == 0)) {
+ TestChannel* det;
+
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" cut channelName\"", (char *) NULL);
return TCL_ERROR;
}
+
+ Tcl_RegisterChannel((Tcl_Interp *) NULL, chan); /* prevent closing */
+ Tcl_UnregisterChannel(interp, chan);
+
Tcl_CutChannel(chan);
+
+ /* Remember the channel in the pool of detached channels */
+
+ det = (TestChannel*) ckalloc (sizeof(TestChannel));
+ det->chan = chan;
+ det->nextPtr = firstDetached;
+ firstDetached = det;
+
return TCL_OK;
}
@@ -5769,6 +5855,14 @@ TestChannelCmd(clientData, interp, argc, argv)
return TCL_OK;
}
+ /*
+ * "splice" is actually more a simplified attach facility as
+ * provided by the Thread package. Without the safeguards of a
+ * regular command (no checking that the command is truly
+ * cut'able, no mutexes for thread-safety). Its complementary
+ * command is "cut", see above.
+ */
+
if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "channel name required", (char *) NULL);
@@ -5776,6 +5870,10 @@ TestChannelCmd(clientData, interp, argc, argv)
}
Tcl_SpliceChannel(chan);
+
+ Tcl_RegisterChannel(interp, chan);
+ Tcl_UnregisterChannel((Tcl_Interp *)NULL, chan);
+
return TCL_OK;
}
@@ -6815,3 +6913,11 @@ TestgetintCmd(dummy, interp, argc, argv)
return TCL_OK;
}
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c
index 8c3e2e9..66a86c7 100644
--- a/generic/tclThreadTest.c
+++ b/generic/tclThreadTest.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclThreadTest.c,v 1.17.2.1 2005/04/10 23:14:57 kennykb Exp $
+ * RCS: @(#) $Id: tclThreadTest.c,v 1.17.2.2 2005/08/25 15:46:31 dgp Exp $
*/
#include "tclInt.h"
@@ -479,6 +479,12 @@ NewTestThread(clientData)
result = Tcl_Init(tsdPtr->interp);
result = TclThread_Init(tsdPtr->interp);
+ /* This is part of the test facility.
+ * Initialize _ALL_ test commands for
+ * use by the new thread.
+ */
+ result = Tcltest_Init(tsdPtr->interp);
+
/*
* Update the list of threads.
*/
diff --git a/library/init.tcl b/library/init.tcl
index 33f3309..2c22c6f 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -3,7 +3,7 @@
# Default system startup file for Tcl-based applications. Defines
# "unknown" procedure and auto-load facilities.
#
-# RCS: @(#) $Id: init.tcl,v 1.69.2.4 2005/08/02 18:16:14 dgp Exp $
+# RCS: @(#) $Id: init.tcl,v 1.69.2.5 2005/08/25 15:46:31 dgp Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -73,24 +73,27 @@ namespace eval tcl {
unsupported::EncodingDirs $Path
}
- # Set up the 'chan' ensemble
+ # Set up the 'chan' ensemble (TIP #208).
namespace eval chan {
- namespace ensemble create -command ::chan -map {
- blocked ::fblocked
- close ::close
- configure ::fconfigure
- copy ::fcopy
- eof ::eof
- event ::fileevent
- flush ::flush
- gets ::gets
- names {::file channels}
- puts ::puts
- read ::read
- seek ::seek
- tell ::tell
- truncate ::tcl::chan::Truncate
- }
+ # TIP #219. Added methods: create, postevent.
+ namespace ensemble create -command ::chan -map {
+ blocked ::fblocked
+ close ::close
+ configure ::fconfigure
+ copy ::fcopy
+ create ::tcl::chan::rCreate
+ eof ::eof
+ event ::fileevent
+ flush ::flush
+ gets ::gets
+ names {::file channels}
+ postevent ::tcl::chan::rPostevent
+ puts ::puts
+ read ::read
+ seek ::seek
+ tell ::tell
+ truncate ::tcl::chan::Truncate
+ }
}
}
diff --git a/library/msgs/af_ZA.msg b/library/msgs/af_za.msg
index fef48ad..fef48ad 100755
--- a/library/msgs/af_ZA.msg
+++ b/library/msgs/af_za.msg
diff --git a/library/msgs/ar_IN.msg b/library/msgs/ar_in.msg
index 185e49c..185e49c 100755
--- a/library/msgs/ar_IN.msg
+++ b/library/msgs/ar_in.msg
diff --git a/library/msgs/ar_JO.msg b/library/msgs/ar_jo.msg
index 0f5e269..0f5e269 100755
--- a/library/msgs/ar_JO.msg
+++ b/library/msgs/ar_jo.msg
diff --git a/library/msgs/ar_LB.msg b/library/msgs/ar_lb.msg
index e62acd3..e62acd3 100755
--- a/library/msgs/ar_LB.msg
+++ b/library/msgs/ar_lb.msg
diff --git a/library/msgs/ar_SY.msg b/library/msgs/ar_sy.msg
index d5e1c87..d5e1c87 100755
--- a/library/msgs/ar_SY.msg
+++ b/library/msgs/ar_sy.msg
diff --git a/library/msgs/bn_IN.msg b/library/msgs/bn_in.msg
index 28c000f..28c000f 100755
--- a/library/msgs/bn_IN.msg
+++ b/library/msgs/bn_in.msg
diff --git a/library/msgs/de_AT.msg b/library/msgs/de_at.msg
index 61bc266..61bc266 100755
--- a/library/msgs/de_AT.msg
+++ b/library/msgs/de_at.msg
diff --git a/library/msgs/de_BE.msg b/library/msgs/de_be.msg
index 3614763..3614763 100755
--- a/library/msgs/de_BE.msg
+++ b/library/msgs/de_be.msg
diff --git a/library/msgs/en_AU.msg b/library/msgs/en_au.msg
index 7f9870c..7f9870c 100755
--- a/library/msgs/en_AU.msg
+++ b/library/msgs/en_au.msg
diff --git a/library/msgs/en_BE.msg b/library/msgs/en_be.msg
index 5072986..5072986 100755
--- a/library/msgs/en_BE.msg
+++ b/library/msgs/en_be.msg
diff --git a/library/msgs/en_BW.msg b/library/msgs/en_bw.msg
index 8fd20c7..8fd20c7 100755
--- a/library/msgs/en_BW.msg
+++ b/library/msgs/en_bw.msg
diff --git a/library/msgs/en_CA.msg b/library/msgs/en_ca.msg
index 278efe7..278efe7 100755
--- a/library/msgs/en_CA.msg
+++ b/library/msgs/en_ca.msg
diff --git a/library/msgs/en_GB.msg b/library/msgs/en_gb.msg
index 5c61c43..5c61c43 100755
--- a/library/msgs/en_GB.msg
+++ b/library/msgs/en_gb.msg
diff --git a/library/msgs/en_HK.msg b/library/msgs/en_hk.msg
index 8b33bc0..8b33bc0 100755
--- a/library/msgs/en_HK.msg
+++ b/library/msgs/en_hk.msg
diff --git a/library/msgs/en_IE.msg b/library/msgs/en_ie.msg
index ba621cf..ba621cf 100755
--- a/library/msgs/en_IE.msg
+++ b/library/msgs/en_ie.msg
diff --git a/library/msgs/en_IN.msg b/library/msgs/en_in.msg
index a1f155d..a1f155d 100755
--- a/library/msgs/en_IN.msg
+++ b/library/msgs/en_in.msg
diff --git a/library/msgs/en_NZ.msg b/library/msgs/en_nz.msg
index b419017..b419017 100755
--- a/library/msgs/en_NZ.msg
+++ b/library/msgs/en_nz.msg
diff --git a/library/msgs/en_PH.msg b/library/msgs/en_ph.msg
index 682666d..682666d 100755
--- a/library/msgs/en_PH.msg
+++ b/library/msgs/en_ph.msg
diff --git a/library/msgs/en_SG.msg b/library/msgs/en_sg.msg
index 4dc5b1d..4dc5b1d 100755
--- a/library/msgs/en_SG.msg
+++ b/library/msgs/en_sg.msg
diff --git a/library/msgs/en_ZA.msg b/library/msgs/en_za.msg
index fe43797..fe43797 100755
--- a/library/msgs/en_ZA.msg
+++ b/library/msgs/en_za.msg
diff --git a/library/msgs/en_ZW.msg b/library/msgs/en_zw.msg
index 2a5804f..2a5804f 100755
--- a/library/msgs/en_ZW.msg
+++ b/library/msgs/en_zw.msg
diff --git a/library/msgs/es_AR.msg b/library/msgs/es_ar.msg
index 7d35027..7d35027 100755
--- a/library/msgs/es_AR.msg
+++ b/library/msgs/es_ar.msg
diff --git a/library/msgs/es_BO.msg b/library/msgs/es_bo.msg
index 498ad0d..498ad0d 100755
--- a/library/msgs/es_BO.msg
+++ b/library/msgs/es_bo.msg
diff --git a/library/msgs/es_CL.msg b/library/msgs/es_cl.msg
index 31d465c..31d465c 100755
--- a/library/msgs/es_CL.msg
+++ b/library/msgs/es_cl.msg
diff --git a/library/msgs/es_CO.msg b/library/msgs/es_co.msg
index 77e57f0..77e57f0 100755
--- a/library/msgs/es_CO.msg
+++ b/library/msgs/es_co.msg
diff --git a/library/msgs/es_CR.msg b/library/msgs/es_cr.msg
index 7a652fa..7a652fa 100755
--- a/library/msgs/es_CR.msg
+++ b/library/msgs/es_cr.msg
diff --git a/library/msgs/es_DO.msg b/library/msgs/es_do.msg
index 0e283da..0e283da 100755
--- a/library/msgs/es_DO.msg
+++ b/library/msgs/es_do.msg
diff --git a/library/msgs/es_EC.msg b/library/msgs/es_ec.msg
index 9e921e0..9e921e0 100755
--- a/library/msgs/es_EC.msg
+++ b/library/msgs/es_ec.msg
diff --git a/library/msgs/es_GT.msg b/library/msgs/es_gt.msg
index ecd6faf..ecd6faf 100755
--- a/library/msgs/es_GT.msg
+++ b/library/msgs/es_gt.msg
diff --git a/library/msgs/es_HN.msg b/library/msgs/es_hn.msg
index a758ca2..a758ca2 100755
--- a/library/msgs/es_HN.msg
+++ b/library/msgs/es_hn.msg
diff --git a/library/msgs/es_MX.msg b/library/msgs/es_mx.msg
index 7cfb545..7cfb545 100755
--- a/library/msgs/es_MX.msg
+++ b/library/msgs/es_mx.msg
diff --git a/library/msgs/es_NI.msg b/library/msgs/es_ni.msg
index 7c39495..7c39495 100755
--- a/library/msgs/es_NI.msg
+++ b/library/msgs/es_ni.msg
diff --git a/library/msgs/es_PA.msg b/library/msgs/es_pa.msg
index cecacdc..cecacdc 100755
--- a/library/msgs/es_PA.msg
+++ b/library/msgs/es_pa.msg
diff --git a/library/msgs/es_PE.msg b/library/msgs/es_pe.msg
index 9f90595..9f90595 100755
--- a/library/msgs/es_PE.msg
+++ b/library/msgs/es_pe.msg
diff --git a/library/msgs/es_PR.msg b/library/msgs/es_pr.msg
index 8511b12..8511b12 100755
--- a/library/msgs/es_PR.msg
+++ b/library/msgs/es_pr.msg
diff --git a/library/msgs/es_PY.msg b/library/msgs/es_py.msg
index aa93d36..aa93d36 100755
--- a/library/msgs/es_PY.msg
+++ b/library/msgs/es_py.msg
diff --git a/library/msgs/es_SV.msg b/library/msgs/es_sv.msg
index fc7954d..fc7954d 100755
--- a/library/msgs/es_SV.msg
+++ b/library/msgs/es_sv.msg
diff --git a/library/msgs/es_UY.msg b/library/msgs/es_uy.msg
index b33525c..b33525c 100755
--- a/library/msgs/es_UY.msg
+++ b/library/msgs/es_uy.msg
diff --git a/library/msgs/es_VE.msg b/library/msgs/es_ve.msg
index 7c2a7b0..7c2a7b0 100755
--- a/library/msgs/es_VE.msg
+++ b/library/msgs/es_ve.msg
diff --git a/library/msgs/eu_ES.msg b/library/msgs/eu_es.msg
index 2694418..2694418 100755
--- a/library/msgs/eu_ES.msg
+++ b/library/msgs/eu_es.msg
diff --git a/library/msgs/fa_IN.msg b/library/msgs/fa_in.msg
index adc9e91..adc9e91 100755
--- a/library/msgs/fa_IN.msg
+++ b/library/msgs/fa_in.msg
diff --git a/library/msgs/fa_IR.msg b/library/msgs/fa_ir.msg
index 597ce9d..597ce9d 100755
--- a/library/msgs/fa_IR.msg
+++ b/library/msgs/fa_ir.msg
diff --git a/library/msgs/fo_FO.msg b/library/msgs/fo_fo.msg
index 2392b8e..2392b8e 100755
--- a/library/msgs/fo_FO.msg
+++ b/library/msgs/fo_fo.msg
diff --git a/library/msgs/fr_BE.msg b/library/msgs/fr_be.msg
index cdb13bd..cdb13bd 100755
--- a/library/msgs/fr_BE.msg
+++ b/library/msgs/fr_be.msg
diff --git a/library/msgs/fr_CA.msg b/library/msgs/fr_ca.msg
index 00ccfff..00ccfff 100755
--- a/library/msgs/fr_CA.msg
+++ b/library/msgs/fr_ca.msg
diff --git a/library/msgs/fr_CH.msg b/library/msgs/fr_ch.msg
index 7e2bac7..7e2bac7 100755
--- a/library/msgs/fr_CH.msg
+++ b/library/msgs/fr_ch.msg
diff --git a/library/msgs/ga_IE.msg b/library/msgs/ga_ie.msg
index b6acbbc..b6acbbc 100755
--- a/library/msgs/ga_IE.msg
+++ b/library/msgs/ga_ie.msg
diff --git a/library/msgs/gl_ES.msg b/library/msgs/gl_es.msg
index d4ed270..d4ed270 100755
--- a/library/msgs/gl_ES.msg
+++ b/library/msgs/gl_es.msg
diff --git a/library/msgs/gv_GB.msg b/library/msgs/gv_gb.msg
index 5e96e6f..5e96e6f 100755
--- a/library/msgs/gv_GB.msg
+++ b/library/msgs/gv_gb.msg
diff --git a/library/msgs/hi_IN.msg b/library/msgs/hi_in.msg
index 239793f..239793f 100755
--- a/library/msgs/hi_IN.msg
+++ b/library/msgs/hi_in.msg
diff --git a/library/msgs/id_ID.msg b/library/msgs/id_id.msg
index bb672c1..bb672c1 100755
--- a/library/msgs/id_ID.msg
+++ b/library/msgs/id_id.msg
diff --git a/library/msgs/it_CH.msg b/library/msgs/it_ch.msg
index b36ed36..b36ed36 100755
--- a/library/msgs/it_CH.msg
+++ b/library/msgs/it_ch.msg
diff --git a/library/msgs/kl_GL.msg b/library/msgs/kl_gl.msg
index 403aa10..403aa10 100755
--- a/library/msgs/kl_GL.msg
+++ b/library/msgs/kl_gl.msg
diff --git a/library/msgs/ko_KR.msg b/library/msgs/ko_kr.msg
index ea5bbd7..ea5bbd7 100755
--- a/library/msgs/ko_KR.msg
+++ b/library/msgs/ko_kr.msg
diff --git a/library/msgs/kok_IN.msg b/library/msgs/kok_in.msg
index abcb1ff..abcb1ff 100755
--- a/library/msgs/kok_IN.msg
+++ b/library/msgs/kok_in.msg
diff --git a/library/msgs/kw_GB.msg b/library/msgs/kw_gb.msg
index 2967680..2967680 100755
--- a/library/msgs/kw_GB.msg
+++ b/library/msgs/kw_gb.msg
diff --git a/library/msgs/mr_IN.msg b/library/msgs/mr_in.msg
index 1889da5..1889da5 100755
--- a/library/msgs/mr_IN.msg
+++ b/library/msgs/mr_in.msg
diff --git a/library/msgs/ms_MY.msg b/library/msgs/ms_my.msg
index c1f93d4..c1f93d4 100755
--- a/library/msgs/ms_MY.msg
+++ b/library/msgs/ms_my.msg
diff --git a/library/msgs/nl_BE.msg b/library/msgs/nl_be.msg
index 4b19670..4b19670 100755
--- a/library/msgs/nl_BE.msg
+++ b/library/msgs/nl_be.msg
diff --git a/library/msgs/pt_BR.msg b/library/msgs/pt_br.msg
index 8684327..8684327 100755
--- a/library/msgs/pt_BR.msg
+++ b/library/msgs/pt_br.msg
diff --git a/library/msgs/ru_UA.msg b/library/msgs/ru_ua.msg
index 6e1f8a8..6e1f8a8 100755
--- a/library/msgs/ru_UA.msg
+++ b/library/msgs/ru_ua.msg
diff --git a/library/msgs/ta_IN.msg b/library/msgs/ta_in.msg
index 24590ac..24590ac 100755
--- a/library/msgs/ta_IN.msg
+++ b/library/msgs/ta_in.msg
diff --git a/library/msgs/te_IN.msg b/library/msgs/te_in.msg
index 61638b5..61638b5 100755
--- a/library/msgs/te_IN.msg
+++ b/library/msgs/te_in.msg
diff --git a/library/msgs/zh_CN.msg b/library/msgs/zh_cn.msg
index d62ce77..d62ce77 100755
--- a/library/msgs/zh_CN.msg
+++ b/library/msgs/zh_cn.msg
diff --git a/library/msgs/zh_HK.msg b/library/msgs/zh_hk.msg
index badb1dd..badb1dd 100755
--- a/library/msgs/zh_HK.msg
+++ b/library/msgs/zh_hk.msg
diff --git a/library/msgs/zh_SG.msg b/library/msgs/zh_sg.msg
index a2f3e39..a2f3e39 100755
--- a/library/msgs/zh_SG.msg
+++ b/library/msgs/zh_sg.msg
diff --git a/library/msgs/zh_TW.msg b/library/msgs/zh_tw.msg
index e0796b1..e0796b1 100755
--- a/library/msgs/zh_TW.msg
+++ b/library/msgs/zh_tw.msg
diff --git a/tests/binary.test b/tests/binary.test
index 7d39291..486de9f 100644
--- a/tests/binary.test
+++ b/tests/binary.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: binary.test,v 1.18.2.8 2005/08/24 18:56:32 kennykb Exp $
+# RCS: @(#) $Id: binary.test,v 1.18.2.9 2005/08/25 15:46:53 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -2240,4 +2240,4 @@ return
# Local Variables:
# mode: tcl
-# End: \ No newline at end of file
+# End:
diff --git a/tests/chan.test b/tests/chan.test
index 46dd200..ab250c8 100644
--- a/tests/chan.test
+++ b/tests/chan.test
@@ -7,19 +7,24 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: chan.test,v 1.4.6.2 2005/07/12 20:37:06 kennykb Exp $
+# RCS: @(#) $Id: chan.test,v 1.4.6.3 2005/08/25 15:46:53 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
+#
+# Note: The tests for the chan methods "create" and "postevent"
+# currently reside in the file "ioCmd.test".
+#
+
test chan-1.1 {chan command general syntax} -body {
chan
} -returnCodes error -result "wrong # args: should be \"chan subcommand ?argument ...?\""
test chan-1.2 {chan command general syntax} -body {
chan FOOBAR
-} -returnCodes error -result "unknown or ambiguous subcommand \"FOOBAR\": must be blocked, close, configure, copy, eof, event, flush, gets, names, puts, read, seek, tell, or truncate"
+} -returnCodes error -result "unknown or ambiguous subcommand \"FOOBAR\": must be blocked, close, configure, copy, create, eof, event, flush, gets, names, postevent, puts, read, seek, tell, or truncate"
test chan-2.1 {chan command: blocked subcommand} -body {
chan blocked foo bar
diff --git a/tests/clock.test b/tests/clock.test
index a87f3b0..ce75940 100644
--- a/tests/clock.test
+++ b/tests/clock.test
@@ -11,7 +11,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: clock.test,v 1.52.2.4 2005/08/15 18:14:00 dgp Exp $
+# RCS: @(#) $Id: clock.test,v 1.52.2.5 2005/08/25 15:46:53 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -35329,26 +35329,8 @@ test clock-42.1 {regression test - %z in :localtime when west of Greenwich } \
} \
-result {-0500}
-test clock-43.1 {regression test - mktime returning -1} \
- -setup {
- if { [info exists env(TZ)] } {
- set oldTZ $env(TZ)
- }
- set env(TZ) UTC0
- } \
- -body {
- clock scan 1969-12-31T23:59:59 -format %Y-%m-%dT%T -timezone :localtime
- } \
- -cleanup {
- if { [info exists oldTZ] } {
- set env(TZ) $oldTZ
- unset oldTZ
- } else {
- unset env(TZ)
- }
- } \
- -result {-1}
-
+# 43.1 was a bad test - mktime returning -1 is an error according to posix.
+
test clock-44.1 {regression test - time zone name containing hyphen } \
-setup {
if { [info exists env(TZ)] } {
@@ -35471,12 +35453,24 @@ test clock-50.1 {format / scan -1 as a local time} {
[clock format -1 -format %Y%m%d%H%M%S -timezone :localtime] \
-format %Y%m%d%H%M%S -timezone :localtime
} result]} {
- if { [regexp "clock value too" $result] } {
+ if { [regexp " too large" $result] } {
set result -1
}
}
set result
} -1
+test clock-50.2 {format / scan -2 as a local time} {
+ if {[catch {
+ clock scan \
+ [clock format -2 -format %Y%m%d%H%M%S -timezone :localtime] \
+ -format %Y%m%d%H%M%S -timezone :localtime
+ } result]} {
+ if { [regexp " too large" $result] } {
+ set result -2
+ }
+ }
+ set result
+} -2
# cleanup
diff --git a/tests/expr.test b/tests/expr.test
index 2d4f15d..2ceadad 100644
--- a/tests/expr.test
+++ b/tests/expr.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: expr.test,v 1.30.2.22 2005/08/24 18:56:32 kennykb Exp $
+# RCS: @(#) $Id: expr.test,v 1.30.2.23 2005/08/25 15:46:53 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
@@ -445,15 +445,12 @@ test expr-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12
test expr-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63
test expr-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1
test expr-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8
-
test expr-9.5a {CompileRelationalExpr: shift expr producing LONG_MIN} longIs64bit {
expr {1<<63}
} -9223372036854775808
-
test expr-9.5b {CompileRelationalExpr: shift expr producing LONG_MIN} longIs32bit {
expr {1<<31}
} -2147483648
-
test expr-9.6 {CompileRelationalExpr: error in shift expr} -body {
catch {expr x>>3} msg
set msg
@@ -1023,7 +1020,6 @@ test expr-23.33 {INST_EXPON: special cases} {expr {wide(2)**wide(-2)}} 0
test expr-23.34 {INST_EXPON: special cases} {expr {2**0}} 1
test expr-23.35 {INST_EXPON: special cases} {expr {wide(2)**0}} 1
-
# Some compilers get this wrong; ensure that we work around it correctly
test expr-24.1 {expr edge cases; shifting} {expr int(5)>>32} 0
test expr-24.2 {expr edge cases; shifting} {expr int(5)>>63} 0
@@ -1054,7 +1050,6 @@ test expr-26.7 {'ni' operator} {expr {"" ni ""}} 1
foreach op {< <= == != > >=} {
proc test$op {a b} [list expr "\$a $op \$b"]
-
}
test expr-27.1 {expr - correct ordering - not compiled} ieeeFloatingPoint {
@@ -1082,7 +1077,6 @@ test expr-27.1 {expr - correct ordering - not compiled} ieeeFloatingPoint {
}
set problems
} {}
-
test expr-27.2 {expr - correct ordering - compiled} ieeeFloatingPoint {
set problems {}
# Ordering should be: -Infinity < -Normal < Subnormal < -0
@@ -1108,7 +1102,6 @@ test expr-27.2 {expr - correct ordering - compiled} ieeeFloatingPoint {
}
set problems
} {}
-
test expr-27.3 {expr - NaN is unordered - not compiled} {
set problems {}
set names {
@@ -1128,7 +1121,6 @@ test expr-27.3 {expr - NaN is unordered - not compiled} {
}
set problems
} {}
-
test expr-27.4 {expr - NaN is unordered - compiled} {
set problems {}
set names {
@@ -5335,7 +5327,6 @@ test expr-31.15 {boolean conversion} -body {
expr bool("fred")
} -returnCodes error -match glob -result *
-
test expr-32.1 {expr mod basics} {
set mod_nums [list \
{-3 1} {-3 2} {-3 3} {-3 4} {-3 5} \
@@ -5431,7 +5422,6 @@ test expr-33.1 {parse largest long value} {longIs32bit} {
[expr {(2147483647 + 1) < 0}] \
} {2147483647 2147483647 2147483647 2147483647 1 1}
-
test expr-33.2 {parse smallest long value} {longIs32bit} {
set min_long_str -2147483648
set min_long_hex "-0x80000000 "
@@ -5452,7 +5442,6 @@ test expr-33.2 {parse smallest long value} {longIs32bit} {
[expr {(-2147483648 - 1) == 0x7FFFFFFF}] \
} {-2147483648 -2147483648 -2147483648 -2147483648 1 1}
-
test expr-33.3 {parse largest wide value} {wideIs64bit} {
set max_wide_str 9223372036854775807
set max_wide_hex "0x7FFFFFFFFFFFFFFF "
@@ -5470,7 +5459,6 @@ test expr-33.3 {parse largest wide value} {wideIs64bit} {
[expr {(9223372036854775807 + 1) < 0}] \
} {9223372036854775807 9223372036854775807 9223372036854775807 9223372036854775807 1 1}
-
test expr-33.4 {parse smallest wide value} {wideIs64bit} {
set min_wide_str -9223372036854775808
set min_wide_hex "-0x8000000000000000 "
@@ -5492,366 +5480,276 @@ test expr-33.4 {parse smallest wide value} {wideIs64bit} {
} {-9223372036854775808 -9223372036854775808 -9223372036854775808 -9223372036854775808 1 1}
-
set min -2147483648
set max 2147483647
test expr-34.1 {expr edge cases} {longIs32bit} {
expr {$min / $min}
} {1}
-
test expr-34.2 {expr edge cases} {longIs32bit} {
expr {$min % $min}
} {0}
-
test expr-34.3 {expr edge cases} {longIs32bit} {
expr {$min / ($min + 1)}
} {1}
-
test expr-34.4 {expr edge cases} {longIs32bit} {
expr {$min % ($min + 1)}
} {-1}
-
test expr-34.5 {expr edge cases} {longIs32bit} {
expr {$min / ($min + 2)}
} {1}
-
test expr-34.6 {expr edge cases} {longIs32bit} {
expr {$min % ($min + 2)}
} {-2}
-
test expr-34.7 {expr edge cases} {longIs32bit} {
expr {$min / ($min + 3)}
} {1}
-
test expr-34.8 {expr edge cases} {longIs32bit} {
expr {$min % ($min + 3)}
} {-3}
-
test expr-34.9 {expr edge cases} {longIs32bit} {
expr {$min / -3}
} {715827882}
-
test expr-34.10 {expr edge cases} {longIs32bit} {
expr {$min % -3}
} {-2}
-
test expr-34.11 {expr edge cases} {longIs32bit} {
expr {$min / -2}
} {1073741824}
-
test expr-34.12 {expr edge cases} {longIs32bit} {
expr {$min % -2}
} {0}
-
test expr-34.13 {expr edge cases} {longIs32bit} {
expr {$min / -1}
} {-2147483648}
-
test expr-34.14 {expr edge cases} {longIs32bit} {
expr {$min % -1}
} {0}
-
test expr-34.15 {expr edge cases} {longIs32bit} {
expr {$min * -1}
} $min
-
test expr-34.16 {expr edge cases} {longIs32bit} {
expr {-$min}
} $min
-
test expr-34.17 {expr edge cases} {longIs32bit} {
expr {$min / 1}
} $min
-
test expr-34.18 {expr edge cases} {longIs32bit} {
expr {$min % 1}
} {0}
-
test expr-34.19 {expr edge cases} {longIs32bit} {
expr {$min / 2}
} {-1073741824}
-
test expr-34.20 {expr edge cases} {longIs32bit} {
expr {$min % 2}
} {0}
-
test expr-34.21 {expr edge cases} {longIs32bit} {
expr {$min / 3}
} {-715827883}
-
test expr-34.22 {expr edge cases} {longIs32bit} {
expr {$min % 3}
} {1}
-
test expr-34.23 {expr edge cases} {longIs32bit} {
expr {$min / ($max - 3)}
} {-2}
-
test expr-34.24 {expr edge cases} {longIs32bit} {
expr {$min % ($max - 3)}
} {2147483640}
-
test expr-34.25 {expr edge cases} {longIs32bit} {
expr {$min / ($max - 2)}
} {-2}
-
test expr-34.26 {expr edge cases} {longIs32bit} {
expr {$min % ($max - 2)}
} {2147483642}
-
test expr-34.27 {expr edge cases} {longIs32bit} {
expr {$min / ($max - 1)}
} {-2}
-
test expr-34.28 {expr edge cases} {longIs32bit} {
expr {$min % ($max - 1)}
} {2147483644}
-
test expr-34.29 {expr edge cases} {longIs32bit} {
expr {$min / $max}
} {-2}
-
test expr-34.30 {expr edge cases} {longIs32bit} {
expr {$min % $max}
} {2147483646}
-
test expr-34.31 {expr edge cases} {longIs32bit} {
expr {$max / $max}
} {1}
-
test expr-34.32 {expr edge cases} {longIs32bit} {
expr {$max % $max}
} {0}
-
test expr-34.33 {expr edge cases} {longIs32bit} {
expr {$max / ($max - 1)}
} {1}
-
test expr-34.34 {expr edge cases} {longIs32bit} {
expr {$max % ($max - 1)}
} {1}
-
test expr-34.35 {expr edge cases} {longIs32bit} {
expr {$max / ($max - 2)}
} {1}
-
test expr-34.36 {expr edge cases} {longIs32bit} {
expr {$max % ($max - 2)}
} {2}
-
test expr-34.37 {expr edge cases} {longIs32bit} {
expr {$max / ($max - 3)}
} {1}
-
test expr-34.38 {expr edge cases} {longIs32bit} {
expr {$max % ($max - 3)}
} {3}
-
test expr-34.39 {expr edge cases} {longIs32bit} {
expr {$max / 3}
} {715827882}
-
test expr-34.40 {expr edge cases} {longIs32bit} {
expr {$max % 3}
} {1}
-
test expr-34.41 {expr edge cases} {longIs32bit} {
expr {$max / 2}
} {1073741823}
-
test expr-34.42 {expr edge cases} {longIs32bit} {
expr {$max % 2}
} {1}
-
test expr-34.43 {expr edge cases} {longIs32bit} {
expr {$max / 1}
} $max
-
test expr-34.44 {expr edge cases} {longIs32bit} {
expr {$max % 1}
} {0}
-
test expr-34.45 {expr edge cases} {longIs32bit} {
expr {$max / -1}
} "-$max"
-
test expr-34.46 {expr edge cases} {longIs32bit} {
expr {$max % -1}
} {0}
-
test expr-34.47 {expr edge cases} {longIs32bit} {
expr {$max / -2}
} {-1073741824}
-
test expr-34.48 {expr edge cases} {longIs32bit} {
expr {$max % -2}
} {-1}
-
test expr-34.49 {expr edge cases} {longIs32bit} {
expr {$max / -3}
} {-715827883}
-
test expr-34.50 {expr edge cases} {longIs32bit} {
expr {$max % -3}
} {-2}
-
test expr-34.51 {expr edge cases} {longIs32bit} {
expr {$max / ($min + 3)}
} {-2}
-
test expr-34.52 {expr edge cases} {longIs32bit} {
expr {$max % ($min + 3)}
} {-2147483643}
-
test expr-34.53 {expr edge cases} {longIs32bit} {
expr {$max / ($min + 2)}
} {-2}
-
test expr-34.54 {expr edge cases} {longIs32bit} {
expr {$max % ($min + 2)}
} {-2147483645}
-
test expr-34.55 {expr edge cases} {longIs32bit} {
expr {$max / ($min + 1)}
} {-1}
-
test expr-34.56 {expr edge cases} {longIs32bit} {
expr {$max % ($min + 1)}
} {0}
-
test expr-34.57 {expr edge cases} {longIs32bit} {
expr {$max / $min}
} {-1}
-
test expr-34.58 {expr edge cases} {longIs32bit} {
expr {$max % $min}
} {-1}
-
test expr-34.59 {expr edge cases} {longIs32bit} {
expr {($min + 1) / ($max - 1)}
} {-2}
-
test expr-34.60 {expr edge cases} {longIs32bit} {
expr {($min + 1) % ($max - 1)}
} {2147483645}
-
test expr-34.61 {expr edge cases} {longIs32bit} {
expr {($max - 1) / ($min + 1)}
} {-1}
-
test expr-34.62 {expr edge cases} {longIs32bit} {
expr {($max - 1) % ($min + 1)}
} {-1}
-
test expr-34.63 {expr edge cases} {longIs32bit} {
expr {($max - 1) / $min}
} {-1}
-
test expr-34.64 {expr edge cases} {longIs32bit} {
expr {($max - 1) % $min}
} {-2}
-
test expr-34.65 {expr edge cases} {longIs32bit} {
expr {($max - 2) / $min}
} {-1}
-
test expr-34.66 {expr edge cases} {longIs32bit} {
expr {($max - 2) % $min}
} {-3}
-
test expr-34.67 {expr edge cases} {longIs32bit} {
expr {($max - 3) / $min}
} {-1}
-
test expr-34.68 {expr edge cases} {longIs32bit} {
expr {($max - 3) % $min}
} {-4}
-
test expr-34.69 {expr edge cases} {longIs32bit} {
expr {-3 / $min}
} {0}
-
test expr-34.70 {expr edge cases} {longIs32bit} {
expr {-3 % $min}
} {-3}
-
test expr-34.71 {expr edge cases} {longIs32bit} {
expr {-2 / $min}
} {0}
-
test expr-34.72 {expr edge cases} {longIs32bit} {
expr {-2 % $min}
} {-2}
-
test expr-34.73 {expr edge cases} {longIs32bit} {
expr {-1 / $min}
} {0}
-
test expr-34.74 {expr edge cases} {longIs32bit} {
expr {-1 % $min}
} {-1}
-
test expr-34.75 {expr edge cases} {longIs32bit} {
expr {0 / $min}
} {0}
-
test expr-34.76 {expr edge cases} {longIs32bit} {
expr {0 % $min}
} {0}
-
test expr-34.77 {expr edge cases} {longIs32bit} {
expr {0 / ($min + 1)}
} {0}
-
test expr-34.78 {expr edge cases} {longIs32bit} {
expr {0 % ($min + 1)}
} {0}
-
test expr-34.79 {expr edge cases} {longIs32bit} {
expr {1 / $min}
} {-1}
-
test expr-34.80 {expr edge cases} {longIs32bit} {
expr {1 % $min}
} {-2147483647}
-
test expr-34.81 {expr edge cases} {longIs32bit} {
expr {1 / ($min + 1)}
} {-1}
-
test expr-34.82 {expr edge cases} {longIs32bit} {
expr {1 % ($min + 1)}
} {-2147483646}
-
test expr-34.83 {expr edge cases} {longIs32bit} {
expr {2 / $min}
} {-1}
-
test expr-34.84 {expr edge cases} {longIs32bit} {
expr {2 % $min}
} {-2147483646}
-
test expr-34.85 {expr edge cases} {longIs32bit} {
expr {2 / ($min + 1)}
} {-1}
-
test expr-34.86 {expr edge cases} {longIs32bit} {
expr {2 % ($min + 1)}
} {-2147483645}
-
test expr-34.87 {expr edge cases} {longIs32bit} {
expr {3 / $min}
} {-1}
-
test expr-34.88 {expr edge cases} {longIs32bit} {
expr {3 % $min}
} {-2147483645}
-
test expr-34.89 {expr edge cases} {longIs32bit} {
expr {3 / ($min + 1)}
} {-1}
-
test expr-34.90 {expr edge cases} {longIs32bit} {
expr {3 % ($min + 1)}
} {-2147483644}
@@ -5866,7 +5764,6 @@ test expr-35.1 {expr edge cases} {longIs32bit} {
set r [expr {$dividend % $divisor}]
list $q * $divisor + $r = [expr {($divisor * $q) + $r}]
} {1073741823 * 2 + 1 = 2147483647}
-
test expr-35.2 {expr edge cases} {longIs32bit} {
set dividend [expr {$max - 1}]
set divisor 2
@@ -5874,7 +5771,6 @@ test expr-35.2 {expr edge cases} {longIs32bit} {
set r [expr {$dividend % $divisor}]
list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {1073741823 * 2 + 0 = 2147483646}
-
test expr-35.3 {expr edge cases} {longIs32bit} {
set dividend [expr {$max - 2}]
set divisor 2
@@ -5882,7 +5778,6 @@ test expr-35.3 {expr edge cases} {longIs32bit} {
set r [expr {$dividend % $divisor}]
list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {1073741822 * 2 + 1 = 2147483645}
-
test expr-35.4 {expr edge cases} {longIs32bit} {
set dividend $max
set divisor 3
@@ -5890,7 +5785,6 @@ test expr-35.4 {expr edge cases} {longIs32bit} {
set r [expr {$dividend % $divisor}]
list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {715827882 * 3 + 1 = 2147483647}
-
test expr-35.5 {expr edge cases} {longIs32bit} {
set dividend [expr {$max - 1}]
set divisor 3
@@ -5898,7 +5792,6 @@ test expr-35.5 {expr edge cases} {longIs32bit} {
set r [expr {$dividend % $divisor}]
list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {715827882 * 3 + 0 = 2147483646}
-
test expr-35.6 {expr edge cases} {longIs32bit} {
set dividend [expr {$max - 2}]
set divisor 3
@@ -5906,7 +5799,6 @@ test expr-35.6 {expr edge cases} {longIs32bit} {
set r [expr {$dividend % $divisor}]
list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {715827881 * 3 + 2 = 2147483645}
-
test expr-35.7 {expr edge cases} {longIs32bit} {
set dividend $min
set divisor 2
@@ -5914,7 +5806,6 @@ test expr-35.7 {expr edge cases} {longIs32bit} {
set r [expr {$dividend % $divisor}]
list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {-1073741824 * 2 + 0 = -2147483648}
-
test expr-35.8 {expr edge cases} {longIs32bit} {
set dividend [expr {$min + 1}]
set divisor 2
@@ -5922,7 +5813,6 @@ test expr-35.8 {expr edge cases} {longIs32bit} {
set r [expr {$dividend % $divisor}]
list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {-1073741824 * 2 + 1 = -2147483647}
-
test expr-35.9 {expr edge cases} {longIs32bit} {
set dividend [expr {$min + 2}]
set divisor 2
@@ -5930,7 +5820,6 @@ test expr-35.9 {expr edge cases} {longIs32bit} {
set r [expr {$dividend % $divisor}]
list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {-1073741823 * 2 + 0 = -2147483646}
-
test expr-35.10 {expr edge cases} {longIs32bit} {
# Two things could happen here. The multiplication
# could overflow a 32 bit type, so that when
@@ -5944,7 +5833,6 @@ test expr-35.10 {expr edge cases} {longIs32bit} {
set r [expr {$dividend % $divisor}]
list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {-715827883 * 3 + 1 = -2147483648}
-
test expr-35.11 {expr edge cases} {longIs32bit} {
set dividend $min
set divisor -3
@@ -5952,7 +5840,6 @@ test expr-35.11 {expr edge cases} {longIs32bit} {
set r [expr {$dividend % $divisor}]
list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {715827882 * -3 + -2 = -2147483648}
-
test expr-35.12 {expr edge cases} {longIs32bit} {
set dividend $min
set divisor $min
@@ -5960,7 +5847,6 @@ test expr-35.12 {expr edge cases} {longIs32bit} {
set r [expr {$dividend % $divisor}]
list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {1 * -2147483648 + 0 = -2147483648}
-
test expr-35.13 {expr edge cases} {longIs32bit} {
set dividend $min
set divisor [expr {$min + 1}]
@@ -5968,7 +5854,6 @@ test expr-35.13 {expr edge cases} {longIs32bit} {
set r [expr {$dividend % $divisor}]
list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {1 * -2147483647 + -1 = -2147483648}
-
test expr-35.14 {expr edge cases} {longIs32bit} {
set dividend $min
set divisor [expr {$min + 2}]
@@ -5985,364 +5870,274 @@ set max 9223372036854775807
test expr-36.1 {expr edge cases} {wideIs64bit} {
expr {$min / $min}
} {1}
-
test expr-36.2 {expr edge cases} {wideIs64bit} {
expr {$min % $min}
} {0}
-
test expr-36.3 {expr edge cases} {wideIs64bit} {
expr {$min / ($min + 1)}
} {1}
-
test expr-36.4 {expr edge cases} {wideIs64bit} {
expr {$min % ($min + 1)}
} {-1}
-
test expr-36.5 {expr edge cases} {wideIs64bit} {
expr {$min / ($min + 2)}
} {1}
-
test expr-36.6 {expr edge cases} {wideIs64bit} {
expr {$min % ($min + 2)}
} {-2}
-
test expr-36.7 {expr edge cases} {wideIs64bit} {
expr {$min / ($min + 3)}
} {1}
-
test expr-36.8 {expr edge cases} {wideIs64bit} {
expr {$min % ($min + 3)}
} {-3}
-
test expr-36.9 {expr edge cases} {wideIs64bit} {
expr {$min / -3}
} {3074457345618258602}
-
test expr-36.10 {expr edge cases} {wideIs64bit} {
expr {$min % -3}
} {-2}
-
test expr-36.11 {expr edge cases} {wideIs64bit} {
expr {$min / -2}
} {4611686018427387904}
-
test expr-36.12 {expr edge cases} {wideIs64bit} {
expr {$min % -2}
} {0}
-
test expr-36.13 {expr edge cases} {wideIs64bit} {
expr {$min / -1}
} $min
-
test expr-36.14 {expr edge cases} {wideIs64bit} {
expr {$min % -1}
} {0}
-
test expr-36.15 {expr edge cases} {wideIs64bit} {
expr {$min * -1}
} $min
-
test expr-36.16 {expr edge cases} {wideIs64bit} {
expr {-$min}
} $min
-
test expr-36.17 {expr edge cases} {wideIs64bit} {
expr {$min / 1}
} $min
-
test expr-36.18 {expr edge cases} {wideIs64bit} {
expr {$min % 1}
} {0}
-
test expr-36.19 {expr edge cases} {wideIs64bit} {
expr {$min / 2}
} {-4611686018427387904}
-
test expr-36.20 {expr edge cases} {wideIs64bit} {
expr {$min % 2}
} {0}
-
test expr-36.21 {expr edge cases} {wideIs64bit} {
expr {$min / 3}
} {-3074457345618258603}
-
test expr-36.22 {expr edge cases} {wideIs64bit} {
expr {$min % 3}
} {1}
-
test expr-36.23 {expr edge cases} {wideIs64bit} {
expr {$min / ($max - 3)}
} {-2}
-
test expr-36.24 {expr edge cases} {wideIs64bit} {
expr {$min % ($max - 3)}
} {9223372036854775800}
-
test expr-36.25 {expr edge cases} {wideIs64bit} {
expr {$min / ($max - 2)}
} {-2}
-
test expr-36.26 {expr edge cases} {wideIs64bit} {
expr {$min % ($max - 2)}
} {9223372036854775802}
-
test expr-36.27 {expr edge cases} {wideIs64bit} {
expr {$min / ($max - 1)}
} {-2}
-
test expr-36.28 {expr edge cases} {wideIs64bit} {
expr {$min % ($max - 1)}
} {9223372036854775804}
-
test expr-36.29 {expr edge cases} {wideIs64bit} {
expr {$min / $max}
} {-2}
-
test expr-36.30 {expr edge cases} {wideIs64bit} {
expr {$min % $max}
} {9223372036854775806}
-
test expr-36.31 {expr edge cases} {wideIs64bit} {
expr {$max / $max}
} {1}
-
test expr-36.32 {expr edge cases} {wideIs64bit} {
expr {$max % $max}
} {0}
-
test expr-36.33 {expr edge cases} {wideIs64bit} {
expr {$max / ($max - 1)}
} {1}
-
test expr-36.34 {expr edge cases} {wideIs64bit} {
expr {$max % ($max - 1)}
} {1}
-
test expr-36.35 {expr edge cases} {wideIs64bit} {
expr {$max / ($max - 2)}
} {1}
-
test expr-36.36 {expr edge cases} {wideIs64bit} {
expr {$max % ($max - 2)}
} {2}
-
test expr-36.37 {expr edge cases} {wideIs64bit} {
expr {$max / ($max - 3)}
} {1}
-
test expr-36.38 {expr edge cases} {wideIs64bit} {
expr {$max % ($max - 3)}
} {3}
-
test expr-36.39 {expr edge cases} {wideIs64bit} {
expr {$max / 3}
} {3074457345618258602}
-
test expr-36.40 {expr edge cases} {wideIs64bit} {
expr {$max % 3}
} {1}
-
test expr-36.41 {expr edge cases} {wideIs64bit} {
expr {$max / 2}
} {4611686018427387903}
-
test expr-36.42 {expr edge cases} {wideIs64bit} {
expr {$max % 2}
} {1}
-
test expr-36.43 {expr edge cases} {wideIs64bit} {
expr {$max / 1}
} $max
-
test expr-36.44 {expr edge cases} {wideIs64bit} {
expr {$max % 1}
} {0}
-
test expr-36.45 {expr edge cases} {wideIs64bit} {
expr {$max / -1}
} "-$max"
-
test expr-36.46 {expr edge cases} {wideIs64bit} {
expr {$max % -1}
} {0}
-
test expr-36.47 {expr edge cases} {wideIs64bit} {
expr {$max / -2}
} {-4611686018427387904}
-
test expr-36.48 {expr edge cases} {wideIs64bit} {
expr {$max % -2}
} {-1}
-
test expr-36.49 {expr edge cases} {wideIs64bit} {
expr {$max / -3}
} {-3074457345618258603}
-
test expr-36.50 {expr edge cases} {wideIs64bit} {
expr {$max % -3}
} {-2}
-
test expr-36.51 {expr edge cases} {wideIs64bit} {
expr {$max / ($min + 3)}
} {-2}
-
test expr-36.52 {expr edge cases} {wideIs64bit} {
expr {$max % ($min + 3)}
} {-9223372036854775803}
-
test expr-36.53 {expr edge cases} {wideIs64bit} {
expr {$max / ($min + 2)}
} {-2}
-
test expr-36.54 {expr edge cases} {wideIs64bit} {
expr {$max % ($min + 2)}
} {-9223372036854775805}
-
test expr-36.55 {expr edge cases} {wideIs64bit} {
expr {$max / ($min + 1)}
} {-1}
-
test expr-36.56 {expr edge cases} {wideIs64bit} {
expr {$max % ($min + 1)}
} {0}
-
test expr-36.57 {expr edge cases} {wideIs64bit} {
expr {$max / $min}
} {-1}
-
test expr-36.58 {expr edge cases} {wideIs64bit} {
expr {$max % $min}
} {-1}
-
test expr-36.59 {expr edge cases} {wideIs64bit} {
expr {($min + 1) / ($max - 1)}
} {-2}
-
test expr-36.60 {expr edge cases} {wideIs64bit} {
expr {($min + 1) % ($max - 1)}
} {9223372036854775805}
-
test expr-36.61 {expr edge cases} {wideIs64bit} {
expr {($max - 1) / ($min + 1)}
} {-1}
-
test expr-36.62 {expr edge cases} {wideIs64bit} {
expr {($max - 1) % ($min + 1)}
} {-1}
-
test expr-36.63 {expr edge cases} {wideIs64bit} {
expr {($max - 1) / $min}
} {-1}
-
test expr-36.64 {expr edge cases} {wideIs64bit} {
expr {($max - 1) % $min}
} {-2}
-
test expr-36.65 {expr edge cases} {wideIs64bit} {
expr {($max - 2) / $min}
} {-1}
-
test expr-36.66 {expr edge cases} {wideIs64bit} {
expr {($max - 2) % $min}
} {-3}
-
test expr-36.67 {expr edge cases} {wideIs64bit} {
expr {($max - 3) / $min}
} {-1}
-
test expr-36.68 {expr edge cases} {wideIs64bit} {
expr {($max - 3) % $min}
} {-4}
-
test expr-36.69 {expr edge cases} {wideIs64bit} {
expr {-3 / $min}
} {0}
-
test expr-36.70 {expr edge cases} {wideIs64bit} {
expr {-3 % $min}
} {-3}
-
test expr-36.71 {expr edge cases} {wideIs64bit} {
expr {-2 / $min}
} {0}
-
test expr-36.72 {expr edge cases} {wideIs64bit} {
expr {-2 % $min}
} {-2}
-
test expr-36.73 {expr edge cases} {wideIs64bit} {
expr {-1 / $min}
} {0}
-
test expr-36.74 {expr edge cases} {wideIs64bit} {
expr {-1 % $min}
} {-1}
-
test expr-36.75 {expr edge cases} {wideIs64bit} {
expr {0 / $min}
} {0}
-
test expr-36.76 {expr edge cases} {wideIs64bit} {
expr {0 % $min}
} {0}
-
test expr-36.77 {expr edge cases} {wideIs64bit} {
expr {0 / ($min + 1)}
} {0}
-
test expr-36.78 {expr edge cases} {wideIs64bit} {
expr {0 % ($min + 1)}
} {0}
-
test expr-36.79 {expr edge cases} {wideIs64bit} {
expr {1 / $min}
} {-1}
-
test expr-36.80 {expr edge cases} {wideIs64bit} {
expr {1 % $min}
} {-9223372036854775807}
-
test expr-36.81 {expr edge cases} {wideIs64bit} {
expr {1 / ($min + 1)}
} {-1}
-
test expr-36.82 {expr edge cases} {wideIs64bit} {
expr {1 % ($min + 1)}
} {-9223372036854775806}
-
test expr-36.83 {expr edge cases} {wideIs64bit} {
expr {2 / $min}
} {-1}
-
test expr-36.84 {expr edge cases} {wideIs64bit} {
expr {2 % $min}
} {-9223372036854775806}
-
test expr-36.85 {expr edge cases} {wideIs64bit} {
expr {2 / ($min + 1)}
} {-1}
-
test expr-36.86 {expr edge cases} {wideIs64bit} {
expr {2 % ($min + 1)}
} {-9223372036854775805}
-
test expr-36.87 {expr edge cases} {wideIs64bit} {
expr {3 / $min}
} {-1}
-
test expr-36.88 {expr edge cases} {wideIs64bit} {
expr {3 % $min}
} {-9223372036854775805}
-
test expr-36.89 {expr edge cases} {wideIs64bit} {
expr {3 / ($min + 1)}
} {-1}
-
test expr-36.90 {expr edge cases} {wideIs64bit} {
expr {3 % ($min + 1)}
} {-9223372036854775804}
-
test expr-37.1 {expr edge cases} {wideIs64bit} {
set dividend $max
set divisor 2
@@ -6350,7 +6145,6 @@ test expr-37.1 {expr edge cases} {wideIs64bit} {
set r [expr {$dividend % $divisor}]
list $q * $divisor + $r = [expr {($divisor * $q) + $r}]
} {4611686018427387903 * 2 + 1 = 9223372036854775807}
-
test expr-37.2 {expr edge cases} {wideIs64bit} {
set dividend [expr {$max - 1}]
set divisor 2
@@ -6358,7 +6152,6 @@ test expr-37.2 {expr edge cases} {wideIs64bit} {
set r [expr {$dividend % $divisor}]
list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {4611686018427387903 * 2 + 0 = 9223372036854775806}
-
test expr-37.3 {expr edge cases} {wideIs64bit} {
set dividend [expr {$max - 2}]
set divisor 2
@@ -6366,7 +6159,6 @@ test expr-37.3 {expr edge cases} {wideIs64bit} {
set r [expr {$dividend % $divisor}]
list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {4611686018427387902 * 2 + 1 = 9223372036854775805}
-
test expr-37.4 {expr edge cases} {wideIs64bit} {
set dividend $max
set divisor 3
@@ -6374,7 +6166,6 @@ test expr-37.4 {expr edge cases} {wideIs64bit} {
set r [expr {$dividend % $divisor}]
list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {3074457345618258602 * 3 + 1 = 9223372036854775807}
-
test expr-37.5 {expr edge cases} {wideIs64bit} {
set dividend [expr {$max - 1}]
set divisor 3
@@ -6382,7 +6173,6 @@ test expr-37.5 {expr edge cases} {wideIs64bit} {
set r [expr {$dividend % $divisor}]
list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {3074457345618258602 * 3 + 0 = 9223372036854775806}
-
test expr-37.6 {expr edge cases} {wideIs64bit} {
set dividend [expr {$max - 2}]
set divisor 3
@@ -6390,7 +6180,6 @@ test expr-37.6 {expr edge cases} {wideIs64bit} {
set r [expr {$dividend % $divisor}]
list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {3074457345618258601 * 3 + 2 = 9223372036854775805}
-
test expr-37.7 {expr edge cases} {wideIs64bit} {
set dividend $min
set divisor 2
@@ -6398,7 +6187,6 @@ test expr-37.7 {expr edge cases} {wideIs64bit} {
set r [expr {$dividend % $divisor}]
list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {-4611686018427387904 * 2 + 0 = -9223372036854775808}
-
test expr-37.8 {expr edge cases} {wideIs64bit} {
set dividend [expr {$min + 1}]
set divisor 2
@@ -6406,7 +6194,6 @@ test expr-37.8 {expr edge cases} {wideIs64bit} {
set r [expr {$dividend % $divisor}]
list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {-4611686018427387904 * 2 + 1 = -9223372036854775807}
-
test expr-37.9 {expr edge cases} {wideIs64bit} {
set dividend [expr {$min + 2}]
set divisor 2
@@ -6414,7 +6201,6 @@ test expr-37.9 {expr edge cases} {wideIs64bit} {
set r [expr {$dividend % $divisor}]
list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {-4611686018427387903 * 2 + 0 = -9223372036854775806}
-
test expr-37.10 {expr edge cases} {wideIs64bit} {
# Multiplication overflows 64 bit type here,
# so when the 1 is added it overflows
@@ -6425,7 +6211,6 @@ test expr-37.10 {expr edge cases} {wideIs64bit} {
set r [expr {$dividend % $divisor}]
list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {-3074457345618258603 * 3 + 1 = -9223372036854775808}
-
test expr-37.11 {expr edge cases} {wideIs64bit} {
set dividend $min
set divisor -3
@@ -6433,7 +6218,6 @@ test expr-37.11 {expr edge cases} {wideIs64bit} {
set r [expr {$dividend % $divisor}]
list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {3074457345618258602 * -3 + -2 = -9223372036854775808}
-
test expr-37.12 {expr edge cases} {wideIs64bit} {
set dividend $min
set divisor $min
@@ -6441,7 +6225,6 @@ test expr-37.12 {expr edge cases} {wideIs64bit} {
set r [expr {$dividend % $divisor}]
list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {1 * -9223372036854775808 + 0 = -9223372036854775808}
-
test expr-37.13 {expr edge cases} {wideIs64bit} {
set dividend $min
set divisor [expr {$min + 1}]
@@ -6449,7 +6232,6 @@ test expr-37.13 {expr edge cases} {wideIs64bit} {
set r [expr {$dividend % $divisor}]
list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {1 * -9223372036854775807 + -1 = -9223372036854775808}
-
test expr-37.14 {expr edge cases} {wideIs64bit} {
set dividend $min
set divisor [expr {$min + 2}]
@@ -6458,7 +6240,6 @@ test expr-37.14 {expr edge cases} {wideIs64bit} {
list $q * $divisor + $r = [expr {($q * $divisor) + $r}]
} {1 * -9223372036854775806 + -2 = -9223372036854775808}
-
test expr-38.1 {abs of smallest 32-bit integer [Bug 1241572]} {wideIs64bit} {
expr {abs(-2147483648)}
} 2147483648
diff --git a/tests/io.test b/tests/io.test
index f03cba9..c1f50cb 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -1,3 +1,4 @@
+# -*- tcl -*-
# Functionality covered: operation of all IO commands, and all procedures
# defined in generic/tclIO.c.
#
@@ -12,7 +13,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: io.test,v 1.65.2.2 2005/04/25 21:37:28 kennykb Exp $
+# RCS: @(#) $Id: io.test,v 1.65.2.3 2005/08/25 15:46:53 dgp Exp $
if {[catch {package require tcltest 2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2 required."
@@ -28,14 +29,14 @@ namespace eval ::tcl::test::io {
namespace import ::tcltest::testConstraint
namespace import ::tcltest::viewFile
-testConstraint testchannel [llength [info commands testchannel]]
-testConstraint exec [llength [info commands exec]]
-testConstraint openpipe 1
-testConstraint fileevent [llength [info commands fileevent]]
-testConstraint fcopy [llength [info commands fcopy]]
-testConstraint testfevent [llength [info commands testfevent]]
+testConstraint testchannel [llength [info commands testchannel]]
+testConstraint exec [llength [info commands exec]]
+testConstraint openpipe 1
+testConstraint fileevent [llength [info commands fileevent]]
+testConstraint fcopy [llength [info commands fcopy]]
+testConstraint testfevent [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
-testConstraint testmainthread [llength [info commands testmainthread]]
+testConstraint testmainthread [llength [info commands testmainthread]]
# You need a *very* special environment to do some tests. In
# particular, many file systems do not support large-files...
@@ -7111,6 +7112,266 @@ test io-61.1 {Reset eof state after changing the eof char} -setup {
removeFile eofchar
} -result {77 = 23431}
+
+# Test the cutting and splicing of channels, this is incidentially the
+# attach/detach facility of package Thread, but __without any
+# safeguards__. It can also be used to emulate transfer of channels
+# between threads, and is used for that here.
+
+test io-70.0 {Cutting & Splicing channels} {testchannel} {
+ set f [makeFile {... dummy ...} cutsplice]
+ set c [open $f r]
+
+ set res {}
+ lappend res [catch {seek $c 0 start}]
+ testchannel cut $c
+
+ lappend res [catch {seek $c 0 start}]
+ testchannel splice $c
+
+ lappend res [catch {seek $c 0 start}]
+ close $c
+
+ removeFile cutsplice
+
+ set res
+} {0 1 0}
+
+
+# Duplicate of code in "thread.test". Find a better way of doing this
+# without duplication. Maybe placement into a proc which transforms to
+# nop after the first call, and placement of its defintion in a
+# central location.
+
+testConstraint testthread [expr {[info commands testthread] != {}}]
+
+if {[testConstraint testthread]} {
+ testthread errorproc ThreadError
+
+ proc ThreadError {id info} {
+ global threadError
+ set threadError $info
+ }
+
+ proc ThreadNullError {id info} {
+ # ignore
+ }
+}
+
+test io-70.1 {Transfer channel} {testchannel testthread} {
+ set f [makeFile {... dummy ...} cutsplice]
+ set c [open $f r]
+
+ set res {}
+ lappend res [catch {seek $c 0 start}]
+ testchannel cut $c
+ lappend res [catch {seek $c 0 start}]
+
+ set tid [testthread create]
+ testthread send $tid [list set c $c]
+ lappend res [testthread send $tid {
+ testchannel splice $c
+ set res [catch {seek $c 0 start}]
+ close $c
+ set res
+ }]
+
+ tcltest::threadReap
+ removeFile cutsplice
+
+ set res
+} {0 1 0}
+
+# ### ### ### ######### ######### #########
+
+foreach {n msg expected} {
+ 0 {} {}
+ 1 {{message only}} {{message only}}
+ 2 {-options x} {-options x}
+ 3 {-options {x y} {the message}} {-options {x y} {the message}}
+
+ 4 {-code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 5 {-code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 6 {-code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 7 {-code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 8 {-code error -level 0 -f ba snarf} {-code error -level 0 -f ba snarf}
+ 9 {-code ok -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 10 {-code error -level 5 -f ba snarf} {-code error -level 0 -f ba snarf}
+ 11 {-code ok -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 12 {-code boss -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 13 {-code boss -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 14 {-code 1 -level 0 -f ba} {-code 1 -level 0 -f ba}
+ 15 {-code 0 -level 0 -f ba} {-code 1 -level 0 -f ba}
+ 16 {-code 1 -level 5 -f ba} {-code 1 -level 0 -f ba}
+ 17 {-code 0 -level 5 -f ba} {-code 1 -level 0 -f ba}
+ 18 {-code error -level 0 -f ba} {-code error -level 0 -f ba}
+ 19 {-code ok -level 0 -f ba} {-code 1 -level 0 -f ba}
+ 20 {-code error -level 5 -f ba} {-code error -level 0 -f ba}
+ 21 {-code ok -level 5 -f ba} {-code 1 -level 0 -f ba}
+ 22 {-code boss -level 0 -f ba} {-code 1 -level 0 -f ba}
+ 23 {-code boss -level 5 -f ba} {-code 1 -level 0 -f ba}
+ 24 {-code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 25 {-code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 26 {-code error -level X -f ba snarf} {-code error -level 0 -f ba snarf}
+ 27 {-code ok -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 28 {-code boss -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 29 {-code 1 -level X -f ba} {-code 1 -level 0 -f ba}
+ 30 {-code 0 -level X -f ba} {-code 1 -level 0 -f ba}
+ 31 {-code error -level X -f ba} {-code error -level 0 -f ba}
+ 32 {-code ok -level X -f ba} {-code 1 -level 0 -f ba}
+ 33 {-code boss -level X -f ba} {-code 1 -level 0 -f ba}
+
+ 34 {-code 1 -code 1 -level 0 -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf}
+ 35 {-code 1 -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 36 {-code 1 -code 1 -level 5 -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf}
+ 37 {-code 1 -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 38 {-code 1 -code error -level 0 -f ba snarf} {-code 1 -code error -level 0 -f ba snarf}
+ 39 {-code 1 -code ok -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 40 {-code 1 -code error -level 5 -f ba snarf} {-code 1 -code error -level 0 -f ba snarf}
+ 41 {-code 1 -code ok -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 42 {-code 1 -code boss -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 43 {-code 1 -code boss -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 44 {-code 1 -code 1 -level 0 -f ba} {-code 1 -code 1 -level 0 -f ba}
+ 45 {-code 1 -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba}
+ 46 {-code 1 -code 1 -level 5 -f ba} {-code 1 -code 1 -level 0 -f ba}
+ 47 {-code 1 -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba}
+ 48 {-code 1 -code error -level 0 -f ba} {-code 1 -code error -level 0 -f ba}
+ 49 {-code 1 -code ok -level 0 -f ba} {-code 1 -level 0 -f ba}
+ 50 {-code 1 -code error -level 5 -f ba} {-code 1 -code error -level 0 -f ba}
+ 51 {-code 1 -code ok -level 5 -f ba} {-code 1 -level 0 -f ba}
+ 52 {-code 1 -code boss -level 0 -f ba} {-code 1 -level 0 -f ba}
+ 53 {-code 1 -code boss -level 5 -f ba} {-code 1 -level 0 -f ba}
+ 54 {-code 1 -code 1 -level X -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf}
+ 55 {-code 1 -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 56 {-code 1 -code error -level X -f ba snarf} {-code 1 -code error -level 0 -f ba snarf}
+ 57 {-code 1 -code ok -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 58 {-code 1 -code boss -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 59 {-code 1 -code 1 -level X -f ba} {-code 1 -code 1 -level 0 -f ba}
+ 60 {-code 1 -code 0 -level X -f ba} {-code 1 -level 0 -f ba}
+ 61 {-code 1 -code error -level X -f ba} {-code 1 -code error -level 0 -f ba}
+ 62 {-code 1 -code ok -level X -f ba} {-code 1 -level 0 -f ba}
+ 63 {-code 1 -code boss -level X -f ba} {-code 1 -level 0 -f ba}
+
+ 64 {-code 0 -code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 65 {-code 0 -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 66 {-code 0 -code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 67 {-code 0 -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 68 {-code 0 -code error -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 69 {-code 0 -code ok -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 70 {-code 0 -code error -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 71 {-code 0 -code ok -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 72 {-code 0 -code boss -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 73 {-code 0 -code boss -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 74 {-code 0 -code 1 -level 0 -f ba} {-code 1 -level 0 -f ba}
+ 75 {-code 0 -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba}
+ 76 {-code 0 -code 1 -level 5 -f ba} {-code 1 -level 0 -f ba}
+ 77 {-code 0 -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba}
+ 78 {-code 0 -code error -level 0 -f ba} {-code 1 -level 0 -f ba}
+ 79 {-code 0 -code ok -level 0 -f ba} {-code 1 -level 0 -f ba}
+ 80 {-code 0 -code error -level 5 -f ba} {-code 1 -level 0 -f ba}
+ 81 {-code 0 -code ok -level 5 -f ba} {-code 1 -level 0 -f ba}
+ 82 {-code 0 -code boss -level 0 -f ba} {-code 1 -level 0 -f ba}
+ 83 {-code 0 -code boss -level 5 -f ba} {-code 1 -level 0 -f ba}
+ 84 {-code 0 -code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 85 {-code 0 -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 86 {-code 0 -code error -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 87 {-code 0 -code ok -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 88 {-code 0 -code boss -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 89 {-code 0 -code 1 -level X -f ba} {-code 1 -level 0 -f ba}
+ 90 {-code 0 -code 0 -level X -f ba} {-code 1 -level 0 -f ba}
+ 91 {-code 0 -code error -level X -f ba} {-code 1 -level 0 -f ba}
+ 92 {-code 0 -code ok -level X -f ba} {-code 1 -level 0 -f ba}
+ 93 {-code 0 -code boss -level X -f ba} {-code 1 -level 0 -f ba}
+
+ 94 {-code 1 -code 1 -level 0 -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf}
+ 95 {-code 0 -code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 96 {-code 1 -code 1 -level 5 -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf}
+ 97 {-code 0 -code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ 98 {-code error -code 1 -level 0 -f ba snarf} {-code error -code 1 -level 0 -f ba snarf}
+ 99 {-code ok -code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ a0 {-code error -code 1 -level 5 -f ba snarf} {-code error -code 1 -level 0 -f ba snarf}
+ a1 {-code ok -code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ a2 {-code boss -code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ a3 {-code boss -code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ a4 {-code 1 -code 1 -level 0 -f ba} {-code 1 -code 1 -level 0 -f ba}
+ a5 {-code 0 -code 1 -level 0 -f ba} {-code 1 -level 0 -f ba}
+ a6 {-code 1 -code 1 -level 5 -f ba} {-code 1 -code 1 -level 0 -f ba}
+ a7 {-code 0 -code 1 -level 5 -f ba} {-code 1 -level 0 -f ba}
+ a8 {-code error -code 1 -level 0 -f ba} {-code error -code 1 -level 0 -f ba}
+ a9 {-code ok -code 1 -level 0 -f ba} {-code 1 -level 0 -f ba}
+ b0 {-code error -code 1 -level 5 -f ba} {-code error -code 1 -level 0 -f ba}
+ b1 {-code ok -code 1 -level 5 -f ba} {-code 1 -level 0 -f ba}
+ b2 {-code boss -code 1 -level 0 -f ba} {-code 1 -level 0 -f ba}
+ b3 {-code boss -code 1 -level 5 -f ba} {-code 1 -level 0 -f ba}
+ b4 {-code 1 -code 1 -level X -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf}
+ b5 {-code 0 -code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ b6 {-code error -code 1 -level X -f ba snarf} {-code error -code 1 -level 0 -f ba snarf}
+ b7 {-code ok -code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ b8 {-code boss -code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ b9 {-code 1 -code 1 -level X -f ba} {-code 1 -code 1 -level 0 -f ba}
+ c0 {-code 0 -code 1 -level X -f ba} {-code 1 -level 0 -f ba}
+ c1 {-code error -code 1 -level X -f ba} {-code error -code 1 -level 0 -f ba}
+ c2 {-code ok -code 1 -level X -f ba} {-code 1 -level 0 -f ba}
+ c3 {-code boss -code 1 -level X -f ba} {-code 1 -level 0 -f ba}
+
+ c4 {-code 1 -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ c5 {-code 0 -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ c6 {-code 1 -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ c7 {-code 0 -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ c8 {-code error -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ c9 {-code ok -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ d0 {-code error -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ d1 {-code ok -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ d2 {-code boss -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ d3 {-code boss -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ d4 {-code 1 -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba}
+ d5 {-code 0 -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba}
+ d6 {-code 1 -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba}
+ d7 {-code 0 -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba}
+ d8 {-code error -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba}
+ d9 {-code ok -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba}
+ e0 {-code error -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba}
+ e1 {-code ok -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba}
+ e2 {-code boss -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba}
+ e3 {-code boss -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba}
+ e4 {-code 1 -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ e5 {-code 0 -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ e6 {-code error -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ e7 {-code ok -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ e8 {-code boss -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
+ e9 {-code 1 -code 0 -level X -f ba} {-code 1 -level 0 -f ba}
+ f0 {-code 0 -code 0 -level X -f ba} {-code 1 -level 0 -f ba}
+ f1 {-code error -code 0 -level X -f ba} {-code 1 -level 0 -f ba}
+ f2 {-code ok -code 0 -level X -f ba} {-code 1 -level 0 -f ba}
+ f3 {-code boss -code 0 -level X -f ba} {-code 1 -level 0 -f ba}
+} {
+ test io-71.$n {Tcl_SetChannelError} {testchannel} {
+
+ set f [makeFile {... dummy ...} cutsplice]
+ set c [open $f r]
+
+ set res [testchannel setchannelerror $c [lrange $msg 0 end]]
+ close $c
+ removeFile cutsplice
+
+ set res
+ } [lrange $expected 0 end]
+
+ test io-72.$n {Tcl_SetChannelErrorInterp} {testchannel} {
+
+ set f [makeFile {... dummy ...} cutsplice]
+ set c [open $f r]
+
+ set res [testchannel setchannelerrorinterp $c [lrange $msg 0 end]]
+ close $c
+ removeFile cutsplice
+
+ set res
+ } [lrange $expected 0 end]
+}
+
+# ### ### ### ######### ######### #########
+
# cleanup
foreach file [list fooBar longfile script output test1 pipe my_script foo \
bar test2 test3 cat stdout kyrillic.txt utf8-fcopy.txt utf8-rp.txt] {
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index 23eaeca..6d08d47 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -1,3 +1,4 @@
+# -*- tcl -*-
# Commands covered: open, close, gets, read, puts, seek, tell, eof, flush,
# fblocked, fconfigure, open, channel, fcopy
#
@@ -12,7 +13,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: ioCmd.test,v 1.21.2.1 2005/05/05 17:56:16 kennykb Exp $
+# RCS: @(#) $Id: ioCmd.test,v 1.21.2.2 2005/08/25 15:46:53 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -572,6 +573,3081 @@ test iocmd-15.12 {Tcl_FcopyObjCmd} {fcopy} {
close $rfile
close $wfile
+# ### ### ### ######### ######### #########
+## Testing the reflected channel.
+
+test iocmd-20.0 {chan, wrong#args} {
+ catch {chan} msg
+ set msg
+} {wrong # args: should be "chan subcommand ?argument ...?"}
+
+test iocmd-20.1 {chan, unknown method} {
+ catch {chan foo} msg
+ set msg
+} {unknown or ambiguous subcommand "foo": must be blocked, close, configure, copy, create, eof, event, flush, gets, names, postevent, puts, read, seek, tell, or truncate}
+
+# --- --- --- --------- --------- ---------
+# chan create, and method "initalize"
+
+test iocmd-21.0 {chan create, wrong#args, not enough} {
+ catch {chan create} msg
+ set msg
+} {wrong # args: should be "chan create mode cmdprefix"}
+
+test iocmd-21.1 {chan create, wrong#args, too many} {
+ catch {chan create a b c} msg
+ set msg
+} {wrong # args: should be "chan create mode cmdprefix"}
+
+test iocmd-21.2 {chan create, invalid r/w mode, empty} {
+ proc foo {} {}
+ catch {chan create {} foo} msg
+ rename foo {}
+ set msg
+} {bad mode list: is empty}
+
+test iocmd-21.3 {chan create, invalid r/w mode, bad string} {
+ proc foo {} {}
+ catch {chan create {c} foo} msg
+ rename foo {}
+ set msg
+} {bad mode "c": must be read or write}
+
+test iocmd-21.4 {chan create, bad handler, not a list} {
+ catch {chan create {r w} "foo \{"} msg
+ set msg
+} {unmatched open brace in list}
+
+test iocmd-21.5 {chan create, bad handler, not a command} {
+ catch {chan create {r w} foo} msg
+ set msg
+} {Initialize failure: invalid command name "foo"}
+
+test iocmd-21.6 {chan create, initialize failed, bad signature} {
+ proc foo {} {}
+ catch {chan create {r w} foo} msg
+ rename foo {}
+ set msg
+} {Initialize failure: wrong # args: should be "foo"}
+
+test iocmd-21.7 {chan create, initialize failed, bad signature} {
+ proc foo {} {}
+ catch {chan create {r w} ::foo} msg
+ rename foo {}
+ set msg
+} {Initialize failure: wrong # args: should be "::foo"}
+
+test iocmd-21.8 {chan create, initialize failed, bad result, not a list} {
+ proc foo {args} {return "\{"}
+ catch {chan create {r w} foo} msg
+ rename foo {}
+ set msg
+} {Initialize failure: unmatched open brace in list}
+
+test iocmd-21.9 {chan create, initialize failed, bad result, not a list} {
+ proc foo {args} {return \{\{\}}
+ catch {chan create {r w} foo} msg
+ rename foo {}
+ set msg
+} {Initialize failure: unmatched open brace in list}
+
+test iocmd-21.10 {chan create, initialize failed, bad result, empty list} {
+ proc foo {args} {}
+ catch {chan create {r w} foo} msg
+ rename foo {}
+ set msg
+} {Initialize failure: Not all required methods supported}
+
+test iocmd-21.11 {chan create, initialize failed, bad result, bogus method name} {
+ proc foo {args} {return 1}
+ catch {chan create {r w} foo} msg
+ rename foo {}
+ set msg
+} {Initialize failure: bad method "1": must be blocking, cget, cgetall, configure, finalize, initialize, read, seek, watch, or write}
+
+test iocmd-21.12 {chan create, initialize failed, bad result, ambiguous method name} {
+ proc foo {args} {return {a b c}}
+ catch {chan create {r w} foo} msg
+ rename foo {}
+ set msg
+} {Initialize failure: ambiguous method "c": must be blocking, cget, cgetall, configure, finalize, initialize, read, seek, watch, or write}
+
+test iocmd-21.13 {chan create, initialize failed, bad result, required methods missing} {
+ proc foo {args} {return {initialize finalize}}
+ catch {chan create {r w} foo} msg
+ rename foo {}
+ set msg
+} {Initialize failure: Not all required methods supported}
+
+test iocmd-21.14 {chan create, initialize failed, bad result, mode/handler mismatch} {
+ proc foo {args} {return {initialize finalize watch read}}
+ catch {chan create {r w} foo} msg
+ rename foo {}
+ set msg
+} {Initialize failure: Writing not supported, but requested}
+
+test iocmd-21.15 {chan create, initialize failed, bad result, mode/handler mismatch} {
+ proc foo {args} {return {initialize finalize watch write}}
+ catch {chan create {r w} foo} msg
+ rename foo {}
+ set msg
+} {Initialize failure: Reading not supported, but requested}
+
+test iocmd-21.16 {chan create, initialize failed, bad result, cget(all) mismatch} {
+ proc foo {args} {return {initialize finalize watch cget write read}}
+ catch {chan create {r w} foo} msg
+ rename foo {}
+ set msg
+} {Initialize failure: 'cgetall' not supported, but should be, as 'cget' is}
+
+test iocmd-21.17 {chan create, initialize failed, bad result, cget(all) mismatch} {
+ proc foo {args} {return {initialize finalize watch cgetall read write}}
+ catch {chan create {r w} foo} msg
+ rename foo {}
+ set msg
+} {Initialize failure: 'cget' not supported, but should be, as 'cgetall' is}
+
+test iocmd-21.18 {chan create, initialize ok, creates channel} -match glob -body {
+ proc foo {args} {
+ global res
+ lappend res $args
+ if {[lindex $args 0] ne "initialize"} {return}
+ return {initialize finalize watch read write}
+ }
+ set res {}
+ lappend res [file channel rc*]
+ lappend res [chan create {r w} foo]
+ lappend res [close [lindex $res end]]
+ lappend res [file channel rc*]
+ rename foo {}
+ set res
+} -result {{} {initialize rc* {read write}} rc* {finalize rc*} {} {}}
+
+test iocmd-21.19 {chan create, init failure -> no channel, no finalize} -match glob -body {
+ proc foo {args} {
+ global res
+ lappend res $args
+ return {}
+ }
+ set res {}
+ lappend res [file channel rc*]
+ lappend res [catch {chan create {r w} foo} msg]
+ lappend res $msg
+ lappend res [file channel rc*]
+ rename foo {}
+ set res
+} -result {{} {initialize rc* {read write}} 1 {Initialize failure: Not all required methods supported} {}}
+
+# --- --- --- --------- --------- ---------
+# Helper commands to record the arguments to handler methods.
+
+proc note {item} {global res ; lappend res $item ; return}
+proc track {} {upvar args item ; note $item; return}
+proc notes {items} {foreach i $items {note $i}}
+
+# Helper command, canned result for 'initialize' method.
+# Gets the optional methods as arguments. Use return features
+# to post the result higher up.
+
+proc init {args} {
+ lappend args initialize finalize watch read write
+ return -code return $args
+}
+
+proc oninit {args} {
+ upvar args hargs
+ if {[lindex $hargs 0] ne "initialize"} {return}
+ lappend args initialize finalize watch read write
+ return -code return $args
+}
+
+proc onfinal {} {
+ upvar args hargs
+ if {[lindex $hargs 0] ne "finalize"} {return}
+ return -code return ""
+}
+
+# --- --- --- --------- --------- ---------
+# method finalize
+
+test iocmd-22.1 {chan finalize, handler destruction has no effect on channel} -match glob -body {
+ set res {}
+ proc foo {args} {track ; oninit; return}
+ note [set c [chan create {r w} foo]]
+
+ rename foo {}
+
+ note [file channels rc*]
+ note [catch {close $c} msg] ; note $msg
+ note [file channels rc*]
+
+ set res
+} -result {{initialize rc* {read write}} rc* rc* 1 {invalid command name "foo"} {}}
+
+test iocmd-22.2 {chan finalize, for close} -match glob -body {
+ set res {}
+ proc foo {args} {track ; oninit ; return {}}
+ note [set c [chan create {r w} foo]]
+
+ close $c
+
+ # Close deleted the channel.
+ note [file channels rc*]
+
+ # Channel destruction does not kill handler command!
+ note [info command foo]
+
+ rename foo {}
+ set res
+} -result {{initialize rc* {read write}} rc* {finalize rc*} {} foo}
+
+test iocmd-22.3 {chan finalize, for close, error, close error} -match glob -body {
+ set res {}
+ proc foo {args} {track ; oninit ; return -code error 5}
+ note [set c [chan create {r w} foo]]
+
+ note [catch {close $c} msg] ; note $msg
+ # Channel is gone despite error.
+ note [file channels rc*]
+
+ rename foo {}
+ set res
+} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 5 {}}
+
+test iocmd-22.4 {chan finalize, for close, error, close error} -match glob -body {
+ set res {}
+ proc foo {args} {track ; oninit ; error FOO}
+ note [set c [chan create {r w} foo]]
+
+ note [catch {close $c} msg] ; note $msg
+
+ rename foo {}
+ set res
+} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 FOO}
+
+test iocmd-22.5 {chan finalize, for close, arbitrary result, ignored} -match glob -body {
+ set res {}
+ proc foo {args} {track ; oninit ; return SOMETHING}
+ note [set c [chan create {r w} foo]]
+
+ note [catch {close $c} msg]; note $msg
+
+ rename foo {}
+ set res
+} -result {{initialize rc* {read write}} rc* {finalize rc*} 0 {}}
+
+test iocmd-22.6 {chan finalize, for close, break, close error} -match glob -body {
+ set res {}
+ proc foo {args} {track ; oninit ; return -code 3}
+ note [set c [chan create {r w} foo]]
+
+ note [catch {close $c} msg] ; note $msg
+
+ rename foo {}
+ set res
+} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 {}}
+
+test iocmd-22.7 {chan finalize, for close, continue, close error} -match glob -body {
+ set res {}
+ proc foo {args} {track ; oninit ; return -code 4}
+ note [set c [chan create {r w} foo]]
+
+ note [catch {close $c} msg] ; note $msg
+
+ rename foo {}
+ set res
+} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 {}}
+
+test iocmd-22.8 {chan finalize, for close, custom code, close error} -match glob -body {
+ set res {}
+ proc foo {args} {track ; oninit ; return -code 777 BANG}
+ note [set c [chan create {r w} foo]]
+
+ note [catch {close $c} msg] ; note $msg
+
+ rename foo {}
+ set res
+} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 BANG}
+
+test iocmd-22.9 {chan finalize, for close, ignore level, close error} -match glob -body {
+ set res {}
+ proc foo {args} {track ; oninit ; return -level 5 -code 777 BANG}
+ note [set c [chan create {r w} foo]]
+
+ note [catch {close $c} msg opt] ; note $msg ; note $opt
+
+ rename foo {}
+ set res
+} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}}
+
+# --- === *** ###########################
+# method read
+
+test iocmd-23.1 {chan read, regular data return} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit ; onfinal ; track
+ return snarf
+ }
+ set c [chan create {r w} foo]
+
+ note [read $c 10]
+ close $c
+
+ rename foo {}
+ set res
+} -result {{read rc* 4096} {read rc* 4096} snarfsnarf}
+
+test iocmd-23.2 {chan read, bad data return, to much} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit ; onfinal ; track
+ return [string repeat snarf 1000]
+ }
+ set c [chan create {r w} foo]
+
+ note [catch {read $c 2} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{read rc* 4096} 1 {read delivered more than requested}}
+
+test iocmd-23.3 {chan read, for non-readable channel} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit ; onfinal ; track
+ note MUST_NOT_HAPPEN
+ }
+ set c [chan create {w} foo]
+
+ note [catch {read $c 2} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {1 {channel "rc*" wasn't opened for reading}}
+
+test iocmd-23.4 {chan read, error return} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit ; onfinal ; track
+ return -code error BOOM!
+ }
+ set c [chan create {r w} foo]
+ note [catch {read $c 2} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{read rc* 4096} 1 BOOM!}
+
+test iocmd-23.5 {chan read, break return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit ; onfinal ; track
+ return -code break BOOM!
+ }
+ set c [chan create {r w} foo]
+ note [catch {read $c 2} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{read rc* 4096} 1 BOOM!}
+
+test iocmd-23.6 {chan read, continue return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit ; onfinal ; track
+ return -code continue BOOM!
+ }
+ set c [chan create {r w} foo]
+ note [catch {read $c 2} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{read rc* 4096} 1 BOOM!}
+
+test iocmd-23.7 {chan read, custom return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit ; onfinal ; track
+ return -code 777 BOOM!
+ }
+ set c [chan create {r w} foo]
+ note [catch {read $c 2} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{read rc* 4096} 1 BOOM!}
+
+test iocmd-23.8 {chan read, level is squashed} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit ; onfinal ; track
+ return -level 55 -code 777 BOOM!
+ }
+ set c [chan create {r w} foo]
+ note [catch {read $c 2} msg opt] ; note $msg ; note $opt
+ close $c
+
+ rename foo {}
+ set res
+} -result {{read rc* 4096} 1 BOOM! {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BOOM!}}
+
+# --- === *** ###########################
+# method write
+
+test iocmd-24.1 {chan write, regular write} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal ; track
+ set written [string length [lindex $args 2]]
+ note $written
+ return $written
+ }
+ set c [chan create {r w} foo]
+
+ puts -nonewline $c snarf ; flush $c
+ close $c
+
+ rename foo {}
+ set res
+} -result {{write rc* snarf} 5}
+
+test iocmd-24.2 {chan write, partial write is ok} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit ; onfinal ; track
+ set written [string length [lindex $args 2]]
+ if {$written > 10} {set written [expr {$written / 2}]}
+ note $written
+ return $written
+ }
+ set c [chan create {r w} foo]
+
+ puts -nonewline $c snarfsnarfsnarf ; flush $c
+ close $c
+
+ rename foo {}
+ set res
+} -result {{write rc* snarfsnarfsnarf} 7 {write rc* arfsnarf} 8}
+
+test iocmd-24.3 {chan write, failed write} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; note -1 ; return -1}
+
+ set c [chan create {r w} foo]
+ puts -nonewline $c snarfsnarfsnarf ; flush $c
+ close $c
+
+ rename foo {}
+ set res
+} -result {{write rc* snarfsnarfsnarf} -1}
+
+test iocmd-24.4 {chan write, non-writable channel} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return}
+ set c [chan create {r} foo]
+
+ note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {1 {channel "rc*" wasn't opened for writing}}
+
+test iocmd-24.5 {chan write, bad result, more written than data} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; return 10000}
+ set c [chan create {r w} foo]
+
+ note [catch {puts -nonewline $c snarf ; flush $c} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{write rc* snarf} 1 {write wrote more than requested}}
+
+test iocmd-24.6 {chan write, bad result, zero-length write} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; return 0}
+ set c [chan create {r w} foo]
+
+ note [catch {puts -nonewline $c snarf ; flush $c} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{write rc* snarf} 1 {write wrote more than requested}}
+
+test iocmd-24.7 {chan write, failed write, error return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; return -code error BOOM!}
+ set c [chan create {r w} foo]
+
+ note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg]
+ note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{write rc* snarfsnarfsnarf} 1 BOOM!}
+
+test iocmd-24.8 {chan write, failed write, error return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; error BOOM!}
+ set c [chan create {r w} foo]
+
+ notes [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg]
+ note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{write rc* snarfsnarfsnarf} 1 BOOM!}
+
+test iocmd-24.9 {chan write, failed write, break return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; return -code break BOOM!}
+ set c [chan create {r w} foo]
+
+ note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg]
+ note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{write rc* snarfsnarfsnarf} 1 BOOM!}
+
+test iocmd-24.10 {chan write, failed write, continue return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; return -code continue BOOM!}
+ set c [chan create {r w} foo]
+
+ note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg]
+ note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{write rc* snarfsnarfsnarf} 1 BOOM!}
+
+test iocmd-24.11 {chan write, failed write, custom return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; return -code 777 BOOM!}
+ set c [chan create {r w} foo]
+
+ note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg]
+ note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{write rc* snarfsnarfsnarf} 1 BOOM!}
+
+test iocmd-24.12 {chan write, failed write, non-numeric return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; return BANG}
+ set c [chan create {r w} foo]
+
+ note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg]
+ note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{write rc* snarfsnarfsnarf} 1 {expected integer but got "BANG"}}
+
+test iocmd-24.13 {chan write, failed write, level is ignored} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; return -level 55 -code 777 BOOM!}
+ set c [chan create {r w} foo]
+
+ note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg opt]
+ note $msg
+ note $opt
+ close $c
+
+ rename foo {}
+ set res
+} -result {{write rc* snarfsnarfsnarf} 1 BOOM! {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BOOM!}}
+
+# --- === *** ###########################
+# method cgetall
+
+test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return}
+ set c [chan create {r w} foo]
+
+ note [fconfigure $c]
+ close $c
+
+ rename foo {}
+ set res
+} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}}
+
+test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body {
+ set res {}
+ proc foo {args} {oninit cget cgetall ; onfinal ; track ; return ""}
+ set c [chan create {r w} foo]
+
+ note [fconfigure $c]
+ close $c
+
+ rename foo {}
+ set res
+} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}}
+
+test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit cget cgetall ; onfinal ; track
+ return "-bar foo -snarf x"
+ }
+ set c [chan create {r w} foo]
+
+ note [fconfigure $c]
+ close $c
+
+ rename foo {}
+ set res
+} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *} -bar foo -snarf x}}
+
+test iocmd-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit cget cgetall ; onfinal ; track
+ return "-bar"
+ }
+ set c [chan create {r w} foo]
+
+ note [catch {fconfigure $c} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{cgetall rc*} 1 {Expected list with even number of elements, got 1 element instead}}
+
+test iocmd-25.5 {chan configure, cgetall, bad result, not a list} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit cget cgetall ; onfinal ; track
+ return "\{"
+ }
+ set c [chan create {r w} foo]
+
+ note [catch {fconfigure $c} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{cgetall rc*} 1 {unmatched open brace in list}}
+
+test iocmd-25.6 {chan configure, cgetall, error return} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit cget cgetall ; onfinal ; track
+ return -code error BOOM!
+ }
+ set c [chan create {r w} foo]
+
+ note [catch {fconfigure $c} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{cgetall rc*} 1 BOOM!}
+
+test iocmd-25.7 {chan configure, cgetall, break return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit cget cgetall ; onfinal ; track
+ return -code break BOOM!
+ }
+ set c [chan create {r w} foo]
+
+ note [catch {fconfigure $c} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{cgetall rc*} 1 BOOM!}
+
+test iocmd-25.8 {chan configure, cgetall, continue return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit cget cgetall ; onfinal ; track
+ return -code continue BOOM!
+ }
+ set c [chan create {r w} foo]
+
+ note [catch {fconfigure $c} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{cgetall rc*} 1 BOOM!}
+
+test iocmd-25.9 {chan configure, cgetall, custom return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit cget cgetall ; onfinal ; track
+ return -code 777 BOOM!
+ }
+ set c [chan create {r w} foo]
+
+ note [catch {fconfigure $c} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{cgetall rc*} 1 BOOM!}
+
+test iocmd-25.10 {chan configure, cgetall, level is ignored} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit cget cgetall ; onfinal ; track
+ return -level 55 -code 777 BANG
+ }
+ set c [chan create {r w} foo]
+
+ note [catch {fconfigure $c} msg opt] ; note $msg ; note $opt
+ close $c
+
+ rename foo {}
+ set res
+} -result {{cgetall rc*} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}}
+
+# --- === *** ###########################
+# method configure
+
+test iocmd-26.1 {chan configure, set standard option} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit configure ; onfinal ; track ; note MUST_NOT_HAPPEN
+ return
+ }
+ set c [chan create {r w} foo]
+
+ note [fconfigure $c -translation lf]
+ close $c
+
+ rename foo {}
+ set res
+} -result {{}}
+
+test iocmd-26.2 {chan configure, set option, error return} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit configure ; onfinal ; track
+ return -code error BOOM!
+ }
+ set c [chan create {r w} foo]
+
+ note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{configure rc* -rc-foo bar} 1 BOOM!}
+
+test iocmd-26.3 {chan configure, set option, ok return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit configure ; onfinal ; track ; return}
+ set c [chan create {r w} foo]
+
+ note [fconfigure $c -rc-foo bar]
+ close $c
+
+ rename foo {}
+ set res
+} -result {{configure rc* -rc-foo bar} {}}
+
+test iocmd-26.4 {chan configure, set option, break return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit configure ; onfinal ; track
+ return -code break BOOM!
+ }
+ set c [chan create {r w} foo]
+
+ note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{configure rc* -rc-foo bar} 1 BOOM!}
+
+test iocmd-26.5 {chan configure, set option, continue return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit configure ; onfinal ; track
+ return -code continue BOOM!
+ }
+ set c [chan create {r w} foo]
+
+ note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{configure rc* -rc-foo bar} 1 BOOM!}
+
+test iocmd-26.6 {chan configure, set option, custom return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit configure ; onfinal ; track
+ return -code 444 BOOM!
+ }
+ set c [chan create {r w} foo]
+
+ note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{configure rc* -rc-foo bar} 1 BOOM!}
+
+test iocmd-26.7 {chan configure, set option, level is ignored} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit configure ; onfinal ; track
+ return -level 55 -code 444 BANG
+ }
+ set c [chan create {r w} foo]
+
+ note [catch {fconfigure $c -rc-foo bar} msg opt] ; note $msg ; note $opt
+ close $c
+
+ rename foo {}
+ set res
+} -result {{configure rc* -rc-foo bar} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}}
+
+# --- === *** ###########################
+# method cget
+
+test iocmd-27.1 {chan configure, get option, ok return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit cget cgetall ; onfinal ; track ; return foo}
+ set c [chan create {r w} foo]
+
+ note [fconfigure $c -rc-foo]
+ close $c
+
+ rename foo {}
+ set res
+} -result {{cget rc* -rc-foo} foo}
+
+test iocmd-27.2 {chan configure, get option, error return} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit cget cgetall ; onfinal ; track
+ return -code error BOOM!
+ }
+ set c [chan create {r w} foo]
+
+ note [catch {fconfigure $c -rc-foo} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{cget rc* -rc-foo} 1 BOOM!}
+
+test iocmd-27.3 {chan configure, get option, break return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit cget cgetall ; onfinal ; track
+ return -code error BOOM!
+ }
+ set c [chan create {r w} foo]
+
+ note [catch {fconfigure $c -rc-foo} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{cget rc* -rc-foo} 1 BOOM!}
+
+test iocmd-27.4 {chan configure, get option, continue return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit cget cgetall ; onfinal ; track
+ return -code continue BOOM!
+ }
+ set c [chan create {r w} foo]
+
+ note [catch {fconfigure $c -rc-foo} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{cget rc* -rc-foo} 1 BOOM!}
+
+test iocmd-27.5 {chan configure, get option, custom return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit cget cgetall ; onfinal ; track
+ return -code 333 BOOM!
+ }
+ set c [chan create {r w} foo]
+
+ note [catch {fconfigure $c -rc-foo} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{cget rc* -rc-foo} 1 BOOM!}
+
+test iocmd-27.6 {chan configure, get option, level is ignored} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit cget cgetall ; onfinal ; track
+ return -level 77 -code 333 BANG
+ }
+ set c [chan create {r w} foo]
+
+ note [catch {fconfigure $c -rc-foo} msg opt] ; note $msg ; note $opt
+ close $c
+
+ rename foo {}
+ set res
+} -result {{cget rc* -rc-foo} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}}
+
+# --- === *** ###########################
+# method seek
+
+test iocmd-28.1 {chan tell, not supported by handler} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return}
+ set c [chan create {r w} foo]
+
+ note [tell $c]
+ close $c
+
+ rename foo {}
+ set res
+} -result {-1}
+
+test iocmd-28.2 {chan tell, error return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return -code error BOOM!}
+ set c [chan create {r w} foo]
+
+ note [catch {tell $c} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 current} 1 BOOM!}
+
+test iocmd-28.3 {chan tell, break return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return -code break BOOM!}
+ set c [chan create {r w} foo]
+
+ note [catch {tell $c} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 current} 1 BOOM!}
+
+test iocmd-28.4 {chan tell, continue return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return -code continue BOOM!}
+ set c [chan create {r w} foo]
+
+ note [catch {tell $c} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 current} 1 BOOM!}
+
+test iocmd-28.5 {chan tell, custom return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return -code 222 BOOM!}
+ set c [chan create {r w} foo]
+
+ note [catch {tell $c} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 current} 1 BOOM!}
+
+test iocmd-28.6 {chan tell, level is ignored} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return -level 11 -code 222 BANG}
+ set c [chan create {r w} foo]
+
+ note [catch {tell $c} msg opt] ; note $msg ; note $opt
+ close $c
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 current} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}}
+
+test iocmd-28.7 {chan tell, regular return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return 88}
+ set c [chan create {r w} foo]
+
+ note [tell $c]
+ close $c
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 current} 88}
+
+test iocmd-28.8 {chan tell, negative return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return -1}
+ set c [chan create {r w} foo]
+
+ note [catch {tell $c} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 current} 1 {Tried to seek before origin}}
+
+test iocmd-28.9 {chan tell, string return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return BOGUS}
+ set c [chan create {r w} foo]
+
+ note [catch {tell $c} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 current} 1 {expected integer but got "BOGUS"}}
+
+test iocmd-28.10 {chan seek, not supported by handler} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return}
+ set c [chan create {r w} foo]
+
+ note [catch {seek $c 0 start} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {1 {error during seek on "rc*": invalid argument}}
+
+test iocmd-28.11 {chan seek, error return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return -code error BOOM!}
+ set c [chan create {r w} foo]
+
+ note [catch {seek $c 0 start} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 start} 1 BOOM!}
+
+test iocmd-28.12 {chan seek, break return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return -code break BOOM!}
+ set c [chan create {r w} foo]
+
+ note [catch {seek $c 0 start} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 start} 1 BOOM!}
+
+test iocmd-28.13 {chan seek, continue return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return -code continue BOOM!}
+ set c [chan create {r w} foo]
+
+ note [catch {seek $c 0 start} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 start} 1 BOOM!}
+
+test iocmd-28.14 {chan seek, custom return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return -code 99 BOOM!}
+ set c [chan create {r w} foo]
+
+ note [catch {seek $c 0 start} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 start} 1 BOOM!}
+
+test iocmd-28.15 {chan seek, level is ignored} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return -level 33 -code 99 BANG}
+ set c [chan create {r w} foo]
+
+ note [catch {seek $c 0 start} msg opt] ; note $msg ; note $opt
+ close $c
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 start} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}}
+
+test iocmd-28.16 {chan seek, bogus return, negative location} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return -45}
+ set c [chan create {r w} foo]
+
+ note [catch {seek $c 0 start} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 start} 1 {Tried to seek before origin}}
+
+test iocmd-28.17 {chan seek, bogus return, string return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return BOGUS}
+ set c [chan create {r w} foo]
+
+ note [catch {seek $c 0 start} msg] ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 start} 1 {expected integer but got "BOGUS"}}
+
+test iocmd-28.18 {chan seek, ok result} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return 23}
+ set c [chan create {r w} foo]
+
+ note [seek $c 0 current]
+ close $c
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 current} {}}
+
+foreach {n code} {
+ 0 start
+ 1 current
+ 2 end
+} {
+ test iocmd-28.19.$n "chan seek, base conversion, $code" -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return 0}
+
+ set c [chan create {r w} foo]
+ note [seek $c 0 $code]
+ close $c
+
+ rename foo {}
+ set res
+ } -result [list [list seek rc* 0 $code] {}]
+}
+
+# --- === *** ###########################
+# method blocking
+
+test iocmd-29.1 {chan blocking, no handler support} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return}
+ set c [chan create {r w} foo]
+
+ note [fconfigure $c -blocking]
+ close $c
+
+ rename foo {}
+ set res
+} -result {1}
+
+test iocmd-29.2 {chan blocking, no handler support} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return}
+ set c [chan create {r w} foo]
+
+ note [fconfigure $c -blocking 0]
+ note [fconfigure $c -blocking]
+ close $c
+
+ rename foo {}
+ set res
+} -result {{} 0}
+
+test iocmd-29.3 {chan blocking, retrieval, handler support} -match glob -body {
+ set res {}
+ proc foo {args} {oninit blocking ; onfinal ; track ; note MUST_NOT_HAPPEN ; return}
+ set c [chan create {r w} foo]
+
+ note [fconfigure $c -blocking]
+ close $c
+
+ rename foo {}
+ set res
+} -result {1}
+
+test iocmd-29.4 {chan blocking, resetting, handler support} -match glob -body {
+ set res {}
+ proc foo {args} {oninit blocking ; onfinal ; track ; return}
+ set c [chan create {r w} foo]
+
+ note [fconfigure $c -blocking 0]
+ note [fconfigure $c -blocking]
+ close $c
+
+ rename foo {}
+ set res
+} -result {{blocking rc* 0} {} 0}
+
+test iocmd-29.5 {chan blocking, setting, handler support} -match glob -body {
+ set res {}
+ proc foo {args} {oninit blocking ; onfinal ; track ; return}
+ set c [chan create {r w} foo]
+
+ note [fconfigure $c -blocking 1]
+ note [fconfigure $c -blocking]
+ close $c
+
+ rename foo {}
+ set res
+} -result {{blocking rc* 1} {} 1}
+
+test iocmd-29.6 {chan blocking, error return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit blocking ; onfinal ; track ; error BOOM!}
+
+ set c [chan create {r w} foo]
+
+ note [catch {fconfigure $c -blocking 0} msg] ; note $msg
+
+ # Catch the close. It changes blocking mode internally, and runs into the error result.
+ catch {close $c}
+ rename foo {}
+ set res
+} -result {{blocking rc* 0} 1 BOOM!}
+
+test iocmd-29.7 {chan blocking, break return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit blocking ; onfinal ; track ; return -code break BOOM!}
+ set c [chan create {r w} foo]
+
+ note [catch {fconfigure $c -blocking 0} msg] ; note $msg
+
+ catch {close $c}
+ rename foo {}
+ set res
+} -result {{blocking rc* 0} 1 BOOM!}
+
+test iocmd-29.8 {chan blocking, continue return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit blocking ; onfinal ; track ; return -code continue BOOM!}
+ set c [chan create {r w} foo]
+
+ note [catch {fconfigure $c -blocking 0} msg] ; note $msg
+
+ catch {close $c}
+ rename foo {}
+ set res
+} -result {{blocking rc* 0} 1 BOOM!}
+
+test iocmd-29.9 {chan blocking, custom return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit blocking ; onfinal ; track ; return -code 44 BOOM!}
+ set c [chan create {r w} foo]
+
+ note [catch {fconfigure $c -blocking 0} msg] ; note $msg
+
+ catch {close $c}
+ rename foo {}
+ set res
+} -result {{blocking rc* 0} 1 BOOM!}
+
+test iocmd-29.10 {chan blocking, level is ignored} -match glob -body {
+ set res {}
+ proc foo {args} {oninit blocking ; onfinal ; track ; return -level 99 -code 44 BANG}
+ set c [chan create {r w} foo]
+
+ note [catch {fconfigure $c -blocking 0} msg opt] ; note $msg ; note $opt
+
+ catch {close $c}
+ rename foo {}
+ set res
+} -result {{blocking rc* 0} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}}
+
+test iocmd-29.11 {chan blocking, regular return ok, value ignored} -match glob -body {
+ set res {}
+ proc foo {args} {oninit blocking ; onfinal ; track ; return BOGUS}
+ set c [chan create {r w} foo]
+
+ note [catch {fconfigure $c -blocking 0} msg] ; note $msg
+
+ catch {close $c}
+ rename foo {}
+ set res
+} -result {{blocking rc* 0} 0 {}}
+
+# --- === *** ###########################
+# method watch
+
+test iocmd-30.1 {chan watch, read interest, some return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; return IGNORED}
+ set c [chan create {r w} foo]
+
+ note [fileevent $c readable {set tick $tick}]
+ close $c ;# 2nd watch, interest zero.
+
+ rename foo {}
+ set res
+} -result {{watch rc* read} {} {watch rc* {}}}
+
+test iocmd-30.2 {chan watch, write interest, error return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; return -code error BOOM!_IGNORED}
+ set c [chan create {r w} foo]
+
+ note [fileevent $c writable {set tick $tick}]
+ note [fileevent $c writable {}]
+ close $c
+
+ rename foo {}
+ set res
+} -result {{watch rc* write} {} {watch rc* {}} {}}
+
+test iocmd-30.3 {chan watch, accumulated interests} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; return}
+ set c [chan create {r w} foo]
+
+ note [fileevent $c writable {set tick $tick}]
+ note [fileevent $c readable {set tick $tick}]
+ note [fileevent $c writable {}]
+ note [fileevent $c readable {}]
+ close $c
+
+ rename foo {}
+ set res
+} -result {{watch rc* write} {} {watch rc* {read write}} {} {watch rc* read} {} {watch rc* {}} {}}
+
+test iocmd-30.4 {chan watch, unchanged interest not forwarded} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; return}
+ set c [chan create {r w} foo]
+
+ note [fileevent $c writable {set tick $tick}]
+ note [fileevent $c readable {set tick $tick}] ;# Script is changing,
+ note [fileevent $c readable {set tock $tock}] ;# interest does not.
+
+ close $c ;# 3rd and 4th watch, removing the event handlers.
+ rename foo {}
+ set res
+} -result {{watch rc* write} {} {watch rc* {read write}} {} {} {watch rc* write} {watch rc* {}}}
+
+# --- === *** ###########################
+# chan postevent
+
+test iocmd-31.1 {chan postevent, restricted to reflected channels} -match glob -body {
+ set c [open [makeFile {} goo] r]
+
+ catch {chan postevent $c {r w}} msg
+
+ close $c
+ removeFile goo
+ set msg
+} -result {channel "file*" is not a reflected channel}
+
+test iocmd-31.2 {chan postevent, unwanted events} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; return}
+ set c [chan create {r w} foo]
+
+ catch {chan postevent $c {r w}} msg ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{tried to post events channel "rc*" is not interested in}}
+
+test iocmd-31.3 {chan postevent, bad input, empty list} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; return}
+ set c [chan create {r w} foo]
+
+ catch {chan postevent $c {}} msg ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{bad event list: is empty}}
+
+test iocmd-31.4 {chan postevent, bad input, illlegal keyword} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; return}
+ set c [chan create {r w} foo]
+
+ catch {chan postevent $c goo} msg ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{bad event "goo": must be read or write}}
+
+test iocmd-31.5 {chan postevent, bad input, not a list} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; return}
+ set c [chan create {r w} foo]
+
+ catch {chan postevent $c "\{"} msg ; note $msg
+ close $c
+
+ rename foo {}
+ set res
+} -result {{unmatched open brace in list}}
+
+test iocmd-31.6 {chan postevent, posted events do happen} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; return}
+ set c [chan create {r w} foo]
+
+ note [fileevent $c readable {note TOCK}]
+
+ set stop [after 10000 {note TIMEOUT}]
+ after 1000 {note [chan postevent $c r]}
+ vwait ::res
+ catch {after cancel $stop}
+ close $c
+
+ rename foo {}
+ set res
+} -result {{watch rc* read} {} TOCK {} {watch rc* {}}}
+
+test iocmd-31.7 {chan postevent, posted events do happen} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; return}
+ set c [chan create {r w} foo]
+
+ note [fileevent $c writable {note TOCK}]
+
+ set stop [after 10000 {note TIMEOUT}]
+ after 1000 {note [chan postevent $c w]}
+ vwait ::res
+ catch {after cancel $stop}
+ close $c
+
+ rename foo {}
+ set res
+} -result {{watch rc* write} {} TOCK {} {watch rc* {}}}
+
+# ### ### ### ######### ######### #########
+## Same tests as above, but exercising the code forwarding and
+## receiving driver operations to the originator thread.
+
+# -*- tcl -*-
+# ### ### ### ######### ######### #########
+## Testing the reflected channel (Thread forwarding).
+#
+## The id numbers refer to the original test without thread
+## forwarding, and gaps due to tests not applicable to forwarding are
+## left to keep this asociation.
+
+testConstraint testchannel [llength [info commands testchannel]]
+
+# Duplicate of code in "thread.test". Find a better way of doing this
+# without duplication. Maybe placement into a proc which transforms to
+# nop after the first call, and placement of its defintion in a
+# central location.
+
+testConstraint testthread [expr {[info commands testthread] != {}}]
+
+if {[testConstraint testthread]} {
+ testthread errorproc ThreadError
+
+ proc ThreadError {id info} {
+ global threadError
+ set threadError $info
+ }
+
+ proc ThreadNullError {id info} {
+ # ignore
+ }
+}
+
+# ### ### ### ######### ######### #########
+## Helper command. Runs a script in a separate thread and returns the
+## result. A channel is transfered into the thread as well, and list of
+## configuation variables
+
+proc inthread {chan script args} {
+
+ # Test thread.
+
+ set tid [testthread create]
+
+ # Init thread configuration.
+ # - Listed variables
+ # - Id of main thread
+ # - A number of helper commands
+
+ foreach v $args {
+ upvar 1 $v x
+ testthread send $tid [list set $v $x]
+ }
+ testthread send $tid [list set mid $tcltest::mainThread]
+ testthread send $tid {
+ proc note {item} {global notes ; lappend notes $item}
+ proc notes {} {global notes ; return $notes}
+ }
+ testthread send $tid [list proc s {} [list uplevel 1 $script]] ; # (*)
+
+ # Transfer channel (cut/splice aka detach/attach)
+
+ testchannel cut $chan
+ testthread send $tid [list testchannel splice $chan]
+
+ # Run test script, also run local event loop!
+ # The local event loop waits for the result to come back.
+ # It is also necessary for the execution of forwarded channel
+ # operations.
+
+ set ::tres ""
+ testthread send -async $tid {
+ after 500
+ catch {s} res ; # This runs the script, 's' was defined at (*)
+ testthread send -async $mid [list set ::tres $res]
+ }
+ vwait ::tres
+ # Remove test thread, and return the captured result.
+
+ tcltest::threadReap
+ return $::tres
+}
+
+# ### ### ### ######### ######### #########
+
+# ### ### ### ######### ######### #########
+
+test iocmd.tf-22.2 {chan finalize, for close} -match glob -body {
+ set res {}
+ proc foo {args} {track ; oninit ; return {}}
+ note [set c [chan create {r w} foo]]
+
+ note [inthread $c {
+ close $c
+ # Close the deleted the channel.
+ file channels rc*
+ } c]
+
+ # Channel destruction does not kill handler command!
+ note [info command foo]
+
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} {} foo}
+
+test iocmd.tf-22.3 {chan finalize, for close, error, close error} -match glob -body {
+ set res {}
+ proc foo {args} {track ; oninit ; return -code error 5}
+ note [set c [chan create {r w} foo]]
+
+ notes [inthread $c {
+ note [catch {close $c} msg] ; note $msg
+ # Channel is gone despite error.
+ note [file channels rc*]
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 5 {}}
+
+test iocmd.tf-22.4 {chan finalize, for close, error, close errror} -match glob -body {
+ set res {}
+ proc foo {args} {track ; oninit ; error FOO}
+ note [set c [chan create {r w} foo]]
+
+ notes [inthread $c {
+ note [catch {close $c} msg] ; note $msg
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 FOO}
+
+test iocmd.tf-22.5 {chan finalize, for close, arbitrary result} -match glob -body {
+ set res {}
+ proc foo {args} {track ; oninit ; return SOMETHING}
+ note [set c [chan create {r w} foo]]
+
+ notes [inthread $c {
+ note [catch {close $c} msg]; note $msg
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} 0 {}}
+
+test iocmd.tf-22.6 {chan finalize, for close, break, close error} -match glob -body {
+ set res {}
+ proc foo {args} {track ; oninit ; return -code 3}
+ note [set c [chan create {r w} foo]]
+
+ notes [inthread $c {
+ note [catch {close $c} msg] ; note $msg
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 {}} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-22.7 {chan finalize, for close, continue, close error} -match glob -body {
+ set res {}
+ proc foo {args} {track ; oninit ; return -code 4}
+ note [set c [chan create {r w} foo]]
+
+ notes [inthread $c {
+ note [catch {close $c} msg] ; note $msg
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 {}} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-22.8 {chan finalize, for close, custom code, close error} -match glob -body {
+ set res {}
+ proc foo {args} {track ; oninit ; return -code 777 BANG}
+ note [set c [chan create {r w} foo]]
+
+ notes [inthread $c {
+ note [catch {close $c} msg] ; note $msg
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 BANG} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-22.9 {chan finalize, for close, ignore level, close error} -match glob -body {
+ set res {}
+ proc foo {args} {track ; oninit ; return -level 5 -code 777 BANG}
+ note [set c [chan create {r w} foo]]
+
+ notes [inthread $c {
+ note [catch {close $c} msg opt] ; note $msg ; note $opt
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \
+ -constraints {testchannel testthread}
+
+# --- === *** ###########################
+# method read
+
+test iocmd.tf-23.1 {chan read, regular data return} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit ; onfinal ; track
+ return snarf
+ }
+ set c [chan create {r w} foo]
+ notes [inthread $c {
+ note [read $c 10]
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} -result {{read rc* 4096} {read rc* 4096} snarfsnarf}
+
+test iocmd.tf-23.2 {chan read, bad data return, to much} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit ; onfinal ; track
+ return [string repeat snarf 1000]
+ }
+ set c [chan create {r w} foo]
+ notes [inthread $c {
+ note [catch {[read $c 2]} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} -result {{read rc* 4096} 1 {read delivered more than requested}}
+
+test iocmd.tf-23.3 {chan read, for non-readable channel} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit ; onfinal ; track
+ note MUST_NOT_HAPPEN
+ }
+ set c [chan create {w} foo]
+ notes [inthread $c {
+ note [catch {[read $c 2]} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} -result {1 {channel "rc*" wasn't opened for reading}}
+
+test iocmd.tf-23.4 {chan read, error return} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit ; onfinal ; track
+ return -code error BOOM!
+ }
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {read $c 2} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{read rc* 4096} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-23.5 {chan read, break return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit ; onfinal ; track
+ return -code break BOOM!
+ }
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {read $c 2} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{read rc* 4096} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-23.6 {chan read, continue return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit ; onfinal ; track
+ return -code continue BOOM!
+ }
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {read $c 2} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{read rc* 4096} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-23.7 {chan read, custom return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit ; onfinal ; track
+ return -code 777 BOOM!
+ }
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {read $c 2} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{read rc* 4096} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-23.8 {chan read, level is squashed} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit ; onfinal ; track
+ return -level 55 -code 777 BOOM!
+ }
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {read $c 2} msg opt] ; note $msg ; note $opt
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{read rc* 4096} 1 BOOM! {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BOOM!}} \
+ -constraints {testchannel testthread}
+
+# --- === *** ###########################
+# method write
+
+test iocmd.tf-24.1 {chan write, regular write} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal ; track
+ set written [string length [lindex $args 2]]
+ note $written
+ return $written
+ }
+ set c [chan create {r w} foo]
+
+ inthread $c {
+ puts -nonewline $c snarf ; flush $c
+ close $c
+ } c
+
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} -result {{write rc* snarf} 5}
+
+test iocmd.tf-24.2 {chan write, ack partial writes} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit ; onfinal ; track
+ set written [string length [lindex $args 2]]
+ if {$written > 10} {set written [expr {$written / 2}]}
+ note $written
+ return $written
+ }
+ set c [chan create {r w} foo]
+
+ inthread $c {
+ puts -nonewline $c snarfsnarfsnarf ; flush $c
+ close $c
+ } c
+
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} -result {{write rc* snarfsnarfsnarf} 7 {write rc* arfsnarf} 8}
+
+test iocmd.tf-24.3 {chan write, failed write} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; note -1 ; return -1}
+ set c [chan create {r w} foo]
+
+ inthread $c {
+ puts -nonewline $c snarfsnarfsnarf ; flush $c
+ close $c
+ } c
+
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} -result {{write rc* snarfsnarfsnarf} -1}
+
+test iocmd.tf-24.4 {chan write, non-writable channel} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return}
+ set c [chan create {r} foo]
+
+ notes [inthread $c {
+ note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} -result {1 {channel "rc*" wasn't opened for writing}}
+
+test iocmd.tf-24.5 {chan write, bad result, more written than data} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; return 10000}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {puts -nonewline $c snarf ; flush $c} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} -result {{write rc* snarf} 1 {write wrote more than requested}}
+
+test iocmd.tf-24.6 {chan write, zero writes} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; return 0}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {puts -nonewline $c snarf ; flush $c} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} -result {{write rc* snarf} 1 {write wrote more than requested}}
+
+test iocmd.tf-24.7 {chan write, failed write, error return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; return -code error BOOM!}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg]
+ note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-24.8 {chan write, failed write, error return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; error BOOM!}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg]
+ note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-24.9 {chan write, failed write, break return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; return -code break BOOM!}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg]
+ note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-24.10 {chan write, failed write, continue return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; return -code continue BOOM!}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg]
+ note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-24.11 {chan write, failed write, custom return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; return -code 777 BOOM!}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg]
+ note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-24.12 {chan write, failed write, non-numeric return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; return BANG}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg]
+ note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{write rc* snarfsnarfsnarf} 1 {expected integer but got "BANG"}} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-24.13 {chan write, failed write, level is ignored} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; return -level 55 -code 777 BOOM!}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg opt]
+ note $msg
+ note $opt
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{write rc* snarfsnarfsnarf} 1 BOOM! {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BOOM!}} \
+ -constraints {testchannel testthread}
+
+# --- === *** ###########################
+# method cgetall
+
+test iocmd.tf-25.1 {chan configure, cgetall, standard options} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [fconfigure $c]
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} \
+ -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}}
+
+test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body {
+ set res {}
+ proc foo {args} {oninit cget cgetall ; onfinal ; track ; return ""}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [fconfigure $c]
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} \
+ -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}}
+
+test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit cget cgetall ; onfinal ; track
+ return "-bar foo -snarf x"
+ }
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [fconfigure $c]
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} \
+ -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *} -bar foo -snarf x}}
+
+test iocmd.tf-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit cget cgetall ; onfinal ; track
+ return "-bar"
+ }
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {fconfigure $c} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} -result {{cgetall rc*} 1 {Expected list with even number of elements, got 1 element instead}}
+
+test iocmd.tf-25.5 {chan configure, cgetall, bad result, not a list} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit cget cgetall ; onfinal ; track
+ return "\{"
+ }
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {fconfigure $c} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} -result {{cgetall rc*} 1 {unmatched open brace in list}}
+
+test iocmd.tf-25.6 {chan configure, cgetall, error return} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit cget cgetall ; onfinal ; track
+ return -code error BOOM!
+ }
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {fconfigure $c} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} -result {{cgetall rc*} 1 BOOM!}
+
+test iocmd.tf-25.7 {chan configure, cgetall, break return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit cget cgetall ; onfinal ; track
+ return -code break BOOM!
+ }
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {fconfigure $c} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{cgetall rc*} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-25.8 {chan configure, cgetall, continue return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit cget cgetall ; onfinal ; track
+ return -code continue BOOM!
+ }
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {fconfigure $c} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{cgetall rc*} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-25.9 {chan configure, cgetall, custom return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit cget cgetall ; onfinal ; track
+ return -code 777 BOOM!
+ }
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {fconfigure $c} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{cgetall rc*} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-25.10 {chan configure, cgetall, level is ignored} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit cget cgetall ; onfinal ; track
+ return -level 55 -code 777 BANG
+ }
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {fconfigure $c} msg opt] ; note $msg ; note $opt
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{cgetall rc*} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \
+ -constraints {testchannel testthread}
+
+# --- === *** ###########################
+# method configure
+
+test iocmd.tf-26.1 {chan configure, set standard option} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit configure ; onfinal ; track ; note MUST_NOT_HAPPEN
+ return
+ }
+
+ set c [chan create {r w} foo]
+ notes [inthread $c {
+ note [fconfigure $c -translation lf]
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} -result {{}}
+
+test iocmd.tf-26.2 {chan configure, set option, error return} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit configure ; onfinal ; track
+ return -code error BOOM!
+ }
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} -result {{configure rc* -rc-foo bar} 1 BOOM!}
+
+test iocmd.tf-26.3 {chan configure, set option, ok return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit configure ; onfinal ; track ; return}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [fconfigure $c -rc-foo bar]
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} -result {{configure rc* -rc-foo bar} {}}
+
+test iocmd.tf-26.4 {chan configure, set option, break return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit configure ; onfinal ; track
+ return -code break BOOM!
+ }
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{configure rc* -rc-foo bar} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-26.5 {chan configure, set option, continue return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit configure ; onfinal ; track
+ return -code continue BOOM!
+ }
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{configure rc* -rc-foo bar} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-26.6 {chan configure, set option, custom return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit configure ; onfinal ; track
+ return -code 444 BOOM!
+ }
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{configure rc* -rc-foo bar} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-26.7 {chan configure, set option, level is ignored} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit configure ; onfinal ; track
+ return -level 55 -code 444 BANG
+ }
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {fconfigure $c -rc-foo bar} msg opt] ; note $msg ; note $opt
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{configure rc* -rc-foo bar} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \
+ -constraints {testchannel testthread}
+
+# --- === *** ###########################
+# method cget
+
+test iocmd.tf-27.1 {chan configure, get option, ok return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit cget cgetall ; onfinal ; track ; return foo}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [fconfigure $c -rc-foo]
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} -result {{cget rc* -rc-foo} foo}
+
+test iocmd.tf-27.2 {chan configure, get option, error return} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit cget cgetall ; onfinal ; track
+ return -code error BOOM!
+ }
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {fconfigure $c -rc-foo} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} -result {{cget rc* -rc-foo} 1 BOOM!}
+
+test iocmd.tf-27.3 {chan configure, get option, break return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit cget cgetall ; onfinal ; track
+ return -code error BOOM!
+ }
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {fconfigure $c -rc-foo} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{cget rc* -rc-foo} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-27.4 {chan configure, get option, continue return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit cget cgetall ; onfinal ; track
+ return -code continue BOOM!
+ }
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {fconfigure $c -rc-foo} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{cget rc* -rc-foo} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-27.5 {chan configure, get option, custom return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit cget cgetall ; onfinal ; track
+ return -code 333 BOOM!
+ }
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {fconfigure $c -rc-foo} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{cget rc* -rc-foo} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-27.6 {chan configure, get option, level is ignored} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit cget cgetall ; onfinal ; track
+ return -level 77 -code 333 BANG
+ }
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {fconfigure $c -rc-foo} msg opt] ; note $msg ; note $opt
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{cget rc* -rc-foo} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \
+ -constraints {testchannel testthread}
+
+# --- === *** ###########################
+# method seek
+
+test iocmd.tf-28.1 {chan tell, not supported by handler} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [tell $c]
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {-1} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-28.2 {chan tell, error return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return -code error BOOM!}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {tell $c} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 current} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-28.3 {chan tell, break return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return -code break BOOM!}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {tell $c} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 current} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-28.4 {chan tell, continue return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return -code continue BOOM!}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {tell $c} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 current} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-28.5 {chan tell, custom return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return -code 222 BOOM!}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {tell $c} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 current} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-28.6 {chan tell, level is ignored} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return -level 11 -code 222 BANG}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {tell $c} msg opt] ; note $msg ; note $opt
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 current} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-28.7 {chan tell, regular return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return 88}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [tell $c]
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 current} 88} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-28.8 {chan tell, negative return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return -1}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {tell $c} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 current} 1 {Tried to seek before origin}} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-28.9 {chan tell, string return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return BOGUS}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {tell $c} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 current} 1 {expected integer but got "BOGUS"}} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-28.10 {chan seek, not supported by handler} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {seek $c 0 start} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {1 {error during seek on "rc*": invalid argument}} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-28.11 {chan seek, error return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return -code error BOOM!}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {seek $c 0 start} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 start} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-28.12 {chan seek, break return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return -code break BOOM!}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {seek $c 0 start} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 start} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-28.13 {chan seek, continue return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return -code continue BOOM!}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {seek $c 0 start} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 start} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-28.14 {chan seek, custom return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return -code 99 BOOM!}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {seek $c 0 start} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 start} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-28.15 {chan seek, level is ignored} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return -level 33 -code 99 BANG}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {seek $c 0 start} msg opt] ; note $msg ; note $opt
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 start} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-28.16 {chan seek, bogus return, negative location} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return -45}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {seek $c 0 start} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 start} 1 {Tried to seek before origin}} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-28.17 {chan seek, bogus return, string return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return BOGUS}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {seek $c 0 start} msg] ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 start} 1 {expected integer but got "BOGUS"}} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-28.18 {chan seek, ok result} -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return 23}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [seek $c 0 current]
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{seek rc* 0 current} {}} \
+ -constraints {testchannel testthread}
+
+foreach {n code} {
+ 0 start
+ 1 current
+ 2 end
+} {
+ test iocmd.tf-28.19.$n "chan seek, base conversion, $code" -match glob -body {
+ set res {}
+ proc foo {args} {oninit seek ; onfinal ; track ; return 0}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [seek $c 0 $code]
+ close $c
+ notes
+ } c code]
+
+ rename foo {}
+ set res
+ } -result [list [list seek rc* 0 $code] {}] \
+ -constraints {testchannel testthread}
+}
+
+# --- === *** ###########################
+# method blocking
+
+test iocmd.tf-29.1 {chan blocking, no handler support} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [fconfigure $c -blocking]
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {1} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-29.2 {chan blocking, no handler support} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [fconfigure $c -blocking 0]
+ note [fconfigure $c -blocking]
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{} 0} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-29.3 {chan blocking, retrieval, handler support} -match glob -body {
+ set res {}
+ proc foo {args} {oninit blocking ; onfinal ; track ; note MUST_NOT_HAPPEN ; return}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [fconfigure $c -blocking]
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {1} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-29.4 {chan blocking, resetting, handler support} -match glob -body {
+ set res {}
+ proc foo {args} {oninit blocking ; onfinal ; track ; return}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [fconfigure $c -blocking 0]
+ note [fconfigure $c -blocking]
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{blocking rc* 0} {} 0} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-29.5 {chan blocking, setting, handler support} -match glob -body {
+ set res {}
+ proc foo {args} {oninit blocking ; onfinal ; track ; return}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [fconfigure $c -blocking 1]
+ note [fconfigure $c -blocking]
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{blocking rc* 1} {} 1} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-29.6 {chan blocking, error return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit blocking ; onfinal ; track ; error BOOM!}
+
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {fconfigure $c -blocking 0} msg] ; note $msg
+ # Catch the close. It changes blocking mode internally, and runs into the error result.
+ catch {close $c}
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{blocking rc* 0} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-29.7 {chan blocking, break return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit blocking ; onfinal ; track ; return -code break BOOM!}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {fconfigure $c -blocking 0} msg] ; note $msg
+ catch {close $c}
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{blocking rc* 0} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-29.8 {chan blocking, continue return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit blocking ; onfinal ; track ; return -code continue BOOM!}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {fconfigure $c -blocking 0} msg] ; note $msg
+ catch {close $c}
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{blocking rc* 0} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-29.9 {chan blocking, custom return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit blocking ; onfinal ; track ; return -code 44 BOOM!}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {fconfigure $c -blocking 0} msg] ; note $msg
+ catch {close $c}
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{blocking rc* 0} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-29.10 {chan blocking, level is ignored} -match glob -body {
+ set res {}
+ proc foo {args} {oninit blocking ; onfinal ; track ; return -level 99 -code 44 BANG}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {fconfigure $c -blocking 0} msg opt] ; note $msg ; note $opt
+ catch {close $c}
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{blocking rc* 0} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \
+ -constraints {testchannel testthread}
+
+test iocmd.tf-29.11 {chan blocking, regular return ok, value ignored} -match glob -body {
+ set res {}
+ proc foo {args} {oninit blocking ; onfinal ; track ; return BOGUS}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [catch {fconfigure $c -blocking 0} msg] ; note $msg
+ catch {close $c}
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -result {{blocking rc* 0} 0 {}} \
+ -constraints {testchannel testthread}
+
+# --- === *** ###########################
+# method watch
+
+test iocmd.tf-30.1 {chan watch, read interest, some return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; return IGNORED}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [fileevent $c readable {set tick $tick}]
+ close $c ;# 2nd watch, interest zero.
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} -result {{watch rc* read} {watch rc* {}} {}}
+
+test iocmd.tf-30.2 {chan watch, write interest, error return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; return -code error BOOM!_IGNORED}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [fileevent $c writable {set tick $tick}]
+ note [fileevent $c writable {}]
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} -result {{watch rc* write} {watch rc* {}} {} {}}
+
+test iocmd.tf-30.3 {chan watch, accumulated interests} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; return}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [fileevent $c writable {set tick $tick}]
+ note [fileevent $c readable {set tick $tick}]
+ note [fileevent $c writable {}]
+ note [fileevent $c readable {}]
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} \
+ -result {{watch rc* write} {watch rc* {read write}} {watch rc* read} {watch rc* {}} {} {} {} {}}
+
+test iocmd.tf-30.4 {chan watch, unchanged interest not forwarded} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; return}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ note [fileevent $c writable {set tick $tick}]
+ note [fileevent $c readable {set tick $tick}] ;# Script is changing,
+ note [fileevent $c readable {set tock $tock}] ;# interest does not.
+ close $c ;# 3rd and 4th watch, removing the event handlers.
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} \
+ -result {{watch rc* write} {watch rc* {read write}} {watch rc* write} {watch rc* {}} {} {} {}}
+
+# --- === *** ###########################
+# postevent
+# Not possible from a thread not containing the command handler.
+# Check that this is rejected.
+
+test iocmd.tf-31.8 {chan postevent, bad input} -match glob -body {
+ set res {}
+ proc foo {args} {oninit ; onfinal ; track ; return}
+ set c [chan create {r w} foo]
+
+ notes [inthread $c {
+ catch {chan postevent $c r} msg ; note $msg
+ close $c
+ notes
+ } c]
+
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} \
+ -result {{postevent for channel "rc*" called from outside interpreter}}
+
+
+# ### ### ### ######### ######### #########
+
+# ### ### ### ######### ######### #########
+
+rename track {}
# cleanup
foreach file [list test1 test2 test3 test4] {
removeFile $file
diff --git a/unix/Makefile.in b/unix/Makefile.in
index a1e18ad..b2ff79f 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -5,7 +5,7 @@
# "autoconf" program (constructs like "@foo@" will get replaced in the
# actual Makefile.
#
-# RCS: @(#) $Id: Makefile.in,v 1.157.2.15 2005/08/16 16:55:18 dgp Exp $
+# RCS: @(#) $Id: Makefile.in,v 1.157.2.16 2005/08/25 15:47:07 dgp Exp $
VERSION = @TCL_VERSION@
MAJOR_VERSION = @TCL_MAJOR_VERSION@
@@ -302,7 +302,7 @@ GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \
tclCompile.o tclConfig.o tclDate.o tclDictObj.o tclEncoding.o \
tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \
tclHash.o tclHistory.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \
- tclIOGT.o tclIOSock.o tclIOUtil.o tclLink.o tclListObj.o \
+ tclIORChan.o tclIOGT.o tclIOSock.o tclIOUtil.o tclLink.o tclListObj.o \
tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \
tclObj.o tclPanic.o tclParse.o tclParseExpr.o tclPathObj.o tclPipe.o \
tclPkg.o tclPkgConfig.o tclPosixStr.o \
@@ -390,6 +390,7 @@ GENERIC_SRCS = \
$(GENERIC_DIR)/tclIOGT.c \
$(GENERIC_DIR)/tclIOSock.c \
$(GENERIC_DIR)/tclIOUtil.c \
+ $(GENERIC_DIR)/tclIORChan.c \
$(GENERIC_DIR)/tclLink.c \
$(GENERIC_DIR)/tclListObj.c \
$(GENERIC_DIR)/tclLiteral.c \
@@ -1020,6 +1021,9 @@ tclIOSock.o: $(GENERIC_DIR)/tclIOSock.c
tclIOUtil.o: $(GENERIC_DIR)/tclIOUtil.c
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIOUtil.c
+tclIORChan.o: $(GENERIC_DIR)/tclIORChan.c
+ $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIORChan.c
+
tclLink.o: $(GENERIC_DIR)/tclLink.c
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLink.c
diff --git a/unix/configure.in b/unix/configure.in
index 2da3ff8..e102840 100644
--- a/unix/configure.in
+++ b/unix/configure.in
@@ -3,10 +3,10 @@ dnl This file is an input file used by the GNU "autoconf" program to
dnl generate the file "configure", which is run during Tcl installation
dnl to configure the system for the local environment.
#
-# RCS: @(#) $Id: configure.in,v 1.123.2.7 2005/08/02 18:16:53 dgp Exp $
+# RCS: @(#) $Id: configure.in,v 1.123.2.8 2005/08/25 15:47:07 dgp Exp $
AC_INIT([tcl],[8.5])
-AC_PREREQ(2.57)
+AC_PREREQ(2.59)
dnl AC_CONFIG_HEADERS([tclConfig.h])
dnl AC_CONFIG_COMMANDS_PRE([DEFS="-DHAVE_TCL_CONFIG_H -imacros tclConfig.h"])
diff --git a/unix/tclConfig.h.in b/unix/tclConfig.h.in
index 9a7fe25..39df8cf 100644
--- a/unix/tclConfig.h.in
+++ b/unix/tclConfig.h.in
@@ -312,9 +312,6 @@
/* Is getcwd Posix-compliant? */
#undef USEGETWD
-/* Should we use <a.out.h> when doing dynamic loading? */
-#undef USE_A_OUT_H
-
/* Do we need a special AIX hack for timezones? */
#undef USE_DELTA_FOR_TZ
@@ -327,12 +324,6 @@
/* Use the sgtty API for serial lines */
#undef USE_SGTTY
-/* Should we use <sys/exec_aout.h> when doing dynamic loading? */
-#undef USE_SYS_EXEC_AOUT_H
-
-/* Should we use <sys/exec.h> when doing dynamic loading? */
-#undef USE_SYS_EXEC_H
-
/* Use the termio API for serial lines */
#undef USE_TERMIO
diff --git a/win/Makefile.in b/win/Makefile.in
index 399af6a..4d14ad6 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -5,7 +5,7 @@
# "autoconf" program (constructs like "@foo@" will get replaced in the
# actual Makefile.
#
-# RCS: @(#) $Id: Makefile.in,v 1.84.2.11 2005/08/16 16:55:18 dgp Exp $
+# RCS: @(#) $Id: Makefile.in,v 1.84.2.12 2005/08/25 15:47:07 dgp Exp $
VERSION = @TCL_VERSION@
@@ -242,6 +242,7 @@ GENERIC_OBJS = \
tclIO.$(OBJEXT) \
tclIOCmd.$(OBJEXT) \
tclIOGT.$(OBJEXT) \
+ tclIORChan.$(OBJEXT) \
tclIOSock.$(OBJEXT) \
tclIOUtil.$(OBJEXT) \
tclLink.$(OBJEXT) \
diff --git a/win/configure b/win/configure
index cadddbe..b294788 100755
--- a/win/configure
+++ b/win/configure
@@ -3133,12 +3133,6 @@ _ACEOF
#define USE_THREAD_ALLOC 1
_ACEOF
- # USE_THREAD_STORAGE tells us to use the new generic thread
- # storage subsystem.
- cat >>confdefs.h <<\_ACEOF
-#define USE_THREAD_STORAGE 1
-_ACEOF
-
else
TCL_THREADS=0
echo "$as_me:$LINENO: result: no (default)" >&5
diff --git a/win/configure.in b/win/configure.in
index df4862e..90b46f2 100644
--- a/win/configure.in
+++ b/win/configure.in
@@ -3,10 +3,10 @@
# generate the file "configure", which is run during Tcl installation
# to configure the system for the local environment.
#
-# RCS: @(#) $Id: configure.in,v 1.81.2.4 2005/07/12 20:37:32 kennykb Exp $
+# RCS: @(#) $Id: configure.in,v 1.81.2.5 2005/08/25 15:47:07 dgp Exp $
AC_INIT(../generic/tcl.h)
-AC_PREREQ(2.57)
+AC_PREREQ(2.59)
# The following define is needed when building with Cygwin since newer
# versions of autoconf incorrectly set SHELL to /bin/bash instead of
diff --git a/win/makefile.vc b/win/makefile.vc
index d09bf42..3c5062a 100644
--- a/win/makefile.vc
+++ b/win/makefile.vc
@@ -12,7 +12,7 @@
# Copyright (c) 2001-2004 David Gravereaux.
#
#------------------------------------------------------------------------------
-# RCS: @(#) $Id: makefile.vc,v 1.135.2.7 2005/08/16 16:55:18 dgp Exp $
+# RCS: @(#) $Id: makefile.vc,v 1.135.2.8 2005/08/25 15:47:07 dgp Exp $
#------------------------------------------------------------------------------
# Check to see we are configured to build with MSVC (MSDEVDIR or MSVCDIR)
@@ -284,6 +284,7 @@ TCLOBJS = \
$(TMP_DIR)\tclIOGT.obj \
$(TMP_DIR)\tclIOSock.obj \
$(TMP_DIR)\tclIOUtil.obj \
+ $(TMP_DIR)\tclIORChan.obj \
$(TMP_DIR)\tclLink.obj \
$(TMP_DIR)\tclListObj.obj \
$(TMP_DIR)\tclLiteral.obj \