diff options
| author | Kevin B Kenny <kennykb@acm.org> | 2010-12-01 16:42:33 (GMT) |
|---|---|---|
| committer | Kevin B Kenny <kennykb@acm.org> | 2010-12-01 16:42:33 (GMT) |
| commit | 921c2612861d68b7b4eee66736379431ac081f30 (patch) | |
| tree | 47091361dfd1c093c24bb1dc06082c6dc469eaad | |
| parent | 86b28e0c4b2444435a30d345b3fe26daaf9de126 (diff) | |
| download | tcl-921c2612861d68b7b4eee66736379431ac081f30.zip tcl-921c2612861d68b7b4eee66736379431ac081f30.tar.gz tcl-921c2612861d68b7b4eee66736379431ac081f30.tar.bz2 | |
merge
57 files changed, 8723 insertions, 3916 deletions
@@ -1,7 +1,219 @@ +2010-12-01 Kevin B. Kenny <kennykb@acm.org> + + * generic/tclStrToD.c (SetPrecisionLimits, TclDoubleDigits): + Added meaningless initialization of 'i', 'ilim' and 'ilim1' + to silence warnings from the C compiler about possible use of + uninitialized variables, Added a panic to the 'switch' that + assigns them, to assert that the 'default' case is impossible. + [Bug 3124675] + +2010-12-01 Jan Nijtmans <nijtmans@users.sf.net> + + * generic/tclBasic.c: fix gcc 64-bit warnings: cast from pointer to + * generic/tclHash.c: integer of different size. + * generic/tclTest.c: + * generic/tclThreadTest.c: + * generic/tclStrToD.c: fix gcc(-4.5.2) warning: 'static' is not at + beginning of declaration. + * generic/tclPanic.c: Allow Tcl_Panic() to enter the debugger on win32 + * generic/tclCkalloc.c: use Tcl_Panic() in stead of duplicating the code. + +2010-11-30 Jeff Hobbs <jeffh@ActiveState.com> + + * generic/tclInt.decls, generic/tclInt.h, generic/tclIntDecls.h: + * generic/tclStubInit.c: TclFormatInt restored at slot 24 + * generic/tclUtil.c (TclFormatInt): restore TclFormatInt func from + 2005-07-05 macro-ization. Benchmarks indicate it is faster, as a + key int->string routine (e.g. int-indexed arrays). + +2010-11-29 Alexandre Ferrieux <ferrieux@users.sourceforge.net> + + * generic/tclBasic.c: Patch by Miguel, providing a + [::tcl::unsupported::inject coroname command args], which prepends + ("injects") arbitrary code to a suspended coro's future resumption. + Neat for debugging complex coros without heavy instrumentation. + +2010-11-29 Kevin B. Kenny <kennykb@acm.org> + + * generic/tclInt.decls: + * generic/tclInt.h: + * generic/tclStrToD.c: + * generic/tclTest.c: + * generic/tclTomMath.decls: + * generic/tclUtil.c: + * tests/util.test: + * unix/Makefile.in: + * win/Makefile.in: + * win/makefile.vc: Rewrite of Tcl_PrintDouble and TclDoubleDigits + that (a) fixes a severe performance problem with floating point + shimmering reported by Karl Lehenbauer, (b) allows TclDoubleDigits + to generate the digit strings for 'e' and 'f' format, so that it + can be used for tcl_precision != 0 (and possibly later for [format]), + (c) fixes [Bug 3120139] by making TclPrintDouble inherently + locale-independent, (d) adds test cases to util.test for + correct rounding in difficult cases of TclDoubleDigits where fixed- + precision results are requested. (e) adds test cases to util.test for + the controversial aspects of [Bug 3105247]. As a side effect, two + more modules from libtommath (bn_mp_set_int.c and bn_mp_init_set_int.c) + are brought into the build, since the new code uses them. + + * generic/tclIntDecls.h: + * generic/tclStubInit.c: + * generic/tclTomMathDecls.h: Regenerated. + +2010-11-24 Donal K. Fellows <dkf@users.sf.net> + + * tests/chanio.test, tests/iogt.test, tests/ioTrans.test: Convert more + tests to tcltest2 and factor them to be easier to understand. + +2010-11-20 Donal K. Fellows <dkf@users.sf.net> + + * tests/chanio.test: Converted many tests to tcltest2 by marking the + setup and cleanup parts as such. + +2010-11-19 Jan Nijtmans <nijtmans@users.sf.net> + + * win/tclWin32Dll.c: fix gcc warnings: unused variable 'registration' + * win/tclWinChan.c: + * win/tclWinFCmd.c: + +2010-11-18 Jan Nijtmans <nijtmans@users.sf.net> + + * win/tclAppInit.c: [FRQ 491789]: "setargv() doesn't support a + unicode cmdline" now implemented for cygwin and mingw32 too. + * tests/main.test: No longer disable tests Tcl_Main-1.4 and 1.6 + on Windows, because those now work on all supported platforms. + * win/configure.in: Set NO_VIZ=1 when zlib is compiled in libtcl, + this resolves compiler warnings in 64-bit and static builds. + * win/configure (regenerated) + +2010-11-18 Donal K. Fellows <dkf@users.sf.net> + + * doc/file.n: [Bug 3111298]: Typofix. + + * tests/oo.test: [Bug 3111059]: Added testing that neatly trapped this + issue. + +2010-11-18 Miguel Sofer <msofer@users.sf.net> + + * generic/tclNamesp.c: [Bug 3111059]: Fix leak due to bad looping + construct. + +2010-11-17 Jan Nijtmans <nijtmans@users.sf.net> + + * win/tcl.m4: [FRQ 491789]: "setargv() doesn't support a unicode + cmdline" now implemented for mingw-w64 + * win/configure (re-generated) + +2010-11-16 Jan Nijtmans <nijtmans@users.sf.net> + + * win/tclAppInit.c:Bring compilation under mingw-w64 a bit closer + * win/cat.c: to reality. See for what's missing: + * win/tcl.m4: <https://sourceforge.net/apps/trac/mingw-w64/wiki/Unicode%20apps> + * win/configure: (re-generated) + * win/tclWinPort.h:[Bug #3110161]: Extensions using TCHAR don't compile + on VS2005 SP1 + +2010-11-15 Andreas Kupries <andreask@activestate.com> + + * doc/interp.n: [Bug 3081184]: TIP #378. + * doc/tclvars.n: Performance fix for TIP #280. + * generic/tclBasic.c: + * generic/tclExecute.c: + * generic/tclInt.h: + * generic/tclInterp.c: + * tests/info.test: + * tests/interp.test: + +2010-11-10 Andreas Kupries <andreask@activestate.com> + + * changes: Updates for 8.6b2 release. + +2010-11-09 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclOOMethod.c (ProcedureMethodVarResolver): [Bug 3105999]: + * tests/oo.test: Make sure that resolver structures that are + only temporarily needed get squelched. + +2010-11-05 Jan Nijtmans <nijtmans@users.sf.net> + + * generic/tclMain.c: Thanks, Kevin, for the fix, but this how it was + supposed to be (TCL_ASCII_MAIN is only supposed to be defined on + WIN32). + +2010-11-05 Kevin B. Kenny <kennykb@acm.org> + + * generic/tclMain.c: Added missing conditional on _WIN32 around code + that messes around with the definition of _UNICODE, to correct a badly + broken Unix build from Jan's last commit. + +2010-11-04 Jan Nijtmans <nijtmans@users.sf.net> + + * generic/tclDecls.h: [FRQ 491789]: "setargv() doesn't support a + * generic/tclMain.c: unicode cmdline" implemented for Tcl on MSVC++ + * doc/Tcl_Main.3: + * win/tclAppInit.c: + * win/makefile.vc: + * win/Makefile.in: + * win/tclWin32Dll.c: Eliminate minor MSVC warning TCHAR -> char + conversion + +2010-11-04 Reinhard Max <max@suse.de> + + * tests/socket.test: Run the socket tests three times with the address + family set to any, inet, and inet6 respectively. Use constraints to + skip the tests if a family is found to be unsupported or not + configured on the local machine. Adjust the tests to dynamically adapt + to the address family that is being tested. + + Rework some of the tests to speed them up by avoiding (supposedly) + unneeded [after]s. + +2010-11-04 Stuart Cassoff <stwo@users.sourceforge.net> + + * unix/Makefile.in: [Patch 3101127]: Installer Improvements. + * unix/install-sh: + +2010-11-04 Donal K. Fellows <dkf@users.sf.net> + + * tests/error.test (error-19.13): Another variation on testing for + issues in [try] compilation. + + * doc/Tcl.n (Variable substitution): [Bug 3099086]: Increase clarity + of explanation of what characters are actually permitted in variable + substitutions. Note that this does not constitute a change of + behavior; it is just an improvement of explanation. + +2010-11-04 Don Porter <dgp@users.sourceforge.net> + + * changes: Updates for 8.6b2 release. (Thanks Andreas Kupries) + +2010-11-03 Jan Nijtmans <nijtmans@users.sf.net> + + * win/tclWinFcmd.c: [FRQ 2965056]: Windows build with -DUNICODE + * win/tclWinFile.c: (more clean-ups for pre-win2000 stuff) + * win/tclWinReg.c: + +2010-11-03 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclCmdMZ.c (TryPostBody): Ensure that errors when setting + * tests/error.test (error-19.1[12]): message/opt capture variables get + reflected properly to the caller. + +2010-11-03 Kevin B. Kenny <kennykb@acm.org> + + * generic/tclCompCmds.c (TclCompileCatchCmd): [Bug 3098302]: + * tests/compile.test (compile-3.6): Reworked the compilation of the + [catch] command so as to avoid placing any code that might throw an + exception (specifically, any initial substitutions or any stores to + result or options variables) between the BEGIN_CATCH and END_CATCH but + outside the exception range. Added a test case that panics on a stack + smash if the change is not made. + 2010-11-01 Stuart Cassoff <stwo@users.sourceforge.net> - * library/safe.tcl: Improved handling of non-standard module - * tests/safe.test: path lists, empty path lists in particular. + * library/safe.tcl: Improved handling of non-standard module path + * tests/safe.test: lists, empty path lists in particular. 2010-11-01 Kevin B. Kenny <kennykb@acm.org> @@ -11,8 +223,8 @@ 2010-10-29 Alexandre Ferrieux <ferrieux@users.sourceforge.net> - * generic/tclTimer.c: Stop small [afters] from wasting CPU [Bug - 2905784] while keeping accuracy. + * generic/tclTimer.c: [Bug 2905784]: Stop small [after]s from + wasting CPU while keeping accuracy. 2010-10-28 Kevin B. Kenny <kennykb@acm.org> @@ -22,10 +234,12 @@ 2010-10-28 Don Porter <dgp@users.sourceforge.net> - * tests/http.test: Make http-4.15 pass in isolation [Bug 3097490] + * tests/http.test: [Bug 3097490]: Make http-4.15 pass in + isolation. - * unix/tclUnixSock.c: Prevent calls freeaddrinfo(NULL) which can - crash some systems. Thanks Larry Virden. [Bug 3093120] + * unix/tclUnixSock.c: [Bug 3093120]: Prevent calls of + freeaddrinfo(NULL) which can crash some + systems. Thanks Larry Virden. 2010-10-26 Reinhard Max <max@suse.de> @@ -1,6 +1,6 @@ Recent user-visible changes to Tcl: -RCS: @(#) $Id: changes,v 1.149 2010/08/10 20:36:39 dgp Exp $ +RCS: @(#) $Id: changes,v 1.149.2.1 2010/12/01 16:42:33 kennykb Exp $ 1. No more [command1] [command2] construct for grouping multiple commands on a single command line. @@ -7767,8 +7767,6 @@ memory with buffer backup (ferrieux) 2010-07-28 (bug fix)[3037525] crash deleting vars @ callframe pop (sofer) -2010-08-02 tzdata updated to Olson's tzdata2010k (kenny) - 2010-08-04 (bug fix)[3034840] mem corrupt when refchan loses interp (kupries) 2010-08-04 (enhancement) Win [load] use LOAD_WITH_ALTERED_SEARCH_PATH (hobbs) @@ -7776,4 +7774,99 @@ memory with buffer backup (ferrieux) 2010-08-04 (platform support) panic on detection of win9x system (hobbs) *** POTENTIAL INCOMPATIBILITY *** ---- Released 8.6b2, September ??, 2010 --- See ChangeLog for details --- +2010-08-10 (fix) Handle non-null-terminated bytearrys in glob matching (hobbs) + +2010-08-11 (fix) copy-paste bug in [yield] implementation (sofer, goth) + +2010-08-11 (platform) Drop pre-aix 4.2 support, ldAix (hobbs) + +2010-08-14 (frq)[2819611] changed signatures of hash fnctions, delete-file, and get-native-path (nijtmans) + *** POTENTIAL INCOMPATIBILITY *** + +2010-08-15 (bug fix)[3045010] tweaked error message for wrong#args of lambda's (fellows) + +2010-08-18 (bug fix)[3004191] fixed safe [glob] (fellows) + +2010-08-21 (patch)[3034251] genStubs steal features of ttkGenStubs (nijtmans) + +2010-08-26 (bug fix)[1230554] configure, OSF-1 problems, windows manifest issues (hobbs) + +2010-08-30 (bug fix) [3046594,3047235,3048771] reimplemented tailcall (sofer) + +2010-08-31 fixed manifest handling on windows (hobbs, kupries) + +2010-08-31 windows makefile and stub changes (nijtmans) + +2010-09-01 (bug fix)[3057639] compiled lappend trace consistency (hobbs,kupries) + *** POTENTIAL INCOMPATIBILITY *** + +2010-09-01 fixed safe glob handling of -directory (kupries) + +2010-09-02 fixed safe glob handling of -join (kupries) + +2010-09-08 (bug fix)[3059922] build with mingw on amd64 (porter, mescalinum) + +2010-09-15 (bug fix)[3067036] stop hang in bytearray append (fellows) + +2010-09-22 unified set of link libraries between mingw and vc (nijtmans) + +2010-09-22 (bug fix)[3072640] protect writes to ::error* variables (sofer) + +2010-09-23 fix leak of return options [catch $err m constant] (porter, hobbs) + +2010-09-24 (bugfix)[3056775] fixed race condition in windows sockets (kupries) + +2010-09-24 (performance) string eq/cmp (hobbs) + +2010-09-26 (patch)[3072080] rewritten NRE core (sofer) + +2010-09-28 (new feature)[TIP 162] implementation of ipv6 sockets (max) + +2010-10-02 (bug fix)[3079830] properly invalidate string rep of dicts (fellows) + +2010-10-06 (bug fix)[3081065] fix writing to freed Tcl_Obj (porter) + +2010-10-08 fix in ipv6 code on windows (nijtmans) + +2010-10-09 fixed overallocation of execution stack (sofer) + +2010-10-11 windows unicode changes (nijtmans) + +2010-10-12 (bug fix)[3084338] fixed meamleak in ipv6 code (max) + +2010-10-13 (bug fix)[467523,983660] alt fix allows empty literal share (porter) + +2010-10-15 (bugfix)[3085863] updated unicode tables (nijtmans) + *** POTENTIAL INCOMPATIBILITY *** + +2010-10-16 refactored implementation of dict iteration (fellows) + +2010-10-17 (patch)[2995655] report inner contexts on error stack (ferrieux) + +2010-10-19 (bug fix)[3081008] fixed bytearray zlib interaction (fellows) + +2010-10-19 improved crc, appending to bytearray (fellows) + +2010-10-20 improved compilation of [dict for] (fellows) + +2010-10-26 Added private support to disable reverse dns (max) + +2010-10-26 Prevent crashes when querying socket options (fellows, max) + +2010-10-28 (bug fix)[3093120] prevent freeaddrinfo(NULL) (porter, virden) + +2010-10-29 (bug fix)[2905784] stop cycle waste in short [after] (ferrieux) + +2010-11-01 tzdata updated to Olson's tzdata2010o (kenny) + +2010-11-04 (bug fix)[3099086] Clarified docs of var substitution (fellows) + +2010-11-04 improved install targets (cassof) + +2010-11-04 improved testing of sockets (max) + +2010-11-05 (frq)[491789] setargv/unicode cmdline for MSVC (nijtmans) + +2010-11-09 (bug fix)[3105999] fixed memleak in OO var resolver (fellows) + +--- Released 8.6b2, November 15, 2010 --- See ChangeLog for details --- @@ -5,7 +5,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.n,v 1.24 2010/01/13 12:08:30 dkf Exp $ +'\" RCS: @(#) $Id: Tcl.n,v 1.24.4.1 2010/12/01 16:42:33 kennykb Exp $ '\" .so man.macros .TH Tcl n "8.5" Tcl "Tcl Built-In Commands" @@ -110,6 +110,8 @@ Variable substitution may take any of the following forms: \fIName\fR is the name of a scalar variable; the name is a sequence of one or more characters that are a letter, digit, underscore, or namespace separators (two or more colons). +Letters and digits are \fIonly\fR the standard ASCII ones (\fB0\fR\-\fB9\fR, +\fBA\fR\-\fBZ\fR and \fBa\fR\-\fBz\fR). .TP 15 \fB$\fIname\fB(\fIindex\fB)\fR . @@ -117,6 +119,8 @@ or namespace separators (two or more colons). the name of an element within that array. \fIName\fR must contain only letters, digits, underscores, and namespace separators, and may be an empty string. +Letters and digits are \fIonly\fR the standard ASCII ones (\fB0\fR\-\fB9\fR, +\fBA\fR\-\fBZ\fR and \fBa\fR\-\fBz\fR). Command substitutions, variable substitutions, and backslash substitutions are performed on the characters of \fIindex\fR. .TP 15 @@ -136,6 +140,10 @@ substitutions are performed during the parsing of \fIname\fR. .PP There may be any number of variable substitutions in a single word. Variable substitution is not performed on words enclosed in braces. +.PP +Note that variables may contain character sequences other than those listed +above, but in that case other mechanisms must be used to access them (e.g., +via the \fBset\fR command's single-argument form). .RE .IP "[9] \fBBackslash substitution.\fR" If a backslash diff --git a/doc/Tcl_Main.3 b/doc/Tcl_Main.3 index e37ffe4..252d9fe 100644 --- a/doc/Tcl_Main.3 +++ b/doc/Tcl_Main.3 @@ -6,7 +6,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_Main.3,v 1.20 2008/12/19 18:23:04 dgp Exp $ +'\" RCS: @(#) $Id: Tcl_Main.3,v 1.20.4.1 2010/12/01 16:42:33 kennykb Exp $ '\" .so man.macros .TH Tcl_Main 3 8.4 Tcl "Tcl Library Procedures" @@ -30,7 +30,8 @@ Tcl_Obj * .AP int argc in Number of elements in \fIargv\fR. .AP char *argv[] in -Array of strings containing command-line arguments. +Array of strings containing command-line arguments. On Windows, when +using -DUNICODE, the parameter type changes to wchar_t *. .AP Tcl_AppInitProc *appInitProc in Address of an application-specific initialization procedure. The value for this argument is usually \fBTcl_AppInit\fR. @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: file.n,v 1.60 2010/09/18 23:14:19 dkf Exp $ +'\" RCS: @(#) $Id: file.n,v 1.60.2.1 2010/12/01 16:42:33 kennykb Exp $ '\" .so man.macros .TH file n 8.3 Tcl "Tcl Built-In Commands" @@ -377,7 +377,7 @@ generated. Returns a list whose elements are the path components in \fIname\fR. The first element of the list will have the same path type as \fIname\fR. All other elements will be relative. Path separators will be discarded -unless they are needed ensure that an element is unambiguously relative. +unless they are needed to ensure that an element is unambiguously relative. For example, under Unix .RS .PP diff --git a/doc/interp.n b/doc/interp.n index 2d2330b..2cb0e81 100644 --- a/doc/interp.n +++ b/doc/interp.n @@ -6,7 +6,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: interp.n,v 1.44 2010/01/20 13:42:17 dkf Exp $ +'\" RCS: @(#) $Id: interp.n,v 1.44.4.1 2010/12/01 16:42:33 kennykb Exp $ '\" .so man.macros .TH interp n 8.6 Tcl "Tcl Built-In Commands" @@ -186,6 +186,44 @@ given name already exists in this master. The initial recursion limit of the slave interpreter is set to the current recursion limit of its parent interpreter. .TP +\fBinterp\fR \fBdebug \fIpath\fR ?\fI\-frame\fR ?\fIbool\fR?? +. +Controls whether frame-level stack information is captured in the +slave interpreter identified by \fIpath\fR. If no arguments are +given, option and current setting are returned. If \fI\-frame\fR +is given, the debug setting is set to the given boolean if provided +and the current setting is returned. +This only effects the output of \fBinfo frame\fR, in that exact +frame-level information for command invocation at the bytecode level +is only captured with this setting on. +.PP +.RS +For example, with code like +.PP +.CS +\fBproc\fR mycontrol {... script} { + ... + \fBuplevel\fR 1 $script + ... +} + +\fBproc\fR dosomething {...} { + ... + mycontrol { + somecode + } +} +.CE +.PP +the standard setting will provide a relative line number for the +command \fBsomecode\fR and the relevant frame will be of type +\fBeval\fR. With frame-debug active on the other hand the tracking +extends so far that the system will be able to determine the file and +absolute line number of this command, and return a frame of type +\fBsource\fR. This more exact information is paid for with slower +execution of all commands. +.RE +.TP \fBinterp\fR \fBdelete \fR?\fIpath ...?\fR . Deletes zero or more interpreters given by the optional \fIpath\fR diff --git a/doc/tclvars.n b/doc/tclvars.n index 792d5c8..385e850 100644 --- a/doc/tclvars.n +++ b/doc/tclvars.n @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: tclvars.n,v 1.42 2010/01/14 11:47:09 dkf Exp $ +'\" RCS: @(#) $Id: tclvars.n,v 1.42.4.1 2010/12/01 16:42:33 kennykb Exp $ '\" .so man.macros .TH tclvars n 8.0 Tcl "Tcl Built-In Commands" @@ -101,6 +101,11 @@ Tcl format, using .QW / as the path separator, regardless of platform. This variable is only used when initializing the \fBauto_path\fR variable. +.TP +\fBenv(TCL_INTERP_DEBUG_FRAME)\fR +. +If existing, it has the same effect as running \fBinterp debug {} -frame 1\fR +as the very first command of each new Tcl interpreter. .RE .TP \fBerrorCode\fR diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 954426c..90d5460 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -16,7 +16,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.465.2.4 2010/10/23 15:49:54 kennykb Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.465.2.5 2010/12/01 16:42:34 kennykb Exp $ */ #include "tclInt.h" @@ -168,6 +168,7 @@ static Tcl_NRPostProc YieldToCallback; static void ClearTailcall(Tcl_Interp *interp, struct TEOV_callback *tailcallPtr); +static Tcl_ObjCmdProc NRCoroInjectObjCmd; MODULE_SCOPE const TclStubs tclStubs; @@ -596,6 +597,15 @@ Tcl_CreateInterp(void) iPtr->resultSpace[0] = 0; iPtr->threadId = Tcl_GetCurrentThread(); + /* TIP #378 */ +#ifdef TCL_INTERP_DEBUG_FRAME + iPtr->flags |= INTERP_DEBUG_FRAME; +#else + if (getenv("TCL_INTERP_DEBUG_FRAME") != NULL) { + iPtr->flags |= INTERP_DEBUG_FRAME; + } +#endif + /* * Initialise the tables for variable traces and searches *before* * creating the global ns - so that the trace on errorInfo can be @@ -826,7 +836,9 @@ Tcl_CreateInterp(void) TclNRYieldToObjCmd, NULL, NULL); Tcl_NRCreateCommand(interp, "::tcl::unsupported::yieldm", NULL, TclNRYieldObjCmd, INT2PTR(CORO_ACTIVATE_YIELDM), NULL); - + Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL, + NRCoroInjectObjCmd, NULL, NULL); + #ifdef USE_DTRACE /* * Register the tcl::dtrace command. @@ -7697,7 +7709,7 @@ ExprRandFunc( * to insure different seeds in different threads (bug #416643) */ - iPtr->randSeed = TclpGetClicks() + ((long)Tcl_GetCurrentThread()<<12); + iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12); /* * Make sure 1 <= randSeed <= (2^31) - 2. See below. @@ -8754,6 +8766,52 @@ NRCoroutineActivateCallback( } } + +static int +NRCoroInjectObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Command *cmdPtr; + CoroutineData *corPtr; + ExecEnv *savedEEPtr = iPtr->execEnvPtr; + + /* + * Usage more or less like tailcall: + * inject coroName cmd ?arg1 arg2 ...? + */ + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?"); + return TCL_ERROR; + } + + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]); + if ((!cmdPtr) || (cmdPtr->nreProc != NRInterpCoroutine)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("can only inject a command into a coroutine", -1)); + return TCL_ERROR; + } + + corPtr = (CoroutineData *) cmdPtr->objClientData; + if (!COR_IS_SUSPENDED(corPtr)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("can only inject a command into a suspended coroutine", -1)); + return TCL_ERROR; + } + + /* + * Add the callback to the coro's execEnv, so that it is the first thing + * to happen when the coro is resumed + */ + + iPtr->execEnvPtr = corPtr->eePtr; + Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0); + iPtr->execEnvPtr = savedEEPtr; + + return TCL_OK; +} + int NRInterpCoroutine( ClientData clientData, diff --git a/generic/tclBinary.c b/generic/tclBinary.c index de2d319..5a92f8d 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.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: tclBinary.c,v 1.66 2010/09/15 22:12:00 dkf Exp $ + * RCS: @(#) $Id: tclBinary.c,v 1.66.2.1 2010/12/01 16:42:34 kennykb Exp $ */ #include "tclInt.h" @@ -2454,7 +2454,7 @@ BinaryDecodeHex( } \ } \ if (cursor > limit) { \ - Tcl_Panic("limit hit\n"); \ + Tcl_Panic("limit hit"); \ } \ } while (0) diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 154db18..1ef646c 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -14,7 +14,7 @@ * * This code contributed by Karl Lehenbauer and Mark Diekhans * - * RCS: @(#) $Id: tclCkalloc.c,v 1.38.4.1 2010/10/02 01:38:27 kennykb Exp $ + * RCS: @(#) $Id: tclCkalloc.c,v 1.38.4.2 2010/12/01 16:42:34 kennykb Exp $ */ #include "tclInt.h" @@ -453,11 +453,7 @@ Tcl_DbCkalloc( if (break_on_malloc && (total_mallocs >= break_on_malloc)) { break_on_malloc = 0; (void) fflush(stdout); - fprintf(stderr,"reached malloc break limit (%d)\n", - total_mallocs); - fprintf(stderr, "program will now enter C debugger\n"); - (void) fflush(stderr); - abort(); + Tcl_Panic("reached malloc break limit (%d)", total_mallocs); } current_malloc_packets++; @@ -546,11 +542,7 @@ Tcl_AttemptDbCkalloc( if (break_on_malloc && (total_mallocs >= break_on_malloc)) { break_on_malloc = 0; (void) fflush(stdout); - fprintf(stderr,"reached malloc break limit (%d)\n", - total_mallocs); - fprintf(stderr, "program will now enter C debugger\n"); - (void) fflush(stderr); - abort(); + Tcl_Panic("reached malloc break limit (%d)", total_mallocs); } current_malloc_packets++; @@ -948,7 +940,7 @@ MemoryCmd( } Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": should be active, break_on_malloc, info, init, onexit, " + "\": should be active, break_on_malloc, info, init, objs, onexit, " "tag, trace, trace_on_at_malloc, or validate", NULL); return TCL_ERROR; @@ -1315,5 +1307,7 @@ TclFinalizeMemorySubsystem(void) * mode: c * c-basic-offset: 4 * fill-column: 78 + * tab-width: 8 + * indent-tabs-mode: nil * End: */ diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 7690649..ae2688d 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdMZ.c,v 1.214 2010/08/30 14:02:09 msofer Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.214.2.1 2010/12/01 16:42:34 kennykb Exp $ */ #include "tclInt.h" @@ -4499,6 +4499,8 @@ TryPostBody( ((Interp *) interp)->cmdFramePtr, 4*i + 5); handlerFailed: + resultObj = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(resultObj); options = During(interp, result, options, NULL); break; diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 044d9b1..c8e8618 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.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: tclCompCmds.c,v 1.169.2.2 2010/11/03 00:18:57 kennykb Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.169.2.3 2010/12/01 16:42:34 kennykb Exp $ */ #include "tclInt.h" @@ -453,7 +453,7 @@ TclCompileCatchCmd( TclEmitOpcode(INST_POP, envPtr); /* - * Stack is now ?script? result returnCode. + * Stack is now ?script? ?returnOptions? returnCode. * If the options dict has been requested, it is buried on the stack * under the return code. Reverse the stack to bring it to the top, * store it and remove it from the stack. diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 0c64526..1b44b7d 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.186.2.1 2010/09/25 14:51:12 kennykb Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.186.2.2 2010/12/01 16:42:35 kennykb Exp $ */ #ifndef _TCLDECLS @@ -3787,8 +3787,14 @@ extern const TclStubs *tclStubsPtr; # define Tcl_SetVar(interp, varName, newValue, flags) \ (tclStubsPtr->tcl_SetVar(interp, varName, newValue, flags)) #endif + #if defined(_WIN32) && defined(UNICODE) # define Tcl_FindExecutable(arg) ((Tcl_FindExecutable)((const char *)(arg))) +# define Tcl_MainEx Tcl_MainExW + EXTERN void Tcl_MainExW(int argc, wchar_t **argv, + Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); +# define Tcl_Main(argc, argv, proc) Tcl_MainExW(argc, argv, proc, \ + (Tcl_FindExecutable(argv[0]), (Tcl_CreateInterp)())) #endif #undef TCL_STORAGE_CLASS diff --git a/generic/tclExecute.c b/generic/tclExecute.c index b69d281..7a8f082 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.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: tclExecute.c,v 1.494.2.8 2010/10/23 15:49:54 kennykb Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.494.2.9 2010/12/01 16:42:35 kennykb Exp $ */ #include "tclInt.h" @@ -2120,7 +2120,9 @@ TEBCresume( NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr); NRE_ASSERT(TOP_CB(interp)->procPtr == TEBCreturn); iPtr->cmdFramePtr = bcFramePtr->nextPtr; - TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr); + if (iPtr->flags & INTERP_DEBUG_FRAME) { + TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr); + } if (codePtr->flags & TCL_BYTECODE_RECOMPILE) { iPtr->flags |= ERR_ALREADY_LOGGED; codePtr->flags &= ~TCL_BYTECODE_RECOMPILE; @@ -2797,8 +2799,10 @@ TEBCresume( bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; - TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, - codePtr, bcFramePtr, pc - codePtr->codeStart); + if (iPtr->flags & INTERP_DEBUG_FRAME) { + TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, + codePtr, bcFramePtr, pc - codePtr->codeStart); + } DECACHE_STACK_INFO(); diff --git a/generic/tclHash.c b/generic/tclHash.c index 81f9326..f53bbfe 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.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: tclHash.c,v 1.46 2010/08/24 06:17:55 nijtmans Exp $ + * RCS: @(#) $Id: tclHash.c,v 1.46.2.1 2010/12/01 16:42:35 kennykb Exp $ */ #include "tclInt.h" @@ -37,7 +37,7 @@ */ #define RANDOM_INDEX(tablePtr, i) \ - (((((long) (i))*1103515245) >> (tablePtr)->downShift) & (tablePtr)->mask) + ((((i)*1103515245L) >> (tablePtr)->downShift) & (tablePtr)->mask) /* * Prototypes for the array hash key methods. @@ -436,7 +436,7 @@ Tcl_DeleteHashEntry( #if TCL_HASH_KEY_STORE_HASH if (typePtr->hashKeyProc == NULL || typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { - index = RANDOM_INDEX(tablePtr, entryPtr->hash); + index = RANDOM_INDEX(tablePtr, PTR2INT(entryPtr->hash)); } else { index = PTR2UINT(entryPtr->hash) & tablePtr->mask; } @@ -1065,7 +1065,7 @@ RebuildTable( #if TCL_HASH_KEY_STORE_HASH if (typePtr->hashKeyProc == NULL || typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { - index = RANDOM_INDEX(tablePtr, hPtr->hash); + index = RANDOM_INDEX(tablePtr, PTR2INT(hPtr->hash)); } else { index = PTR2UINT(hPtr->hash) & tablePtr->mask; } diff --git a/generic/tclInt.decls b/generic/tclInt.decls index f877c89..2b2274d 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -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: tclInt.decls,v 1.148.2.2 2010/10/02 01:38:27 kennykb Exp $ +# RCS: @(#) $Id: tclInt.decls,v 1.148.2.3 2010/12/01 16:42:35 kennykb Exp $ library tcl @@ -116,10 +116,10 @@ declare 22 { declare 23 { Proc *TclFindProc(Interp *iPtr, const char *procName) } -# Replaced with macro (see tclInt.h) in Tcl 8.5 -#declare 24 { -# int TclFormatInt(char *buffer, long n) -#} +# Replaced with macro (see tclInt.h) in Tcl 8.5.0, restored in 8.5.10 +declare 24 { + int TclFormatInt(char *buffer, long n) +} declare 25 { void TclFreePackageInfo(Interp *iPtr) } @@ -996,6 +996,11 @@ declare 248 { int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr) } + +declare 249 { + char* TclDoubleDigits(double dv, int ndigits, int flags, + int* decpt, int* signum, char** endPtr) +} ############################################################################## diff --git a/generic/tclInt.h b/generic/tclInt.h index 4dff202..dbabccf 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -15,7 +15,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.482.2.4 2010/10/23 15:49:54 kennykb Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.482.2.5 2010/12/01 16:42:36 kennykb Exp $ */ #ifndef _TCLINT @@ -2253,6 +2253,9 @@ typedef struct InterpList { * SAFE_INTERP: Non zero means that the current interp is a safe * interp (i.e. it has only the safe commands installed, * less priviledge than a regular interp). + * INTERP_DEBUG_FRAME: Used for switching on various extra interpreter + * debug/info mechanisms (e.g. info frame eval/uplevel + * tracing) which are performance intensive. * INTERP_TRACE_IN_PROGRESS: Non-zero means that an interp trace is currently * active; so no further trace callbacks should be * invoked. @@ -2278,6 +2281,7 @@ typedef struct InterpList { #define DELETED 1 #define ERR_ALREADY_LOGGED 4 +#define INTERP_DEBUG_FRAME 0x10 #define DONT_COMPILE_CMDS_INLINE 0x20 #define RAND_SEED_INITIALIZED 0x40 #define SAFE_INTERP 0x80 @@ -2791,6 +2795,32 @@ struct Tcl_LoadHandle_ { /* Procedure that unloads a loaded module */ }; +/* Flags for conversion of doubles to digit strings */ + +#define TCL_DD_SHORTEST 0x4 + /* Use the shortest possible string */ +#define TCL_DD_STEELE 0x5 + /* Use the original Steele&White algorithm */ +#define TCL_DD_E_FORMAT 0x2 + /* Use a fixed-length string of digits, + * suitable for E format*/ +#define TCL_DD_F_FORMAT 0x3 + /* Use a fixed number of digits after the + * decimal point, suitable for F format */ + +#define TCL_DD_SHORTEN_FLAG 0x4 + /* Allow return of a shorter digit string + * if it converts losslessly */ +#define TCL_DD_NO_QUICK 0x8 + /* Debug flag: forbid quick FP conversion */ + +#define TCL_DD_CONVERSION_TYPE_MASK 0x3 + /* Mask to isolate the conversion type */ +#define TCL_DD_STEELE0 0x1 + /* 'Steele&White' after masking */ +#define TCL_DD_SHORTEST0 0x0 + /* 'Shortest possible' after masking */ + /* *---------------------------------------------------------------- * Procedures shared among Tcl modules but not used by the outside world: @@ -2839,7 +2869,6 @@ MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr, MODULE_SCOPE ContLineLoc *TclContinuationsGet(Tcl_Obj *objPtr); MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr, Tcl_Obj *originObjPtr); -MODULE_SCOPE int TclDoubleDigits(char *buf, double value, int *signum); MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); /* TIP #280 - Modified token based evulation, with line information. */ MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, @@ -4205,18 +4234,6 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; /* *---------------------------------------------------------------- - * Macro used by the Tcl core to write the string rep of a long integer to a - * character buffer. The ANSI C "prototype" for this macro is: - * - * MODULE_SCOPE int TclFormatInt(char *buf, long n); - *---------------------------------------------------------------- - */ - -#define TclFormatInt(buf, n) \ - sprintf((buf), "%ld", (long)(n)) - -/* - *---------------------------------------------------------------- * Macros used by the Tcl core to set a Tcl_Obj's numeric representation * avoiding the corresponding function calls in time critical parts of the * core. They should only be called on unshared objects. The ANSI C diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 890263b..ba82f75 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -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: tclIntDecls.h,v 1.142.2.2 2010/10/02 01:38:27 kennykb Exp $ + * RCS: @(#) $Id: tclIntDecls.h,v 1.142.2.3 2010/12/01 16:42:36 kennykb Exp $ */ #ifndef _TCLINTDECLS @@ -109,7 +109,8 @@ EXTERN int TclFindElement(Tcl_Interp *interp, int *bracePtr); /* 23 */ EXTERN Proc * TclFindProc(Interp *iPtr, const char *procName); -/* Slot 24 is reserved */ +/* 24 */ +EXTERN int TclFormatInt(char *buffer, long n); /* 25 */ EXTERN void TclFreePackageInfo(Interp *iPtr); /* Slot 26 is reserved */ @@ -596,6 +597,9 @@ EXTERN void TclResetRewriteEnsemble(Tcl_Interp *interp, EXTERN int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); +/* 249 */ +EXTERN char* TclDoubleDigits(double dv, int ndigits, int flags, + int*decpt, int*signum, char**endPtr); typedef struct TclIntStubs { int magic; @@ -625,7 +629,7 @@ typedef struct TclIntStubs { void (*reserved21)(void); int (*tclFindElement) (Tcl_Interp *interp, const char *listStr, int listLength, const char **elementPtr, const char **nextPtr, int *sizePtr, int *bracePtr); /* 22 */ Proc * (*tclFindProc) (Interp *iPtr, const char *procName); /* 23 */ - void (*reserved24)(void); + int (*tclFormatInt) (char *buffer, long n); /* 24 */ void (*tclFreePackageInfo) (Interp *iPtr); /* 25 */ void (*reserved26)(void); void (*reserved27)(void); @@ -850,6 +854,7 @@ typedef struct TclIntStubs { int (*tclInitRewriteEnsemble) (Tcl_Interp *interp, int numRemoved, int numInserted, Tcl_Obj *const *objv); /* 246 */ void (*tclResetRewriteEnsemble) (Tcl_Interp *interp, int isRootEnsemble); /* 247 */ int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 248 */ + char* (*tclDoubleDigits) (double dv, int ndigits, int flags, int*decpt, int*signum, char**endPtr); /* 249 */ } TclIntStubs; #ifdef __cplusplus @@ -903,7 +908,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclFindElement) /* 22 */ #define TclFindProc \ (tclIntStubsPtr->tclFindProc) /* 23 */ -/* Slot 24 is reserved */ +#define TclFormatInt \ + (tclIntStubsPtr->tclFormatInt) /* 24 */ #define TclFreePackageInfo \ (tclIntStubsPtr->tclFreePackageInfo) /* 25 */ /* Slot 26 is reserved */ @@ -1269,6 +1275,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclResetRewriteEnsemble) /* 247 */ #define TclCopyChannel \ (tclIntStubsPtr->tclCopyChannel) /* 248 */ +#define TclDoubleDigits \ + (tclIntStubsPtr->tclDoubleDigits) /* 249 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index e22133a..c32daa1 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.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: tclInterp.c,v 1.113 2010/08/22 18:53:26 nijtmans Exp $ + * RCS: @(#) $Id: tclInterp.c,v 1.113.2.1 2010/12/01 16:42:36 kennykb Exp $ */ #include "tclInt.h" @@ -210,6 +210,9 @@ static int SlaveBgerror(Tcl_Interp *interp, Tcl_Obj *const objv[]); static Tcl_Interp * SlaveCreate(Tcl_Interp *interp, Tcl_Obj *pathPtr, int safe); +static int SlaveDebugCmd(Tcl_Interp *interp, + Tcl_Interp *slaveInterp, + int objc, Tcl_Obj *const objv[]); static int SlaveEval(Tcl_Interp *interp, Tcl_Interp *slaveInterp, int objc, Tcl_Obj *const objv[]); static int SlaveExpose(Tcl_Interp *interp, @@ -561,16 +564,18 @@ Tcl_InterpObjCmd( int index; static const char *const options[] = { "alias", "aliases", "bgerror", "cancel", - "create", "delete", "eval", "exists", - "expose", "hide", "hidden", "issafe", + "create", "debug", "delete", + "eval", "exists", "expose", + "hide", "hidden", "issafe", "invokehidden", "limit", "marktrusted", "recursionlimit", "slaves", "share", "target", "transfer", NULL }; enum option { OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CANCEL, - OPT_CREATE, OPT_DELETE, OPT_EVAL, OPT_EXISTS, - OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, + OPT_CREATE, OPT_DEBUG, OPT_DELETE, + OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, + OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID, OPT_LIMIT, OPT_MARKTRUSTED,OPT_RECLIMIT, OPT_SLAVES, OPT_SHARE, OPT_TARGET, OPT_TRANSFER }; @@ -784,6 +789,23 @@ Tcl_InterpObjCmd( Tcl_SetObjResult(interp, slavePtr); return TCL_OK; } + case OPT_DEBUG: { + /* TIP #378 */ + Tcl_Interp *slaveInterp; + + /* + * Currently only -frame supported, otherwise ?-option ?value?? + */ + if (objc < 3 || objc > 5) { + Tcl_WrongNumArgs(interp, 2, objv, "path ?-frame ?bool??"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveDebugCmd(interp, slaveInterp, objc - 3, objv + 3); + } case OPT_DELETE: { int i; InterpInfo *iiPtr; @@ -2376,14 +2398,16 @@ SlaveObjCmd( Tcl_Interp *slaveInterp = clientData; int index; static const char *const options[] = { - "alias", "aliases", "bgerror", "eval", - "expose", "hide", "hidden", "issafe", - "invokehidden", "limit", "marktrusted", "recursionlimit", NULL + "alias", "aliases", "bgerror", "debug", + "eval", "expose", "hide", "hidden", + "issafe", "invokehidden", "limit", "marktrusted", + "recursionlimit", NULL }; enum options { - OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_EVAL, - OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, - OPT_INVOKEHIDDEN, OPT_LIMIT, OPT_MARKTRUSTED, OPT_RECLIMIT + OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_DEBUG, + OPT_EVAL, OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, + OPT_ISSAFE, OPT_INVOKEHIDDEN, OPT_LIMIT, OPT_MARKTRUSTED, + OPT_RECLIMIT }; if (slaveInterp == NULL) { @@ -2428,6 +2452,16 @@ SlaveObjCmd( return TCL_ERROR; } return SlaveBgerror(interp, slaveInterp, objc - 2, objv + 2); + case OPT_DEBUG: + /* + * TIP #378 + * Currently only -frame supported, otherwise ?-option ?value? ...? + */ + if (objc > 4) { + Tcl_WrongNumArgs(interp, 2, objv, "?-frame ?bool??"); + return TCL_ERROR; + } + return SlaveDebugCmd(interp, slaveInterp, objc - 2, objv + 2); case OPT_EVAL: if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?"); @@ -2591,6 +2625,75 @@ SlaveObjCmdDeleteProc( /* *---------------------------------------------------------------------- * + * SlaveDebugCmd -- TIP #378 + * + * Helper function to handle 'debug' command in a slave interpreter. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May modify INTERP_DEBUG_FRAME flag in the slave. + * + *---------------------------------------------------------------------- + */ + +static int +SlaveDebugCmd( + Tcl_Interp *interp, /* Interp for error return. */ + Tcl_Interp *slaveInterp, /* The slave interpreter in which command + * will be evaluated. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + static const char *const debugTypes[] = { + "-frame", NULL + }; + enum DebugTypes { + DEBUG_TYPE_FRAME + }; + int debugType; + Interp *iPtr; + Tcl_Obj *resultPtr; + + iPtr = (Interp *) slaveInterp; + if (objc == 0) { + resultPtr = Tcl_NewObj(); + Tcl_ListObjAppendElement(NULL, resultPtr, + Tcl_NewStringObj("-frame", -1)); + Tcl_ListObjAppendElement(NULL, resultPtr, + Tcl_NewBooleanObj(iPtr->flags & INTERP_DEBUG_FRAME)); + Tcl_SetObjResult(interp, resultPtr); + } else { + if (Tcl_GetIndexFromObj(interp, objv[0], debugTypes, + "debug option", 0, &debugType) != TCL_OK) { + return TCL_ERROR; + } + if (debugType == DEBUG_TYPE_FRAME) { + if (objc == 2) { /* set */ + if (Tcl_GetBooleanFromObj(interp, objv[1], &debugType) + != TCL_OK) { + return TCL_ERROR; + } + /* + * Quietly ignore attempts to disable interp debugging. + * This is a one-way switch as frame debug info is maintained + * in a stack that must be consistent once turned on. + */ + if (debugType) { + iPtr->flags |= INTERP_DEBUG_FRAME; + } + } + Tcl_SetObjResult(interp, + Tcl_NewBooleanObj(iPtr->flags & INTERP_DEBUG_FRAME)); + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * SlaveEval -- * * Helper function to evaluate a command in a slave interpreter. diff --git a/generic/tclMain.c b/generic/tclMain.c index 3e2e1da..4cb9c27 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.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: tclMain.c,v 1.50.2.2 2010/09/30 02:48:06 kennykb Exp $ + * RCS: @(#) $Id: tclMain.c,v 1.50.2.3 2010/12/01 16:42:36 kennykb Exp $ */ /** @@ -18,9 +18,14 @@ * TCL_ASCII_MAIN defined. This way both Tcl_Main and Tcl_MainExW * can be implemented, sharing the same source code. */ -#ifndef TCL_ASCII_MAIN -# undef UNICODE -# undef _UNICODE +#if defined(TCL_ASCII_MAIN) +# ifdef UNICODE +# undef UNICODE +# undef _UNICODE +# else +# define UNICODE +# define _UNICODE +# endif #endif #include "tclInt.h" @@ -265,7 +270,7 @@ Tcl_SourceRCFile( /*---------------------------------------------------------------------- * - * Tcl_Main -- + * Tcl_Main, Tcl_MainEx -- * * Main program for tclsh and most other Tcl-based applications. * @@ -282,13 +287,14 @@ Tcl_SourceRCFile( */ void -Tcl_Main( +Tcl_MainEx( int argc, /* Number of arguments. */ TCHAR **argv, /* Array of argument strings. */ - Tcl_AppInitProc *appInitProc) + Tcl_AppInitProc *appInitProc, /* Application-specific initialization * function to call after most initialization * but before starting to execute commands. */ + Tcl_Interp *interp) { Tcl_Obj *path, *resultPtr, *argvPtr, *commandPtr = NULL; const char *encodingName = NULL; @@ -296,12 +302,8 @@ Tcl_Main( int code, length, tty, exitCode = 0; Tcl_MainLoopProc *mainLoopProc; Tcl_Channel inChannel, outChannel, errChannel; - Tcl_Interp *interp; Tcl_DString appName; - Tcl_FindExecutable(argv[0]); - - interp = Tcl_CreateInterp(); Tcl_InitMemory(interp); /* @@ -650,8 +652,24 @@ Tcl_Main( Tcl_Release(interp); Tcl_Exit(exitCode); } + +#ifndef UNICODE +void +Tcl_Main( + int argc, /* Number of arguments. */ + TCHAR **argv, /* Array of argument strings. */ + Tcl_AppInitProc *appInitProc) + /* Application-specific initialization + * function to call after most initialization + * but before starting to execute commands. */ +{ + Tcl_FindExecutable(argv[0]); + Tcl_MainEx(argc, argv, appInitProc, Tcl_CreateInterp()); +} +#endif #ifndef TCL_ASCII_MAIN + /* *--------------------------------------------------------------- * diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index e1dfd48..2e5decc 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -22,7 +22,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclNamesp.c,v 1.212.2.2 2010/10/23 15:49:54 kennykb Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.212.2.3 2010/12/01 16:42:36 kennykb Exp $ */ #include "tclInt.h" @@ -888,7 +888,7 @@ Tcl_DeleteNamespace( (Tcl_Command) cmdPtr); entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); } else { - entryPtr = entryPtr->nextPtr; + entryPtr = Tcl_NextHashEntry(&search); } } diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 20f6ab6..2fefa31 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.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: tclOOMethod.c,v 1.26.2.2 2010/09/27 20:33:37 kennykb Exp $ + * RCS: @(#) $Id: tclOOMethod.c,v 1.26.2.3 2010/12/01 16:42:36 kennykb Exp $ */ #ifdef HAVE_CONFIG_H @@ -929,7 +929,7 @@ ProcedureMethodVarResolver( Tcl_Var *varPtr) { int result; - Tcl_ResolvedVarInfo *rPtr; + Tcl_ResolvedVarInfo *rPtr = NULL; result = ProcedureMethodCompiledVarResolver(interp, varName, strlen(varName), contextNs, &rPtr); @@ -939,6 +939,14 @@ ProcedureMethodVarResolver( } *varPtr = rPtr->fetchProc(interp, rPtr); + + /* + * Must not retain reference to resolved information. [Bug 3105999] + */ + + if (rPtr != NULL) { + rPtr->deleteProc(rPtr); + } return (*varPtr? TCL_OK : TCL_CONTINUE); } @@ -956,8 +964,6 @@ ProcedureMethodCompiledVarConnect( int i, isNew, cacheIt, varLen, len; const char *match, *varName; - varName = TclGetStringFromObj(infoPtr->variableObj, &varLen); - /* * Check that the variable is being requested in a context that is also a * method call; if not (i.e. we're evaluating in the object's namespace or @@ -984,6 +990,7 @@ ProcedureMethodCompiledVarConnect( * either. */ + varName = TclGetStringFromObj(infoPtr->variableObj, &varLen); if (contextPtr->callPtr->chain[contextPtr->index] .mPtr->declaringClassPtr != NULL) { FOREACH(variableObj, contextPtr->callPtr->chain[contextPtr->index] diff --git a/generic/tclPanic.c b/generic/tclPanic.c index b3a5ed6..70d37a1 100644 --- a/generic/tclPanic.c +++ b/generic/tclPanic.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: tclPanic.c,v 1.14 2009/07/22 19:54:50 nijtmans Exp $ + * RCS: @(#) $Id: tclPanic.c,v 1.14.4.1 2010/12/01 16:42:36 kennykb Exp $ */ #include "tclInt.h" @@ -90,7 +90,12 @@ Tcl_PanicVA( arg8); fprintf(stderr, "\n"); fflush(stderr); +#ifdef _WIN32 + DebugBreak(); + ExitProcess(1); +#else abort(); +#endif } } diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index d0a5345..8544351 100755 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.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: tclStrToD.c,v 1.46 2010/05/21 12:43:29 nijtmans Exp $ + * RCS: @(#) $Id: tclStrToD.c,v 1.46.2.1 2010/12/01 16:42:36 kennykb Exp $ * *---------------------------------------------------------------------- */ @@ -90,6 +90,66 @@ typedef unsigned int fpu_control_t __attribute__ ((__mode__ (__HI__))); * runtime). */ +/* Magic constants */ + +#define LOG10_2 0.3010299956639812 +#define TWO_OVER_3LOG10 0.28952965460216784 +#define LOG10_3HALVES_PLUS_FUDGE 0.1760912590558 + +/* Definitions of the parts of an IEEE754-format floating point number */ + +#define SIGN_BIT 0x80000000 + /* Mask for the sign bit in the first + * word of a double */ +#define EXP_MASK 0x7ff00000 + /* Mask for the exponent field in the + * first word of a double */ +#define EXP_SHIFT 20 + /* Shift count to make the exponent an + * integer */ +#define HIDDEN_BIT (((Tcl_WideUInt) 0x00100000) << 32) + /* Hidden 1 bit for the significand */ +#define HI_ORDER_SIG_MASK 0x000fffff + /* Mask for the high-order part of the + * significand in the first word of a + * double */ +#define SIG_MASK (((Tcl_WideUInt) HI_ORDER_SIG_MASK << 32) \ + | 0xffffffff) + /* Mask for the 52-bit significand. */ +#define FP_PRECISION 53 + /* Number of bits of significand plus the + * hidden bit */ +#define EXPONENT_BIAS 0x3ff + /* Bias of the exponent 0 */ + +/* Derived quantities */ + +#define TEN_PMAX 22 + /* floor(FP_PRECISION*log(2)/log(5)) */ +#define QUICK_MAX 14 + /* floor((FP_PRECISION-1)*log(2)/log(10)) - 1 */ +#define BLETCH 0x10 + /* Highest power of two that is greater than + * DBL_MAX_10_EXP, divided by 16 */ +#define DIGIT_GROUP 8 + /* floor(DIGIT_BIT*log(2)/log(10)) */ + +/* Union used to dismantle floating point numbers. */ + +typedef union Double { + struct { +#ifdef WORDS_BIGENDIAN + int word0; + int word1; +#else + int word1; + int word0; +#endif + } w; + double d; + Tcl_WideUInt q; +} Double; + static int maxpow10_wide; /* The powers of ten that can be represented * exactly as wide integers. */ static Tcl_WideUInt *pow10_wide; @@ -123,6 +183,7 @@ static const double pow_10_2_n[] = { /* Inexact higher powers of ten. */ 1.0e+128, 1.0e+256 }; + static int n770_fp; /* Flag is 1 on Nokia N770 floating point. * Nokia's floating point has the words * reversed: if big-endian is 7654 3210, @@ -131,27 +192,161 @@ static int n770_fp; /* Flag is 1 on Nokia N770 floating point. * little-endian within the 32-bit words * but big-endian between them. */ +/* Table of powers of 5 that are small enough to fit in an mp_digit. */ + +static const mp_digit dpow5[13] = { + 1, 5, 25, 125, + 625, 3125, 15625, 78125, + 390625, 1953125, 9765625, 48828125, + 244140625 +}; + +/* Table of powers: pow5_13[n] = 5**(13*2**(n+1)) */ +static mp_int pow5_13[5]; /* Table of powers: 5**13, 5**26, 5**52, + * 5**104, 5**208 */ +static const double tens[] = { + 1e00, 1e01, 1e02, 1e03, 1e04, 1e05, 1e06, 1e07, 1e08, 1e09, + 1e10, 1e11, 1e12, 1e13, 1e14, 1e15, 1e16, 1e17, 1e18, 1e19, + 1e20, 1e21, 1e22 +}; + +static const int itens [] = { + 1, + 10, + 100, + 1000, + 10000, + 100000, + 1000000, + 10000000, + 100000000 +}; + +static const Tcl_WideUInt wtens[] = { + 1, 10, 100, 1000, 10000, 100000, 1000000, + (Tcl_WideUInt) 1000000*10, (Tcl_WideUInt) 1000000*100, + (Tcl_WideUInt) 1000000*1000, (Tcl_WideUInt) 1000000*10000, + (Tcl_WideUInt) 1000000*100000, (Tcl_WideUInt) 1000000*1000000, + (Tcl_WideUInt) 1000000*1000000*10, (Tcl_WideUInt) 1000000*1000000*100, + (Tcl_WideUInt) 1000000*1000000*1000,(Tcl_WideUInt) 1000000*1000000*10000 + +}; + +static const double bigtens[] = { + 1e016, 1e032, 1e064, 1e128, 1e256 +}; +#define N_BIGTENS 5 + +static const int log2pow5[27] = { + 01, 3, 5, 7, 10, 12, 14, 17, 19, 21, + 24, 26, 28, 31, 33, 35, 38, 40, 42, 45, + 47, 49, 52, 54, 56, 59, 61 +}; +#define N_LOG2POW5 27 + +static const Tcl_WideUInt wuipow5[27] = { + (Tcl_WideUInt) 1, /* 5**0 */ + (Tcl_WideUInt) 5, + (Tcl_WideUInt) 25, + (Tcl_WideUInt) 125, + (Tcl_WideUInt) 625, + (Tcl_WideUInt) 3125, /* 5**5 */ + (Tcl_WideUInt) 3125*5, + (Tcl_WideUInt) 3125*25, + (Tcl_WideUInt) 3125*125, + (Tcl_WideUInt) 3125*625, + (Tcl_WideUInt) 3125*3125, /* 5**10 */ + (Tcl_WideUInt) 3125*3125*5, + (Tcl_WideUInt) 3125*3125*25, + (Tcl_WideUInt) 3125*3125*125, + (Tcl_WideUInt) 3125*3125*625, + (Tcl_WideUInt) 3125*3125*3125, /* 5**15 */ + (Tcl_WideUInt) 3125*3125*3125*5, + (Tcl_WideUInt) 3125*3125*3125*25, + (Tcl_WideUInt) 3125*3125*3125*125, + (Tcl_WideUInt) 3125*3125*3125*625, + (Tcl_WideUInt) 3125*3125*3125*3125, /* 5**20 */ + (Tcl_WideUInt) 3125*3125*3125*3125*5, + (Tcl_WideUInt) 3125*3125*3125*3125*25, + (Tcl_WideUInt) 3125*3125*3125*3125*125, + (Tcl_WideUInt) 3125*3125*3125*3125*625, + (Tcl_WideUInt) 3125*3125*3125*3125*3125, /* 5**25 */ + (Tcl_WideUInt) 3125*3125*3125*3125*3125*5 /* 5**26 */ +}; + /* * Static functions defined in this file. */ -static double AbsoluteValue(double v, int *signum); static int AccumulateDecimalDigit(unsigned, int, Tcl_WideUInt *, mp_int *, int); -static double BignumToBiasedFrExp(const mp_int *big, int *machexp); -static int GetIntegerTimesPower(double v, mp_int *r, int *e); static double MakeHighPrecisionDouble(int signum, mp_int *significand, int nSigDigs, int exponent); static double MakeLowPrecisionDouble(int signum, Tcl_WideUInt significand, int nSigDigs, int exponent); static double MakeNaN(int signum, Tcl_WideUInt tag); -static Tcl_WideUInt Nokia770Twiddle(Tcl_WideUInt w); -static double Pow10TimesFrExp(int exponent, double fraction, - int *machexp); static double RefineApproximation(double approx, mp_int *exactSignificand, int exponent); +static void MulPow5(mp_int*, unsigned, mp_int*); +static int NormalizeRightward(Tcl_WideUInt*); +static int RequiredPrecision(Tcl_WideUInt); +static void DoubleToExpAndSig(double, Tcl_WideUInt*, int*, int*); +static void TakeAbsoluteValue(Double*, int*); +static char* FormatInfAndNaN(Double*, int*, char**); +static char* FormatZero(int*, char**); +static int ApproximateLog10(Tcl_WideUInt, int, int); +static int BetterLog10(double, int, int*); +static void ComputeScale(int, int, int*, int*, int*, int*); +static void SetPrecisionLimits(int, int, int*, int*, int*, int*); +static char* BumpUp(char*, char*, int*); +static int AdjustRange(double*, int); +static char* ShorteningQuickFormat(double, int, int, double, + char*, int*); +static char* StrictQuickFormat(double, int, int, double, + char*, int*); +static char* QuickConversion(double, int, int, int, int, int, int, + int*, char**); +static void CastOutPowersOf2(int*, int*, int*); +static char* ShorteningInt64Conversion(Double*, int, Tcl_WideUInt, + int, int, int, int, int, int, int, int, int, + int, int, int*, char**); +static char* StrictInt64Conversion(Double*, int, Tcl_WideUInt, + int, int, int, int, int, int, + int, int, int*, char**); +static int ShouldBankerRoundUpPowD(mp_int*, int, int); +static int ShouldBankerRoundUpToNextPowD(mp_int*, mp_int*, + int, int, int, mp_int*); +static char* ShorteningBignumConversionPowD(Double* dPtr, + int convType, Tcl_WideUInt bw, int b2, int b5, + int m2plus, int m2minus, int m5, + int sd, int k, int len, + int ilim, int ilim1, int* decpt, + char** endPtr); +static char* StrictBignumConversionPowD(Double* dPtr, int convType, + Tcl_WideUInt bw, int b2, int b5, + int sd, int k, int len, + int ilim, int ilim1, int* decpt, + char** endPtr); +static int ShouldBankerRoundUp(mp_int*, mp_int*, int); +static int ShouldBankerRoundUpToNext(mp_int*, mp_int*, mp_int*, + int, int, mp_int*); +static char* ShorteningBignumConversion(Double* dPtr, int convType, + Tcl_WideUInt bw, int b2, + int m2plus, int m2minus, + int s2, int s5, int k, int len, + int ilim, int ilim1, int* decpt, + char** endPtr); +static char* StrictBignumConversion(Double* dPtr, int convType, + Tcl_WideUInt bw, int b2, + int s2, int s5, int k, int len, + int ilim, int ilim1, int* decpt, + char** endPtr); +static double BignumToBiasedFrExp(const mp_int *big, int *machexp); +static double Pow10TimesFrExp(int exponent, double fraction, + int *machexp); static double SafeLdExp(double fraction, int exponent); +static Tcl_WideUInt Nokia770Twiddle(Tcl_WideUInt w); /* *---------------------------------------------------------------------- @@ -1732,414 +1927,2369 @@ RefineApproximation( } /* - *---------------------------------------------------------------------- + *----------------------------------------------------------------------------- * - * TclDoubleDigits -- + * MultPow5 -- + * + * Multiply a bignum by a power of 5. + * + * Side effects: + * Stores base*5**n in result + * + *----------------------------------------------------------------------------- + */ + +inline static void +MulPow5(mp_int* base, /* Number to multiply */ + unsigned n, /* Power of 5 to multiply by */ + mp_int* result) /* Place to store the result */ +{ + mp_int* p = base; + int n13 = n / 13; + int r = n % 13; + if (r != 0) { + mp_mul_d(p, dpow5[r], result); + p = result; + } + r = 0; + while (n13 != 0) { + if (n13 & 1) { + mp_mul(p, pow5_13+r, result); + p = result; + } + n13 >>= 1; + ++r; + } + if (p != result) { + mp_copy(p, result); + } +} + +/* + *----------------------------------------------------------------------------- + * + * NormalizeRightward -- * - * Converts a double to a string of digits. + * Shifts a number rightward until it is odd (that is, until the + * least significant bit is nonzero. * * Results: - * Returns the position of the character in the string after which the - * decimal point should appear. Since the string contains only - * significant digits, the position may be less than zero or greater than - * the length of the string. + * Returns the number of bit positions by which the number was shifted. * * Side effects: - * Stores the digits in the given buffer and sets 'signum' according to - * the sign of the number. + * Shifts the number in place; *wPtr is replaced by the shifted number. * - *---------------------------------------------------------------------- + *----------------------------------------------------------------------------- + */ +inline static int +NormalizeRightward(Tcl_WideUInt* wPtr) + /* INOUT: Number to shift */ +{ + int rv = 0; + Tcl_WideUInt w = *wPtr; + if (!(w & (Tcl_WideUInt) 0xffffffff)) { + w >>= 32; rv += 32; + } + if (!(w & (Tcl_WideUInt) 0xffff)) { + w >>= 16; rv += 16; + } + if (!(w & (Tcl_WideUInt) 0xff)) { + w >>= 8; rv += 8; + } + if (!(w & (Tcl_WideUInt) 0xf)) { + w >>= 4; rv += 4; + } + if (!(w & 0x3)) { + w >>= 2; rv += 2; + } + if (!(w & 0x1)) { + w >>= 1; ++rv; + } + *wPtr = w; + return rv; +} + +/* + *-----------------------------------------------------------------------------0 + * + * RequiredPrecision -- + * + * Determines the number of bits needed to hold an intger. + * + * Results: + * Returns the position of the most significant bit (0 - 63). + * Returns 0 if the number is zero. + * + *---------------------------------------------------------------------------- */ -int -TclDoubleDigits( - char *buffer, /* Buffer in which to store the result, must - * have at least 18 chars */ - double v, /* Number to convert. Must be finite, and not - * NaN */ - int *signum) /* Output: 1 if the number is negative. - * Should handle -0 correctly on the IEEE - * architecture. */ +static int +RequiredPrecision(Tcl_WideUInt w) + /* Number to interrogate */ { - int e; /* Power of FLT_RADIX that satisfies - * v = f * FLT_RADIX**e */ - int lowOK, highOK; - mp_int r; /* Scaled significand. */ - mp_int s; /* Divisor such that v = r / s */ - int smallestSig; /* Flag == 1 iff v's significand is the - * smallest that can be represented. */ - mp_int mplus; /* Scaled epsilon: (r + 2* mplus) == v(+) - * where v(+) is the floating point successor - * of v. */ - mp_int mminus; /* Scaled epsilon: (r - 2*mminus) == v(-) - * where v(-) is the floating point - * predecessor of v. */ - mp_int temp; - int rfac2 = 0; /* Powers of 2 and 5 by which large */ - int rfac5 = 0; /* integers should be scaled. */ - int sfac2 = 0; - int sfac5 = 0; - int mplusfac2 = 0; - int mminusfac2 = 0; - char c; - int i, k, n; + int rv; + unsigned long wi; + if (w & ((Tcl_WideUInt) 0xffffffff << 32)) { + wi = (unsigned long) (w >> 32); rv = 32; + } else { + wi = (unsigned long) w; rv = 0; + } + if (wi & 0xffff0000) { + wi >>= 16; rv += 16; + } + if (wi & 0xff00) { + wi >>= 8; rv += 8; + } + if (wi & 0xf0) { + wi >>= 4; rv += 4; + } + if (wi & 0xc) { + wi >>= 2; rv += 2; + } + if (wi & 0x2) { + wi >>= 1; ++rv; + } + if (wi & 0x1) { + ++rv; + } + return rv; +} + +/* + *----------------------------------------------------------------------------- + * + * DoubleToExpAndSig -- + * + * Separates a 'double' into exponent and significand. + * + * Side effects: + * Stores the significand in '*significand' and the exponent in + * '*expon' so that dv == significand * 2.0**expon, and significand + * is odd. Also stores the position of the leftmost 1-bit in 'significand' + * in 'bits'. + * + *----------------------------------------------------------------------------- + */ + +inline static void +DoubleToExpAndSig(double dv, /* Number to convert */ + Tcl_WideUInt* significand, + /* OUTPUT: Significand of the number */ + int* expon, /* OUTPUT: Exponent to multiply the number by */ + int* bits) /* OUTPUT: Number of significant bits */ +{ + Double d; /* Number being converted */ + Tcl_WideUInt z; /* Significand under construction */ + int de; /* Exponent of the number */ + int k; /* Bit count */ + + d.d = dv; + + /* Extract exponent and significand */ + + de = (d.w.word0 & EXP_MASK) >> EXP_SHIFT; + z = d.q & SIG_MASK; + if (de != 0) { + z |= HIDDEN_BIT; + k = NormalizeRightward(&z); + *bits = FP_PRECISION - k; + *expon = k + (de - EXPONENT_BIAS) - (FP_PRECISION-1); + } else { + k = NormalizeRightward(&z); + *expon = k + (de - EXPONENT_BIAS) - (FP_PRECISION-1) + 1; + *bits = RequiredPrecision(z); + } + *significand = z; +} + +/* + *----------------------------------------------------------------------------- + * + * TakeAbsoluteValue -- + * + * Takes the absolute value of a 'double' including 0, Inf and NaN + * + * Side effects: + * The 'double' in *d is replaced with its absolute value. The + * signum is stored in 'sign': 1 for negative, 0 for nonnegative. + * + *----------------------------------------------------------------------------- + */ + +inline static void +TakeAbsoluteValue(Double* d, /* Number to replace with absolute value */ + int* sign) /* Place to put the signum */ +{ + if (d->w.word0 & SIGN_BIT) { + *sign = 1; + d->w.word0 &= ~SIGN_BIT; + } else { + *sign = 0; + } +} + +/* + *----------------------------------------------------------------------------- + * + * FormatInfAndNaN -- + * + * Bailout for formatting infinities and Not-A-Number. + * + * Results: + * Returns one of the strings 'Infinity' and 'NaN'. + * + * Side effects: + * Stores 9999 in *decpt, and sets '*endPtr' to designate the + * terminating NUL byte of the string if 'endPtr' is not NULL. + * + * The string returned must be freed by the caller using 'ckfree'. + * + *----------------------------------------------------------------------------- + */ + +inline static char* +FormatInfAndNaN(Double* d, /* Exceptional number to format */ + int* decpt, /* Decimal point to set to a bogus value */ + char** endPtr) /* Pointer to the end of the formatted data */ +{ + char* retval; + *decpt = 9999; + if (!(d->w.word1) && !(d->w.word0 & HI_ORDER_SIG_MASK)) { + retval = ckalloc(9); + strcpy(retval, "Infinity"); + if (endPtr) { + *endPtr = retval + 8; + } + } else { + retval = ckalloc(4); + strcpy(retval, "NaN"); + if (endPtr) { + *endPtr = retval + 3; + } + } + return retval; +} + +/* + *----------------------------------------------------------------------------- + * + * FormatZero -- + * + * Bailout to format a zero floating-point number. + * + * Results: + * Returns the constant string "0" + * + * Side effects: + * Stores 1 in '*decpt' and puts a pointer to the NUL byte terminating + * the string in '*endPtr' if 'endPtr' is not NULL. + * + *----------------------------------------------------------------------------- + */ + +inline static char* +FormatZero(int* decpt, /* Location of the decimal point */ + char** endPtr) /* Pointer to the end of the formatted data */ +{ + char* retval = ckalloc(2); + strcpy(retval, "0"); + if (endPtr) { + *endPtr = retval+1; + } + *decpt = 0; + return retval; +} + +/* + *----------------------------------------------------------------------------- + * + * ApproximateLog10 -- + * + * Computes a two-term Taylor series approximation to the common + * log of a number, and computes the number's binary log. + * + * Results: + * Return an approximation to floor(log10(bw*2**be)) that is either + * exact or 1 too high. + * + *----------------------------------------------------------------------------- + */ + +inline static int +ApproximateLog10(Tcl_WideUInt bw, + /* Integer significand of the number */ + int be, /* Power of two to scale bw */ + int bbits) /* Number of bits of precision in bw */ +{ + int i; /* Log base 2 of the number */ + int k; /* Floor(Log base 10 of the number) */ + double ds; /* Mantissa of the number */ + Double d2; /* - * Split the number into absolute value and signum. + * Compute i and d2 such that d = d2*2**i, and 1 < d2 < 2. + * Compute an approximation to log10(d), + * log10(d) ~ log10(2) * i + log10(1.5) + * + (significand-1.5)/(1.5 * log(10)) */ - v = AbsoluteValue(v, signum); + d2.q = bw << (FP_PRECISION - bbits) & SIG_MASK; + d2.w.word0 |= (EXPONENT_BIAS) << EXP_SHIFT; + i = be + bbits - 1; + ds = (d2.d - 1.5) * TWO_OVER_3LOG10 + + LOG10_3HALVES_PLUS_FUDGE + + LOG10_2 * i; + k = (int) ds; + if (k > ds) { + --k; + } + return k; +} + +/* + *----------------------------------------------------------------------------- + * + * BetterLog10 -- + * + * Improves the result of ApproximateLog10 for numbers in the range + * 1 .. 10**(TEN_PMAX)-1 + * + * Side effects: + * Sets k_check to 0 if the new result is known to be exact, and to + * 1 if it may still be one too high. + * + * Results: + * Returns the improved approximation to log10(d) + * + *----------------------------------------------------------------------------- + */ - /* - * Handle zero specially. +inline static int +BetterLog10(double d, /* Original number to format */ + int k, /* Characteristic(Log base 10) of the number */ + int* k_check) /* Flag == 1 if k is inexact */ +{ + /* + * Performance hack. If k is in the range 0..TEN_PMAX, then we can + * use a powers-of-ten table to check it. */ + if (k >= 0 && k <= TEN_PMAX) { + if (d < tens[k]) { + k--; + } + *k_check = 0; + } else { + *k_check = 1; + } + return k; +} + +/* + *----------------------------------------------------------------------------- + * + * ComputeScale -- + * + * Prepares to format a floating-point number as decimal. + * + * Parameters: + * floor(log10*x) is k (or possibly k-1). floor(log2(x) is i. + * The significand of x requires bbits bits to represent. + * + * Results: + * Determines integers b2, b5, s2, s5 so that sig*2**b2*5**b5/2**s2*2**s5 + * exactly represents the value of the x/10**k. This value will lie + * in the range [1 .. 10), and allows for computing successive digits + * by multiplying sig%10 by 10. + * + *----------------------------------------------------------------------------- + */ - if (v == 0.0) { - *buffer++ = '0'; - *buffer++ = '\0'; - return 1; +inline static void +ComputeScale(int be, /* Exponent part of number: d = bw * 2**be */ + int k, /* Characteristic of log10(number) */ + int* b2, /* OUTPUT: Power of 2 in the numerator */ + int* b5, /* OUTPUT: Power of 5 in the numerator */ + int* s2, /* OUTPUT: Power of 2 in the denominator */ + int* s5) /* OUTPUT: Power of 5 in the denominator */ +{ + + /* + * Scale numerator and denominator powers of 2 so that the + * input binary number is the ratio of integers + */ + if (be <= 0) { + *b2 = 0; + *s2 = -be; + } else { + *b2 = be; + *s2 = 0; + } + + /* + * Scale numerator and denominator so that the output decimal number + * is the ratio of integers + */ + if (k >= 0) { + *b5 = 0; + *s5 = k; + *s2 += k; + } else { + *b2 -= k; + *b5 = -k; + *s5 = 0; + } +} + +/* + *----------------------------------------------------------------------------- + * + * SetPrecisionLimits -- + * + * Determines how many digits of significance should be computed + * (and, hence, how much memory need be allocated) for formatting a + * floating point number. + * + * Given that 'k' is floor(log10(x)): + * if 'shortest' format is used, there will be at most 18 digits in the result. + * if 'F' format is used, there will be at most 'ndigits' + k + 1 digits + * if 'E' format is used, there will be exactly 'ndigits' digits. + * + * Side effects: + * Adjusts '*ndigitsPtr' to have a valid value. + * Stores the maximum memory allocation needed in *iPtr. + * Sets '*iLimPtr' to the limiting number of digits to convert if k + * has been guessed correctly, and '*iLim1Ptr' to the limiting number + * of digits to convert if k has been guessed to be one too high. + * + *----------------------------------------------------------------------------- + */ + +inline static void +SetPrecisionLimits(int convType, + /* Type of conversion: + * TCL_DD_SHORTEST + * TCL_DD_STEELE0 + * TCL_DD_E_FMT + * TCL_DD_F_FMT */ + int k, /* Floor(log10(number to convert)) */ + int* ndigitsPtr, + /* IN/OUT: Number of digits requested + * (Will be adjusted if needed) */ + int* iPtr, /* OUT: Maximum number of digits + * to return */ + int *iLimPtr,/* OUT: Number of digits of significance + * if the bignum method is used.*/ + int *iLim1Ptr) + /* OUT: Number of digits of significance + * if the quick method is used. */ +{ + switch(convType) { + case TCL_DD_SHORTEST0: + case TCL_DD_STEELE0: + *iLimPtr = *iLim1Ptr = -1; + *iPtr = 18; + *ndigitsPtr = 0; + break; + case TCL_DD_E_FORMAT: + if (*ndigitsPtr <= 0) { + *ndigitsPtr = 1; + } + *iLimPtr = *iLim1Ptr = *iPtr = *ndigitsPtr; + break; + case TCL_DD_F_FORMAT: + *iPtr = *ndigitsPtr + k + 1; + *iLimPtr = *iPtr; + *iLim1Ptr = *iPtr - 1; + if (*iPtr <= 0) { + *iPtr = 1; + } + break; + default: + *iPtr = -1; + *iLimPtr = -1; + *iLim1Ptr = -1; + Tcl_Panic("impossible conversion type in TclDoubleDigits"); + } +} + +/* + *----------------------------------------------------------------------------- + * + * BumpUp -- + * + * Increases a string of digits ending in a series of nines to + * designate the next higher number. xxxxb9999... -> xxxx(b+1)0000... + * + * Results: + * Returns a pointer to the end of the adjusted string. + * + * Side effects: + * In the case that the string consists solely of '999999', sets it + * to "1" and moves the decimal point (*kPtr) one place to the right. + * + *----------------------------------------------------------------------------- + */ + + +inline static char* +BumpUp(char* s, /* Cursor pointing one past the end of the + * string */ + char* retval, /* Start of the string of digits */ + int* kPtr) /* Position of the decimal point */ +{ + while (*--s == '9') { + if (s == retval) { + ++(*kPtr); + *s = '1'; + return s+1; + } + } + ++*s; + ++s; + return s; +} + +/* + *----------------------------------------------------------------------------- + * + * AdjustRange -- + * + * Rescales a 'double' in preparation for formatting it using the + * 'quick' double-to-string method. + * + * Results: + * Returns the precision that has been lost in the prescaling as + * a count of units in the least significant place. + * + *----------------------------------------------------------------------------- + */ + +inline static int +AdjustRange(double* dPtr, /* INOUT: Number to adjust */ + int k) /* IN: floor(log10(d)) */ +{ + int ieps; /* Number of roundoff errors that have + * accumulated */ + double d = *dPtr; /* Number to adjust */ + double ds; + int i, j, j1; + + ieps = 2; + + if (k > 0) { + /* + * The number must be reduced to bring it into range. + */ + ds = tens[k & 0xf]; + j = k >> 4; + if (j & BLETCH) { + j &= (BLETCH-1); + d /= bigtens[N_BIGTENS - 1]; + ieps++; + } + i = 0; + for (; j != 0; j>>=1) { + if (j & 1) { + ds *= bigtens[i]; + ++ieps; + } + ++i; + } + d /= ds; + } else if ((j1 = -k) != 0) { + /* + * The number must be increased to bring it into range + */ + d *= tens[j1 & 0xf]; + i = 0; + for (j = j1>>4; j; j>>=1) { + if (j & 1) { + ieps++; + d *= bigtens[i]; + } + ++i; + } } + *dPtr = d; + return ieps; +} + +/* + *----------------------------------------------------------------------------- + * + * ShorteningQuickFormat -- + * + * Returns a 'quick' format of a double precision number to a string + * of digits, preferring a shorter string of digits if the shorter + * string is still within 1/2 ulp of the number. + * + * Results: + * Returns the string of digits. Returns NULL if the 'quick' method + * fails and the bignum method must be used. + * + * Side effects: + * Stores the position of the decimal point at '*kPtr'. + * + *----------------------------------------------------------------------------- + */ + +inline static char* +ShorteningQuickFormat(double d, /* Number to convert */ + int k, /* floor(log10(d)) */ + int ilim, /* Number of significant digits to return */ + double eps, + /* Estimated roundoff error */ + char* retval, + /* Buffer to receive the digit string */ + int* kPtr) + /* Pointer to stash the position of + * the decimal point */ +{ + char* s = retval; /* Cursor in the return value */ + int digit; /* Current digit */ + int i; + + eps = 0.5 / tens[ilim-1] - eps; + i = 0; + for (;;) { + /* Convert a digit */ + + digit = (int) d; + d -= digit; + *s++ = '0' + digit; + + /* + * Truncate the conversion if the string of digits is within + * 1/2 ulp of the actual value. + */ + + if (d < eps) { + *kPtr = k; + return s; + } + if ((1. - d) < eps) { + *kPtr = k; + return BumpUp(s, retval, kPtr); + } + + /* + * Bail out if the conversion fails to converge to a sufficiently + * precise value + */ + + if (++i >= ilim) { + return NULL; + } + + /* + * Bring the next digit to the integer part. + */ + + eps *= 10; + d *= 10.0; + } +} + +/* + *----------------------------------------------------------------------------- + * + * StrictQuickFormat -- + * + * Convert a double precision number of a string of a precise number + * of digits, using the 'quick' double precision method. + * + * Results: + * Returns the digit string, or NULL if the bignum method must be + * used to do the formatting. + * + * Side effects: + * Stores the position of the decimal point in '*kPtr'. + * + *----------------------------------------------------------------------------- + */ + +inline static char* +StrictQuickFormat(double d, /* Number to convert */ + int k, /* floor(log10(d)) */ + int ilim, /* Number of significant digits to return */ + double eps, /* Estimated roundoff error */ + char* retval, /* Start of the digit string */ + int* kPtr) /* Pointer to stash the position of + * the decimal point */ +{ + char* s = retval; /* Cursor in the return value */ + int digit; /* Current digit of the answer */ + int i; + + eps *= tens[ilim-1]; + i = 1; + for (;;) { + /* Extract a digit */ + digit = (int) d; + d -= digit; + if (d == 0.0) { + ilim = i; + } + *s++ = '0' + digit; + + /* + * When the given digit count is reached, handle trailing strings + * of 0 and 9. + */ + if (i == ilim) { + if (d > 0.5 + eps) { + *kPtr = k; + return BumpUp(s, retval, kPtr); + } else if (d < 0.5 - eps) { + while (*--s == '0') { + /* do nothing */ + } + s++; + *kPtr = k; + return s; + } else { + return NULL; + } + } + + /* Advance to the next digit */ + ++i; + d *= 10.0; + } +} + +/* + *----------------------------------------------------------------------------- + * + * QuickConversion -- + * + * Converts a floating point number the 'quick' way, when only a limited + * number of digits is required and floating point arithmetic can + * therefore be used for the intermediate results. + * + * Results: + * Returns the converted string, or NULL if the bignum method must + * be used. + * + *----------------------------------------------------------------------------- + */ + +inline static char* +QuickConversion(double d, /* Number to format */ + int k, /* floor(log10(d)), approximately */ + int k_check, /* 0 if k is exact, 1 if it may be too high */ + int flags, /* Flags passed to dtoa: + * TCL_DD_SHORTEN_FLAG */ + int len, /* Length of the return value */ + int ilim, /* Number of digits to store */ + int ilim1, /* Number of digits to store if we + * musguessed k */ + int* decpt, /* OUTPUT: Location of the decimal point */ + char** endPtr) /* OUTPUT: Pointer to the terminal null byte */ +{ + int ieps; /* Number of 1-ulp roundoff errors that have + * accumulated in the calculation*/ + Double eps; /* Estimated roundoff error */ + char* retval; /* Returned string */ + char* end; /* Pointer to the terminal null byte in the + * returned string */ + /* - * Find a large integer r, and integer e, such that - * v = r * FLT_RADIX**e - * and r is as small as possible. Also determine whether the significand - * is the smallest possible. + * Bring d into the range [1 .. 10) */ + ieps = AdjustRange(&d, k); - smallestSig = GetIntegerTimesPower(v, &r, &e); + /* + * If the guessed value of k didn't get d into range, adjust it + * by one. If that leaves us outside the range in which quick format + * is accurate, bail out. + */ + if (k_check && d < 1. && ilim > 0) { + if (ilim1 < 0) { + return NULL; + } + ilim = ilim1; + --k; + d *= 10.0; + ++ieps; + } - lowOK = highOK = (mp_iseven(&r)); + /* + * Compute estimated roundoff error + */ + eps.d = ieps * d + 7.; + eps.w.word0 -= (FP_PRECISION-1) << EXP_SHIFT; /* - * We are going to want to develop integers r, s, mplus, and mminus such - * that v = r / s, v(+)-v / 2 = mplus / s; v-v(-) / 2 = mminus / s and - * then scale either s or r, mplus, mminus by an appropriate power of ten. - * - * We actually do this by keeping track of the powers of 2 and 5 by which - * f is multiplied to yield v and by which 1 is multiplied to yield s, - * mplus, and mminus. + * Handle the peculiar case where the result has no significant + * digits. */ + retval = ckalloc(len + 1); + if (ilim == 0) { + d -= 5.; + if (d > eps.d) { + *retval = '1'; + *decpt = k; + return retval; + } else if (d < -eps.d) { + *decpt = k; + return retval; + } else { + ckfree(retval); + return NULL; + } + } - if (e >= 0) { - int bits = e * log2FLT_RADIX; + /* Format the digit string */ - if (!smallestSig) { - /* - * Normal case, m+ and m- are both FLT_RADIX**e - */ + if (flags & TCL_DD_SHORTEN_FLAG) { + end = ShorteningQuickFormat(d, k, ilim, eps.d, retval, decpt); + } else { + end = StrictQuickFormat(d, k, ilim, eps.d, retval, decpt); + } + if (end == NULL) { + ckfree(retval); + return NULL; + } + *end = '\0'; + if (endPtr != NULL) { + *endPtr = end; + } + return retval; +} + +/* + *----------------------------------------------------------------------------- + * + * CastOutPowersOf2 -- + * + * Adjust the factors 'b2', 'm2', and 's2' to cast out common powers + * of 2 from numerator and denominator in preparation for the 'bignum' + * method of floating point conversion. + * + *----------------------------------------------------------------------------- + */ - rfac2 = bits + 1; - sfac2 = 1; - mplusfac2 = bits; - mminusfac2 = bits; +inline static void +CastOutPowersOf2(int* b2, /* Power of 2 to multiply the significand */ + int* m2, /* Power of 2 to multiply 1/2 ulp */ + int* s2) /* Power of 2 to multiply the common + * denominator */ +{ + int i; + if (*m2 > 0 && *s2 > 0) { /* Find the smallest power of 2 in the + * numerator */ + if (*m2 < *s2) { /* Find the lowest common denominatorr */ + i = *m2; } else { - /* - * If f is equal to the smallest significand, then we need another - * factor of FLT_RADIX in s to cope with stepping to the next - * smaller exponent when going to e's predecessor. - */ + i = *s2; + } + *b2 -= i; /* Reduce to lowest terms */ + *m2 -= i; + *s2 -= i; + } +} + +/* + *----------------------------------------------------------------------------- + * + * ShorteningInt64Conversion -- + * + * Converts a double-precision number to the shortest string of + * digits that reconverts exactly to the given number, or to + * 'ilim' digits if that will yield a shorter result. The numerator and + * denominator in David Gay's conversion algorithm are known to fit + * in Tcl_WideUInt, giving considerably faster arithmetic than mp_int's. + * + * Results: + * Returns the string of significant decimal digits, in newly + * allocated memory + * + * Side effects: + * Stores the location of the decimal point in '*decpt' and the + * location of the terminal null byte in '*endPtr'. + * + *----------------------------------------------------------------------------- + */ + +inline static char* +ShorteningInt64Conversion(Double* dPtr, + /* Original number to convert */ + int convType, + /* Type of conversion (shortest, Steele, + E format, F format) */ + Tcl_WideUInt bw, + /* Integer significand */ + int b2, int b5, + /* Scale factor for the significand + * in the numerator */ + int m2plus, int m2minus, int m5, + /* Scale factors for 1/2 ulp in + * the numerator (will be different if + * bw == 1 */ + int s2, int s5, + /* Scale factors for the denominator */ + int k, + /* Number of output digits before the decimal + * point */ + int len, + /* Number of digits to allocate */ + int ilim, + /* Number of digits to convert if b >= s */ + int ilim1, + /* Number of digits to convert if b < s */ + int* decpt, + /* OUTPUT: Position of the decimal point */ + char** endPtr) + /* OUTPUT: Position of the terminal '\0' + * at the end of the returned string */ +{ + + char* retval = ckalloc(len + 1); + /* Output buffer */ + Tcl_WideUInt b = (bw * wuipow5[b5]) << b2; + /* Numerator of the fraction being converted */ + Tcl_WideUInt S = wuipow5[s5] << s2; + /* Denominator of the fraction being + * converted */ + Tcl_WideUInt mplus, mminus; /* Ranges for testing whether the result + * is within roundoff of being exact */ + int digit; /* Current output digit */ + char* s = retval; /* Cursor in the output buffer */ + int i; /* Current position in the output buffer */ + + /* Adjust if the logarithm was guessed wrong */ + + if (b < S) { + b = 10 * b; + ++m2plus; ++m2minus; ++m5; + ilim = ilim1; + --k; + } + + /* Compute roundoff ranges */ - rfac2 = bits + log2FLT_RADIX + 1; - sfac2 = 1 + log2FLT_RADIX; - mplusfac2 = bits + log2FLT_RADIX; - mminusfac2 = bits; + mplus = wuipow5[m5] << m2plus; + mminus = wuipow5[m5] << m2minus; + + /* Loop through the digits */ + + i = 1; + for (;;) { + digit = (int)(b / S); + if (digit > 10) { + Tcl_Panic("wrong digit!"); } - } else { - /* - * v has digits after the binary point - */ + b = b % S; - if (e <= DBL_MIN_EXP-DBL_MANT_DIG || !smallestSig) { + /* + * Does the current digit put us on the low side of the exact value + * but within within roundoff of being exact? + */ + if (b < mplus + || (b == mplus + && convType != TCL_DD_STEELE0 + && (dPtr->w.word1 & 1) == 0)) { /* - * Either f isn't the smallest significand or e is the smallest - * exponent. mplus and mminus will both be 1. + * Make sure we shouldn't be rounding *up* instead, + * in case the next number above is closer */ + if (2 * b > S + || (2 * b == S + && (digit & 1) != 0)) { + ++digit; + if (digit == 10) { + *s++ = '9'; + s = BumpUp(s, retval, &k); + break; + } + } - rfac2 = 1; - sfac2 = 1 - e * log2FLT_RADIX; - mplusfac2 = 0; - mminusfac2 = 0; - } else { - /* - * f is the smallest significand, but e is not the smallest - * exponent. We need to scale by FLT_RADIX again to cope with the - * fact that v's predecessor has a smaller exponent. - */ + /* Stash the current digit */ + + *s++ = '0' + digit; + break; + } - rfac2 = 1 + log2FLT_RADIX; - sfac2 = 1 + log2FLT_RADIX * (1 - e); - mplusfac2 = FLT_RADIX; - mminusfac2 = 0; + /* + * Does one plus the current digit put us within roundoff of the + * number? + */ + if (b > S - mminus + || (b == S - mminus + && convType != TCL_DD_STEELE0 + && (dPtr->w.word1 & 1) == 0)) { + if (digit == 9) { + *s++ = '9'; + s = BumpUp(s, retval, &k); + break; + } + ++digit; + *s++ = '0' + digit; + break; + } + + /* + * Have we converted all the requested digits? + */ + *s++ = '0' + digit; + if (i == ilim) { + if (2*b > S + || (2*b == S && (digit & 1) != 0)) { + s = BumpUp(s, retval, &k); + } + break; } + + /* Advance to the next digit */ + + b = 10 * b; + mplus = 10 * mplus; + mminus = 10 * mminus; + ++i; } - /* - * Estimate the highest power of ten that will be needed to hold the - * result. + /* + * Endgame - store the location of the decimal point and the end of the + * string. */ + *s = '\0'; + *decpt = k; + if (endPtr) { + *endPtr = s; + } + return retval; +} + +/* + *----------------------------------------------------------------------------- + * + * StrictInt64Conversion -- + * + * Converts a double-precision number to a fixed-length string of + * 'ilim' digits that reconverts exactly to the given number. + * ('ilim' should be replaced with 'ilim1' in the case where + * log10(d) has been overestimated). The numerator and + * denominator in David Gay's conversion algorithm are known to fit + * in Tcl_WideUInt, giving considerably faster arithmetic than mp_int's. + * + * Results: + * Returns the string of significant decimal digits, in newly + * allocated memory + * + * Side effects: + * Stores the location of the decimal point in '*decpt' and the + * location of the terminal null byte in '*endPtr'. + * + *----------------------------------------------------------------------------- + */ - k = (int) ceil(log(v) / log(10.)); - if (k >= 0) { - sfac2 += k; - sfac5 = k; - } else { - rfac2 -= k; - mplusfac2 -= k; - mminusfac2 -= k; - rfac5 = -k; +inline static char* +StrictInt64Conversion(Double* dPtr, + /* Original number to convert */ + int convType, + /* Type of conversion (shortest, Steele, + E format, F format) */ + Tcl_WideUInt bw, + /* Integer significand */ + int b2, int b5, + /* Scale factor for the significand + * in the numerator */ + int s2, int s5, + /* Scale factors for the denominator */ + int k, + /* Number of output digits before the decimal + * point */ + int len, + /* Number of digits to allocate */ + int ilim, + /* Number of digits to convert if b >= s */ + int ilim1, + /* Number of digits to convert if b < s */ + int* decpt, + /* OUTPUT: Position of the decimal point */ + char** endPtr) + /* OUTPUT: Position of the terminal '\0' + * at the end of the returned string */ +{ + + char* retval = ckalloc(len + 1); + /* Output buffer */ + Tcl_WideUInt b = (bw * wuipow5[b5]) << b2; + /* Numerator of the fraction being converted */ + Tcl_WideUInt S = wuipow5[s5] << s2; + /* Denominator of the fraction being + * converted */ + int digit; /* Current output digit */ + char* s = retval; /* Cursor in the output buffer */ + int i; /* Current position in the output buffer */ + + /* Adjust if the logarithm was guessed wrong */ + + if (b < S) { + b = 10 * b; + ilim = ilim1; + --k; } - /* - * Scale r, s, mplus, mminus by the appropriate powers of 2 and 5. + /* Loop through the digits */ + + i = 1; + for (;;) { + digit = (int)(b / S); + if (digit > 10) { + Tcl_Panic("wrong digit!"); + } + b = b % S; + + /* + * Have we converted all the requested digits? + */ + *s++ = '0' + digit; + if (i == ilim) { + if (2*b > S + || (2*b == S && (digit & 1) != 0)) { + s = BumpUp(s, retval, &k); + } + break; + } + + /* Advance to the next digit */ + + b = 10 * b; + ++i; + } + + /* + * Endgame - store the location of the decimal point and the end of the + * string. */ + *s = '\0'; + *decpt = k; + if (endPtr) { + *endPtr = s; + } + return retval; +} + +/* + *----------------------------------------------------------------------------- + * + * ShouldBankerRoundUpPowD -- + * + * Test whether bankers' rounding should round a digit up. Assumption + * is made that the denominator of the fraction being tested is + * a power of 2**DIGIT_BIT. + * + * Results: + * Returns 1 iff the fraction is more than 1/2, or if the fraction + * is exactly 1/2 and the digit is odd. + * + *----------------------------------------------------------------------------- + */ - mp_init_set(&mplus, 1); - for (i=0 ; i<=8 ; ++i) { - if (rfac5 & (1 << i)) { - mp_mul(&mplus, pow5+i, &mplus); +inline static int +ShouldBankerRoundUpPowD(mp_int* b, + /* Numerator of the fraction */ + int sd, /* Denominator is 2**(sd*DIGIT_BIT) */ + int isodd) + /* 1 if the digit is odd, 0 if even */ +{ + int i; + static const mp_digit topbit = (1<<(DIGIT_BIT-1)); + if (b->used < sd || (b->dp[sd-1] & topbit) == 0) { + return 0; + } + if (b->dp[sd-1] != topbit) { + return 1; + } + for (i = sd-2; i >= 0; --i) { + if (b->dp[i] != 0) { + return 1; } } - mp_mul(&r, &mplus, &r); - mp_mul_2d(&r, rfac2, &r); - mp_init_copy(&mminus, &mplus); - mp_mul_2d(&mplus, mplusfac2, &mplus); - mp_mul_2d(&mminus, mminusfac2, &mminus); - mp_init_set(&s, 1); - for (i=0 ; i<=8 ; ++i) { - if (sfac5 & (1 << i)) { - mp_mul(&s, pow5+i, &s); + return isodd; +} + +/* + *----------------------------------------------------------------------------- + * + * ShouldBankerRoundUpToNextPowD -- + * + * Tests whether bankers' rounding will round down in the + * "denominator is a power of 2**MP_DIGIT" case. + * + * Results: + * Returns 1 if the rounding will be performed - which increases the + * digit by one - and 0 otherwise. + * + *----------------------------------------------------------------------------- + */ + +inline static int +ShouldBankerRoundUpToNextPowD(mp_int* b, + /* Numerator of the fraction */ + mp_int* m, + /* Numerator of the rounding tolerance */ + int sd, + /* Common denominator is 2**(sd*DIGIT_BIT) */ + int convType, + /* Conversion type: STEELE defeats + * round-to-even (Not sure why one wants to + * do this; I copied it from Gay) FIXME */ + int isodd, + /* 1 if the integer significand is odd */ + mp_int* temp) + /* Work area for the calculation */ +{ + int i; + + /* + * Compare B and S-m -- which is the same as comparing B+m and S -- + * which we do by computing b+m and doing a bitwhack compare against + * 2**(DIGIT_BIT*sd) + */ + mp_add(b, m, temp); + if (temp->used <= sd) { /* too few digits to be > S */ + return 0; + } + if (temp->used > sd+1 || temp->dp[sd] > 1) { + /* >= 2s */ + return 1; + } + for (i = sd-1; i >= 0; --i) { + /* check for ==s */ + if (temp->dp[i] != 0) { /* > s */ + return 1; } } - mp_mul_2d(&s, sfac2, &s); + if (convType == TCL_DD_STEELE0) { + /* biased rounding */ + return 0; + } + return isodd; +} + +/* + *----------------------------------------------------------------------------- + * + * ShorteningBignumConversionPowD -- + * + * Converts a double-precision number to the shortest string of + * digits that reconverts exactly to the given number, or to + * 'ilim' digits if that will yield a shorter result. The denominator + * in David Gay's conversion algorithm is known to be a power of + * 2**DIGIT_BIT, and hence the division in the main loop may be replaced + * by a digit shift and mask. + * + * Results: + * Returns the string of significant decimal digits, in newly + * allocated memory + * + * Side effects: + * Stores the location of the decimal point in '*decpt' and the + * location of the terminal null byte in '*endPtr'. + * + *----------------------------------------------------------------------------- + */ - /* - * It is possible for k to be off by one because we used an inexact - * logarithm. +inline static char* +ShorteningBignumConversionPowD(Double* dPtr, + /* Original number to convert */ + int convType, + /* Type of conversion (shortest, Steele, + E format, F format) */ + Tcl_WideUInt bw, + /* Integer significand */ + int b2, int b5, + /* Scale factor for the significand + * in the numerator */ + int m2plus, int m2minus, int m5, + /* Scale factors for 1/2 ulp in + * the numerator (will be different if + * bw == 1 */ + int sd, + /* Scale factor for the denominator */ + int k, + /* Number of output digits before the decimal + * point */ + int len, + /* Number of digits to allocate */ + int ilim, + /* Number of digits to convert if b >= s */ + int ilim1, + /* Number of digits to convert if b < s */ + int* decpt, + /* OUTPUT: Position of the decimal point */ + char** endPtr) + /* OUTPUT: Position of the terminal '\0' + * at the end of the returned string */ +{ + + char* retval = ckalloc(len + 1); + /* Output buffer */ + mp_int b; /* Numerator of the fraction being converted */ + mp_int mplus, mminus; /* Bounds for roundoff */ + mp_digit digit; /* Current output digit */ + char* s = retval; /* Cursor in the output buffer */ + int i; /* Index in the output buffer */ + mp_int temp; + int r1; + + /* + * b = bw * 2**b2 * 5**b5 + * mminus = 5**m5 */ - mp_init(&temp); - mp_add(&r, &mplus, &temp); - i = mp_cmp_mag(&temp, &s); - if (i>0 || (highOK && i==0)) { - mp_mul_d(&s, 10, &s); - k++; - } else { - mp_mul_d(&temp, 10, &temp); - i = mp_cmp_mag(&temp, &s); - if (i<0 || (highOK && i==0)) { - mp_mul_d(&r, 10, &r); - mp_mul_d(&mplus, 10, &mplus); - mp_mul_d(&mminus, 10, &mminus); - k--; - } + TclBNInitBignumFromWideUInt(&b, bw); + mp_init_set_int(&mminus, 1); + MulPow5(&b, b5, &b); + mp_mul_2d(&b, b2, &b); + + /* Adjust if the logarithm was guessed wrong */ + + if (b.used <= sd) { + mp_mul_d(&b, 10, &b); + ++m2plus; ++m2minus; ++m5; + ilim = ilim1; + --k; } /* - * At this point, k contains the power of ten by which we're scaling the - * result. r/s is at least 1/10 and strictly less than ten, and v = r/s * - * 10**k. mplus and mminus give the rounding limits. + * mminus = 5**m5 * 2**m2minus + * mplus = 5**m5 * 2**m2plus */ - for (;;) { - int tc1, tc2; + mp_mul_2d(&mminus, m2minus, &mminus); + MulPow5(&mminus, m5, &mminus); + if (m2plus > m2minus) { + mp_init_copy(&mplus, &mminus); + mp_mul_2d(&mplus, m2plus-m2minus, &mplus); + } + mp_init(&temp); - mp_mul_d(&r, 10, &r); - mp_div(&r, &s, &temp, &r); /* temp = 10r / s; r = 10r mod s */ - i = temp.dp[0]; - mp_mul_d(&mplus, 10, &mplus); - mp_mul_d(&mminus, 10, &mminus); - tc1 = mp_cmp_mag(&r, &mminus); - if (lowOK) { - tc1 = (tc1 <= 0); + /* Loop through the digits. Do division and mod by s == 2**(sd*DIGIT_BIT) + * by mp_digit extraction */ + + i = 0; + for (;;) { + if (b.used <= sd) { + digit = 0; } else { - tc1 = (tc1 < 0); + digit = b.dp[sd]; + if (b.used > sd+1 || digit >= 10) { + Tcl_Panic("wrong digit!"); + } + --b.used; mp_clamp(&b); } - mp_add(&r, &mplus, &temp); - tc2 = mp_cmp_mag(&temp, &s); - if (highOK) { - tc2 = (tc2 >= 0); - } else { - tc2 = (tc2 > 0); + + /* + * Does the current digit put us on the low side of the exact value + * but within within roundoff of being exact? + */ + + r1 = mp_cmp_mag(&b, (m2plus > m2minus)? &mplus : &mminus); + if (r1 == MP_LT + || (r1 == MP_EQ + && convType != TCL_DD_STEELE0 + && (dPtr->w.word1 & 1) == 0)) { + /* + * Make sure we shouldn't be rounding *up* instead, + * in case the next number above is closer + */ + if (ShouldBankerRoundUpPowD(&b, sd, digit&1)) { + ++digit; + if (digit == 10) { + *s++ = '9'; + s = BumpUp(s, retval, &k); + break; + } + } + + /* Stash the last digit */ + + *s++ = '0' + digit; + break; } - if (!tc1) { - if (!tc2) { - *buffer++ = '0' + i; - } else { - c = (char) (i + '1'); + + /* + * Does one plus the current digit put us within roundoff of the + * number? + */ + + if (ShouldBankerRoundUpToNextPowD(&b, &mminus, sd, + convType, dPtr->w.word1 & 1, + &temp)) { + if (digit == 9) { + *s++ = '9'; + s = BumpUp(s, retval, &k); break; } + ++digit; + *s++ = '0' + digit; + break; + } + + /* + * Have we converted all the requested digits? + */ + *s++ = '0' + digit; + if (i == ilim) { + if (ShouldBankerRoundUpPowD(&b, sd, digit&1)) { + s = BumpUp(s, retval, &k); + } + break; + } + + /* Advance to the next digit */ + + mp_mul_d(&b, 10, &b); + mp_mul_d(&mminus, 10, &mminus); + if (m2plus > m2minus) { + mp_mul_2d(&mminus, m2plus-m2minus, &mplus); + } + ++i; + } + + /* + * Endgame - store the location of the decimal point and the end of the + * string. + */ + if (m2plus > m2minus) { + mp_clear(&mplus); + } + mp_clear_multi(&b, &mminus, &temp, NULL); + *s = '\0'; + *decpt = k; + if (endPtr) { + *endPtr = s; + } + return retval; +} + +/* + *----------------------------------------------------------------------------- + * + * StrictBignumConversionPowD -- + * + * Converts a double-precision number to a fixed-lengt string of + * 'ilim' digits (or 'ilim1' if log10(d) has been overestimated.) + * The denominator in David Gay's conversion algorithm is known to + * be a power of 2**DIGIT_BIT, and hence the division in the main + * loop may be replaced by a digit shift and mask. + * + * Results: + * Returns the string of significant decimal digits, in newly + * allocated memory. + * + * Side effects: + * Stores the location of the decimal point in '*decpt' and the + * location of the terminal null byte in '*endPtr'. + * + *----------------------------------------------------------------------------- + */ + +inline static char* +StrictBignumConversionPowD(Double* dPtr, + /* Original number to convert */ + int convType, + /* Type of conversion (shortest, Steele, + E format, F format) */ + Tcl_WideUInt bw, + /* Integer significand */ + int b2, int b5, + /* Scale factor for the significand + * in the numerator */ + int sd, + /* Scale factor for the denominator */ + int k, + /* Number of output digits before the decimal + * point */ + int len, + /* Number of digits to allocate */ + int ilim, + /* Number of digits to convert if b >= s */ + int ilim1, + /* Number of digits to convert if b < s */ + int* decpt, + /* OUTPUT: Position of the decimal point */ + char** endPtr) + /* OUTPUT: Position of the terminal '\0' + * at the end of the returned string */ +{ + + char* retval = ckalloc(len + 1); + /* Output buffer */ + mp_int b; /* Numerator of the fraction being converted */ + mp_digit digit; /* Current output digit */ + char* s = retval; /* Cursor in the output buffer */ + int i; /* Index in the output buffer */ + mp_int temp; + + /* + * b = bw * 2**b2 * 5**b5 + */ + + TclBNInitBignumFromWideUInt(&b, bw); + MulPow5(&b, b5, &b); + mp_mul_2d(&b, b2, &b); + + /* Adjust if the logarithm was guessed wrong */ + + if (b.used <= sd) { + mp_mul_d(&b, 10, &b); + ilim = ilim1; + --k; + } + mp_init(&temp); + + /* + * Loop through the digits. Do division and mod by s == 2**(sd*DIGIT_BIT) + * by mp_digit extraction + */ + + i = 1; + for (;;) { + if (b.used <= sd) { + digit = 0; } else { - if (!tc2) { - c = (char) (i + '0'); - } else { - mp_mul_2d(&r, 1, &r); - n = mp_cmp_mag(&r, &s); - if (n < 0) { - c = (char) (i + '0'); - } else { - c = (char) (i + '1'); - } + digit = b.dp[sd]; + if (b.used > sd+1 || digit >= 10) { + Tcl_Panic("wrong digit!"); + } + --b.used; mp_clamp(&b); + } + + /* + * Have we converted all the requested digits? + */ + *s++ = '0' + digit; + if (i == ilim) { + if (ShouldBankerRoundUpPowD(&b, sd, digit&1)) { + s = BumpUp(s, retval, &k); } break; } - }; - *buffer++ = c; - *buffer++ = '\0'; + + /* Advance to the next digit */ + + mp_mul_d(&b, 10, &b); + ++i; + } - /* - * Free memory, and return. + /* + * Endgame - store the location of the decimal point and the end of the + * string. */ + mp_clear_multi(&b, &temp, NULL); + *s = '\0'; + *decpt = k; + if (endPtr) { + *endPtr = s; + } + return retval; +} + +/* + *----------------------------------------------------------------------------- + * + * ShouldBankerRoundUp -- + * + * Tests whether a digit should be rounded up or down when finishing + * bignum-based floating point conversion. + * + * Results: + * Returns 1 if the number needs to be rounded up, 0 otherwise. + * + *----------------------------------------------------------------------------- + */ - mp_clear_multi(&r, &s, &mplus, &mminus, &temp, NULL); - return k; +inline static int +ShouldBankerRoundUp(mp_int* twor, + /* 2x the remainder from thd division that + * produced the last digit */ + mp_int* S, /* Denominator */ + int isodd) /* Flag == 1 if the last digit is odd */ +{ + int r = mp_cmp_mag(twor, S); + switch (r) { + case MP_LT: + return 0; + case MP_EQ: + return isodd; + case MP_GT: + return 1; + } + Tcl_Panic("in ShouldBankerRoundUp, trichotomy fails!"); + return 0; } /* - *---------------------------------------------------------------------- + *----------------------------------------------------------------------------- + * + * ShouldBankerRoundUpToNext -- + * + * Tests whether the remainder is great enough to force rounding + * to the next higher digit. + * + * Results: + * Returns 1 if the number should be rounded up, 0 otherwise. + * + *----------------------------------------------------------------------------- + */ + +inline static int +ShouldBankerRoundUpToNext(mp_int* b, + /* Remainder from the division that produced + * the last digit. */ + mp_int* m, + /* Numerator of the rounding tolerance */ + mp_int* S, + /* Denominator */ + int convType, + /* Conversion type: STEELE0 defeats + * round-to-even. (Not sure why one would + * want this; I coped it from Gay. FIXME */ + int isodd, + /* 1 if the integer significand is odd */ + mp_int* temp) + /* Work area needed for the calculation */ +{ + int r; + /* Compare b and S-m: this is the same as comparing B+m and S. */ + mp_add(b, m, temp); + r = mp_cmp_mag(temp, S); + switch(r) { + case MP_LT: + return 0; + case MP_EQ: + if (convType == TCL_DD_STEELE0) { + return 0; + } else { + return isodd; + } + case MP_GT: + return 1; + } + Tcl_Panic("in ShouldBankerRoundUpToNext, trichotomy fails!"); + return 0; +} + +/* + *----------------------------------------------------------------------------- * - * AbsoluteValue -- + * ShorteningBignumConversion -- * - * Splits a 'double' into its absolute value and sign. + * Convert a floating point number to a variable-length digit string + * using the multiprecision method. * * Results: - * Returns the absolute value. + * Returns the string of digits. * * Side effects: - * Stores the signum in '*signum'. + * Stores the position of the decimal point in *decpt. + * Stores a pointer to the end of the number in *endPtr. * - *---------------------------------------------------------------------- + *----------------------------------------------------------------------------- */ -static double -AbsoluteValue( - double v, /* Number to split */ - int *signum) /* (Output) Sign of the number 1=-, 0=+ */ +inline static char* +ShorteningBignumConversion(Double* dPtr, + /* Original number being converted */ + int convType, + /* Conversion type */ + Tcl_WideUInt bw, + /* Integer significand and exponent */ + int b2, + /* Scale factor for the significand */ + int m2plus, int m2minus, + /* Scale factors for 1/2 ulp in numerator */ + int s2, int s5, + /* Scale factors for denominator */ + int k, + /* Guessed position of the decimal point */ + int len, + /* Size of the digit buffer to allocate */ + int ilim, + /* Number of digits to convert if b >= s */ + int ilim1, + /* Number of digits to convert if b < s */ + int* decpt, + /* OUTPUT: Position of the decimal point */ + char** endPtr) + /* OUTPUT: Pointer to the end of the number */ { + char* retval = ckalloc(len+1); + /* Buffer of digits to return */ + char* s = retval; /* Cursor in the return value */ + mp_int b; /* Numerator of the result */ + mp_int mminus; /* 1/2 ulp below the result */ + mp_int mplus; /* 1/2 ulp above the result */ + mp_int S; /* Denominator of the result */ + mp_int dig; /* Current digit of the result */ + int digit; /* Current digit of the result */ + mp_int temp; /* Work area */ + int minit = 1; /* Fudge factor for when we misguess k */ + int i; + int r1; + /* - * Take the absolute value of the number, and report the number's sign. - * Take special steps to preserve signed zeroes in IEEE floating point. - * (We can't use fpclassify, because that's a C9x feature and we still - * have to build on C89 compilers.) + * b = bw * 2**b2 * 5**b5 + * S = 2**s2 * 5*s5 */ -#ifndef IEEE_FLOATING_POINT - if (v >= 0.0) { - *signum = 0; - } else { - *signum = 1; - v = -v; + TclBNInitBignumFromWideUInt(&b, bw); + mp_mul_2d(&b, b2, &b); + mp_init_set_int(&S, 1); + MulPow5(&S, s5, &S); mp_mul_2d(&S, s2, &S); + + /* + * Handle the case where we guess the position of the decimal point + * wrong. + */ + + if (mp_cmp_mag(&b, &S) == MP_LT) { + mp_mul_d(&b, 10, &b); + minit = 10; + ilim =ilim1; + --k; } -#else - union { - Tcl_WideUInt iv; - double dv; - } bitwhack; - bitwhack.dv = v; - if (n770_fp) { - bitwhack.iv = Nokia770Twiddle(bitwhack.iv); + + /* mminus = 2**m2minus * 5**m5 */ + + mp_init_set_int(&mminus, minit); + mp_mul_2d(&mminus, m2minus, &mminus); + if (m2plus > m2minus) { + mp_init_copy(&mplus, &mminus); + mp_mul_2d(&mplus, m2plus-m2minus, &mplus); } - if (bitwhack.iv & ((Tcl_WideUInt) 1 << 63)) { - *signum = 1; - bitwhack.iv &= ~((Tcl_WideUInt) 1 << 63); - if (n770_fp) { - bitwhack.iv = Nokia770Twiddle(bitwhack.iv); + mp_init(&temp); + + /* Loop through the digits */ + + mp_init(&dig); + i = 1; + for (;;) { + mp_div(&b, &S, &dig, &b); + if (dig.used > 1 || dig.dp[0] >= 10) { + Tcl_Panic("wrong digit!"); } - v = bitwhack.dv; - } else { - *signum = 0; + digit = dig.dp[0]; + + /* + * Does the current digit leave us with a remainder small enough to + * round to it? + */ + + r1 = mp_cmp_mag(&b, (m2plus > m2minus)? &mplus : &mminus); + if (r1 == MP_LT + || (r1 == MP_EQ + && convType != TCL_DD_STEELE0 + && (dPtr->w.word1 & 1) == 0)) { + mp_mul_2d(&b, 1, &b); + if (ShouldBankerRoundUp(&b, &S, digit&1)) { + ++digit; + if (digit == 10) { + *s++ = '9'; + s = BumpUp(s, retval, &k); + break; + } + } + *s++ = '0' + digit; + break; + } + + /* + * Does the current digit leave us with a remainder large enough + * to commit to rounding up to the next higher digit? + */ + + if (ShouldBankerRoundUpToNext(&b, &mminus, &S, convType, + dPtr->w.word1 & 1, &temp)) { + ++digit; + if (digit == 10) { + *s++ = '9'; + s = BumpUp(s, retval, &k); + break; + } + *s++ = '0' + digit; + break; + } + + /* Have we converted all the requested digits? */ + + *s++ = '0' + digit; + if (i == ilim) { + mp_mul_2d(&b, 1, &b); + if (ShouldBankerRoundUp(&b, &S, digit&1)) { + s = BumpUp(s, retval, &k); + } + break; + } + + /* Advance to the next digit */ + + if (s5 > 0) { + + /* Can possibly shorten the denominator */ + mp_mul_2d(&b, 1, &b); + mp_mul_2d(&mminus, 1, &mminus); + if (m2plus > m2minus) { + mp_mul_2d(&mplus, 1, &mplus); + } + mp_div_d(&S, 5, &S, NULL); + --s5; + /* + * TODO: It might possibly be a win to fall back to + * int64 arithmetic here if S < 2**64/10. But it's + * a win only for a fairly narrow range of magnitudes + * so perhaps not worth bothering. We already know that + * we shorten the denominator by at least 1 mp_digit, perhaps + * 2. as we do the conversion for 17 digits of significance. + * Possible savings: + * 10**26 1 trip through loop before fallback possible + * 10**27 1 trip + * 10**28 2 trips + * 10**29 3 trips + * 10**30 4 trips + * 10**31 5 trips + * 10**32 6 trips + * 10**33 7 trips + * 10**34 8 trips + * 10**35 9 trips + * 10**36 10 trips + * 10**37 11 trips + * 10**38 12 trips + * 10**39 13 trips + * 10**40 14 trips + * 10**41 15 trips + * 10**42 16 trips + * thereafter no gain. + */ + } else { + mp_mul_d(&b, 10, &b); + mp_mul_d(&mminus, 10, &mminus); + if (m2plus > m2minus) { + mp_mul_2d(&mplus, 10, &mplus); + } + } + + ++i; } -#endif - return v; + + + /* + * Endgame - store the location of the decimal point and the end of the + * string. + */ + if (m2plus > m2minus) { + mp_clear(&mplus); + } + mp_clear_multi(&b, &mminus, &temp, NULL); + *s = '\0'; + *decpt = k; + if (endPtr) { + *endPtr = s; + } + return retval; + } - + /* - *---------------------------------------------------------------------- + *----------------------------------------------------------------------------- * - * GetIntegerTimesPower -- + * StrictBignumConversion -- * - * Converts a floating point number to an exact integer times a power of - * the floating point radix. + * Convert a floating point number to a fixed-length digit string + * using the multiprecision method. * * Results: - * Returns 1 if it converted the smallest significand, 0 otherwise. + * Returns the string of digits. * * Side effects: - * Initializes the integer value (does not just assign it), and stores - * the exponent. + * Stores the position of the decimal point in *decpt. + * Stores a pointer to the end of the number in *endPtr. * - *---------------------------------------------------------------------- + *----------------------------------------------------------------------------- */ -static int -GetIntegerTimesPower( - double v, /* Value to convert */ - mp_int *rPtr, /* (Output) Integer value */ - int *ePtr) /* (Output) Power of FLT_RADIX by which r must - * be multiplied to yield v*/ +inline static char* +StrictBignumConversion(Double* dPtr, + /* Original number being converted */ + int convType, + /* Conversion type */ + Tcl_WideUInt bw, + /* Integer significand and exponent */ + int b2, /* Scale factor for the significand */ + int s2, int s5, + /* Scale factors for denominator */ + int k, /* Guessed position of the decimal point */ + int len, /* Size of the digit buffer to allocate */ + int ilim, + /* Number of digits to convert if b >= s */ + int ilim1, + /* Number of digits to convert if b < s */ + int* decpt, + /* OUTPUT: Position of the decimal point */ + char** endPtr) + /* OUTPUT: Pointer to the end of the number */ { - double a, f; - int e, i, n; + char* retval = ckalloc(len+1); + /* Buffer of digits to return */ + char* s = retval; /* Cursor in the return value */ + mp_int b; /* Numerator of the result */ + mp_int S; /* Denominator of the result */ + mp_int dig; /* Current digit of the result */ + int digit; /* Current digit of the result */ + mp_int temp; /* Work area */ + int g; /* Size of the current digit groun */ + int i, j; + + /* + * b = bw * 2**b2 * 5**b5 + * S = 2**s2 * 5*s5 + */ + + TclBNInitBignumFromWideUInt(&b, bw); + mp_mul_2d(&b, b2, &b); + mp_init_set_int(&S, 1); + MulPow5(&S, s5, &S); mp_mul_2d(&S, s2, &S); /* - * Develop f and e such that v = f * FLT_RADIX**e, with - * 1.0/FLT_RADIX <= f < 1. + * Handle the case where we guess the position of the decimal point + * wrong. */ + + if (mp_cmp_mag(&b, &S) == MP_LT) { + mp_mul_d(&b, 10, &b); + ilim =ilim1; + --k; + } + mp_init(&temp); + + /* Convert the leading digit */ + + mp_init(&dig); + i = 0; + mp_div(&b, &S, &dig, &b); + if (dig.used > 1 || dig.dp[0] >= 10) { + Tcl_Panic("wrong digit!"); + } + digit = dig.dp[0]; + + /* Is a single digit all that was requested? */ - f = frexp(v, &e); -#if FLT_RADIX > 2 - n = e % log2FLT_RADIX; - if (n > 0) { - n -= log2FLT_RADIX; - e += 1; - f *= ldexp(1.0, n); + *s++ = '0' + digit; + if (++i >= ilim) { + mp_mul_2d(&b, 1, &b); + if (ShouldBankerRoundUp(&b, &S, digit&1)) { + s = BumpUp(s, retval, &k); + } + } else { + + for (;;) { + + /* Shift by a group of digits. */ + + g = ilim - i; + if (g > DIGIT_GROUP) { + g = DIGIT_GROUP; + } + if (s5 >= g) { + mp_div_d(&S, dpow5[g], &S, NULL); + s5 -= g; + } else if (s5 > 0) { + mp_div_d(&S, dpow5[s5], &S, NULL); + mp_mul_d(&b, dpow5[g - s5], &b); + s5 = 0; + } else { + mp_mul_d(&b, dpow5[g], &b); + } + mp_mul_2d(&b, g, &b); + + /* + * As with the shortening bignum conversion, it's possible at + * this point that we will have reduced the denominator to + * less than 2**64/10, at which point it would be possible to + * fall back to to int64 arithmetic. But the potential payoff + * is tremendously less - unless we're working in F format - + * because we know that three groups of digits will always + * suffice for %#.17e, the longest format that doesn't introduce + * empty precision. + */ + + /* Extract the next group of digits */ + + mp_div(&b, &S, &dig, &b); + if (dig.used > 1) { + Tcl_Panic("wrong digit!"); + } + digit = dig.dp[0]; + for (j = g-1; j >= 0; --j) { + int t = itens[j]; + *s++ = digit / t + '0'; + digit %= t; + } + i += g; + + /* Have we converted all the requested digits? */ + + if (i == ilim) { + mp_mul_2d(&b, 1, &b); + if (ShouldBankerRoundUp(&b, &S, digit&1)) { + s = BumpUp(s, retval, &k); + } + break; + } + } } - e = (e - n) / log2FLT_RADIX; -#endif - if (f == 1.0) { - f = 1.0 / FLT_RADIX; - e += 1; + /* + * Endgame - store the location of the decimal point and the end of the + * string. + */ + mp_clear_multi(&b, &temp, NULL); + *s = '\0'; + *decpt = k; + if (endPtr) { + *endPtr = s; } + return retval; - /* - * If the original number was denormalized, adjust e and f to be denormal - * as well. +} + +/* + *----------------------------------------------------------------------------- + * + * TclDoubleDigits -- + * + * Core of Tcl's conversion of double-precision floating point numbers + * to decimal. + * + * Results: + * Returns a newly-allocated string of digits. + * + * Side effects: + * Sets *decpt to the index of the character in the string before the + * place that the decimal point should go. If 'endPtr' is not NULL, + * sets endPtr to point to the terminating '\0' byte of the string. + * Sets *sign to 1 if a minus sign should be printed with the number, + * or 0 if a plus sign (or no sign) should appear. + * + * This function is a service routine that produces the string of digits + * for floating-point-to-decimal conversion. It can do a number of things + * according to the 'flags' argument. Valid values for 'flags' include: + * TCL_DD_SHORTEST - This is the default for floating point conversion + * if ::tcl_precision is 0. It constructs the shortest string + * of digits that will reconvert to the given number when scanned. + * For floating point numbers that are exactly between two + * decimal numbers, it resolves using the 'round to even' rule. + * With this value, the 'ndigits' parameter is ignored. + * TCL_DD_STEELE - This value is not recommended and may be removed + * in the future. It follows the conversion algorithm outlined + * in "How to Print Floating-Point Numbers Accurately" by + * Guy L. Steele, Jr. and Jon L. White [Proc. ACM SIGPLAN '90, + * pp. 112-126]. This rule has the effect of rendering 1e23 + * as 9.9999999999999999e22 - which is a 'better' approximation + * in the sense that it will reconvert correctly even if + * a subsequent input conversion is 'round up' or 'round down' + * rather than 'round to nearest', but is surprising otherwise. + * TCL_DD_E_FORMAT - This value is used to prepare numbers for %e + * format conversion (or for default floating->string if + * tcl_precision is not 0). It constructs a string of at most + * 'ndigits' digits, choosing the one that is closest to the + * given number (and resolving ties with 'round to even'). + * It is allowed to return fewer than 'ndigits' if the number + * converts exactly; if the TCL_DD_E_FORMAT|TCL_DD_SHORTEN_FLAG + * is supplied instead, it is also allowed to return fewer digits + * if the shorter string will still reconvert to the given + * input number. + * TCL_DD_F_FORMAT - This value is used to prepare numbers for %f + * format conversion. It requests that conversion proceed until + * 'ndigits' digits after the decimal point have been converted. + * It is possible for this format to result in a zero-length + * string if the number is sufficiently small. Again, it + * is permissible for TCL_DD_F_FORMAT to return fewer digits + * for a number that converts exactly, and changing the + * argument to TCL_DD_F_FORMAT|TCL_DD_SHORTEN_FLAG will allow + * the routine also to return fewer digits if the shorter string + * will still reconvert without loss to the given input number. + * + * To any of these flags may be OR'ed TCL_DD_NO_QUICK; this flag + * requires all calculations to be done in exact arithmetic. Normally, + * E and F format with fewer than about 14 digits will be done with + * a quick floating point approximation and fall back on the exact + * arithmetic only if the input number is close enough to the + * midpoint between two decimal strings that more precision is needed + * to resolve which string is correct. + * + * The value stored in the 'decpt' argument on return may be negative + * (indicating that the decimal point falls to the left of the string) + * or greater than the length of the string. In addition, the value -9999 + * is used as a sentinel to indicate that the string is one of the special + * values "Infinity" and "NaN", and that no decimal point should be inserted. + * + *----------------------------------------------------------------------------- + */ +char* +TclDoubleDigits(double dv, /* Number to convert */ + int ndigits, /* Number of digits requested */ + int flags, /* Conversion flags */ + int* decpt, /* OUTPUT: Position of the decimal point */ + int* sign, /* OUTPUT: 1 if the result is negative */ + char** endPtr) /* OUTPUT: If not NULL, receives a pointer + * to one character beyond the end + * of the returned string */ +{ + int convType = (flags & TCL_DD_CONVERSION_TYPE_MASK); + /* Type of conversion being performed + * TCL_DD_SHORTEST0 + * TCL_DD_STEELE0 + * TCL_DD_E_FORMAT + * TCL_DD_F_FORMAT */ + Double d; /* Union for deconstructing doubles */ + Tcl_WideUInt bw; /* Integer significand */ + int be; /* Power of 2 by which b must be multiplied */ + int bbits; /* Number of bits needed to represent b */ + int denorm; /* Flag == 1 iff the input number was + * denormalized */ + int k; /* Estimate of floor(log10(d)) */ + int k_check; /* Flag == 1 if d is near enough to a + * power of ten that k must be checked */ + int b2, b5, s2, s5; /* Powers of 2 and 5 in the numerator and + * denominator of intermediate results */ + int ilim = -1, ilim1 = -1; /* Number of digits to convert, and number + * to convert if log10(d) has been + * overestimated */ + char* retval; /* Return value from this function */ + int i = -1; + + /* Put the input number into a union for bit-whacking */ + + d.d = dv; + + /* + * Handle the cases of negative numbers (by taking the absolute value: + * this includes -Inf and -NaN!), infinity, Not a Number, and zero. */ - if (e < DBL_MIN_EXP) { - n = mantBits + (e - DBL_MIN_EXP)*log2FLT_RADIX; - f = ldexp(f, (e - DBL_MIN_EXP)*log2FLT_RADIX); - e = DBL_MIN_EXP; - n = (n + DIGIT_BIT - 1) / DIGIT_BIT; - } else { - n = mantDIGIT; + TakeAbsoluteValue(&d, sign); + if ((d.w.word0 & EXP_MASK) == EXP_MASK) { + return FormatInfAndNaN(&d, decpt, endPtr); + } + if (d.d == 0.0) { + return FormatZero(decpt, endPtr); } + /* + * Unpack the floating point into a wide integer and an exponent. + * Determine the number of bits that the big integer requires, and + * compute a quick approximation (which may be one too high) of + * ceil(log10(d.d)). + */ + denorm = ((d.w.word0 & EXP_MASK) == 0); + DoubleToExpAndSig(d.d, &bw, &be, &bbits); + k = ApproximateLog10(bw, be, bbits); + k = BetterLog10(d.d, k, &k_check); + + /* At this point, we have: + * d is the number to convert. + * bw are significand and exponent: d == bw*2**be, + * bbits is the length of bw: 2**bbits-1 <= bw < 2**bbits + * k is either ceil(log10(d)) or ceil(log10(d))+1. k_check is 0 + * if we know that k is exactly ceil(log10(d)) and 1 if we need to + * check. + * We want a rational number + * r = b * 10**(1-k) = bw * 2**b2 * 5**b5 / (2**s2 / 5**s5), + * with b2, b5, s2, s5 >= 0. Note that the most significant decimal + * digit is floor(r) and that successive digits can be obtained + * by setting r <- 10*floor(r) (or b <= 10 * (b % S)). + * Find appropriate b2, b5, s2, s5. + */ + + ComputeScale(be, k, &b2, &b5, &s2, &s5); + /* - * Now extract the base-2**DIGIT_BIT digits of f into a multi-precision - * integer r. Preserve the invariant v = r * 2**rfac2 * FLT_RADIX**e by - * adjusting e. - */ - - a = f; - n = mantDIGIT; - mp_init_size(rPtr, n); - rPtr->used = n; - rPtr->sign = MP_ZPOS; - i = (mantBits % DIGIT_BIT); - if (i == 0) { - i = DIGIT_BIT; - } - while (n > 0) { - a *= ldexp(1.0, i); - i = DIGIT_BIT; - rPtr->dp[--n] = (mp_digit) a; - a -= (mp_digit) a; - } - *ePtr = e - DBL_MANT_DIG; - return (f == 1.0 / FLT_RADIX); + * Correct an incorrect caller-supplied 'ndigits'. + * Also determine: + * i = The maximum number of decimal digits that will be returned in the + * formatted string. This is k + 1 + ndigits for F format, 18 for + * shortest and Steele, and ndigits for E format. + * ilim = The number of significant digits to convert if + * k has been guessed correctly. This is -1 for shortest and Steele + * (which stop when all significance has been lost), 'ndigits' + * for E format, and 'k + 1 + ndigits' for F format. + * ilim1 = The minimum number of significant digits to convert if + * k has been guessed 1 too high. This, too, is -1 for shortest + * and Steele, and 'ndigits' for E format, but it's 'ndigits-1' + * for F format. + */ + + SetPrecisionLimits(convType, k, &ndigits, &i, &ilim, &ilim1); + + /* + * Try to do low-precision conversion in floating point rather + * than resorting to expensive multiprecision arithmetic + */ + if (ilim >= 0 && ilim <= QUICK_MAX && !(flags & TCL_DD_NO_QUICK)) { + if ((retval = QuickConversion(d.d, k, k_check, flags, + i, ilim, ilim1, + decpt, endPtr)) != NULL) { + return retval; + } + } + + /* + * For shortening conversions, determine the upper and lower bounds + * for the remainder at which we can stop. + * m+ = (2**m2plus * 5**m5) / (2**s2 * 5**s5) is the limit on the + * high side, and + * m- = (2**m2minus * 5**m5) / (2**s2 * 5**s5) is the limit on the + * low side. + * We may need to increase s2 to put m2plus, m2minus, b2 over a + * common denominator. + */ + + if (flags & TCL_DD_SHORTEN_FLAG) { + int m2minus = b2; + int m2plus; + int m5 = b5; + int len = i; + + /* + * Find the quantity i so that (2**i*5**b5)/(2**s2*5**s5) + * is 1/2 unit in the least significant place of the floating + * point number. + */ + if (denorm) { + i = be + EXPONENT_BIAS + (FP_PRECISION-1); + } else { + i = 1 + FP_PRECISION - bbits; + } + b2 += i; + s2 += i; + + /* + * Reduce the fractions to lowest terms, since the above calculation + * may have left excess powers of 2 in numerator and denominator + */ + CastOutPowersOf2(&b2, &m2minus, &s2); + + /* + * In the special case where bw==1, the nearest floating point number + * to it on the low side is 1/4 ulp below it. Adjust accordingly. + */ + m2plus = m2minus; + if (!denorm && bw == 1) { + ++b2; + ++s2; + ++m2plus; + } + + if (s5+1 < N_LOG2POW5 + && s2+1 + log2pow5[s5+1] <= 64) { + /* + * If 10*2**s2*5**s5 == 2**(s2+1)+5**(s5+1) fits in a 64-bit + * word, then all our intermediate calculations can be done + * using exact 64-bit arithmetic with no need for expensive + * multiprecision operations. (This will be true for all numbers + * in the range [1.0e-3 .. 1.0e+24]). + */ + + return ShorteningInt64Conversion(&d, convType, bw, b2, b5, + m2plus, m2minus, m5, + s2, s5, k, len, ilim, ilim1, + decpt, endPtr); + } else if (s5 == 0) { + /* + * The denominator is a power of 2, so we can replace division + * by digit shifts. First we round up s2 to a multiple of + * DIGIT_BIT, and adjust m2 and b2 accordingly. Then we launch + * into a version of the comparison that's specialized for + * the 'power of mp_digit in the denominator' case. + */ + if (s2 % DIGIT_BIT != 0) { + int delta = DIGIT_BIT - (s2 % DIGIT_BIT); + b2 += delta; + m2plus += delta; + m2minus += delta; + s2 += delta; + } + return ShorteningBignumConversionPowD(&d, convType, bw, b2, b5, + m2plus, m2minus, m5, + s2/DIGIT_BIT, k, len, + ilim, ilim1, decpt, endPtr); + } else { + + /* + * Alas, there's no helpful special case; use full-up + * bignum arithmetic for the conversion + */ + + return ShorteningBignumConversion(&d, convType, bw, + b2, m2plus, m2minus, + s2, s5, k, len, + ilim, ilim1, decpt, endPtr); + + } + + } else { + + /* Non-shortening conversion */ + + int len = i; + + /* Reduce numerator and denominator to lowest terms */ + + if (b2 >= s2 && s2 > 0) { + b2 -= s2; s2 = 0; + } else if (s2 >= b2 && b2 > 0) { + s2 -= b2; b2 = 0; + } + + if (s5+1 < N_LOG2POW5 + && s2+1 + log2pow5[s5+1] <= 64) { + /* + * If 10*2**s2*5**s5 == 2**(s2+1)+5**(s5+1) fits in a 64-bit + * word, then all our intermediate calculations can be done + * using exact 64-bit arithmetic with no need for expensive + * multiprecision operations. + */ + + return StrictInt64Conversion(&d, convType, bw, b2, b5, + s2, s5, k, len, ilim, ilim1, + decpt, endPtr); + + } else if (s5 == 0) { + /* + * The denominator is a power of 2, so we can replace division + * by digit shifts. First we round up s2 to a multiple of + * DIGIT_BIT, and adjust m2 and b2 accordingly. Then we launch + * into a version of the comparison that's specialized for + * the 'power of mp_digit in the denominator' case. + */ + if (s2 % DIGIT_BIT != 0) { + int delta = DIGIT_BIT - (s2 % DIGIT_BIT); + b2 += delta; + s2 += delta; + } + return StrictBignumConversionPowD(&d, convType, bw, b2, b5, + s2/DIGIT_BIT, k, len, + ilim, ilim1, decpt, endPtr); + } else { + /* + * There are no helpful special cases, but at least we know + * in advance how many digits we will convert. We can run the + * conversion in steps of DIGIT_GROUP digits, so as to + * have many fewer mp_int divisions. + */ + return StrictBignumConversion(&d, convType, bw, b2, s2, s5, + k, len, ilim, ilim1, decpt, endPtr); + } + } } + /* *---------------------------------------------------------------------- @@ -2237,6 +4387,11 @@ TclInitDoubleConversion(void) for (i=0; i<8; ++i) { mp_sqr(pow5+i, pow5+i+1); } + mp_init_set_int(pow5_13, 1220703125); + for (i = 1; i < 5; ++i) { + mp_init(pow5_13 + i); + mp_sqr(pow5_13 + i - 1, pow5_13 + i); + } /* * Determine the number of decimal digits to the left and right of the @@ -2293,7 +4448,7 @@ TclFinalizeDoubleConversion(void) { int i; - Tcl_Free((char *) pow10_wide); + ckfree((char *) pow10_wide); for (i=0; i<9; ++i) { mp_clear(pow5 + i); } @@ -2433,6 +4588,20 @@ TclBignumToDouble( return -r; } } + +/* + *----------------------------------------------------------------------------- + * + * TclCeil -- + * + * Computes the smallest floating point number that is at least the + * mp_int argument. + * + * Results: + * Returns the floating point number. + * + *----------------------------------------------------------------------------- + */ double TclCeil( @@ -2476,6 +4645,20 @@ TclCeil( mp_clear(&b); return r; } + +/* + *----------------------------------------------------------------------------- + * + * TclFloor -- + * + * Computes the largest floating point number less than or equal to + * the mp_int argument. + * + * Results: + * Returns the floating point value. + * + *----------------------------------------------------------------------------- + */ double TclFloor( diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index b804b9a..152a181 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.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: tclStubInit.c,v 1.197 2010/09/16 14:49:37 nijtmans Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.197.2.1 2010/12/01 16:42:36 kennykb Exp $ */ #include "tclInt.h" @@ -80,7 +80,7 @@ static const TclIntStubs tclIntStubs = { 0, /* 21 */ TclFindElement, /* 22 */ TclFindProc, /* 23 */ - 0, /* 24 */ + TclFormatInt, /* 24 */ TclFreePackageInfo, /* 25 */ 0, /* 26 */ 0, /* 27 */ @@ -305,6 +305,7 @@ static const TclIntStubs tclIntStubs = { TclInitRewriteEnsemble, /* 246 */ TclResetRewriteEnsemble, /* 247 */ TclCopyChannel, /* 248 */ + TclDoubleDigits, /* 249 */ }; static const TclIntPlatStubs tclIntPlatStubs = { @@ -460,6 +461,8 @@ const TclTomMathStubs tclTomMathStubs = { TclBN_s_mp_mul_digs, /* 58 */ TclBN_s_mp_sqr, /* 59 */ TclBN_s_mp_sub, /* 60 */ + TclBN_mp_init_set_int, /* 61 */ + TclBN_mp_set_int, /* 62 */ }; static const TclStubHooks tclStubHooks = { diff --git a/generic/tclTest.c b/generic/tclTest.c index 982bd50..f03b486 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -14,9 +14,11 @@ * 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.153.2.1 2010/09/27 20:33:37 kennykb Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.153.2.2 2010/12/01 16:42:36 kennykb Exp $ */ +#include <math.h> + #undef STATIC_BUILD #ifndef USE_TCL_STUBS # define USE_TCL_STUBS @@ -233,6 +235,9 @@ static int TestdelCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestdelassocdataCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); +static int TestdoubledigitsObjCmd(ClientData dummy, + Tcl_Interp* interp, + int objc, Tcl_Obj* const objv[]); static int TestdstringCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestencodingObjCmd(ClientData dummy, @@ -569,6 +574,8 @@ Tcltest_Init( Tcl_CreateCommand(interp, "testdel", TestdelCmd, NULL, NULL); Tcl_CreateCommand(interp, "testdelassocdata", TestdelassocdataCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testdoubledigits", TestdoubledigitsObjCmd, + NULL, NULL); Tcl_DStringInit(&dstring); Tcl_CreateCommand(interp, "testdstring", TestdstringCmd, NULL, NULL); @@ -1594,6 +1601,102 @@ TestdelassocdataCmd( } /* + *----------------------------------------------------------------------------- + * + * TestdoubledigitsCmd -- + * + * This procedure implements the 'testdoubledigits' command. It is + * used to test the low-level floating-point formatting primitives + * in Tcl. + * + * Usage: + * testdoubledigits fpval ndigits type ?shorten" + * + * Parameters: + * fpval - Floating-point value to format. + * ndigits - Digit count to request from Tcl_DoubleDigits + * type - One of 'shortest', 'Steele', 'e', 'f' + * shorten - Indicates that the 'shorten' flag should be passed in. + * + *----------------------------------------------------------------------------- + */ + +static int +TestdoubledigitsObjCmd(ClientData unused, + /* NULL */ + Tcl_Interp* interp, + /* Tcl interpreter */ + int objc, + /* Parameter count */ + Tcl_Obj* const objv[]) + /* Parameter vector */ +{ + static const char* options[] = { + "shortest", + "Steele", + "e", + "f", + NULL + }; + static const int types[] = { + TCL_DD_SHORTEST, + TCL_DD_STEELE, + TCL_DD_E_FORMAT, + TCL_DD_F_FORMAT + }; + + const Tcl_ObjType* doubleType; + double d; + int status; + int ndigits; + int type; + int decpt; + int signum; + char* str; + char* endPtr; + Tcl_Obj* strObj; + Tcl_Obj* retval; + + if (objc < 4 || objc > 5) { + Tcl_WrongNumArgs(interp, 1, objv, "fpval ndigits type ?shorten?"); + return TCL_ERROR; + } + status = Tcl_GetDoubleFromObj(interp, objv[1], &d); + if (status != TCL_OK) { + doubleType = Tcl_GetObjType("double"); + if (objv[1]->typePtr == doubleType + || TclIsNaN(objv[1]->internalRep.doubleValue)) { + status = TCL_OK; + memcpy(&d, &(objv[1]->internalRep.doubleValue), sizeof(double)); + } + } + if (status != TCL_OK + || Tcl_GetIntFromObj(interp, objv[2], &ndigits) != TCL_OK + || Tcl_GetIndexFromObj(interp, objv[3], options, "conversion type", + TCL_EXACT, &type) != TCL_OK) { + fprintf(stderr, "bad value? %g\n", d); + return TCL_ERROR; + } + type = types[type]; + if (objc > 4) { + if (strcmp(Tcl_GetString(objv[4]), "shorten")) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("bad flag", -1)); + return TCL_ERROR; + } + type |= TCL_DD_SHORTEN_FLAG; + } + str = TclDoubleDigits(d, ndigits, type, &decpt, &signum, &endPtr); + strObj = Tcl_NewStringObj(str, endPtr-str); + ckfree(str); + retval = Tcl_NewListObj(1, &strObj); + Tcl_ListObjAppendElement(NULL, retval, Tcl_NewIntObj(decpt)); + strObj = Tcl_NewStringObj(signum ? "-" : "+", 1); + Tcl_ListObjAppendElement(NULL, retval, strObj); + Tcl_SetObjResult(interp, retval); + return TCL_OK; +} + +/* *---------------------------------------------------------------------- * * TestdstringCmd -- @@ -5054,7 +5157,7 @@ TestmainthreadCmd( const char **argv) /* Argument strings. */ { if (argc == 1) { - Tcl_Obj *idObj = Tcl_NewLongObj((long) Tcl_GetCurrentThread()); + Tcl_Obj *idObj = Tcl_NewLongObj((long)(size_t)Tcl_GetCurrentThread()); Tcl_SetObjResult(interp, idObj); return TCL_OK; @@ -5451,7 +5554,7 @@ TestChannelCmd( return TCL_ERROR; } - TclFormatInt(buf, (long) Tcl_GetChannelThread(chan)); + TclFormatInt(buf, (size_t) Tcl_GetChannelThread(chan)); Tcl_AppendResult(interp, buf, NULL); return TCL_OK; } diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index 8607b15..8bc68ca 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.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: tclThreadTest.c,v 1.35 2009/11/23 20:17:36 nijtmans Exp $ + * RCS: @(#) $Id: tclThreadTest.c,v 1.35.4.1 2010/12/01 16:42:36 kennykb Exp $ */ #ifndef USE_TCL_STUBS @@ -168,7 +168,7 @@ TclThread_Init( */ Tcl_MutexLock(&threadMutex); - if ((long) mainThreadId == 0) { + if (mainThreadId == 0) { mainThreadId = Tcl_GetCurrentThread(); } Tcl_MutexUnlock(&threadMutex); @@ -275,7 +275,7 @@ ThreadObjCmd( } else { result = NULL; } - return ThreadCancel(interp, (Tcl_ThreadId) id, result, flags); + return ThreadCancel(interp, (Tcl_ThreadId) (size_t) id, result, flags); } case THREAD_CREATE: { const char *script; @@ -339,11 +339,11 @@ ThreadObjCmd( */ if (objc == 2) { - idObj = Tcl_NewLongObj((long) Tcl_GetCurrentThread()); + idObj = Tcl_NewLongObj((long)(size_t)Tcl_GetCurrentThread()); } else if (objc == 3 && strcmp("-main", Tcl_GetString(objv[2])) == 0) { Tcl_MutexLock(&threadMutex); - idObj = Tcl_NewLongObj((long) mainThreadId); + idObj = Tcl_NewLongObj((long)(size_t)mainThreadId); Tcl_MutexUnlock(&threadMutex); } else { Tcl_WrongNumArgs(interp, 2, objv, NULL); @@ -368,13 +368,13 @@ ThreadObjCmd( return TCL_ERROR; } - result = Tcl_JoinThread((Tcl_ThreadId) id, &status); + result = Tcl_JoinThread((Tcl_ThreadId)(size_t)id, &status); if (result == TCL_OK) { Tcl_SetIntObj(Tcl_GetObjResult(interp), status); } else { char buf[20]; - sprintf(buf, "%ld", id); + TclFormatInt(buf, id); Tcl_AppendResult(interp, "cannot join thread ", buf, NULL); } return result; @@ -410,7 +410,7 @@ ThreadObjCmd( } arg++; script = Tcl_GetString(objv[arg]); - return ThreadSend(interp, (Tcl_ThreadId) id, script, wait); + return ThreadSend(interp, (Tcl_ThreadId)(size_t)id, script, wait); } case THREAD_EVENT: { if (objc > 2) { @@ -526,7 +526,7 @@ ThreadCreate( Tcl_ConditionWait(&ctrl.condWait, &threadMutex, NULL); Tcl_MutexUnlock(&threadMutex); Tcl_ConditionFinalize(&ctrl.condWait); - Tcl_SetObjResult(interp, Tcl_NewLongObj((long)id)); + Tcl_SetObjResult(interp, Tcl_NewLongObj((long)(size_t)id)); return TCL_OK; } @@ -658,7 +658,7 @@ ThreadErrorProc( char *script; char buf[TCL_DOUBLE_SPACE+1]; - sprintf(buf, "%ld", (long) Tcl_GetCurrentThread()); + TclFormatInt(buf, (size_t) Tcl_GetCurrentThread()); errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); if (errorProcString == NULL) { @@ -775,7 +775,7 @@ ThreadList( Tcl_MutexLock(&threadMutex); for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) { Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewLongObj((long) tsdPtr->threadId)); + Tcl_NewLongObj((long)(size_t)tsdPtr->threadId)); } Tcl_MutexUnlock(&threadMutex); Tcl_SetObjResult(interp, listPtr); diff --git a/generic/tclTomMath.decls b/generic/tclTomMath.decls index 12fa7cd..fd2dc40 100644 --- a/generic/tclTomMath.decls +++ b/generic/tclTomMath.decls @@ -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: tclTomMath.decls,v 1.8 2010/09/15 07:33:54 nijtmans Exp $ +# RCS: @(#) $Id: tclTomMath.decls,v 1.8.2.1 2010/12/01 16:42:36 kennykb Exp $ library tcl @@ -214,3 +214,9 @@ declare 59 { declare 60 { int TclBN_s_mp_sub(mp_int *a, mp_int *b, mp_int *c) } +declare 61 { + int TclBN_mp_init_set_int(mp_int* a, unsigned long i) +} +declare 62 { + int TclBN_mp_set_int(mp_int* a, unsigned long i) +}
\ No newline at end of file diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h index 61e9c07..849f08f 100644 --- a/generic/tclTomMathDecls.h +++ b/generic/tclTomMathDecls.h @@ -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: tclTomMathDecls.h,v 1.13 2010/08/19 04:26:04 nijtmans Exp $ + * RCS: @(#) $Id: tclTomMathDecls.h,v 1.13.2.1 2010/12/01 16:42:36 kennykb Exp $ */ #ifndef _TCLTOMMATHDECLS @@ -79,6 +79,7 @@ #define mp_init_copy TclBN_mp_init_copy #define mp_init_multi TclBN_mp_init_multi #define mp_init_set TclBN_mp_init_set +#define mp_init_set_int TclBN_mp_init_set_int #define mp_init_size TclBN_mp_init_size #define mp_karatsuba_mul TclBN_mp_karatsuba_mul #define mp_karatsuba_sqr TclBN_mp_karatsuba_sqr @@ -96,6 +97,7 @@ #define mp_rshd TclBN_mp_rshd #define mp_s_rmap TclBNMpSRmap #define mp_set TclBN_mp_set +#define mp_set_int TclBN_mp_set_int #define mp_shrink TclBN_mp_shrink #define mp_sqr TclBN_mp_sqr #define mp_sqrt TclBN_mp_sqrt @@ -268,6 +270,10 @@ EXTERN int TclBN_s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, EXTERN int TclBN_s_mp_sqr(mp_int *a, mp_int *b); /* 60 */ EXTERN int TclBN_s_mp_sub(mp_int *a, mp_int *b, mp_int *c); +/* 61 */ +EXTERN int TclBN_mp_init_set_int(mp_int*a, unsigned long i); +/* 62 */ +EXTERN int TclBN_mp_set_int(mp_int*a, unsigned long i); typedef struct TclTomMathStubs { int magic; @@ -334,6 +340,8 @@ typedef struct TclTomMathStubs { int (*tclBN_s_mp_mul_digs) (mp_int *a, mp_int *b, mp_int *c, int digs); /* 58 */ int (*tclBN_s_mp_sqr) (mp_int *a, mp_int *b); /* 59 */ int (*tclBN_s_mp_sub) (mp_int *a, mp_int *b, mp_int *c); /* 60 */ + int (*tclBN_mp_init_set_int) (mp_int*a, unsigned long i); /* 61 */ + int (*tclBN_mp_set_int) (mp_int*a, unsigned long i); /* 62 */ } TclTomMathStubs; #ifdef __cplusplus @@ -472,6 +480,10 @@ extern const TclTomMathStubs *tclTomMathStubsPtr; (tclTomMathStubsPtr->tclBN_s_mp_sqr) /* 59 */ #define TclBN_s_mp_sub \ (tclTomMathStubsPtr->tclBN_s_mp_sub) /* 60 */ +#define TclBN_mp_init_set_int \ + (tclTomMathStubsPtr->tclBN_mp_init_set_int) /* 61 */ +#define TclBN_mp_set_int \ + (tclTomMathStubsPtr->tclBN_mp_set_int) /* 62 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 2094357..4e43176 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.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: tclUtil.c,v 1.117.2.1 2010/10/01 13:34:10 kennykb Exp $ + * RCS: @(#) $Id: tclUtil.c,v 1.117.2.2 2010/12/01 16:42:36 kennykb Exp $ */ #include "tclInt.h" @@ -2234,129 +2234,99 @@ Tcl_PrintDouble( char *p, c; int exponent; int signum; - char buffer[TCL_DOUBLE_SPACE]; - Tcl_UniChar ch; + char* digits; + char* end; int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int)sizeof(int)); /* - * If *precisionPtr == 0, then use TclDoubleDigits to develop a decimal - * significand and exponent, then format it in E or F format as - * appropriate. If *precisionPtr != 0, use the native sprintf and then add - * a trailing ".0" if there is no decimal point in the rep. + * Handle NaN. */ + + if (TclIsNaN(value)) { + TclFormatNaN(value, dst); + return; + } - if (*precisionPtr == 0) { + /* + * Handle infinities. + */ + + if (TclIsInfinite(value)) { /* - * Handle NaN. + * Remember to copy the terminating NUL too. */ - - if (TclIsNaN(value)) { - TclFormatNaN(value, dst); - return; + + if (value < 0) { + memcpy(dst, "-Inf", 5); + } else { + memcpy(dst, "Inf", 4); } + return; + } + /* + * Ordinary (normal and denormal) values. + */ + + if (*precisionPtr == 0) { + digits = TclDoubleDigits(value, -1, TCL_DD_SHORTEST, + &exponent, &signum, &end); + } else { + digits = TclDoubleDigits(value, *precisionPtr, TCL_DD_E_FORMAT, + &exponent, &signum, &end); + } + if (signum) { + *dst++ = '-'; + } + p = digits; + if (exponent < -4 || exponent > 16) { /* - * Handle infinities. + * E format for numbers < 1e-3 or >= 1e17. */ - - if (TclIsInfinite(value)) { - /* - * Remember to copy the terminating NUL too. - */ - - if (value < 0) { - memcpy(dst, "-Inf", 5); - } else { - memcpy(dst, "Inf", 4); + + *dst++ = *p++; + c = *p; + if (c != '\0') { + *dst++ = '.'; + while (c != '\0') { + *dst++ = c; + c = *++p; } - return; } - + sprintf(dst, "e%+d", exponent); + } else { /* - * Ordinary (normal and denormal) values. + * F format for others. */ - - exponent = TclDoubleDigits(buffer, value, &signum); - if (signum) { - *dst++ = '-'; + + if (exponent < 0) { + *dst++ = '0'; } - p = buffer; - if (exponent < -3 || exponent > 17) { - /* - * E format for numbers < 1e-3 or >= 1e17. - */ - - *dst++ = *p++; - c = *p; + c = *p; + while (exponent-- >= 0) { if (c != '\0') { - *dst++ = '.'; - while (c != '\0') { - *dst++ = c; - c = *++p; - } - } - sprintf(dst, "e%+d", exponent-1); - } else { - /* - * F format for others. - */ - - if (exponent <= 0) { - *dst++ = '0'; - } - c = *p; - while (exponent-- > 0) { - if (c != '\0') { - *dst++ = c; - c = *++p; - } else { - *dst++ = '0'; - } - } - *dst++ = '.'; - if (c == '\0') { - *dst++ = '0'; + *dst++ = c; + c = *++p; } else { - while (++exponent < 0) { - *dst++ = '0'; - } - while (c != '\0') { - *dst++ = c; - c = *++p; - } + *dst++ = '0'; } - *dst++ = '\0'; } - } else { - /* - * tcl_precision is supplied, pass it to the native sprintf. - */ - - sprintf(dst, "%.*g", *precisionPtr, value); - - /* - * If the ASCII result looks like an integer, add ".0" so that it - * doesn't look like an integer anymore. This prevents floating-point - * values from being converted to integers unintentionally. Check for - * ASCII specifically to speed up the function. - */ - - for (p = dst; *p != 0;) { - if (UCHAR(*p) < 0x80) { - c = *p++; - } else { - p += Tcl_UtfToUniChar(p, &ch); - c = UCHAR(ch); + *dst++ = '.'; + if (c == '\0') { + *dst++ = '0'; + } else { + while (++exponent < -1) { + *dst++ = '0'; } - if ((c == '.') || isalpha(UCHAR(c))) { /* INTL: ISO only. */ - return; + while (c != '\0') { + *dst++ = c; + c = *++p; } } - p[0] = '.'; - p[1] = '0'; - p[2] = 0; + *dst++ = '\0'; } + ckfree(digits); } /* @@ -2526,6 +2496,92 @@ TclNeedSpace( /* *---------------------------------------------------------------------- * + * TclFormatInt -- + * + * This procedure formats an integer into a sequence of decimal digit + * characters in a buffer. If the integer is negative, a minus sign is + * inserted at the start of the buffer. A null character is inserted at + * the end of the formatted characters. It is the caller's + * responsibility to ensure that enough storage is available. This + * procedure has the effect of sprintf(buffer, "%ld", n) but is faster + * as proven in benchmarks. This is key to UpdateStringOfInt, which + * is a common path for a lot of code (e.g. int-indexed arrays). + * + * Results: + * An integer representing the number of characters formatted, not + * including the terminating \0. + * + * Side effects: + * The formatted characters are written into the storage pointer to + * by the "buffer" argument. + * + *---------------------------------------------------------------------- + */ + +int +TclFormatInt(buffer, n) + char *buffer; /* Points to the storage into which the + * formatted characters are written. */ + long n; /* The integer to format. */ +{ + long intVal; + int i; + int numFormatted, j; + char *digits = "0123456789"; + + /* + * Check first whether "n" is zero. + */ + + if (n == 0) { + buffer[0] = '0'; + buffer[1] = 0; + return 1; + } + + /* + * Check whether "n" is the maximum negative value. This is + * -2^(m-1) for an m-bit word, and has no positive equivalent; + * negating it produces the same value. + */ + + if (n == -n) { + return sprintf(buffer, "%ld", n); + } + + /* + * Generate the characters of the result backwards in the buffer. + */ + + intVal = (n < 0? -n : n); + i = 0; + buffer[0] = '\0'; + do { + i++; + buffer[i] = digits[intVal % 10]; + intVal = intVal/10; + } while (intVal > 0); + if (n < 0) { + i++; + buffer[i] = '-'; + } + numFormatted = i; + + /* + * Now reverse the characters. + */ + + for (j = 0; j < i; j++, i--) { + char tmp = buffer[i]; + buffer[i] = buffer[j]; + buffer[j] = tmp; + } + return numFormatted; +} + +/* + *---------------------------------------------------------------------- + * * TclGetIntForIndex -- * * This function returns an integer corresponding to the list index held diff --git a/tests/chanio.test b/tests/chanio.test index c1dba49..11bf23e 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -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: chanio.test,v 1.23 2010/02/07 08:03:11 dkf Exp $ +# RCS: @(#) $Id: chanio.test,v 1.23.4.1 2010/12/01 16:42:36 kennykb Exp $ if {[catch {package require tcltest 2}]} { chan puts stderr "Skipping tests in [info script]. tcltest 2 required." @@ -41,12 +41,12 @@ namespace eval ::tcl::test::io { testConstraint testmainthread [llength [info commands testmainthread]] testConstraint testthread [llength [info commands testthread]] - # You need a *very* special environment to do some tests. In - # particular, many file systems do not support large-files... + # You need a *very* special environment to do some tests. In particular, + # many file systems do not support large-files... testConstraint largefileSupport 0 - # some tests can only be run is umask is 2 - # if "umask" cannot be run, the tests will be skipped. + # some tests can only be run is umask is 2 if "umask" cannot be run, the + # tests will be skipped. set umaskValue 0 testConstraint umask [expr {![catch {set umaskValue [scan [exec /bin/sh -c umask] %o]}]}] @@ -92,6 +92,11 @@ namespace eval ::tcl::test::io { chan close $f return $a } + + # Wrapper round butt-ugly pipe syntax + proc openpipe {{mode r+} args} { + open "|[list [interpreter] {*}$args]" $mode + } test chan-io-1.5 {Tcl_WriteChars: CheckChannelErrors} {emptyTest} { # no test, need to cause an async error. @@ -183,17 +188,17 @@ test chan-io-2.2 {WriteBytes: savedLF > 0} { chan close $f lappend x [contents $path(test1)] } [list "123456789012345\r" "123456789012345\r\n12"] -test chan-io-2.3 {WriteBytes: flush on line} { - # Tcl "line" buffering has weird behavior: if current buffer contains - # a \n, entire buffer gets flushed. Logical behavior would be to flush - # only up to the \n. +test chan-io-2.3 {WriteBytes: flush on line} -body { + # Tcl "line" buffering has weird behavior: if current buffer contains a + # \n, entire buffer gets flushed. Logical behavior would be to flush only + # up to the \n. set f [open $path(test1) w] chan configure $f -encoding binary -buffering line -translation crlf chan puts -nonewline $f "\n12" - set x [contents $path(test1)] + contents $path(test1) +} -cleanup { chan close $f - set x -} "\r\n12" +} -result "\r\n12" test chan-io-2.4 {WriteBytes: reset sawLF after each buffer} { set f [open $path(test1) w] chan configure $f -encoding binary -buffering line -translation lf \ @@ -222,17 +227,17 @@ test chan-io-3.2 {WriteChars: compatibility with WriteBytes: savedLF > 0} { chan close $f lappend x [contents $path(test1)] } [list "123456789012345\r" "123456789012345\r\n12"] -test chan-io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} { - # Tcl "line" buffering has weird behavior: if current buffer contains - # a \n, entire buffer gets flushed. Logical behavior would be to flush - # only up to the \n. +test chan-io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} -body { + # Tcl "line" buffering has weird behavior: if current buffer contains a + # \n, entire buffer gets flushed. Logical behavior would be to flush only + # up to the \n. set f [open $path(test1) w] chan configure $f -encoding ascii -buffering line -translation crlf chan puts -nonewline $f "\n12" - set x [contents $path(test1)] + contents $path(test1) +} -cleanup { chan close $f - set x -} "\r\n12" +} -result "\r\n12" test chan-io-3.4 {WriteChars: loop over stage buffer} { # stage buffer maps to more than can be queued at once. set f [open $path(test1) w] @@ -380,118 +385,118 @@ test chan-io-5.5 {CheckFlush: none} { lappend x [contents $path(test1)] } [list "1234567890" "1234567890"] -test chan-io-6.1 {Tcl_GetsObj: working} { +test chan-io-6.1 {Tcl_GetsObj: working} -body { set f [open $path(test1) w] chan puts $f "foo\nboo" chan close $f set f [open $path(test1)] - set x [chan gets $f] + chan gets $f +} -cleanup { chan close $f - set x -} {foo} +} -result {foo} test chan-io-6.2 {Tcl_GetsObj: CheckChannelErrors() != 0} emptyTest { # no test, need to cause an async error. } {} -test chan-io-6.3 {Tcl_GetsObj: how many have we used?} { +test chan-io-6.3 {Tcl_GetsObj: how many have we used?} -body { # if (bufPtr != NULL) {oldRemoved = bufPtr->nextRemoved} set f [open $path(test1) w] chan configure $f -translation crlf chan puts $f "abc\ndefg" chan close $f set f [open $path(test1)] - set x [list [chan tell $f] [chan gets $f line] [chan tell $f] [chan gets $f line] $line] + list [chan tell $f] [chan gets $f line] [chan tell $f] [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {0 3 5 4 defg} -test chan-io-6.4 {Tcl_GetsObj: encoding == NULL} { +} -result {0 3 5 4 defg} +test chan-io-6.4 {Tcl_GetsObj: encoding == NULL} -body { set f [open $path(test1) w] chan configure $f -translation binary chan puts $f "\x81\u1234\0" chan close $f set f [open $path(test1)] chan configure $f -translation binary - set x [list [chan gets $f line] $line] + list [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 3 "\x81\x34\x00"] -test chan-io-6.5 {Tcl_GetsObj: encoding != NULL} { +} -result [list 3 "\x81\x34\x00"] +test chan-io-6.5 {Tcl_GetsObj: encoding != NULL} -body { set f [open $path(test1) w] chan configure $f -translation binary chan puts $f "\x88\xea\x92\x9a" chan close $f set f [open $path(test1)] chan configure $f -encoding shiftjis - set x [list [chan gets $f line] $line] + list [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 2 "\u4e00\u4e01"] +} -result [list 2 "\u4e00\u4e01"] set a "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" append a $a append a $a -test chan-io-6.6 {Tcl_GetsObj: loop test} { +test chan-io-6.6 {Tcl_GetsObj: loop test} -body { # if (dst >= dstEnd) set f [open $path(test1) w] chan puts $f $a chan puts $f hi chan close $f set f [open $path(test1)] - set x [list [chan gets $f line] $line] + list [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 256 $a] -test chan-io-6.7 {Tcl_GetsObj: error in input} {stdio openpipe} { +} -result [list 256 $a] +test chan-io-6.7 {Tcl_GetsObj: error in input} -constraints {stdio openpipe} -body { # if (FilterInputBytes(chanPtr, &gs) != 0) - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan puts -nonewline $f "hi\nwould" chan flush $f chan gets $f chan configure $f -blocking 0 - set x [chan gets $f line] + chan gets $f line +} -cleanup { chan close $f - set x -} {-1} -test chan-io-6.8 {Tcl_GetsObj: remember if EOF is seen} { +} -result {-1} +test chan-io-6.8 {Tcl_GetsObj: remember if EOF is seen} -body { set f [open $path(test1) w] chan puts $f "abcdef\x1aghijk\nwombat" chan close $f set f [open $path(test1)] chan configure $f -eofchar \x1a - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {6 abcdef -1 {}} -test chan-io-6.9 {Tcl_GetsObj: remember if EOF is seen} { +} -result {6 abcdef -1 {}} +test chan-io-6.9 {Tcl_GetsObj: remember if EOF is seen} -body { set f [open $path(test1) w] chan puts $f "abcdefghijk\nwom\u001abat" chan close $f set f [open $path(test1)] chan configure $f -eofchar \x1a - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {11 abcdefghijk 3 wom} +} -result {11 abcdefghijk 3 wom} # Comprehensive tests -test chan-io-6.10 {Tcl_GetsObj: lf mode: no chars} { +test chan-io-6.10 {Tcl_GetsObj: lf mode: no chars} -body { set f [open $path(test1) w] chan close $f set f [open $path(test1)] chan configure $f -translation lf - set x [list [chan gets $f line] $line] + list [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {-1 {}} -test chan-io-6.11 {Tcl_GetsObj: lf mode: lone \n} { +} -result {-1 {}} +test chan-io-6.11 {Tcl_GetsObj: lf mode: lone \n} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "\n" chan close $f set f [open $path(test1)] chan configure $f -translation lf - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {0 {} -1 {}} -test chan-io-6.12 {Tcl_GetsObj: lf mode: lone \r} { +} -result {0 {} -1 {}} +test chan-io-6.12 {Tcl_GetsObj: lf mode: lone \r} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "\r" @@ -499,193 +504,194 @@ test chan-io-6.12 {Tcl_GetsObj: lf mode: lone \r} { set f [open $path(test1)] chan configure $f -translation lf set x [list [chan gets $f line] $line [chan gets $f line] $line] +} -cleanup { chan close $f - set x -} [list 1 "\r" -1 ""] -test chan-io-6.13 {Tcl_GetsObj: lf mode: 1 char} { +} -result [list 1 "\r" -1 ""] +test chan-io-6.13 {Tcl_GetsObj: lf mode: 1 char} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f a chan close $f set f [open $path(test1)] chan configure $f -translation lf - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {1 a -1 {}} -test chan-io-6.14 {Tcl_GetsObj: lf mode: 1 char followed by EOL} { +} -result {1 a -1 {}} +test chan-io-6.14 {Tcl_GetsObj: lf mode: 1 char followed by EOL} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "a\n" chan close $f set f [open $path(test1)] chan configure $f -translation lf - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {1 a -1 {}} -test chan-io-6.15 {Tcl_GetsObj: lf mode: several chars} { +} -result {1 a -1 {}} +test chan-io-6.15 {Tcl_GetsObj: lf mode: several chars} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" chan close $f set f [open $path(test1)] chan configure $f -translation lf - set x [list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line \ + [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 4 "abcd" 10 "efgh\rijkl\r" 4 "mnop" -1 ""] -test chan-io-6.16 {Tcl_GetsObj: cr mode: no chars} { +} -result [list 4 "abcd" 10 "efgh\rijkl\r" 4 "mnop" -1 ""] +test chan-io-6.16 {Tcl_GetsObj: cr mode: no chars} -body { set f [open $path(test1) w] chan close $f set f [open $path(test1)] chan configure $f -translation cr - set x [list [chan gets $f line] $line] + list [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {-1 {}} -test chan-io-6.17 {Tcl_GetsObj: cr mode: lone \n} { +} -result {-1 {}} +test chan-io-6.17 {Tcl_GetsObj: cr mode: lone \n} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "\n" chan close $f set f [open $path(test1)] chan configure $f -translation cr - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 1 "\n" -1 ""] -test chan-io-6.18 {Tcl_GetsObj: cr mode: lone \r} { +} -result [list 1 "\n" -1 ""] +test chan-io-6.18 {Tcl_GetsObj: cr mode: lone \r} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "\r" chan close $f set f [open $path(test1)] chan configure $f -translation cr - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {0 {} -1 {}} -test chan-io-6.19 {Tcl_GetsObj: cr mode: 1 char} { +} -result {0 {} -1 {}} +test chan-io-6.19 {Tcl_GetsObj: cr mode: 1 char} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f a chan close $f set f [open $path(test1)] chan configure $f -translation cr - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {1 a -1 {}} -test chan-io-6.20 {Tcl_GetsObj: cr mode: 1 char followed by EOL} { +} -result {1 a -1 {}} +test chan-io-6.20 {Tcl_GetsObj: cr mode: 1 char followed by EOL} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "a\r" chan close $f set f [open $path(test1)] chan configure $f -translation cr - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {1 a -1 {}} -test chan-io-6.21 {Tcl_GetsObj: cr mode: several chars} { +} -result {1 a -1 {}} +test chan-io-6.21 {Tcl_GetsObj: cr mode: several chars} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" chan close $f set f [open $path(test1)] chan configure $f -translation cr - set x [list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 9 "abcd\nefgh" 4 "ijkl" 5 "\nmnop" -1 ""] -test chan-io-6.22 {Tcl_GetsObj: crlf mode: no chars} { +} -result [list 9 "abcd\nefgh" 4 "ijkl" 5 "\nmnop" -1 ""] +test chan-io-6.22 {Tcl_GetsObj: crlf mode: no chars} -body { set f [open $path(test1) w] chan close $f set f [open $path(test1)] chan configure $f -translation crlf - set x [list [chan gets $f line] $line] + list [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {-1 {}} -test chan-io-6.23 {Tcl_GetsObj: crlf mode: lone \n} { +} -result {-1 {}} +test chan-io-6.23 {Tcl_GetsObj: crlf mode: lone \n} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "\n" chan close $f set f [open $path(test1)] chan configure $f -translation crlf - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 1 "\n" -1 ""] -test chan-io-6.24 {Tcl_GetsObj: crlf mode: lone \r} { +} -result [list 1 "\n" -1 ""] +test chan-io-6.24 {Tcl_GetsObj: crlf mode: lone \r} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "\r" chan close $f set f [open $path(test1)] chan configure $f -translation crlf - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 1 "\r" -1 ""] -test chan-io-6.25 {Tcl_GetsObj: crlf mode: \r\r} { +} -result [list 1 "\r" -1 ""] +test chan-io-6.25 {Tcl_GetsObj: crlf mode: \r\r} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "\r\r" chan close $f set f [open $path(test1)] chan configure $f -translation crlf - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 2 "\r\r" -1 ""] -test chan-io-6.26 {Tcl_GetsObj: crlf mode: \r\n} { +} -result [list 2 "\r\r" -1 ""] +test chan-io-6.26 {Tcl_GetsObj: crlf mode: \r\n} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "\r\n" chan close $f set f [open $path(test1)] chan configure $f -translation crlf - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 0 "" -1 ""] -test chan-io-6.27 {Tcl_GetsObj: crlf mode: 1 char} { +} -result {0 {} -1 {}} +test chan-io-6.27 {Tcl_GetsObj: crlf mode: 1 char} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f a chan close $f set f [open $path(test1)] chan configure $f -translation crlf - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {1 a -1 {}} -test chan-io-6.28 {Tcl_GetsObj: crlf mode: 1 char followed by EOL} { +} -result {1 a -1 {}} +test chan-io-6.28 {Tcl_GetsObj: crlf mode: 1 char followed by EOL} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "a\r\n" chan close $f set f [open $path(test1)] chan configure $f -translation crlf - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {1 a -1 {}} -test chan-io-6.29 {Tcl_GetsObj: crlf mode: several chars} { +} -result {1 a -1 {}} +test chan-io-6.29 {Tcl_GetsObj: crlf mode: several chars} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" chan close $f set f [open $path(test1)] chan configure $f -translation crlf - set x [list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 14 "abcd\nefgh\rijkl" 4 "mnop" -1 ""] -test chan-io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} {testchannel} { +} -result [list 14 "abcd\nefgh\rijkl" 4 "mnop" -1 ""] +test chan-io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} -constraints {testchannel} -body { # if (eol >= dstEnd) set f [open $path(test1) w] chan configure $f -translation lf @@ -693,23 +699,26 @@ test chan-io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} {testchannel} { chan close $f set f [open $path(test1)] chan configure $f -translation crlf -buffersize 16 - set x [list [chan gets $f line] $line [testchannel inputbuffered $f]] + list [chan gets $f line] $line [testchannel inputbuffered $f] +} -cleanup { chan close $f - set x -} [list 15 "123456789012345" 15] -test chan-io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio testchannel openpipe fileevent} { +} -result [list 15 "123456789012345" 15] +test chan-io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} -setup { + set x "" +} -constraints {stdio testchannel openpipe fileevent} -body { # (FilterInputBytes() != 0) - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -translation {crlf lf} -buffering none chan puts -nonewline $f "bbbbbbbbbbbbbb\r\n123456789012345\r" chan configure $f -buffersize 16 - set x [chan gets $f] + lappend x [chan gets $f] chan configure $f -blocking 0 - lappend x [chan gets $f line] $line [chan blocked $f] [testchannel inputbuffered $f] + lappend x [chan gets $f line] $line [chan blocked $f] \ + [testchannel inputbuffered $f] +} -cleanup { chan close $f - set x -} [list "bbbbbbbbbbbbbb" -1 "" 1 16] -test chan-io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} {testchannel} { +} -result {bbbbbbbbbbbbbb -1 {} 1 16} +test chan-io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} -constraints {testchannel} -body { # not (FilterInputBytes() != 0) set f [open $path(test1) w] chan configure $f -translation lf @@ -717,11 +726,11 @@ test chan-io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} {testcha chan close $f set f [open $path(test1)] chan configure $f -translation crlf -buffersize 16 - set x [list [chan gets $f line] $line [chan tell $f] [testchannel inputbuffered $f]] + list [chan gets $f line] $line [chan tell $f] [testchannel inputbuffered $f] +} -cleanup { chan close $f - set x -} [list 15 "123456789012345" 17 3] -test chan-io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} { +} -result {15 123456789012345 17 3} +test chan-io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} -body { # eol still equals dstEnd set f [open $path(test1) w] chan configure $f -translation lf @@ -729,11 +738,11 @@ test chan-io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} { chan close $f set f [open $path(test1)] chan configure $f -translation crlf -buffersize 16 - set x [list [chan gets $f line] $line [chan eof $f]] + list [chan gets $f line] $line [chan eof $f] +} -cleanup { chan close $f - set x -} [list 16 "123456789012345\r" 1] -test chan-io-6.34 {Tcl_GetsObj: crlf mode: buffer exhausted, not followed by \n} { +} -result [list 16 "123456789012345\r" 1] +test chan-io-6.34 {Tcl_GetsObj: crlf mode: buffer exhausted, not followed by \n} -body { # not (*eol == '\n') set f [open $path(test1) w] chan configure $f -translation lf @@ -741,161 +750,171 @@ test chan-io-6.34 {Tcl_GetsObj: crlf mode: buffer exhausted, not followed by \n} chan close $f set f [open $path(test1)] chan configure $f -translation crlf -buffersize 16 - set x [list [chan gets $f line] $line [chan tell $f]] + list [chan gets $f line] $line [chan tell $f] +} -cleanup { chan close $f - set x -} [list 20 "123456789012345\rabcd" 22] -test chan-io-6.35 {Tcl_GetsObj: auto mode: no chars} { +} -result [list 20 "123456789012345\rabcd" 22] +test chan-io-6.35 {Tcl_GetsObj: auto mode: no chars} -body { set f [open $path(test1) w] chan close $f set f [open $path(test1)] chan configure $f -translation auto - set x [list [chan gets $f line] $line] + list [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {-1 {}} -test chan-io-6.36 {Tcl_GetsObj: auto mode: lone \n} { +} -result {-1 {}} +test chan-io-6.36 {Tcl_GetsObj: auto mode: lone \n} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "\n" chan close $f set f [open $path(test1)] chan configure $f -translation auto - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 0 "" -1 ""] -test chan-io-6.37 {Tcl_GetsObj: auto mode: lone \r} { +} -result {0 {} -1 {}} +test chan-io-6.37 {Tcl_GetsObj: auto mode: lone \r} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "\r" chan close $f set f [open $path(test1)] chan configure $f -translation auto - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 0 "" -1 ""] -test chan-io-6.38 {Tcl_GetsObj: auto mode: \r\r} { +} -result {0 {} -1 {}} +test chan-io-6.38 {Tcl_GetsObj: auto mode: \r\r} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "\r\r" chan close $f set f [open $path(test1)] chan configure $f -translation auto - set x [list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 0 "" 0 "" -1 ""] -test chan-io-6.39 {Tcl_GetsObj: auto mode: \r\n} { +} -result {0 {} 0 {} -1 {}} +test chan-io-6.39 {Tcl_GetsObj: auto mode: \r\n} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "\r\n" chan close $f set f [open $path(test1)] chan configure $f -translation auto - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 0 "" -1 ""] -test chan-io-6.40 {Tcl_GetsObj: auto mode: 1 char} { +} -result {0 {} -1 {}} +test chan-io-6.40 {Tcl_GetsObj: auto mode: 1 char} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f a chan close $f set f [open $path(test1)] chan configure $f -translation auto - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {1 a -1 {}} -test chan-io-6.41 {Tcl_GetsObj: auto mode: 1 char followed by EOL} { +} -result {1 a -1 {}} +test chan-io-6.41 {Tcl_GetsObj: auto mode: 1 char followed by EOL} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "a\r\n" chan close $f set f [open $path(test1)] chan configure $f -translation auto - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {1 a -1 {}} -test chan-io-6.42 {Tcl_GetsObj: auto mode: several chars} { +} -result {1 a -1 {}} +test chan-io-6.42 {Tcl_GetsObj: auto mode: several chars} -setup { + set x "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" chan close $f set f [open $path(test1)] chan configure $f -translation auto - set x [list [chan gets $f line] $line [chan gets $f line] $line] + lappend x [chan gets $f line] $line [chan gets $f line] $line lappend x [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 4 "abcd" 4 "efgh" 4 "ijkl" 4 "mnop" -1 ""] -test chan-io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel openpipe fileevent} { +} -result {4 abcd 4 efgh 4 ijkl 4 mnop -1 {}} +test chan-io-6.43 {Tcl_GetsObj: input saw cr} -setup { + set x "" +} -constraints {stdio testchannel openpipe fileevent} -body { # if (chanPtr->flags & INPUT_SAW_CR) - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -translation {auto lf} -buffering none chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" chan configure $f -buffersize 16 - set x [list [chan gets $f]] + lappend x [chan gets $f] chan configure $f -blocking 0 lappend x [chan gets $f line] $line [testchannel queuedcr $f] chan configure $f -blocking 1 chan puts -nonewline $f "\nabcd\refg\x1a" lappend x [chan gets $f line] $line [testchannel queuedcr $f] lappend x [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"] -test chan-io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel openpipe fileevent} { +} -result {bbbbbbbbbbbbbbb 15 123456789abcdef 1 4 abcd 0 3 efg} +test chan-io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} -setup { + set x "" +} -constraints {stdio testchannel openpipe fileevent} -body { # not (*eol == '\n') - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -translation {auto lf} -buffering none chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" chan configure $f -buffersize 16 - set x [list [chan gets $f]] + lappend x [chan gets $f] chan configure $f -blocking 0 lappend x [chan gets $f line] $line [testchannel queuedcr $f] chan configure $f -blocking 1 chan puts -nonewline $f "abcd\refg\x1a" lappend x [chan gets $f line] $line [testchannel queuedcr $f] lappend x [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"] -test chan-io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio testchannel openpipe fileevent} { +} -result {bbbbbbbbbbbbbbb 15 123456789abcdef 1 4 abcd 0 3 efg} +test chan-io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} -setup { + set x "" +} -constraints {stdio testchannel openpipe fileevent} -body { # Tcl_ExternalToUtf() - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -translation {auto lf} -buffering none chan configure $f -encoding unicode chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" chan configure $f -buffersize 16 chan gets $f chan configure $f -blocking 0 - set x [list [chan gets $f line] $line [testchannel queuedcr $f]] + lappend x [chan gets $f line] $line [testchannel queuedcr $f] chan configure $f -blocking 1 chan puts -nonewline $f "\nabcd\refg" lappend x [chan gets $f line] $line [testchannel queuedcr $f] +} -cleanup { chan close $f - set x -} [list 15 "123456789abcdef" 1 4 "abcd" 0] -test chan-io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {stdio testchannel openpipe fileevent} { +} -result {15 123456789abcdef 1 4 abcd 0} +test chan-io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} -setup { + set x "" +} -constraints {stdio testchannel openpipe fileevent} -body { # memmove() - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -translation {auto lf} -buffering none chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" chan configure $f -buffersize 16 chan gets $f chan configure $f -blocking 0 - set x [list [chan gets $f line] $line [testchannel queuedcr $f]] + lappend x [chan gets $f line] $line [testchannel queuedcr $f] chan configure $f -blocking 1 chan puts -nonewline $f "\n\x1a" lappend x [chan gets $f line] $line [testchannel queuedcr $f] +} -cleanup { chan close $f - set x -} [list 15 "123456789abcdef" 1 -1 "" 0] -test chan-io-6.47 {Tcl_GetsObj: auto mode: \r at end of buffer, peek for \n} {testchannel} { +} -result {15 123456789abcdef 1 -1 {} 0} +test chan-io-6.47 {Tcl_GetsObj: auto mode: \r at end of buffer, peek for \n} -constraints {testchannel} -body { # (eol == dstEnd) set f [open $path(test1) w] chan configure $f -translation lf @@ -903,11 +922,11 @@ test chan-io-6.47 {Tcl_GetsObj: auto mode: \r at end of buffer, peek for \n} {te chan close $f set f [open $path(test1)] chan configure $f -translation auto -buffersize 16 - set x [list [chan gets $f] [testchannel inputbuffered $f]] + list [chan gets $f] [testchannel inputbuffered $f] +} -cleanup { chan close $f - set x -} [list "123456789012345" 15] -test chan-io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} {testchannel} { +} -result {123456789012345 15} +test chan-io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} -constraints {testchannel} -body { # PeekAhead() did not get any, so (eol >= dstEnd) set f [open $path(test1) w] chan configure $f -translation lf @@ -915,44 +934,44 @@ test chan-io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} { chan close $f set f [open $path(test1)] chan configure $f -translation auto -buffersize 16 - set x [list [chan gets $f] [testchannel queuedcr $f]] + list [chan gets $f] [testchannel queuedcr $f] +} -cleanup { chan close $f - set x -} [list "123456789012345" 1] -test chan-io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} {testchannel} { +} -result {123456789012345 1} +test chan-io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} -constraints {testchannel} -body { # if (*eol == '\n') {skip++} set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "123456\r\n78901" chan close $f set f [open $path(test1)] - set x [list [chan gets $f] [testchannel queuedcr $f] [chan tell $f] [chan gets $f]] + list [chan gets $f] [testchannel queuedcr $f] [chan tell $f] [chan gets $f] +} -cleanup { chan close $f - set x -} [list "123456" 0 8 "78901"] -test chan-io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} {testchannel} { +} -result {123456 0 8 78901} +test chan-io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} -constraints {testchannel} -body { # not (*eol == '\n') set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "123456\r78901" chan close $f set f [open $path(test1)] - set x [list [chan gets $f] [testchannel queuedcr $f] [chan tell $f] [chan gets $f]] + list [chan gets $f] [testchannel queuedcr $f] [chan tell $f] [chan gets $f] +} -cleanup { chan close $f - set x -} [list "123456" 0 7 "78901"] -test chan-io-6.51 {Tcl_GetsObj: auto mode: \n} { +} -result {123456 0 7 78901} +test chan-io-6.51 {Tcl_GetsObj: auto mode: \n} -body { # else if (*eol == '\n') {goto gotoeol;} set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "123456\n78901" chan close $f set f [open $path(test1)] - set x [list [chan gets $f] [chan tell $f] [chan gets $f]] + list [chan gets $f] [chan tell $f] [chan gets $f] +} -cleanup { chan close $f - set x -} [list "123456" 7 "78901"] -test chan-io-6.52 {Tcl_GetsObj: saw EOF character} {testchannel} { +} -result {123456 7 78901} +test chan-io-6.52 {Tcl_GetsObj: saw EOF character} -constraints {testchannel} -body { # if (eof != NULL) set f [open $path(test1) w] chan configure $f -translation lf @@ -960,30 +979,30 @@ test chan-io-6.52 {Tcl_GetsObj: saw EOF character} {testchannel} { chan close $f set f [open $path(test1)] chan configure $f -eofchar \x1a - set x [list [chan gets $f] [testchannel queuedcr $f] [chan tell $f] [chan gets $f]] + list [chan gets $f] [testchannel queuedcr $f] [chan tell $f] [chan gets $f] +} -cleanup { chan close $f - set x -} [list "123456" 0 6 ""] -test chan-io-6.53 {Tcl_GetsObj: device EOF} { +} -result {123456 0 6 {}} +test chan-io-6.53 {Tcl_GetsObj: device EOF} -body { # didn't produce any bytes set f [open $path(test1) w] chan close $f set f [open $path(test1)] - set x [list [chan gets $f line] $line [chan eof $f]] + list [chan gets $f line] $line [chan eof $f] +} -cleanup { chan close $f - set x -} {-1 {} 1} -test chan-io-6.54 {Tcl_GetsObj: device EOF} { +} -result {-1 {} 1} +test chan-io-6.54 {Tcl_GetsObj: device EOF} -body { # got some bytes before EOF. set f [open $path(test1) w] chan puts -nonewline $f abc chan close $f set f [open $path(test1)] - set x [list [chan gets $f line] $line [chan eof $f]] + list [chan gets $f line] $line [chan eof $f] +} -cleanup { chan close $f - set x -} {3 abc 1} -test chan-io-6.55 {Tcl_GetsObj: overconverted} { +} -result {3 abc 1} +test chan-io-6.55 {Tcl_GetsObj: overconverted} -body { # Tcl_ExternalToUtf(), make sure state updated set f [open $path(test1) w] chan configure $f -encoding iso2022-jp @@ -991,32 +1010,40 @@ test chan-io-6.55 {Tcl_GetsObj: overconverted} { chan close $f set f [open $path(test1)] chan configure $f -encoding iso2022-jp - set x [list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"] -test chan-io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio openpipe fileevent} { +} -result [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"] +test chan-io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} -setup { update - set f [open "|[list [interpreter] $path(cat)]" w+] + variable x {} +} -constraints {stdio openpipe fileevent} -body { + set f [openpipe w+ $path(cat)] chan configure $f -buffering none chan puts -nonewline $f "foobar" chan configure $f -blocking 0 - variable x {} - after 500 [namespace code { lappend x timeout }] - chan event $f readable [namespace code { lappend x [chan gets $f] }] + after 500 [namespace code { + lappend x timeout + }] + chan event $f readable [namespace code { + lappend x [chan gets $f] + }] vwait [namespace which -variable x] vwait [namespace which -variable x] chan configure $f -blocking 1 chan puts -nonewline $f "baz\n" - after 500 [namespace code { lappend x timeout }] + after 500 [namespace code { + lappend x timeout + }] chan configure $f -blocking 0 vwait [namespace which -variable x] vwait [namespace which -variable x] + return $x +} -cleanup { chan close $f - set x -} {{} timeout foobarbaz timeout} +} -result {{} timeout foobarbaz timeout} -test chan-io-7.1 {FilterInputBytes: split up character at end of buffer} { +test chan-io-7.1 {FilterInputBytes: split up character at end of buffer} -body { # (result == TCL_CONVERT_MULTIBYTE) set f [open $path(test1) w] chan configure $f -encoding shiftjis @@ -1024,11 +1051,11 @@ test chan-io-7.1 {FilterInputBytes: split up character at end of buffer} { chan close $f set f [open $path(test1)] chan configure $f -encoding shiftjis -buffersize 16 - set x [chan gets $f] + chan gets $f +} -cleanup { chan close $f - set x -} "1234567890123\uff10\uff11\uff12\uff13\uff14" -test chan-io-7.2 {FilterInputBytes: split up character in middle of buffer} { +} -result "1234567890123\uff10\uff11\uff12\uff13\uff14" +test chan-io-7.2 {FilterInputBytes: split up character in middle of buffer} -body { # (bufPtr->nextAdded < bufPtr->bufLength) set f [open $path(test1) w] chan configure $f -encoding binary @@ -1036,44 +1063,46 @@ test chan-io-7.2 {FilterInputBytes: split up character in middle of buffer} { chan close $f set f [open $path(test1)] chan configure $f -encoding shiftjis - set x [list [chan gets $f line] $line [chan eof $f]] + list [chan gets $f line] $line [chan eof $f] +} -cleanup { chan close $f - set x -} [list 10 "1234567890" 0] -test chan-io-7.3 {FilterInputBytes: split up character at EOF} {testchannel} { +} -result {10 1234567890 0} +test chan-io-7.3 {FilterInputBytes: split up character at EOF} -setup { + set x "" +} -constraints {testchannel} -body { set f [open $path(test1) w] chan configure $f -encoding binary chan puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82" chan close $f set f [open $path(test1)] chan configure $f -encoding shiftjis - set x [list [chan gets $f line] $line] + lappend x [chan gets $f line] $line lappend x [chan tell $f] [testchannel inputbuffered $f] [chan eof $f] lappend x [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""] -test chan-io-7.4 {FilterInputBytes: recover from split up character} {stdio openpipe fileevent} { - set f [open "|[list [interpreter] $path(cat)]" w+] +} -result [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""] +test chan-io-7.4 {FilterInputBytes: recover from split up character} -setup { + variable x "" +} -constraints {stdio openpipe fileevent} -body { + set f [openpipe w+ $path(cat)] chan configure $f -encoding binary -buffering none chan puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82" chan configure $f -encoding shiftjis -blocking 0 - chan event $f read [namespace code "ready $f"] - variable x {} - proc ready {f} { - variable x + chan event $f read [namespace code { lappend x [chan gets $f line] $line [chan blocked $f] - } + }] vwait [namespace which -variable x] chan configure $f -encoding binary -blocking 1 chan puts $f "\x51\x82\x52" chan configure $f -encoding shiftjis vwait [namespace which -variable x] + return $x +} -cleanup { chan close $f - set x -} [list -1 "" 1 17 "1234567890123\uff10\uff11\uff12\uff13" 0] +} -result [list -1 "" 1 17 "1234567890123\uff10\uff11\uff12\uff13" 0] -test chan-io-8.1 {PeekAhead: only go to device if no more cached data} {testchannel} { +test chan-io-8.1 {PeekAhead: only go to device if no more cached data} -constraints {testchannel} -body { # (bufPtr->nextPtr == NULL) set f [open $path(test1) w] chan configure $f -encoding ascii -translation lf @@ -1083,43 +1112,43 @@ test chan-io-8.1 {PeekAhead: only go to device if no more cached data} {testchan chan configure $f -encoding ascii -translation auto -buffersize 16 # here chan gets $f - set x [testchannel inputbuffered $f] + testchannel inputbuffered $f +} -cleanup { chan close $f - set x -} "7" -test chan-io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testchannel openpipe fileevent} { +} -result 7 +test chan-io-8.2 {PeekAhead: only go to device if no more cached data} -setup { + variable x {} +} -constraints {stdio testchannel openpipe fileevent} -body { # not (bufPtr->nextPtr == NULL) - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -translation lf -encoding ascii -buffering none chan puts -nonewline $f "123456789012345\r\nbcdefghijklmnopqrstuvwxyz" - variable x {} - chan event $f read [namespace code "ready $f"] - proc ready {f} { - variable x + chan event $f read [namespace code { lappend x [chan gets $f line] $line [testchannel inputbuffered $f] - } + }] chan configure $f -encoding unicode -buffersize 16 -blocking 0 vwait [namespace which -variable x] chan configure $f -translation auto -encoding ascii -blocking 1 # here vwait [namespace which -variable x] + return $x +} -cleanup { chan close $f - set x -} [list -1 "" 42 15 "123456789012345" 25] -test chan-io-8.3 {PeekAhead: no cached data available} {stdio testchannel openpipe fileevent} { +} -result {-1 {} 42 15 123456789012345 25} +test chan-io-8.3 {PeekAhead: no cached data available} -constraints {stdio testchannel openpipe fileevent} -body { # (bytesLeft == 0) - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -translation {auto binary} chan puts -nonewline $f "abcdefghijklmno\r" chan flush $f - set x [list [chan gets $f line] $line [testchannel queuedcr $f]] + list [chan gets $f line] $line [testchannel queuedcr $f] +} -cleanup { chan close $f - set x -} [list 15 "abcdefghijklmno" 1] +} -result {15 abcdefghijklmno 1} set a "123456789012345678901234567890" append a "123456789012345678901234567890" append a "1234567890123456789012345678901" -test chan-io-8.4 {PeekAhead: cached data available in this buffer} { +test chan-io-8.4 {PeekAhead: cached data available in this buffer} -body { # not (bytesLeft == 0) set f [open $path(test1) w+] chan configure $f -translation binary @@ -1130,45 +1159,47 @@ test chan-io-8.4 {PeekAhead: cached data available in this buffer} { # "${a}\r" was converted in one operation (because ENCODING_LINESIZE is # 30). To check if "\n" follows, calls PeekAhead and determines that # cached data is available in buffer w/o having to call driver. - set x [chan gets $f] + chan gets $f +} -cleanup { chan close $f - set x -} $a +} -result $a unset a -test chan-io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel openpipe fileevent} { +test chan-io-8.5 {PeekAhead: don't peek if last read was short} -constraints {stdio testchannel openpipe fileevent} -body { # (bufPtr->nextAdded < bufPtr->length) - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -translation {auto binary} chan puts -nonewline $f "abcdefghijklmno\r" chan flush $f # here - set x [list [chan gets $f line] $line [testchannel queuedcr $f]] + list [chan gets $f line] $line [testchannel queuedcr $f] +} -cleanup { chan close $f - set x -} {15 abcdefghijklmno 1} -test chan-io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel openpipe fileevent} { +} -result {15 abcdefghijklmno 1} +test chan-io-8.6 {PeekAhead: change to non-blocking mode} -constraints {stdio testchannel openpipe fileevent} -body { # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -translation {auto binary} -buffersize 16 chan puts -nonewline $f "abcdefghijklmno\r" chan flush $f # here - set x [list [chan gets $f line] $line [testchannel queuedcr $f]] + list [chan gets $f line] $line [testchannel queuedcr $f] +} -cleanup { chan close $f - set x -} {15 abcdefghijklmno 1} -test chan-io-8.7 {PeekAhead: cleanup} {stdio testchannel openpipe fileevent} { +} -result {15 abcdefghijklmno 1} +test chan-io-8.7 {PeekAhead: cleanup} -setup { + set x "" +} -constraints {stdio testchannel openpipe fileevent} -body { # Make sure bytes are removed from buffer. - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -translation {auto binary} -buffering none chan puts -nonewline $f "abcdefghijklmno\r" # here - set x [list [chan gets $f line] $line [testchannel queuedcr $f]] + lappend x [chan gets $f line] $line [testchannel queuedcr $f] chan puts -nonewline $f "\x1a" lappend x [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {15 abcdefghijklmno 1 -1 {}} +} -result {15 abcdefghijklmno 1 -1 {}} test chan-io-9.1 {CommonGetsCleanup} emptyTest { } {} @@ -1176,18 +1207,18 @@ test chan-io-9.1 {CommonGetsCleanup} emptyTest { test chan-io-10.1 {Tcl_ReadChars: CheckChannelErrors} emptyTest { # no test, need to cause an async error. } {} -test chan-io-10.2 {Tcl_ReadChars: loop until enough copied} { +test chan-io-10.2 {Tcl_ReadChars: loop until enough copied} -body { # one time # for (copied = 0; (unsigned) toRead > 0; ) set f [open $path(test1) w] chan puts $f abcdefghijklmnop chan close $f set f [open $path(test1)] - set x [chan read $f 5] + chan read $f 5 +} -cleanup { chan close $f - set x -} {abcde} -test chan-io-10.3 {Tcl_ReadChars: loop until enough copied} { +} -result {abcde} +test chan-io-10.3 {Tcl_ReadChars: loop until enough copied} -body { # multiple times # for (copied = 0; (unsigned) toRead > 0; ) set f [open $path(test1) w] @@ -1196,34 +1227,34 @@ test chan-io-10.3 {Tcl_ReadChars: loop until enough copied} { set f [open $path(test1)] chan configure $f -buffersize 16 # here - set x [chan read $f 19] + chan read $f 19 +} -cleanup { chan close $f - set x -} {abcdefghijklmnopqrs} -test chan-io-10.4 {Tcl_ReadChars: no more in channel buffer} { +} -result {abcdefghijklmnopqrs} +test chan-io-10.4 {Tcl_ReadChars: no more in channel buffer} -body { # (copiedNow < 0) set f [open $path(test1) w] chan puts -nonewline $f abcdefghijkl chan close $f set f [open $path(test1)] # here - set x [chan read $f 1000] + chan read $f 1000 +} -cleanup { chan close $f - set x -} {abcdefghijkl} -test chan-io-10.5 {Tcl_ReadChars: stop on EOF} { +} -result {abcdefghijkl} +test chan-io-10.5 {Tcl_ReadChars: stop on EOF} -body { # (chanPtr->flags & CHANNEL_EOF) set f [open $path(test1) w] chan puts -nonewline $f abcdefghijkl chan close $f set f [open $path(test1)] # here - set x [chan read $f 1000] + chan read $f 1000 +} -cleanup { chan close $f - set x -} {abcdefghijkl} +} -result {abcdefghijkl} -test chan-io-11.1 {ReadBytes: want to read a lot} { +test chan-io-11.1 {ReadBytes: want to read a lot} -body { # ((unsigned) toRead > (unsigned) srcLen) set f [open $path(test1) w] chan puts -nonewline $f abcdefghijkl @@ -1231,11 +1262,11 @@ test chan-io-11.1 {ReadBytes: want to read a lot} { set f [open $path(test1)] chan configure $f -encoding binary # here - set x [chan read $f 1000] + chan read $f 1000 +} -cleanup { chan close $f - set x -} {abcdefghijkl} -test chan-io-11.2 {ReadBytes: want to read all} { +} -result {abcdefghijkl} +test chan-io-11.2 {ReadBytes: want to read all} -body { # ((unsigned) toRead > (unsigned) srcLen) set f [open $path(test1) w] chan puts -nonewline $f abcdefghijkl @@ -1243,11 +1274,11 @@ test chan-io-11.2 {ReadBytes: want to read all} { set f [open $path(test1)] chan configure $f -encoding binary # here - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} {abcdefghijkl} -test chan-io-11.3 {ReadBytes: allocate more space} { +} -result {abcdefghijkl} +test chan-io-11.3 {ReadBytes: allocate more space} -body { # (toRead > length - offset - 1) set f [open $path(test1) w] chan puts -nonewline $f abcdefghijklmnopqrstuvwxyz @@ -1255,11 +1286,11 @@ test chan-io-11.3 {ReadBytes: allocate more space} { set f [open $path(test1)] chan configure $f -buffersize 16 -encoding binary # here - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} {abcdefghijklmnopqrstuvwxyz} -test chan-io-11.4 {ReadBytes: EOF char found} { +} -result {abcdefghijklmnopqrstuvwxyz} +test chan-io-11.4 {ReadBytes: EOF char found} -body { # (TranslateInputEOL() != 0) set f [open $path(test1) w] chan puts $f abcdefghijklmnopqrstuvwxyz @@ -1267,34 +1298,34 @@ test chan-io-11.4 {ReadBytes: EOF char found} { set f [open $path(test1)] chan configure $f -eofchar m -encoding binary # here - set x [list [chan read $f] [chan eof $f] [chan read $f] [chan eof $f]] + list [chan read $f] [chan eof $f] [chan read $f] [chan eof $f] +} -cleanup { chan close $f - set x -} [list "abcdefghijkl" 1 "" 1] +} -result {abcdefghijkl 1 {} 1} -test chan-io-12.1 {ReadChars: want to read a lot} { +test chan-io-12.1 {ReadChars: want to read a lot} -body { # ((unsigned) toRead > (unsigned) srcLen) set f [open $path(test1) w] chan puts -nonewline $f abcdefghijkl chan close $f set f [open $path(test1)] # here - set x [chan read $f 1000] + chan read $f 1000 +} -cleanup { chan close $f - set x -} {abcdefghijkl} -test chan-io-12.2 {ReadChars: want to read all} { +} -result {abcdefghijkl} +test chan-io-12.2 {ReadChars: want to read all} -body { # ((unsigned) toRead > (unsigned) srcLen) set f [open $path(test1) w] chan puts -nonewline $f abcdefghijkl chan close $f set f [open $path(test1)] # here - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} {abcdefghijkl} -test chan-io-12.3 {ReadChars: allocate more space} { +} -result {abcdefghijkl} +test chan-io-12.3 {ReadChars: allocate more space} -body { # (toRead > length - offset - 1) set f [open $path(test1) w] chan puts -nonewline $f abcdefghijklmnopqrstuvwxyz @@ -1302,22 +1333,21 @@ test chan-io-12.3 {ReadChars: allocate more space} { set f [open $path(test1)] chan configure $f -buffersize 16 # here - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} {abcdefghijklmnopqrstuvwxyz} -test chan-io-12.4 {ReadChars: split-up char} {stdio testchannel openpipe fileevent} { +} -result {abcdefghijklmnopqrstuvwxyz} +test chan-io-12.4 {ReadChars: split-up char} -setup { + variable x {} +} -constraints {stdio testchannel openpipe fileevent} -body { # (srcRead == 0) - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -encoding binary -buffering none -buffersize 16 chan puts -nonewline $f "123456789012345\x96" chan configure $f -encoding shiftjis -blocking 0 - chan event $f read [namespace code "ready $f"] - proc ready {f} { - variable x + chan event $f read [namespace code { lappend x [chan read $f] [testchannel inputbuffered $f] - } - variable x {} + }] chan configure $f -encoding shiftjis vwait [namespace which -variable x] chan configure $f -encoding binary -blocking 1 @@ -1325,17 +1355,20 @@ test chan-io-12.4 {ReadChars: split-up char} {stdio testchannel openpipe fileeve after 500 ;# Give the cat process time to catch up chan configure $f -encoding shiftjis -blocking 0 vwait [namespace which -variable x] + return $x +} -cleanup { chan close $f - set x -} [list "123456789012345" 1 "\u672c" 0] -test chan-io-12.5 {ReadChars: chan events on partial characters} {stdio openpipe fileevent} { +} -result [list "123456789012345" 1 "\u672c" 0] +test chan-io-12.5 {ReadChars: chan events on partial characters} -setup { + variable x {} +} -constraints {stdio openpipe fileevent} -body { set path(test1) [makeFile { chan configure stdout -encoding binary -buffering none chan gets stdin; chan puts -nonewline "\xe7" chan gets stdin; chan puts -nonewline "\x89" chan gets stdin; chan puts -nonewline "\xa6" } test1] - set f [open "|[list [interpreter] $path(test1)]" r+] + set f [openpipe r+ $path(test1)] chan event $f readable [namespace code { lappend x [chan read $f] if {[chan eof $f]} { @@ -1345,7 +1378,6 @@ test chan-io-12.5 {ReadChars: chan events on partial characters} {stdio openpipe chan puts $f "go1" chan flush $f chan configure $f -blocking 0 -encoding utf-8 - variable x {} vwait [namespace which -variable x] after 500 [namespace code { lappend x timeout }] vwait [namespace which -variable x] @@ -1359,32 +1391,31 @@ test chan-io-12.5 {ReadChars: chan events on partial characters} {stdio openpipe vwait [namespace which -variable x] vwait [namespace which -variable x] lappend x [catch {chan close $f} msg] $msg - set x -} "{} timeout {} timeout \u7266 {} eof 0 {}" +} -result "{} timeout {} timeout \u7266 {} eof 0 {}" -test chan-io-13.1 {TranslateInputEOL: cr mode} {} { +test chan-io-13.1 {TranslateInputEOL: cr mode} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "abcd\rdef\r" chan close $f set f [open $path(test1)] chan configure $f -translation cr - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "abcd\ndef\n" -test chan-io-13.2 {TranslateInputEOL: crlf mode} { +} -result "abcd\ndef\n" +test chan-io-13.2 {TranslateInputEOL: crlf mode} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "abcd\r\ndef\r\n" chan close $f set f [open $path(test1)] chan configure $f -translation crlf - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "abcd\ndef\n" -test chan-io-13.3 {TranslateInputEOL: crlf mode: naked cr} { +} -result "abcd\ndef\n" +test chan-io-13.3 {TranslateInputEOL: crlf mode: naked cr} -body { # (src >= srcMax) set f [open $path(test1) w] chan configure $f -translation lf @@ -1392,11 +1423,11 @@ test chan-io-13.3 {TranslateInputEOL: crlf mode: naked cr} { chan close $f set f [open $path(test1)] chan configure $f -translation crlf - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "abcd\ndef\r" -test chan-io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} { +} -result "abcd\ndef\r" +test chan-io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} -body { # (src >= srcMax) set f [open $path(test1) w] chan configure $f -translation lf @@ -1404,11 +1435,11 @@ test chan-io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} { chan close $f set f [open $path(test1)] chan configure $f -translation crlf - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "abcd\ndef\rfgh" -test chan-io-13.5 {TranslateInputEOL: crlf mode: naked lf} { +} -result "abcd\ndef\rfgh" +test chan-io-13.5 {TranslateInputEOL: crlf mode: naked lf} -body { # (src >= srcMax) set f [open $path(test1) w] chan configure $f -translation lf @@ -1416,32 +1447,32 @@ test chan-io-13.5 {TranslateInputEOL: crlf mode: naked lf} { chan close $f set f [open $path(test1)] chan configure $f -translation crlf - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "abcd\ndef\nfgh" -test chan-io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testchannel openpipe fileevent} { +} -result "abcd\ndef\nfgh" +test chan-io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} -setup { + variable x {} + variable y {} +} -constraints {stdio testchannel openpipe fileevent} -body { # (chanPtr->flags & INPUT_SAW_CR) # This test may fail on slower machines. - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -blocking 0 -buffering none -translation {auto lf} - chan event $f read [namespace code "ready $f"] - proc ready {f} { - variable x + chan event $f read [namespace code { lappend x [chan read $f] [testchannel queuedcr $f] - } - variable x {} - variable y {} + }] chan puts -nonewline $f "abcdefghj\r" after 500 [namespace code {set y ok}] vwait [namespace which -variable y] chan puts -nonewline $f "\n01234" after 500 [namespace code {set y ok}] vwait [namespace which -variable y] + return $x +} -cleanup { chan close $f - set x -} [list "abcdefghj\n" 1 "01234" 0] -test chan-io-13.7 {TranslateInputEOL: auto mode: naked \r} {testchannel openpipe} { +} -result [list "abcdefghj\n" 1 "01234" 0] +test chan-io-13.7 {TranslateInputEOL: auto mode: naked \r} -constraints {testchannel openpipe} -body { # (src >= srcMax) set f [open $path(test1) w] chan configure $f -translation lf @@ -1449,11 +1480,11 @@ test chan-io-13.7 {TranslateInputEOL: auto mode: naked \r} {testchannel openpipe chan close $f set f [open $path(test1)] chan configure $f -translation auto - set x [list [chan read $f] [testchannel queuedcr $f]] + list [chan read $f] [testchannel queuedcr $f] +} -cleanup { chan close $f - set x -} [list "abcd\n" 1] -test chan-io-13.8 {TranslateInputEOL: auto mode: \r\n} { +} -result [list "abcd\n" 1] +test chan-io-13.8 {TranslateInputEOL: auto mode: \r\n} -body { # (*src == '\n') set f [open $path(test1) w] chan configure $f -translation lf @@ -1461,22 +1492,22 @@ test chan-io-13.8 {TranslateInputEOL: auto mode: \r\n} { chan close $f set f [open $path(test1)] chan configure $f -translation auto - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "abcd\ndef" -test chan-io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} { +} -result "abcd\ndef" +test chan-io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "abcd\rdef" chan close $f set f [open $path(test1)] chan configure $f -translation auto - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "abcd\ndef" -test chan-io-13.10 {TranslateInputEOL: auto mode: \n} { +} -result "abcd\ndef" +test chan-io-13.10 {TranslateInputEOL: auto mode: \n} -body { # not (*src == '\r') set f [open $path(test1) w] chan configure $f -translation lf @@ -1484,11 +1515,11 @@ test chan-io-13.10 {TranslateInputEOL: auto mode: \n} { chan close $f set f [open $path(test1)] chan configure $f -translation auto - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "abcd\ndef" -test chan-io-13.11 {TranslateInputEOL: EOF char} { +} -result "abcd\ndef" +test chan-io-13.11 {TranslateInputEOL: EOF char} -body { # (*chanPtr->inEofChar != '\0') set f [open $path(test1) w] chan configure $f -translation lf @@ -1496,11 +1527,11 @@ test chan-io-13.11 {TranslateInputEOL: EOF char} { chan close $f set f [open $path(test1)] chan configure $f -translation auto -eofchar e - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "abcd\nd" -test chan-io-13.12 {TranslateInputEOL: find EOF char in src} { +} -result "abcd\nd" +test chan-io-13.12 {TranslateInputEOL: find EOF char in src} -body { # (*chanPtr->inEofChar != '\0') set f [open $path(test1) w] chan configure $f -translation lf @@ -1508,16 +1539,16 @@ test chan-io-13.12 {TranslateInputEOL: find EOF char in src} { chan close $f set f [open $path(test1)] chan configure $f -translation auto -eofchar e - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "\n\n\nab\n\nd" +} -result "\n\n\nab\n\nd" # Test standard handle management. The functions tested are Tcl_SetStdChannel # and Tcl_GetStdChannel. Incidentally we are also testing channel table # management. -if {[info commands testchannel] ne ""} { +if {[testConstraint testchannel]} { set consoleFileNames [lsort [testchannel open]] } else { # just to avoid an error @@ -1525,24 +1556,24 @@ if {[info commands testchannel] ne ""} { } test chan-io-14.1 {Tcl_SetStdChannel and Tcl_GetStdChannel} {testchannel} { - set l "" - lappend l [chan configure stdin -buffering] - lappend l [chan configure stdout -buffering] - lappend l [chan configure stderr -buffering] - lappend l [lsort [testchannel open]] - set l + set result "" + lappend result [chan configure stdin -buffering] + lappend result [chan configure stdout -buffering] + lappend result [chan configure stderr -buffering] + lappend result [lsort [testchannel open]] } [list line line none $consoleFileNames] -test chan-io-14.2 {Tcl_SetStdChannel and Tcl_GetStdChannel} { +test chan-io-14.2 {Tcl_SetStdChannel and Tcl_GetStdChannel} -setup { interp create x - set l "" - lappend l [x eval {chan configure stdin -buffering}] - lappend l [x eval {chan configure stdout -buffering}] - lappend l [x eval {chan configure stderr -buffering}] + set result "" +} -body { + lappend result [x eval {chan configure stdin -buffering}] + lappend result [x eval {chan configure stdout -buffering}] + lappend result [x eval {chan configure stderr -buffering}] +} -cleanup { interp delete x - set l -} {line line none} +} -result {line line none} set path(test3) [makeFile {} test3] -test chan-io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec openpipe} { +test chan-io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} -constraints {exec openpipe} -body { set f [open $path(test1) w] chan puts -nonewline $f { chan close stdin @@ -1564,15 +1595,15 @@ test chan-io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec openpipe} { set f [open $path(test2) r] set f2 [open $path(test3) r] lappend result [chan read $f] [chan read $f2] +} -cleanup { chan close $f chan close $f2 - set result -} {{ +} -result {{ out } {err }} # This test relies on the fact that stdout is used before stderr. -test chan-io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec} { +test chan-io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} -constraints {exec} -body { set f [open $path(test1) w] chan puts -nonewline $f { chan close stdin chan close stdout @@ -1581,7 +1612,8 @@ test chan-io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec} { chan puts $f [list open $path(test1) r]] chan puts $f "set f2 \[[list open $path(test2) w]]" chan puts $f "set f3 \[[list open $path(test3) w]]" - chan puts $f { chan puts stdout [chan gets stdin] + chan puts $f { + chan puts stdout [chan gets stdin] chan puts stdout $f2 chan puts stderr $f3 chan close $f @@ -1593,10 +1625,10 @@ test chan-io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec} { set f [open $path(test2) r] set f2 [open $path(test3) r] lappend result [chan read $f] [chan read $f2] +} -cleanup { chan close $f chan close $f2 - set result -} {{ chan close stdin +} -result {{ chan close stdin stdout } {stderr }} @@ -1653,10 +1685,10 @@ test chan-io-14.8 {reuse of stdio special channels} -setup { chan puts [chan gets $f] } chan close $f - set f [open "|[list [interpreter] $path(script)]" r] - set c [chan gets $f] + set f [openpipe r $path(script)] + chan gets $f +} -cleanup { chan close $f - set c } -result hello test chan-io-14.9 {reuse of stdio special channels} -setup { file delete $path(script) @@ -1673,15 +1705,14 @@ test chan-io-14.9 {reuse of stdio special channels} -setup { chan puts [chan gets $f] } chan close $f - set f [open "|[list [interpreter] $path(script) [array get path]]" r] - set c [chan gets $f] - chan close $f - set c + set f [openpipe r $path(script) [array get path]] + chan gets $f } -cleanup { + chan close $f # Added delay to give Windows time to stop the spawned process and clean # up its grip on the file test1. Added delete as proper test cleanup. # The failing tests were 18.1 and 18.2 as first re-users of file "test1". - after 10000 + after [expr {[testConstraint win] ? 10000 : 500}] file delete $path(script) file delete $path(test1) } -result hello @@ -1699,39 +1730,42 @@ test chan-io-16.1 {Tcl_DeleteChan CloseHandler} emptyTest { # These functions use "eof stdin" to ensure that the standard channels are # added to the channel table of the interpreter. -test chan-io-17.1 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} { +test chan-io-17.1 {GetChannelTable, DeleteChannelTable on std handles} -setup { + set l "" +} -constraints {testchannel} -body { set l1 [testchannel refcount stdin] chan eof stdin interp create x - set l "" - lappend l [expr [testchannel refcount stdin] - $l1] + lappend l [expr {[testchannel refcount stdin] - $l1}] x eval {chan eof stdin} - lappend l [expr [testchannel refcount stdin] - $l1] + lappend l [expr {[testchannel refcount stdin] - $l1}] interp delete x - lappend l [expr [testchannel refcount stdin] - $l1] -} {0 1 0} -test chan-io-17.2 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} { + lappend l [expr {[testchannel refcount stdin] - $l1}] +} -result {0 1 0} +test chan-io-17.2 {GetChannelTable, DeleteChannelTable on std handles} -setup { + set l "" +} -constraints {testchannel} -body { set l1 [testchannel refcount stdout] chan eof stdin interp create x - set l "" - lappend l [expr [testchannel refcount stdout] - $l1] + lappend l [expr {[testchannel refcount stdout] - $l1}] x eval {chan eof stdout} - lappend l [expr [testchannel refcount stdout] - $l1] + lappend l [expr {[testchannel refcount stdout] - $l1}] interp delete x - lappend l [expr [testchannel refcount stdout] - $l1] -} {0 1 0} -test chan-io-17.3 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} { + lappend l [expr {[testchannel refcount stdout] - $l1}] +} -result {0 1 0} +test chan-io-17.3 {GetChannelTable, DeleteChannelTable on std handles} -setup { + set l "" +} -constraints {testchannel} -body { set l1 [testchannel refcount stderr] chan eof stdin interp create x - set l "" - lappend l [expr [testchannel refcount stderr] - $l1] + lappend l [expr {[testchannel refcount stderr] - $l1}] x eval {chan eof stderr} - lappend l [expr [testchannel refcount stderr] - $l1] + lappend l [expr {[testchannel refcount stderr] - $l1}] interp delete x - lappend l [expr [testchannel refcount stderr] - $l1] -} {0 1 0} + lappend l [expr {[testchannel refcount stderr] - $l1}] +} -result {0 1 0} test chan-io-18.1 {Tcl_RegisterChannel, Tcl_UnregisterChannel} -setup { file delete -force $path(test1) @@ -1745,8 +1779,7 @@ test chan-io-18.1 {Tcl_RegisterChannel, Tcl_UnregisterChannel} -setup { } else { lappend l "very broken: $f found after being chan closed" } - string equal [string tolower $l] \ - [list 1 "can not find channel named \"$f\""] + string equal $l [list 1 "can not find channel named \"$f\""] } -result 1 test chan-io-18.2 {Tcl_RegisterChannel, Tcl_UnregisterChannel} -setup { file delete -force $path(test1) @@ -1767,8 +1800,7 @@ test chan-io-18.2 {Tcl_RegisterChannel, Tcl_UnregisterChannel} -setup { } else { lappend l "very broken: $f found after being chan closed" } - string equal [string tolower $l] \ - [list 1 2 1 1 "can not find channel named \"$f\""] + string equal $l [list 1 2 1 1 "can not find channel named \"$f\""] } -result 1 test chan-io-18.3 {Tcl_RegisterChannel, Tcl_UnregisterChannel} -setup { file delete $path(test1) @@ -1787,20 +1819,20 @@ test chan-io-18.3 {Tcl_RegisterChannel, Tcl_UnregisterChannel} -setup { } else { lappend l "very broken: $f found after being chan closed" } - string equal [string tolower $l] \ - [list 1 2 1 "can not find channel named \"$f\""] + string equal $l [list 1 2 1 "can not find channel named \"$f\""] } -result 1 test chan-io-19.1 {Tcl_GetChannel->Tcl_GetStdChannel, standard handles} { chan eof stdin } 0 -test chan-io-19.2 {testing Tcl_GetChannel, user opened handle} { +test chan-io-19.2 {testing Tcl_GetChannel, user opened handle} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] - set x [chan eof $f] + chan eof $f +} -cleanup { chan close $f - set x -} 0 +} -result 0 test chan-io-19.3 {Tcl_GetChannel, channel not found} -body { chan eof file34 } -returnCodes error -result {can not find channel named "file34"} @@ -1816,35 +1848,36 @@ test chan-io-19.4 {Tcl_CreateChannel, insertion into channel table} -setup { } else { lappend l "very broken: $f found after being chan closed" } - string equal [string tolower $l] \ - [list 0 "can not find channel named \"$f\""] + string equal $l [list 0 "can not find channel named \"$f\""] } -result 1 -test chan-io-20.1 {Tcl_CreateChannel: initial settings} { - set a [open $path(test2) w] +test chan-io-20.1 {Tcl_CreateChannel: initial settings} -setup { set old [encoding system] +} -body { + set a [open $path(test2) w] encoding system ascii set f [open $path(test1) w] - set x [chan configure $f -encoding] - chan close $f + chan configure $f -encoding +} -cleanup { encoding system $old + chan close $f chan close $a - set x -} {ascii} -test chan-io-20.2 {Tcl_CreateChannel: initial settings} {win} { +} -result {ascii} +test chan-io-20.2 {Tcl_CreateChannel: initial settings} -constraints {win} -body { set f [open $path(test1) w+] - set x [list [chan configure $f -eofchar] [chan configure $f -translation]] + list [chan configure $f -eofchar] [chan configure $f -translation] +} -cleanup { chan close $f - set x -} [list [list \x1a ""] {auto crlf}] -test chan-io-20.3 {Tcl_CreateChannel: initial settings} {unix} { +} -result [list [list \x1a ""] {auto crlf}] +test chan-io-20.3 {Tcl_CreateChannel: initial settings} -constraints {unix} -body { set f [open $path(test1) w+] - set x [list [chan configure $f -eofchar] [chan configure $f -translation]] + list [chan configure $f -eofchar] [chan configure $f -translation] +} -cleanup { chan close $f - set x -} {{{} {}} {auto lf}} -set path(stdout) [makeFile {} stdout] -test chan-io-20.5 {Tcl_CreateChannel: install channel in empty slot} {stdio openpipe} { +} -result {{{} {}} {auto lf}} +test chan-io-20.5 {Tcl_CreateChannel: install channel in empty slot} -setup { + set path(stdout) [makeFile {} stdout] +} -constraints {stdio openpipe} -body { set f [open $path(script) w] chan puts -nonewline $f { chan close stdout @@ -1855,10 +1888,11 @@ test chan-io-20.5 {Tcl_CreateChannel: install channel in empty slot} {stdio open chan puts stderr [chan configure stdout -buffersize] } chan close $f - set f [open "|[list [interpreter] $path(script)]"] - catch {chan close $f} msg - set msg -} {777} + set f [openpipe r $path(script)] + chan close $f +} -cleanup { + removeFile $path(stdout) +} -returnCodes error -result {777} test chan-io-21.1 {Chan CloseChannelsOnExit} emptyTest { } {} @@ -1873,99 +1907,107 @@ test chan-io-22.1 {Tcl_GetChannelMode} emptyTest { # Not used anywhere in Tcl. } {} -test chan-io-23.1 {Tcl_GetChannelName} {testchannel} { +test chan-io-23.1 {Tcl_GetChannelName} -constraints {testchannel} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] set n [testchannel name $f] + expr {$n eq $f ? "ok" : "$n != $f"} +} -cleanup { chan close $f - string compare $n $f -} 0 +} -result ok -test chan-io-24.1 {Tcl_GetChannelType} {testchannel} { +test chan-io-24.1 {Tcl_GetChannelType} -constraints {testchannel} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] - set t [testchannel type $f] + testchannel type $f +} -cleanup { chan close $f - string compare $t file -} 0 +} -result "file" -test chan-io-25.1 {Tcl_GetChannelHandle, input} {testchannel} { +test chan-io-25.1 {Tcl_GetChannelHandle, input} -setup { + set l "" +} -constraints {testchannel} -body { set f [open $path(test1) w] chan configure $f -translation lf -eofchar {} chan puts $f "1234567890\n098765432" chan close $f set f [open $path(test1) r] chan gets $f - set l "" lappend l [testchannel inputbuffered $f] lappend l [chan tell $f] +} -cleanup { chan close $f - set l -} {10 11} -test chan-io-25.2 {Tcl_GetChannelHandle, output} {testchannel} { +} -result {10 11} +test chan-io-25.2 {Tcl_GetChannelHandle, output} -setup { file delete $path(test1) + set l "" +} -constraints {testchannel} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts $f hello - set l "" lappend l [testchannel outputbuffered $f] lappend l [chan tell $f] chan flush $f lappend l [testchannel outputbuffered $f] lappend l [chan tell $f] +} -cleanup { chan close $f file delete $path(test1) - set l -} {6 6 0 6} +} -result {6 6 0 6} -test chan-io-26.1 {Tcl_GetChannelInstanceData} {stdio openpipe} { +test chan-io-26.1 {Tcl_GetChannelInstanceData} -body { # "pid" command uses Tcl_GetChannelInstanceData # Don't care what pid is (but must be a number), just want to exercise it. - set f [open "|[list [interpreter] << exit]"] - expr [pid $f] + set f [openpipe r << exit] + pid $f +} -constraints {stdio openpipe} -cleanup { chan close $f -} {} +} -match regexp -result {^\d+$} # Test flushing. The functions tested here are FlushChannel. -test chan-io-27.1 {FlushChannel, no output buffered} { +test chan-io-27.1 {FlushChannel, no output buffered} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan flush $f - set s [file size $path(test1)] + file size $path(test1) +} -cleanup { chan close $f - set s -} 0 -test chan-io-27.2 {FlushChannel, some output buffered} { +} -result 0 +test chan-io-27.2 {FlushChannel, some output buffered} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf -eofchar {} - set l "" chan puts $f hello lappend l [file size $path(test1)] chan flush $f lappend l [file size $path(test1)] chan close $f lappend l [file size $path(test1)] - set l -} {0 6 6} -test chan-io-27.3 {FlushChannel, implicit flush on chan close} { +} -result {0 6 6} +test chan-io-27.3 {FlushChannel, implicit flush on chan close} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf -eofchar {} - set l "" chan puts $f hello lappend l [file size $path(test1)] chan close $f lappend l [file size $path(test1)] - set l -} {0 6} -test chan-io-27.4 {FlushChannel, implicit flush when buffer fills} { +} -result {0 6} +test chan-io-27.4 {FlushChannel, implicit flush when buffer fills} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf -eofchar {} chan configure $f -buffersize 60 - set l "" lappend l [file size $path(test1)] for {set i 0} {$i < 12} {incr i} { chan puts $f hello @@ -1973,15 +2015,15 @@ test chan-io-27.4 {FlushChannel, implicit flush when buffer fills} { lappend l [file size $path(test1)] chan flush $f lappend l [file size $path(test1)] +} -cleanup { chan close $f - set l -} {0 60 72} -test chan-io-27.5 {FlushChannel, implicit flush when buffer fills and on chan close} \ - {unixOrPc} { +} -result {0 60 72} +test chan-io-27.5 {FlushChannel, implicit flush when buffer fills and on chan close} -setup { file delete $path(test1) + set l "" +} -constraints {unixOrPc} -body { set f [open $path(test1) w] chan configure $f -translation lf -buffersize 60 -eofchar {} - set l "" lappend l [file size $path(test1)] for {set i 0} {$i < 12} {incr i} { chan puts $f hello @@ -1989,14 +2031,13 @@ test chan-io-27.5 {FlushChannel, implicit flush when buffer fills and on chan cl lappend l [file size $path(test1)] chan close $f lappend l [file size $path(test1)] - set l -} {0 60 72} +} -result {0 60 72} set path(pipe) [makeFile {} pipe] set path(output) [makeFile {} output] -test chan-io-27.6 {FlushChannel, async flushing, async chan close} \ - {stdio asyncPipeChan Close openpipe} { +test chan-io-27.6 {FlushChannel, async flushing, async chan close} -setup { file delete $path(pipe) file delete $path(output) +} -constraints {stdio asyncPipeChan Close openpipe} -body { set f [open $path(pipe) w] chan puts $f "set f \[[list open $path(output) w]]" chan puts $f { @@ -2014,7 +2055,7 @@ test chan-io-27.6 {FlushChannel, async flushing, async chan close} \ } set f [open $path(output) w] chan close $f - set f [open "|[list [interpreter] $path(pipe)]" w] + set f [openpipe w $path(pipe)] chan configure $f -blocking off chan puts -nonewline $f $x chan close $f @@ -2028,26 +2069,28 @@ test chan-io-27.6 {FlushChannel, async flushing, async chan close} \ } else { set result ok } -} ok +} -result ok # Tests closing a channel. The functions tested are Chan CloseChannel and # Tcl_Chan Close. -test chan-io-28.1 {Chan CloseChannel called when all references are dropped} {testchannel} { +test chan-io-28.1 {Chan CloseChannel called when all references are dropped} -setup { file delete $path(test1) + set l "" +} -constraints {testchannel} -body { set f [open $path(test1) w] interp create x interp share "" $f x - set l "" lappend l [testchannel refcount $f] x eval chan close $f interp delete x lappend l [testchannel refcount $f] +} -cleanup { chan close $f - set l -} {2 1} -test chan-io-28.2 {Chan CloseChannel called when all references are dropped} { +} -result {2 1} +test chan-io-28.2 {Chan CloseChannel called when all references are dropped} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] interp create x interp share "" $f x @@ -2057,14 +2100,14 @@ test chan-io-28.2 {Chan CloseChannel called when all references are dropped} { x eval chan close $f interp delete x set f [open $path(test1) r] - set l [chan gets $f] + chan gets $f +} -cleanup { chan close $f - set l -} abcdef -test chan-io-28.3 {Chan CloseChannel, not called before output queue is empty} \ - {stdio asyncPipeChan Close nonPortable openpipe} { +} -result abcdef +test chan-io-28.3 {Chan CloseChannel, not called before output queue is empty} -setup { file delete $path(pipe) file delete $path(output) +} -constraints {stdio asyncPipeChan Close nonPortable openpipe} -body { set f [open $path(pipe) w] chan puts $f { # Need to not have eof char appended on chan close, because the other @@ -2087,7 +2130,7 @@ test chan-io-28.3 {Chan CloseChannel, not called before output queue is empty} \ } set f [open $path(output) w] chan close $f - set f [open "|[list [interpreter] pipe]" r+] + set f [openpipe r+ $path(pipe)] chan configure $f -blocking off -eofchar {} chan puts -nonewline $f $x chan close $f @@ -2101,10 +2144,11 @@ test chan-io-28.3 {Chan CloseChannel, not called before output queue is empty} \ } else { set result ok } -} ok -test chan-io-28.4 {Tcl_Chan Close} {testchannel} { +} -result ok +test chan-io-28.4 {Tcl_Chan Close} -constraints {testchannel} -setup { file delete $path(test1) set l "" +} -body { lappend l [lsort [testchannel open]] set f [open $path(test1) w] lappend l [lsort [testchannel open]] @@ -2113,8 +2157,8 @@ test chan-io-28.4 {Tcl_Chan Close} {testchannel} { set x [list $consoleFileNames \ [lsort [list {*}$consoleFileNames $f]] \ $consoleFileNames] - string compare $l $x -} 0 + expr {$l eq $x ? "ok" : "{$l} != {$x}"} +} -result ok test chan-io-28.5 {Tcl_Chan Close vs standard handles} -setup { file delete $path(script) } -constraints {stdio unix testchannel openpipe} -body { @@ -2124,7 +2168,7 @@ test chan-io-28.5 {Tcl_Chan Close vs standard handles} -setup { chan puts [testchannel open] } chan close $f - set f [open "|[list [interpreter] $path(script)]" r] + set f [openpipe r $path(script)] set l [chan gets $f] chan close $f lsort $l @@ -2132,27 +2176,28 @@ test chan-io-28.5 {Tcl_Chan Close vs standard handles} -setup { test chan-io-28.6 {Tcl_CloseEx (half-close) pipe} -setup { set cat [makeFile { fconfigure stdout -buffering line - while {[gets stdin line]>=0} {puts $line} + while {[gets stdin line] >= 0} {puts $line} puts DONE exit 0 } cat.tcl] + variable done } -body { - set ::ff [open "|[list [interpreter] $cat]" r+] - puts $::ff Hey - close $::ff w - set timer [after 1000 {set ::done Failed}] - set ::acc {} - fileevent $::ff readable { - if {[gets $::ff line]<0} { - set ::done Succeeded + set ff [openpipe r+ $cat] + puts $ff Hey + close $ff w + set timer [after 1000 [namespace code {set done Failed}]] + set acc {} + fileevent $ff readable [namespace code { + if {[gets $ff line] < 0} { + set done Succeeded } else { - lappend ::acc $line + lappend acc $line } - } - vwait ::done + }] + vwait [namespace which -variable done] after cancel $timer - close $::ff r - list $::done $::acc + close $ff r + list $done $acc } -cleanup { removeFile cat.tcl } -result {Succeeded {Hey DONE}} @@ -2163,102 +2208,108 @@ test chan-io-28.7 {Tcl_CloseEx (half-close) socket} -setup { puts [lindex [fconfigure $s -sockname] 2] flush stdout vwait ::sok - fconfigure $::sok -buffering line - while {[gets $::sok line]>=0} {puts $::sok $line} - puts $::sok DONE + fconfigure $sok -buffering line + while {[gets $sok line]>=0} {puts $sok $line} + puts $sok DONE exit 0 } echo.tcl] } -body { - set ::ff [open "|[list [interpreter] $echo]" r] - gets $::ff port - set ::s [socket 127.0.0.1 $port] - puts $::s Hey - close $::s w - set timer [after 1000 {set ::done Failed}] - set ::acc {} - fileevent $::s readable { - if {[gets $::s line]<0} { - set ::done Succeeded + set ff [openpipe r $echo] + gets $ff port + set s [socket 127.0.0.1 $port] + puts $s Hey + close $s w + set timer [after 1000 [namespace code {set ::done Failed}]] + set acc {} + fileevent $s readable [namespace code { + if {[gets $s line]<0} { + set done Succeeded } else { - lappend ::acc $line + lappend acc $line } - } - vwait ::done + }] + vwait [namespace which -variable done] after cancel $timer - close $::s r - close $::ff - list $::done $::acc + close $s r + close $ff + list $done $acc } -cleanup { removeFile echo.tcl } -result {Succeeded {Hey DONE}} -test chan-io-29.1 {Tcl_WriteChars, channel not writable} { - list [catch {chan puts stdin hello} msg] $msg -} {1 {channel "stdin" wasn't opened for writing}} -test chan-io-29.2 {Tcl_WriteChars, empty string} { +test chan-io-29.1 {Tcl_WriteChars, channel not writable} -body { + chan puts stdin hello +} -returnCodes error -result {channel "stdin" wasn't opened for writing} +test chan-io-29.2 {Tcl_WriteChars, empty string} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -eofchar {} chan puts -nonewline $f "" chan close $f file size $path(test1) -} 0 -test chan-io-29.3 {Tcl_WriteChars, nonempty string} { +} -result 0 +test chan-io-29.3 {Tcl_WriteChars, nonempty string} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -eofchar {} chan puts -nonewline $f hello chan close $f file size $path(test1) -} 5 -test chan-io-29.4 {Tcl_WriteChars, buffering in full buffering mode} {testchannel} { +} -result 5 +test chan-io-29.4 {Tcl_WriteChars, buffering in full buffering mode} -setup { file delete $path(test1) + set l "" +} -constraints {testchannel} -body { set f [open $path(test1) w] chan configure $f -translation lf -buffering full -eofchar {} chan puts $f hello - set l "" lappend l [testchannel outputbuffered $f] lappend l [file size $path(test1)] chan flush $f lappend l [testchannel outputbuffered $f] lappend l [file size $path(test1)] +} -cleanup { chan close $f - set l -} {6 0 0 6} -test chan-io-29.5 {Tcl_WriteChars, buffering in line buffering mode} {testchannel} { +} -result {6 0 0 6} +test chan-io-29.5 {Tcl_WriteChars, buffering in line buffering mode} -setup { file delete $path(test1) + set l "" +} -constraints {testchannel} -body { set f [open $path(test1) w] chan configure $f -translation lf -buffering line -eofchar {} chan puts -nonewline $f hello - set l "" lappend l [testchannel outputbuffered $f] lappend l [file size $path(test1)] chan puts $f hello lappend l [testchannel outputbuffered $f] lappend l [file size $path(test1)] +} -cleanup { chan close $f - set l -} {5 0 0 11} -test chan-io-29.6 {Tcl_WriteChars, buffering in no buffering mode} {testchannel} { +} -result {5 0 0 11} +test chan-io-29.6 {Tcl_WriteChars, buffering in no buffering mode} -setup { file delete $path(test1) + set l "" +} -constraints {testchannel} -body { set f [open $path(test1) w] chan configure $f -translation lf -buffering none -eofchar {} chan puts -nonewline $f hello - set l "" lappend l [testchannel outputbuffered $f] lappend l [file size $path(test1)] chan puts $f hello lappend l [testchannel outputbuffered $f] lappend l [file size $path(test1)] +} -cleanup { chan close $f - set l -} {0 5 0 11} -test chan-io-29.7 {Tcl_Flush, full buffering} {testchannel} { +} -result {0 5 0 11} +test chan-io-29.7 {Tcl_Flush, full buffering} -setup { file delete $path(test1) + set l "" +} -constraints {testchannel} -body { set f [open $path(test1) w] chan configure $f -translation lf -buffering full -eofchar {} chan puts -nonewline $f hello - set l "" lappend l [testchannel outputbuffered $f] lappend l [file size $path(test1)] chan puts $f hello @@ -2267,15 +2318,16 @@ test chan-io-29.7 {Tcl_Flush, full buffering} {testchannel} { chan flush $f lappend l [testchannel outputbuffered $f] lappend l [file size $path(test1)] +} -cleanup { chan close $f - set l -} {5 0 11 0 0 11} -test chan-io-29.8 {Tcl_Flush, full buffering} {testchannel} { +} -result {5 0 11 0 0 11} +test chan-io-29.8 {Tcl_Flush, full buffering} -setup { file delete $path(test1) + set l "" +} -constraints {testchannel} -body { set f [open $path(test1) w] chan configure $f -translation lf -buffering line chan puts -nonewline $f hello - set l "" lappend l [testchannel outputbuffered $f] lappend l [file size $path(test1)] chan flush $f @@ -2287,14 +2339,15 @@ test chan-io-29.8 {Tcl_Flush, full buffering} {testchannel} { chan flush $f lappend l [testchannel outputbuffered $f] lappend l [file size $path(test1)] +} -cleanup { chan close $f - set l -} {5 0 0 5 0 11 0 11} -test chan-io-29.9 {Tcl_Flush, channel not writable} { - list [catch {chan flush stdin} msg] $msg -} {1 {channel "stdin" wasn't opened for writing}} -test chan-io-29.10 {Tcl_WriteChars, looping and buffering} { +} -result {5 0 0 5 0 11 0 11} +test chan-io-29.9 {Tcl_Flush, channel not writable} -body { + chan flush stdin +} -returnCodes error -result {channel "stdin" wasn't opened for writing} +test chan-io-29.10 {Tcl_WriteChars, looping and buffering} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan configure $f1 -translation lf -eofchar {} set f2 [open $path(longfile) r] @@ -2304,9 +2357,10 @@ test chan-io-29.10 {Tcl_WriteChars, looping and buffering} { chan close $f2 chan close $f1 file size $path(test1) -} 387 -test chan-io-29.11 {Tcl_WriteChars, no newline, implicit flush} { +} -result 387 +test chan-io-29.11 {Tcl_WriteChars, no newline, implicit flush} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan configure $f1 -eofchar {} set f2 [open $path(longfile) r] @@ -2316,10 +2370,11 @@ test chan-io-29.11 {Tcl_WriteChars, no newline, implicit flush} { chan close $f1 chan close $f2 file size $path(test1) -} 377 -test chan-io-29.12 {Tcl_WriteChars on a pipe} {stdio openpipe} { +} -result 377 +test chan-io-29.12 {Tcl_WriteChars on a pipe} -setup { file delete $path(test1) file delete $path(pipe) +} -constraints {stdio openpipe} -body { set f1 [open $path(pipe) w] chan puts $f1 "set f1 \[[list open $path(longfile) r]]" chan puts $f1 { @@ -2328,23 +2383,25 @@ test chan-io-29.12 {Tcl_WriteChars on a pipe} {stdio openpipe} { } } chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r] + set f1 [openpipe r $path(pipe)] set f2 [open $path(longfile) r] set y ok for {set x 0} {$x < 10} {incr x} { set l1 [chan gets $f1] set l2 [chan gets $f2] - if {"$l1" != "$l2"} { - set y broken + if {$l1 ne $l2} { + set y broken:$x } } + return $y +} -cleanup { chan close $f1 chan close $f2 - set y -} ok -test chan-io-29.13 {Tcl_WriteChars to a pipe, line buffered} {stdio openpipe} { +} -result ok +test chan-io-29.13 {Tcl_WriteChars to a pipe, line buffered} -setup { file delete $path(test1) file delete $path(pipe) +} -constraints {stdio openpipe} -body { set f1 [open $path(pipe) w] chan puts $f1 { chan puts [chan gets stdin] @@ -2352,70 +2409,74 @@ test chan-io-29.13 {Tcl_WriteChars to a pipe, line buffered} {stdio openpipe} { } chan close $f1 set y ok - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] chan configure $f1 -buffering line set f2 [open $path(longfile) r] set line [chan gets $f2] chan puts $f1 $line set backline [chan gets $f1] - if {"$line" != "$backline"} { - set y broken + if {$line ne $backline} { + set y broken1 } set line [chan gets $f2] chan puts $f1 $line set backline [chan gets $f1] - if {"$line" != "$backline"} { - set y broken + if {$line ne $backline} { + set y broken2 } + return $y +} -cleanup { chan close $f1 chan close $f2 - set y -} ok -test chan-io-29.14 {Tcl_WriteChars, buffering and implicit flush at chan close} { +} -result ok +test chan-io-29.14 {Tcl_WriteChars, buffering and implicit flush at chan close} -setup { file delete $path(test3) +} -body { set f [open $path(test3) w] chan puts -nonewline $f "Text1" chan puts -nonewline $f " Text 2" chan puts $f " Text 3" chan close $f set f [open $path(test3) r] - set x [chan gets $f] + chan gets $f +} -cleanup { chan close $f - set x -} {Text1 Text 2 Text 3} -test chan-io-29.15 {Tcl_Flush, channel not open for writing} { +} -result {Text1 Text 2 Text 3} +test chan-io-29.15 {Tcl_Flush, channel not open for writing} -setup { file delete $path(test1) set fd [open $path(test1) w] chan close $fd +} -body { set fd [open $path(test1) r] - set x [list [catch {chan flush $fd} msg] $msg] - chan close $fd - string compare $x \ - [list 1 "channel \"$fd\" wasn't opened for writing"] -} 0 -test chan-io-29.16 {Tcl_Flush on pipe opened only for reading} {stdio openpipe} { - set fd [open "|[list [interpreter] cat longfile]" r] - set x [list [catch {chan flush $fd} msg] $msg] + chan flush $fd +} -returnCodes error -cleanup { catch {chan close $fd} - string compare $x \ - [list 1 "channel \"$fd\" wasn't opened for writing"] -} 0 -test chan-io-29.17 {Tcl_WriteChars buffers, then Tcl_Flush flushes} { +} -match glob -result {channel "*" wasn't opened for writing} +test chan-io-29.16 {Tcl_Flush on pipe opened only for reading} -setup { + set fd [openpipe r cat longfile] +} -constraints {stdio openpipe} -body { + chan flush $fd +} -returnCodes error -cleanup { + catch {chan close $fd} +} -match glob -result {channel "*" wasn't opened for writing} +test chan-io-29.17 {Tcl_WriteChars buffers, then Tcl_Flush flushes} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan configure $f1 -translation lf chan puts $f1 hello chan puts $f1 hello chan puts $f1 hello chan flush $f1 - set x [file size $path(test1)] + file size $path(test1) +} -cleanup { chan close $f1 - set x -} 18 -test chan-io-29.18 {Tcl_WriteChars and Tcl_Flush intermixed} { +} -result 18 +test chan-io-29.18 {Tcl_WriteChars and Tcl_Flush intermixed} -setup { file delete $path(test1) set x "" set f1 [open $path(test1) w] +} -body { chan configure $f1 -translation lf chan puts $f1 hello chan puts $f1 hello @@ -2428,11 +2489,12 @@ test chan-io-29.18 {Tcl_WriteChars and Tcl_Flush intermixed} { chan puts $f1 hello chan flush $f1 lappend x [file size $path(test1)] +} -cleanup { chan close $f1 - set x -} {18 24 30} -test chan-io-29.19 {Explicit and implicit flushes} { +} -result {18 24 30} +test chan-io-29.19 {Explicit and implicit flushes} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan configure $f1 -translation lf -eofchar {} set x "" @@ -2447,10 +2509,10 @@ test chan-io-29.19 {Explicit and implicit flushes} { chan puts $f1 hello chan close $f1 lappend x [file size $path(test1)] - set x -} {18 24 30} -test chan-io-29.20 {Implicit flush when buffer is full} { +} -result {18 24 30} +test chan-io-29.20 {Implicit flush when buffer is full} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan configure $f1 -translation lf -eofchar {} set line "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" @@ -2465,24 +2527,25 @@ test chan-io-29.20 {Implicit flush when buffer is full} { lappend z [file size $path(test1)] chan close $f1 lappend z [file size $path(test1)] - set z -} {4096 12288 12600} -test chan-io-29.21 {Tcl_Flush to pipe} {stdio openpipe} { +} -result {4096 12288 12600} +test chan-io-29.21 {Tcl_Flush to pipe} -setup { file delete $path(pipe) +} -constraints {stdio openpipe} -body { set f1 [open $path(pipe) w] chan puts $f1 {set x [chan read stdin 6]} chan puts $f1 {set cnt [string length $x]} chan puts $f1 {chan puts "read $cnt characters"} chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] chan puts $f1 hello chan flush $f1 - set x [chan gets $f1] + chan gets $f1 +} -cleanup { catch {chan close $f1} - set x -} "read 6 characters" -test chan-io-29.22 {Tcl_Flush called at other end of pipe} {stdio openpipe} { +} -result "read 6 characters" +test chan-io-29.22 {Tcl_Flush called at other end of pipe} -setup { file delete $path(pipe) +} -constraints {stdio openpipe} -body { set f1 [open $path(pipe) w] chan puts $f1 { chan configure stdout -buffering full @@ -2494,18 +2557,19 @@ test chan-io-29.22 {Tcl_Flush called at other end of pipe} {stdio openpipe} { chan flush stdout } chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] set x "" lappend x [chan gets $f1] lappend x [chan gets $f1] chan puts $f1 hello chan flush $f1 lappend x [chan gets $f1] +} -cleanup { chan close $f1 - set x -} {hello hello bye} -test chan-io-29.23 {Tcl_Flush and line buffering at end of pipe} {stdio openpipe} { +} -result {hello hello bye} +test chan-io-29.23 {Tcl_Flush and line buffering at end of pipe} -setup { file delete $path(pipe) +} -constraints {stdio openpipe} -body { set f1 [open $path(pipe) w] chan puts $f1 { chan puts hello @@ -2514,108 +2578,112 @@ test chan-io-29.23 {Tcl_Flush and line buffering at end of pipe} {stdio openpipe chan puts bye } chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] set x "" lappend x [chan gets $f1] lappend x [chan gets $f1] chan puts $f1 hello chan flush $f1 lappend x [chan gets $f1] +} -cleanup { chan close $f1 - set x -} {hello hello bye} -test chan-io-29.24 {Tcl_WriteChars and Tcl_Flush move end of file} { +} -result {hello hello bye} +test chan-io-29.24 {Tcl_WriteChars and Tcl_Flush move end of file} -setup { + variable x {} +} -body { set f [open $path(test3) w] chan puts $f "Line 1" chan puts $f "Line 2" set f2 [open $path(test3)] - set x {} lappend x [chan read -nonewline $f2] chan close $f2 chan flush $f set f2 [open $path(test3)] lappend x [chan read -nonewline $f2] +} -cleanup { chan close $f2 chan close $f - set x -} "{} {Line 1\nLine 2}" -test chan-io-29.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio openpipe fileevent} { +} -result "{} {Line 1\nLine 2}" +test chan-io-29.25 {Implicit flush with Tcl_Flush to command pipelines} -setup { file delete $path(test3) - set f [open "|[list [interpreter] $path(cat) | [interpreter] $path(cat) > $path(test3)]" w] +} -constraints {stdio openpipe fileevent} -body { + set f [openpipe w $path(cat) | [interpreter] $path(cat) > $path(test3)] chan puts $f "Line 1" chan puts $f "Line 2" chan close $f after 100 set f [open $path(test3) r] - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "Line 1\nLine 2\n" -test chan-io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {stdio unixExecs openpipe} { +} -result "Line 1\nLine 2\n" +test chan-io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} -constraints {stdio unixExecs openpipe} -body { set f [open "|[list cat -u]" r+] chan puts $f "Line1" chan flush $f - set x [chan gets $f] + chan gets $f +} -cleanup { chan close $f - set x -} {Line1} -test chan-io-29.27 {Tcl_Flush on chan closed pipeline} {stdio openpipe} { +} -result {Line1} +test chan-io-29.27 {Tcl_Flush on chan closed pipeline} -setup { file delete $path(pipe) set f [open $path(pipe) w] chan puts $f {exit} chan close $f - set f [open "|[list [interpreter] $path(pipe)]" r+] +} -constraints {stdio openpipe} -body { + set f [openpipe r+ $path(pipe)] chan gets $f chan puts $f output after 50 # - # The flush below will get a SIGPIPE. This is an expected part of - # test and indicates that the test operates correctly. If you run - # this test under a debugger, the signal will by intercepted unless - # you disable the debugger's signal interception. + # The flush below will get a SIGPIPE. This is an expected part of the test + # and indicates that the test operates correctly. If you run this test + # under a debugger, the signal will by intercepted unless you disable the + # debugger's signal interception. # if {[catch {chan flush $f} msg]} { set x [list 1 $msg $::errorCode] catch {chan close $f} + } elseif {[catch {chan close $f} msg]} { + set x [list 1 $msg $::errorCode] } else { - if {[catch {chan close $f} msg]} { - set x [list 1 $msg $::errorCode] - } else { - set x {this was supposed to fail and did not} - } + set x {this was supposed to fail and did not} } - regsub {".*":} $x {"":} x string tolower $x -} {1 {error flushing "": broken pipe} {posix epipe {broken pipe}}} -test chan-io-29.28 {Tcl_WriteChars, lf mode} { +} -match glob -result {1 {error flushing "*": broken pipe} {posix epipe {broken pipe}}} +test chan-io-29.28 {Tcl_WriteChars, lf mode} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation lf -eofchar {} chan puts $f hello\nthere\nand\nhere chan flush $f - set s [file size $path(test1)] + file size $path(test1) +} -cleanup { chan close $f - set s -} 21 -test chan-io-29.29 {Tcl_WriteChars, cr mode} { +} -result 21 +test chan-io-29.29 {Tcl_WriteChars, cr mode} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation cr -eofchar {} chan puts $f hello\nthere\nand\nhere chan close $f file size $path(test1) -} 21 -test chan-io-29.30 {Tcl_WriteChars, crlf mode} { +} -result 21 +test chan-io-29.30 {Tcl_WriteChars, crlf mode} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation crlf -eofchar {} chan puts $f hello\nthere\nand\nhere chan close $f file size $path(test1) -} 25 -test chan-io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} { +} -result 25 +test chan-io-29.31 {Tcl_WriteChars, background flush} -setup { file delete $path(pipe) file delete $path(output) +} -constraints {stdio openpipe} -body { set f [open $path(pipe) w] chan puts $f "set f \[[list open $path(output) w]]" chan puts $f {chan configure $f -translation lf} @@ -2633,7 +2701,7 @@ test chan-io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} { } set f [open $path(output) w] chan close $f - set f [open "|[list [interpreter] $path(pipe)]" r+] + set f [openpipe r+ $path(pipe)] chan configure $f -blocking off chan puts -nonewline $f $x chan close $f @@ -2651,12 +2719,12 @@ test chan-io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} { # otherwise, the following test fails on the [file delete $path(output) # on Windows because a process still has the file open. after 100 set v 1; vwait v - set result -} ok -test chan-io-29.32 {Tcl_WriteChars, background flush to slow reader} \ - {stdio asyncPipeChan Close openpipe} { + return $result +} -result ok +test chan-io-29.32 {Tcl_WriteChars, background flush to slow reader} -setup { file delete $path(pipe) file delete $path(output) +} -constraints {stdio asyncPipeChan Close openpipe} -body { set f [open $path(pipe) w] chan puts $f "set f \[[list open $path(output) w]]" chan puts $f {chan configure $f -translation lf} @@ -2675,7 +2743,7 @@ test chan-io-29.32 {Tcl_WriteChars, background flush to slow reader} \ } set f [open $path(output) w] chan close $f - set f [open "|[list [interpreter] $path(pipe)]" r+] + set f [openpipe r+ $path(pipe)] chan configure $f -blocking off chan puts -nonewline $f $x chan close $f @@ -2689,8 +2757,8 @@ test chan-io-29.32 {Tcl_WriteChars, background flush to slow reader} \ } else { set result ok } -} ok -test chan-io-29.33 {Tcl_Flush, implicit flush on exit} {exec} { +} -result ok +test chan-io-29.33 {Tcl_Flush, implicit flush on exit} -setup { set f [open $path(script) w] chan puts $f "set f \[[list open $path(test1) w]]" chan puts $f {chan configure $f -translation lf @@ -2699,13 +2767,14 @@ test chan-io-29.33 {Tcl_Flush, implicit flush on exit} {exec} { chan puts $f strange } chan close $f +} -constraints exec -body { exec [interpreter] $path(script) set f [open $path(test1) r] - set r [chan read $f] + chan read $f +} -cleanup { chan close $f - set r -} "hello\nbye\nstrange\n" -test chan-io-29.34 {Tcl_Chan Close, async flush on chan close, using sockets} {socket tempNotMac fileevent} { +} -result "hello\nbye\nstrange\n" +test chan-io-29.34 {Tcl_Chan Close, async flush on chan close, using sockets} -setup { variable c 0 variable x running set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz @@ -2714,6 +2783,7 @@ test chan-io-29.34 {Tcl_Chan Close, async flush on chan close, using sockets} {s chan puts $s $l } } +} -constraints {socket tempNotMac fileevent} -body { proc accept {s a p} { variable x chan event $s readable [namespace code [list readit $s]] @@ -2739,13 +2809,14 @@ test chan-io-29.34 {Tcl_Chan Close, async flush on chan close, using sockets} {s chan close $cs chan close $ss vwait [namespace which -variable x] - set c -} 2000 -test chan-io-29.35 {Tcl_Chan Close vs chan event vs multiple interpreters} {socket tempNotMac fileevent} { - # On Mac, this test screws up sockets such that subsequent tests using - # port 2828 either cause errors or panic(). + return $c +} -result 2000 +test chan-io-29.35 {Tcl_Chan Close vs chan event vs multiple interpreters} -setup { catch {interp delete x} catch {interp delete y} +} -constraints {socket tempNotMac fileevent} -body { + # On Mac, this test screws up sockets such that subsequent tests using + # port 2828 either cause errors or panic(). interp create x interp create y set s [socket -server [namespace code accept] -myaddr 127.0.0.1 0] @@ -2777,171 +2848,182 @@ test chan-io-29.35 {Tcl_Chan Close vs chan event vs multiple interpreters} {sock y eval "chan event $c readable \{readit $c\}" y eval [list chan close $c] update +} -cleanup { chan close $s interp delete x interp delete y -} "" +} -result "" # Test end of line translations. Procedures tested are Tcl_Write, Tcl_Read. -test chan-io-30.1 {Tcl_Write lf, Tcl_Read lf} { +test chan-io-30.1 {Tcl_Write lf, Tcl_Read lf} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation lf - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "hello\nthere\nand\nhere\n" -test chan-io-30.2 {Tcl_Write lf, Tcl_Read cr} { +} -result "hello\nthere\nand\nhere\n" +test chan-io-30.2 {Tcl_Write lf, Tcl_Read cr} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation cr - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "hello\nthere\nand\nhere\n" -test chan-io-30.3 {Tcl_Write lf, Tcl_Read crlf} { +} -result "hello\nthere\nand\nhere\n" +test chan-io-30.3 {Tcl_Write lf, Tcl_Read crlf} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation crlf - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "hello\nthere\nand\nhere\n" -test chan-io-30.4 {Tcl_Write cr, Tcl_Read cr} { +} -result "hello\nthere\nand\nhere\n" +test chan-io-30.4 {Tcl_Write cr, Tcl_Read cr} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation cr chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation cr - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "hello\nthere\nand\nhere\n" -test chan-io-30.5 {Tcl_Write cr, Tcl_Read lf} { +} -result "hello\nthere\nand\nhere\n" +test chan-io-30.5 {Tcl_Write cr, Tcl_Read lf} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation cr chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation lf - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "hello\rthere\rand\rhere\r" -test chan-io-30.6 {Tcl_Write cr, Tcl_Read crlf} { +} -result "hello\rthere\rand\rhere\r" +test chan-io-30.6 {Tcl_Write cr, Tcl_Read crlf} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation cr chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation crlf - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "hello\rthere\rand\rhere\r" -test chan-io-30.7 {Tcl_Write crlf, Tcl_Read crlf} { +} -result "hello\rthere\rand\rhere\r" +test chan-io-30.7 {Tcl_Write crlf, Tcl_Read crlf} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation crlf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation crlf - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "hello\nthere\nand\nhere\n" -test chan-io-30.8 {Tcl_Write crlf, Tcl_Read lf} { +} -result "hello\nthere\nand\nhere\n" +test chan-io-30.8 {Tcl_Write crlf, Tcl_Read lf} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation crlf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation lf - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "hello\r\nthere\r\nand\r\nhere\r\n" -test chan-io-30.9 {Tcl_Write crlf, Tcl_Read cr} { +} -result "hello\r\nthere\r\nand\r\nhere\r\n" +test chan-io-30.9 {Tcl_Write crlf, Tcl_Read cr} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation crlf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation cr - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "hello\n\nthere\n\nand\n\nhere\n\n" -test chan-io-30.10 {Tcl_Write lf, Tcl_Read auto} { +} -result "hello\n\nthere\n\nand\n\nhere\n\n" +test chan-io-30.10 {Tcl_Write lf, Tcl_Read auto} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] - set c [chan read $f] - set x [chan configure $f -translation] + list [chan read $f] [chan configure $f -translation] +} -cleanup { chan close $f - list $c $x -} {{hello +} -result {{hello there and here } auto} -test chan-io-30.11 {Tcl_Write cr, Tcl_Read auto} { +test chan-io-30.11 {Tcl_Write cr, Tcl_Read auto} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation cr chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] - set c [chan read $f] - set x [chan configure $f -translation] + list [chan read $f] [chan configure $f -translation] +} -cleanup { chan close $f - list $c $x -} {{hello +} -result {{hello there and here } auto} -test chan-io-30.12 {Tcl_Write crlf, Tcl_Read auto} { +test chan-io-30.12 {Tcl_Write crlf, Tcl_Read auto} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation crlf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] - set c [chan read $f] - set x [chan configure $f -translation] + list [chan read $f] [chan configure $f -translation] +} -cleanup { chan close $f - list $c $x -} {{hello +} -result {{hello there and here } auto} -test chan-io-30.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} { +test chan-io-30.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation crlf set line "123456789ABCDE" ;# 14 char plus crlf @@ -2952,12 +3034,13 @@ test chan-io-30.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} { chan close $f set f [open $path(test1) r] chan configure $f -translation auto - set c [chan read $f] + string length [chan read $f] +} -cleanup { chan close $f - string length $c -} [expr 700*15+1] -test chan-io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} { +} -result [expr 700*15+1] +test chan-io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation crlf set line "123456789ABCDE" ;# 14 char plus crlf @@ -2968,60 +3051,64 @@ test chan-io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} { chan close $f set f [open $path(test1) r] chan configure $f -translation crlf - set c [chan read $f] + string length [chan read $f] +} -cleanup { chan close $f - string length $c -} [expr 700*15+1] -test chan-io-30.15 {Tcl_Write mixed, Tcl_Read auto} { +} -result [expr 700*15+1] +test chan-io-30.15 {Tcl_Write mixed, Tcl_Read auto} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts $f hello\nthere\nand\rhere chan close $f set f [open $path(test1) r] chan configure $f -translation auto - set c [chan read $f] + chan read $f +} -cleanup { chan close $f - set c -} {hello +} -result {hello there and here } -test chan-io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} { +test chan-io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f hello\nthere\nand\rhere\n\x1a chan close $f set f [open $path(test1) r] chan configure $f -eofchar \x1a -translation auto - set c [chan read $f] + chan read $f +} -cleanup { chan close $f - set c -} {hello +} -result {hello there and here } -test chan-io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} {win} { +test chan-io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} -setup { file delete $path(test1) +} -constraints {win} -body { set f [open $path(test1) w] chan configure $f -eofchar \x1a -translation lf chan puts $f hello\nthere\nand\rhere chan close $f set f [open $path(test1) r] chan configure $f -eofchar \x1a -translation auto - set c [chan read $f] + chan read $f +} -cleanup { chan close $f - set c -} {hello +} -result {hello there and here } -test chan-io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} { +test chan-io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation lf set s [format "abc\ndef\n%cghi\nqrs" 26] @@ -3037,11 +3124,12 @@ test chan-io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} { lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {abc def 0 {} 1 {} 1} -test chan-io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} { +} -result {abc def 0 {} 1 {} 1} +test chan-io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation lf set s [format "abc\ndef\n%cghi\nqrs" 26] @@ -3057,19 +3145,19 @@ test chan-io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} { lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {abc def 0 {} 1 {} 1} -test chan-io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} { +} -result {abc def 0 {} 1 {} 1} +test chan-io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf -eofchar {} - set s [format "abc\ndef\n%cghi\nqrs" 26] - chan puts $f $s + chan puts $f [format "abc\ndef\n%cghi\nqrs" 26] chan close $f set f [open $path(test1) r] chan configure $f -translation lf -eofchar {} - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3079,61 +3167,61 @@ test chan-io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} { lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} "abc def 0 \x1aghi 0 qrs 0 {} 1" -test chan-io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} { +} -result "abc def 0 \x1aghi 0 qrs 0 {} 1" +test chan-io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf -eofchar {} - set s [format "abc\ndef\n%cghi\nqrs" 26] - chan puts $f $s + chan puts $f [format "abc\ndef\n%cghi\nqrs" 26] chan close $f set f [open $path(test1) r] chan configure $f -translation cr -eofchar {} - set l "" set x [chan gets $f] - lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs\n"] + lappend l [string equal $x "abc\ndef\n\x1aghi\nqrs\n"] lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {0 1 {} 1} -test chan-io-30.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} { +} -result {1 1 {} 1} +test chan-io-30.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf -eofchar {} - set s [format "abc\ndef\n%cghi\nqrs" 26] - chan puts $f $s + chan puts $f [format "abc\ndef\n%cghi\nqrs" 26] chan close $f set f [open $path(test1) r] chan configure $f -translation crlf -eofchar {} - set l "" set x [chan gets $f] - lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs\n"] + lappend l [string equal $x "abc\ndef\n\x1aghi\nqrs\n"] lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {0 1 {} 1} -test chan-io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} { +} -result {1 1 {} 1} +test chan-io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation lf - set c [format abc\ndef\n%cqrs\ntuv 26] - chan puts $f $c + chan puts $f [format abc\ndef\n%cqrs\ntuv 26] chan close $f set f [open $path(test1) r] chan configure $f -translation auto -eofchar \x1a - set c [string length [chan read $f]] - set e [chan eof $f] + list [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $c $e -} {8 1} -test chan-io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} { +} -result {8 1} +test chan-io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation lf set c [format abc\ndef\n%cqrs\ntuv 26] @@ -3141,13 +3229,13 @@ test chan-io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} { chan close $f set f [open $path(test1) r] chan configure $f -translation lf -eofchar \x1a - set c [string length [chan read $f]] - set e [chan eof $f] + list [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $c $e -} {8 1} -test chan-io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} { +} -result {8 1} +test chan-io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation cr set c [format abc\ndef\n%cqrs\ntuv 26] @@ -3155,13 +3243,13 @@ test chan-io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} { chan close $f set f [open $path(test1) r] chan configure $f -translation auto -eofchar \x1a - set c [string length [chan read $f]] - set e [chan eof $f] + list [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $c $e -} {8 1} -test chan-io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} { +} -result {8 1} +test chan-io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation cr set c [format abc\ndef\n%cqrs\ntuv 26] @@ -3169,13 +3257,13 @@ test chan-io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} { chan close $f set f [open $path(test1) r] chan configure $f -translation cr -eofchar \x1a - set c [string length [chan read $f]] - set e [chan eof $f] + list [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $c $e -} {8 1} -test chan-io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} { +} -result {8 1} +test chan-io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation crlf set c [format abc\ndef\n%cqrs\ntuv 26] @@ -3183,13 +3271,13 @@ test chan-io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} { chan close $f set f [open $path(test1) r] chan configure $f -translation auto -eofchar \x1a - set c [string length [chan read $f]] - set e [chan eof $f] + list [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $c $e -} {8 1} -test chan-io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} { +} -result {8 1} +test chan-io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation crlf set c [format abc\ndef\n%cqrs\ntuv 26] @@ -3197,92 +3285,97 @@ test chan-io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} { chan close $f set f [open $path(test1) r] chan configure $f -translation crlf -eofchar \x1a - set c [string length [chan read $f]] - set e [chan eof $f] + list [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $c $e -} {8 1} +} -result {8 1} -# Test end of line translations. Functions tested are Tcl_Write and Tcl_Gets. +# Test end of line translations. Functions tested are Tcl_Write and +# Tcl_Gets. -test chan-io-31.1 {Tcl_Write lf, Tcl_Gets auto} { +test chan-io-31.1 {Tcl_Write lf, Tcl_Gets auto} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] - set l "" lappend l [chan gets $f] lappend l [chan tell $f] lappend l [chan configure $f -translation] lappend l [chan gets $f] lappend l [chan tell $f] lappend l [chan configure $f -translation] +} -cleanup { chan close $f - set l -} {hello 6 auto there 12 auto} -test chan-io-31.2 {Tcl_Write cr, Tcl_Gets auto} { +} -result {hello 6 auto there 12 auto} +test chan-io-31.2 {Tcl_Write cr, Tcl_Gets auto} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation cr chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] - set l "" lappend l [chan gets $f] lappend l [chan tell $f] lappend l [chan configure $f -translation] lappend l [chan gets $f] lappend l [chan tell $f] lappend l [chan configure $f -translation] +} -cleanup { chan close $f - set l -} {hello 6 auto there 12 auto} -test chan-io-31.3 {Tcl_Write crlf, Tcl_Gets auto} { +} -result {hello 6 auto there 12 auto} +test chan-io-31.3 {Tcl_Write crlf, Tcl_Gets auto} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation crlf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] - set l "" lappend l [chan gets $f] lappend l [chan tell $f] lappend l [chan configure $f -translation] lappend l [chan gets $f] lappend l [chan tell $f] lappend l [chan configure $f -translation] +} -cleanup { chan close $f - set l -} {hello 7 auto there 14 auto} -test chan-io-31.4 {Tcl_Write lf, Tcl_Gets lf} { +} -result {hello 7 auto there 14 auto} +test chan-io-31.4 {Tcl_Write lf, Tcl_Gets lf} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation lf - set l "" lappend l [chan gets $f] lappend l [chan tell $f] lappend l [chan configure $f -translation] lappend l [chan gets $f] lappend l [chan tell $f] lappend l [chan configure $f -translation] +} -cleanup { chan close $f - set l -} {hello 6 lf there 12 lf} -test chan-io-31.5 {Tcl_Write lf, Tcl_Gets cr} { +} -result {hello 6 lf there 12 lf} +test chan-io-31.5 {Tcl_Write lf, Tcl_Gets cr} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation cr - set l "" lappend l [string length [chan gets $f]] lappend l [chan tell $f] lappend l [chan configure $f -translation] @@ -3291,18 +3384,19 @@ test chan-io-31.5 {Tcl_Write lf, Tcl_Gets cr} { lappend l [chan tell $f] lappend l [chan configure $f -translation] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {21 21 cr 1 {} 21 cr 1} -test chan-io-31.6 {Tcl_Write lf, Tcl_Gets crlf} { +} -result {21 21 cr 1 {} 21 cr 1} +test chan-io-31.6 {Tcl_Write lf, Tcl_Gets crlf} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation crlf - set l "" lappend l [string length [chan gets $f]] lappend l [chan tell $f] lappend l [chan configure $f -translation] @@ -3311,18 +3405,19 @@ test chan-io-31.6 {Tcl_Write lf, Tcl_Gets crlf} { lappend l [chan tell $f] lappend l [chan configure $f -translation] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {21 21 crlf 1 {} 21 crlf 1} -test chan-io-31.7 {Tcl_Write cr, Tcl_Gets cr} { +} -result {21 21 crlf 1 {} 21 crlf 1} +test chan-io-31.7 {Tcl_Write cr, Tcl_Gets cr} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation cr chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation cr - set l "" lappend l [chan gets $f] lappend l [chan tell $f] lappend l [chan configure $f -translation] @@ -3331,18 +3426,19 @@ test chan-io-31.7 {Tcl_Write cr, Tcl_Gets cr} { lappend l [chan tell $f] lappend l [chan configure $f -translation] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {hello 6 cr 0 there 12 cr 0} -test chan-io-31.8 {Tcl_Write cr, Tcl_Gets lf} { +} -result {hello 6 cr 0 there 12 cr 0} +test chan-io-31.8 {Tcl_Write cr, Tcl_Gets lf} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation cr chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation lf - set l "" lappend l [string length [chan gets $f]] lappend l [chan tell $f] lappend l [chan configure $f -translation] @@ -3351,18 +3447,19 @@ test chan-io-31.8 {Tcl_Write cr, Tcl_Gets lf} { lappend l [chan tell $f] lappend l [chan configure $f -translation] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {21 21 lf 1 {} 21 lf 1} -test chan-io-31.9 {Tcl_Write cr, Tcl_Gets crlf} { +} -result {21 21 lf 1 {} 21 lf 1} +test chan-io-31.9 {Tcl_Write cr, Tcl_Gets crlf} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation cr chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation crlf - set l "" lappend l [string length [chan gets $f]] lappend l [chan tell $f] lappend l [chan configure $f -translation] @@ -3371,18 +3468,19 @@ test chan-io-31.9 {Tcl_Write cr, Tcl_Gets crlf} { lappend l [chan tell $f] lappend l [chan configure $f -translation] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {21 21 crlf 1 {} 21 crlf 1} -test chan-io-31.10 {Tcl_Write crlf, Tcl_Gets crlf} { +} -result {21 21 crlf 1 {} 21 crlf 1} +test chan-io-31.10 {Tcl_Write crlf, Tcl_Gets crlf} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation crlf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation crlf - set l "" lappend l [chan gets $f] lappend l [chan tell $f] lappend l [chan configure $f -translation] @@ -3391,18 +3489,19 @@ test chan-io-31.10 {Tcl_Write crlf, Tcl_Gets crlf} { lappend l [chan tell $f] lappend l [chan configure $f -translation] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {hello 7 crlf 0 there 14 crlf 0} -test chan-io-31.11 {Tcl_Write crlf, Tcl_Gets cr} { +} -result {hello 7 crlf 0 there 14 crlf 0} +test chan-io-31.11 {Tcl_Write crlf, Tcl_Gets cr} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation crlf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation cr - set l "" lappend l [chan gets $f] lappend l [chan tell $f] lappend l [chan configure $f -translation] @@ -3411,18 +3510,19 @@ test chan-io-31.11 {Tcl_Write crlf, Tcl_Gets cr} { lappend l [chan tell $f] lappend l [chan configure $f -translation] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {hello 6 cr 0 6 13 cr 0} -test chan-io-31.12 {Tcl_Write crlf, Tcl_Gets lf} { +} -result {hello 6 cr 0 6 13 cr 0} +test chan-io-31.12 {Tcl_Write crlf, Tcl_Gets lf} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation crlf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation lf - set l "" lappend l [string length [chan gets $f]] lappend l [chan tell $f] lappend l [chan configure $f -translation] @@ -3431,30 +3531,32 @@ test chan-io-31.12 {Tcl_Write crlf, Tcl_Gets lf} { lappend l [chan tell $f] lappend l [chan configure $f -translation] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {6 7 lf 0 6 14 lf 0} -test chan-io-31.13 {binary mode is synonym of lf mode} { +} -result {6 7 lf 0 6 14 lf 0} +test chan-io-31.13 {binary mode is synonym of lf mode} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation binary - set x [chan configure $f -translation] + chan configure $f -translation +} -cleanup { chan close $f - set x -} lf +} -result lf # # Test chan-io-9.14 has been removed because "auto" output translation mode is # not supoprted. # -test chan-io-31.14 {Tcl_Write mixed, Tcl_Gets auto} { +test chan-io-31.14 {Tcl_Write mixed, Tcl_Gets auto} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts $f hello\nthere\rand\r\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation auto - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan gets $f] @@ -3462,18 +3564,19 @@ test chan-io-31.14 {Tcl_Write mixed, Tcl_Gets auto} { lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {hello there and here 0 {} 1} -test chan-io-31.15 {Tcl_Write mixed, Tcl_Gets auto} { +} -result {hello there and here 0 {} 1} +test chan-io-31.15 {Tcl_Write mixed, Tcl_Gets auto} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f hello\nthere\rand\r\nhere\r chan close $f set f [open $path(test1) r] chan configure $f -translation auto - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan gets $f] @@ -3481,17 +3584,18 @@ test chan-io-31.15 {Tcl_Write mixed, Tcl_Gets auto} { lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {hello there and here 0 {} 1} -test chan-io-31.16 {Tcl_Write mixed, Tcl_Gets auto} { +} -result {hello there and here 0 {} 1} +test chan-io-31.16 {Tcl_Write mixed, Tcl_Gets auto} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f hello\nthere\rand\r\nhere\n chan close $f set f [open $path(test1) r] - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan gets $f] @@ -3499,18 +3603,19 @@ test chan-io-31.16 {Tcl_Write mixed, Tcl_Gets auto} { lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {hello there and here 0 {} 1} -test chan-io-31.17 {Tcl_Write mixed, Tcl_Gets auto} { +} -result {hello there and here 0 {} 1} +test chan-io-31.17 {Tcl_Write mixed, Tcl_Gets auto} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f hello\nthere\rand\r\nhere\r\n chan close $f set f [open $path(test1) r] chan configure $f -translation auto - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan gets $f] @@ -3518,19 +3623,19 @@ test chan-io-31.17 {Tcl_Write mixed, Tcl_Gets auto} { lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {hello there and here 0 {} 1} -test chan-io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} { +} -result {hello there and here 0 {} 1} +test chan-io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf - set s [format "hello\nthere\nand\rhere\n\%c" 26] - chan puts $f $s + chan puts $f [format "hello\nthere\nand\rhere\n\%c" 26] chan close $f set f [open $path(test1) r] chan configure $f -eofchar \x1a -translation auto - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan gets $f] @@ -3538,18 +3643,19 @@ test chan-io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} { lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {hello there and here 0 {} 1} -test chan-io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} { +} -result {hello there and here 0 {} 1} +test chan-io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -eofchar \x1a -translation lf chan puts $f hello\nthere\nand\rhere chan close $f set f [open $path(test1) r] chan configure $f -eofchar \x1a -translation auto - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan gets $f] @@ -3557,56 +3663,56 @@ test chan-io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} { lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {hello there and here 0 {} 1} -test chan-io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} { +} -result {hello there and here 0 {} 1} +test chan-io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf - set s [format "abc\ndef\n%cqrs\ntuv" 26] - chan puts $f $s + chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] chan configure $f -eofchar \x1a chan configure $f -translation auto - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {abc def 0 {} 1} -test chan-io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} { +} -result {abc def 0 {} 1} +test chan-io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf - set s [format "abc\ndef\n%cqrs\ntuv" 26] - chan puts $f $s + chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] chan configure $f -eofchar \x1a -translation auto - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {abc def 0 {} 1} -test chan-io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} { +} -result {abc def 0 {} 1} +test chan-io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf -eofchar {} - set s [format "abc\ndef\n%cqrs\ntuv" 26] - chan puts $f $s + chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] chan configure $f -translation lf -eofchar {} - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3616,19 +3722,19 @@ test chan-io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} { lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} "abc def 0 \x1aqrs 0 tuv 0 {} 1" -test chan-io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} { +} -result "abc def 0 \x1aqrs 0 tuv 0 {} 1" +test chan-io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation cr -eofchar {} - set s [format "abc\ndef\n%cqrs\ntuv" 26] - chan puts $f $s + chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] chan configure $f -translation cr -eofchar {} - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3638,19 +3744,19 @@ test chan-io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} { lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} "abc def 0 \x1aqrs 0 tuv 0 {} 1" -test chan-io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} { +} -result "abc def 0 \x1aqrs 0 tuv 0 {} 1" +test chan-io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation crlf -eofchar {} - set s [format "abc\ndef\n%cqrs\ntuv" 26] - chan puts $f $s + chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] chan configure $f -translation crlf -eofchar {} - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3660,119 +3766,121 @@ test chan-io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} { lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} "abc def 0 \x1aqrs 0 tuv 0 {} 1" -test chan-io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} { +} -result "abc def 0 \x1aqrs 0 tuv 0 {} 1" +test chan-io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf - set s [format "abc\ndef\n%cqrs\ntuv" 26] - chan puts $f $s + chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] chan configure $f -translation auto -eofchar \x1a - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {abc def 0 {} 1} -test chan-io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} { +} -result {abc def 0 {} 1} +test chan-io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf - set s [format "abc\ndef\n%cqrs\ntuv" 26] - chan puts $f $s + chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] chan configure $f -translation lf -eofchar \x1a - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {abc def 0 {} 1} -test chan-io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} { +} -result {abc def 0 {} 1} +test chan-io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation cr -eofchar {} - set s [format "abc\ndef\n%cqrs\ntuv" 26] - chan puts $f $s + chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] chan configure $f -translation auto -eofchar \x1a - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {abc def 0 {} 1} -test chan-io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} { +} -result {abc def 0 {} 1} +test chan-io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation cr -eofchar {} - set s [format "abc\ndef\n%cqrs\ntuv" 26] - chan puts $f $s + chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] chan configure $f -translation cr -eofchar \x1a - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {abc def 0 {} 1} -test chan-io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} { +} -result {abc def 0 {} 1} +test chan-io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation crlf -eofchar {} - set s [format "abc\ndef\n%cqrs\ntuv" 26] - chan puts $f $s + chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] chan configure $f -translation auto -eofchar \x1a - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {abc def 0 {} 1} -test chan-io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} { +} -result {abc def 0 {} 1} +test chan-io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation crlf -eofchar {} - set s [format "abc\ndef\n%cqrs\ntuv" 26] - chan puts $f $s + chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] chan configure $f -translation crlf -eofchar \x1a - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {abc def 0 {} 1} -test chan-io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} { +} -result {abc def 0 {} 1} +test chan-io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} -setup { file delete $path(test1) + set c "" +} -body { set f [open $path(test1) w] chan configure $f -translation crlf set line "123456789ABCDE" ;# 14 char plus crlf @@ -3783,15 +3891,16 @@ test chan-io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} { chan close $f set f [open $path(test1) r] chan configure $f -translation crlf - set c "" while {[chan gets $f line] >= 0} { append c $line\n } chan close $f string length $c -} [expr 700*15+1] -test chan-io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { +} -result [expr 700*15+1] +test chan-io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} -setup { file delete $path(test1) + set c "" +} -body { set f [open $path(test1) w] chan configure $f -translation crlf set line "123456789ABCDE" ;# 14 char plus crlf @@ -3802,45 +3911,41 @@ test chan-io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { chan close $f set f [open $path(test1) r] chan configure $f -translation auto - set c "" while {[chan gets $f line] >= 0} { append c $line\n } chan close $f string length $c -} [expr 700*15+1] +} -result [expr 700*15+1] # Test Tcl_Read and buffering. -test chan-io-32.1 {Tcl_Read, channel not readable} { - list [catch {read stdout} msg] $msg -} {1 {channel "stdout" wasn't opened for reading}} +test chan-io-32.1 {Tcl_Read, channel not readable} -body { + read stdout +} -returnCodes error -result {channel "stdout" wasn't opened for reading} test chan-io-32.2 {Tcl_Read, zero byte count} { chan read stdin 0 } "" -test chan-io-32.3 {Tcl_Read, negative byte count} { +test chan-io-32.3 {Tcl_Read, negative byte count} -setup { set f [open $path(longfile) r] - set l [list [catch {chan read $f -1} msg] $msg] +} -body { + chan read $f -1 +} -returnCodes error -cleanup { chan close $f - set l -} {1 {bad argument "-1": should be "nonewline"}} -test chan-io-32.4 {Tcl_Read, positive byte count} { +} -result {bad argument "-1": should be "nonewline"} +test chan-io-32.4 {Tcl_Read, positive byte count} -body { set f [open $path(longfile) r] - set x [chan read $f 1024] - set s [string length $x] - unset x + string length [chan read $f 1024] +} -cleanup { chan close $f - set s -} 1024 -test chan-io-32.5 {Tcl_Read, multiple buffers} { +} -result 1024 +test chan-io-32.5 {Tcl_Read, multiple buffers} -body { set f [open $path(longfile) r] chan configure $f -buffersize 100 - set x [chan read $f 1024] - set s [string length $x] - unset x + string length [chan read $f 1024] +} -cleanup { chan close $f - set s -} 1024 +} -result 1024 test chan-io-32.6 {Tcl_Read, very large read} { set f1 [open $path(longfile) r] set z [chan read $f1 1000000] @@ -3849,7 +3954,7 @@ test chan-io-32.6 {Tcl_Read, very large read} { set x ok set z [file size $path(longfile)] if {$z != $l} { - set x broken + set x "$z != $l" } set x } ok @@ -3861,7 +3966,7 @@ test chan-io-32.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} { set l [string length $z] set x ok if {$l != 20} { - set x broken + set x "$l != 20" } set x } ok @@ -3874,7 +3979,7 @@ test chan-io-32.8 {Tcl_Read, nonblocking, file} {nonBlockFiles} { set l [string length $z] set z [file size $path(longfile)] if {$z != $l} { - set x broken + set x "$z != $l" } set x } ok @@ -3886,121 +3991,125 @@ test chan-io-32.9 {Tcl_Read, read to end of file} { set x ok set z [file size $path(longfile)] if {$z != $l} { - set x broken + set x "$z != $l" } set x } ok -test chan-io-32.10 {Tcl_Read from a pipe} {stdio openpipe} { +test chan-io-32.10 {Tcl_Read from a pipe} -setup { file delete $path(pipe) +} -constraints {stdio openpipe} -body { set f1 [open $path(pipe) w] chan puts $f1 {chan puts [chan gets stdin]} chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] chan puts $f1 hello chan flush $f1 - set x [chan read $f1] + chan read $f1 +} -cleanup { chan close $f1 - set x -} "hello\n" -test chan-io-32.11 {Tcl_Read from a pipe} {stdio openpipe} { +} -result "hello\n" +test chan-io-32.11 {Tcl_Read from a pipe} -setup { file delete $path(pipe) + set x "" +} -constraints {stdio openpipe} -body { set f1 [open $path(pipe) w] chan puts $f1 {chan puts [chan gets stdin]} chan puts $f1 {chan puts [chan gets stdin]} chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] chan puts $f1 hello chan flush $f1 - set x "" lappend x [chan read $f1 6] chan puts $f1 hello chan flush $f1 lappend x [chan read $f1] +} -cleanup { chan close $f1 - set x -} {{hello +} -result {{hello } {hello }} -test chan-io-32.12 {Tcl_Read, -nonewline} { +test chan-io-32.12 {Tcl_Read, -nonewline} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan puts $f1 hello chan puts $f1 bye chan close $f1 set f1 [open $path(test1) r] - set c [chan read -nonewline $f1] + chan read -nonewline $f1 +} -cleanup { chan close $f1 - set c -} {hello +} -result {hello bye} -test chan-io-32.13 {Tcl_Read, -nonewline} { +test chan-io-32.13 {Tcl_Read, -nonewline} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan puts $f1 hello chan puts $f1 bye chan close $f1 set f1 [open $path(test1) r] set c [chan read -nonewline $f1] - chan close $f1 list [string length $c] $c -} {9 {hello +} -cleanup { + chan close $f1 +} -result {9 {hello bye}} -test chan-io-32.14 {Tcl_Read, reading in small chunks} { +test chan-io-32.14 {Tcl_Read, reading in small chunks} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan puts $f "Two lines: this one" chan puts $f "and this one" chan close $f set f [open $path(test1)] - set x [list [chan read $f 1] [chan read $f 2] [chan read $f]] + list [chan read $f 1] [chan read $f 2] [chan read $f] +} -cleanup { chan close $f - set x -} {T wo { lines: this one +} -result {T wo { lines: this one and this one }} -test chan-io-32.15 {Tcl_Read, asking for more input than available} { +test chan-io-32.15 {Tcl_Read, asking for more input than available} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan puts $f "Two lines: this one" chan puts $f "and this one" chan close $f set f [open $path(test1)] - set x [chan read $f 100] + chan read $f 100 +} -cleanup { chan close $f - set x -} {Two lines: this one +} -result {Two lines: this one and this one } -test chan-io-32.16 {Tcl_Read, read to end of file with -nonewline} { +test chan-io-32.16 {Tcl_Read, read to end of file with -nonewline} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan puts $f "Two lines: this one" chan puts $f "and this one" chan close $f set f [open $path(test1)] - set x [chan read -nonewline $f] + chan read -nonewline $f +} -cleanup { chan close $f - set x -} {Two lines: this one +} -result {Two lines: this one and this one} # Test Tcl_Gets. -test chan-io-33.1 {Tcl_Gets, reading what was written} { +test chan-io-33.1 {Tcl_Gets, reading what was written} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] - set y "first line" - chan puts $f1 $y + chan puts $f1 "first line" chan close $f1 set f1 [open $path(test1) r] - set x [chan gets $f1] - set z ok - if {"$x" != "$y"} { - set z broken - } + chan gets $f1 +} -cleanup { chan close $f1 - set z -} ok +} -result {first line} test chan-io-33.2 {Tcl_Gets into variable} { set f1 [open $path(longfile) r] set c [chan gets $f1 x] @@ -4012,24 +4121,22 @@ test chan-io-33.2 {Tcl_Gets into variable} { chan close $f1 set z } ok -test chan-io-33.3 {Tcl_Gets from pipe} {stdio openpipe} { +test chan-io-33.3 {Tcl_Gets from pipe} -setup { file delete $path(pipe) +} -constraints {stdio openpipe} -body { set f1 [open $path(pipe) w] chan puts $f1 {chan puts [chan gets stdin]} chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] chan puts $f1 hello chan flush $f1 - set x [chan gets $f1] + chan gets $f1 +} -cleanup { chan close $f1 - set z ok - if {"$x" != "hello"} { - set z broken - } - set z -} ok -test chan-io-33.4 {Tcl_Gets with long line} { +} -result hello +test chan-io-33.4 {Tcl_Gets with long line} -setup { file delete $path(test3) +} -body { set f [open $path(test3) w] chan puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" chan puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" @@ -4038,44 +4145,46 @@ test chan-io-33.4 {Tcl_Gets with long line} { chan puts $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" chan close $f set f [open $path(test3)] - set x [chan gets $f] + chan gets $f +} -cleanup { chan close $f - set x -} {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} +} -result {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} test chan-io-33.5 {Tcl_Gets with long line} { set f [open $path(test3)] set x [chan gets $f y] chan close $f list $x $y } {260 abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} -test chan-io-33.6 {Tcl_Gets and end of file} { +test chan-io-33.6 {Tcl_Gets and end of file} -setup { file delete $path(test3) + set x {} +} -body { set f [open $path(test3) w] chan puts -nonewline $f "Test1\nTest2" chan close $f set f [open $path(test3)] - set x {} set y {} lappend x [chan gets $f y] $y set y {} lappend x [chan gets $f y] $y set y {} lappend x [chan gets $f y] $y +} -cleanup { chan close $f - set x -} {5 Test1 5 Test2 -1 {}} -test chan-io-33.7 {Tcl_Gets and bad variable} { +} -result {5 Test1 5 Test2 -1 {}} +test chan-io-33.7 {Tcl_Gets and bad variable} -setup { set f [open $path(test3) w] chan puts $f "Line 1" chan puts $f "Line 2" chan close $f catch {unset x} - set x 24 set f [open $path(test3) r] - set result [list [catch {chan gets $f x(0)} msg] $msg] +} -body { + set x 24 + chan gets $f x(0) +} -returnCodes error -cleanup { chan close $f - set result -} {1 {can't set "x(0)": variable isn't array}} +} -result {can't set "x(0)": variable isn't array} test chan-io-33.8 {Tcl_Gets, exercising double buffering} { set f [open $path(test3) w] chan configure $f -translation lf -eofchar {} @@ -4118,15 +4227,16 @@ test chan-io-33.10 {Tcl_Gets, exercising double buffering} { # Test Tcl_Seek and Tcl_Tell. -test chan-io-34.1 {Tcl_Seek to current position at start of file} { +test chan-io-34.1 {Tcl_Seek to current position at start of file} -body { set f1 [open $path(longfile) r] chan seek $f1 0 current - set c [chan tell $f1] + chan tell $f1 +} -cleanup { chan close $f1 - set c -} 0 -test chan-io-34.2 {Tcl_Seek to offset from start} { +} -result 0 +test chan-io-34.2 {Tcl_Seek to offset from start} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan configure $f1 -translation lf -eofchar {} chan puts $f1 "abcdefghijklmnopqrstuvwxyz" @@ -4134,12 +4244,13 @@ test chan-io-34.2 {Tcl_Seek to offset from start} { chan close $f1 set f1 [open $path(test1) r] chan seek $f1 10 start - set c [chan tell $f1] + chan tell $f1 +} -cleanup { chan close $f1 - set c -} 10 -test chan-io-34.3 {Tcl_Seek to end of file} { +} -result 10 +test chan-io-34.3 {Tcl_Seek to end of file} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan configure $f1 -translation lf -eofchar {} chan puts $f1 "abcdefghijklmnopqrstuvwxyz" @@ -4147,12 +4258,13 @@ test chan-io-34.3 {Tcl_Seek to end of file} { chan close $f1 set f1 [open $path(test1) r] chan seek $f1 0 end - set c [chan tell $f1] + chan tell $f1 +} -cleanup { chan close $f1 - set c -} 54 -test chan-io-34.4 {Tcl_Seek to offset from end of file} { +} -result 54 +test chan-io-34.4 {Tcl_Seek to offset from end of file} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan configure $f1 -translation lf -eofchar {} chan puts $f1 "abcdefghijklmnopqrstuvwxyz" @@ -4160,12 +4272,13 @@ test chan-io-34.4 {Tcl_Seek to offset from end of file} { chan close $f1 set f1 [open $path(test1) r] chan seek $f1 -10 end - set c [chan tell $f1] + chan tell $f1 +} -cleanup { chan close $f1 - set c -} 44 -test chan-io-34.5 {Tcl_Seek to offset from current position} { +} -result 44 +test chan-io-34.5 {Tcl_Seek to offset from current position} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan configure $f1 -translation lf -eofchar {} chan puts $f1 "abcdefghijklmnopqrstuvwxyz" @@ -4174,12 +4287,13 @@ test chan-io-34.5 {Tcl_Seek to offset from current position} { set f1 [open $path(test1) r] chan seek $f1 10 current chan seek $f1 10 current - set c [chan tell $f1] + chan tell $f1 +} -cleanup { chan close $f1 - set c -} 20 -test chan-io-34.6 {Tcl_Seek to offset from end of file} { +} -result 20 +test chan-io-34.6 {Tcl_Seek to offset from end of file} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan configure $f1 -translation lf -eofchar {} chan puts $f1 "abcdefghijklmnopqrstuvwxyz" @@ -4187,14 +4301,14 @@ test chan-io-34.6 {Tcl_Seek to offset from end of file} { chan close $f1 set f1 [open $path(test1) r] chan seek $f1 -10 end - set c [chan tell $f1] - set r [chan read $f1] + list [chan tell $f1] [chan read $f1] +} -cleanup { chan close $f1 - list $c $r -} {44 {rstuvwxyz +} -result {44 {rstuvwxyz }} -test chan-io-34.7 {Tcl_Seek to offset from end of file, then to current position} { +test chan-io-34.7 {Tcl_Seek to offset from end of file, then to current position} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan configure $f1 -translation lf -eofchar {} chan puts $f1 "abcdefghijklmnopqrstuvwxyz" @@ -4205,19 +4319,20 @@ test chan-io-34.7 {Tcl_Seek to offset from end of file, then to current position set c1 [chan tell $f1] set r1 [chan read $f1 5] chan seek $f1 0 current - set c2 [chan tell $f1] - chan close $f1 - list $c1 $r1 $c2 -} {44 rstuv 49} -test chan-io-34.8 {Tcl_Seek on pipes: not supported} {stdio openpipe} { - set f1 [open "|[list [interpreter]]" r+] - set x [list [catch {chan seek $f1 0 current} msg] $msg] + list $c1 $r1 [chan tell $f1] +} -cleanup { chan close $f1 - regsub {".*":} $x {"":} x - string tolower $x -} {1 {error during seek on "": invalid argument}} -test chan-io-34.9 {Tcl_Seek, testing buffered input flushing} { +} -result {44 rstuv 49} +test chan-io-34.8 {Tcl_Seek on pipes: not supported} -setup { + set pipe [openpipe] +} -constraints {stdio openpipe} -body { + chan seek $pipe 0 current +} -returnCodes error -cleanup { + chan close $pipe +} -match glob -result {error during seek on "*": invalid argument} +test chan-io-34.9 {Tcl_Seek, testing buffered input flushing} -setup { file delete $path(test3) +} -body { set f [open $path(test3) w] chan configure $f -eofchar {} chan puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" @@ -4236,9 +4351,9 @@ test chan-io-34.9 {Tcl_Seek, testing buffered input flushing} { lappend x [chan read $f 1] chan seek $f 1 lappend x [chan read $f 1] +} -cleanup { chan close $f - set x -} {a d a l Y {} b} +} -result {a d a l Y {} b} set path(test3) [makeFile {} test3] test chan-io-34.10 {Tcl_Seek testing flushing of buffered input} { set f [open $path(test3) w] @@ -4282,15 +4397,17 @@ test chan-io-34.12 {Tcl_Seek testing combination of write, seek back and read} { } {14 {xyz 123 xyzzy} zzy} -test chan-io-34.13 {Tcl_Tell at start of file} { +test chan-io-34.13 {Tcl_Tell at start of file} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] - set p [chan tell $f1] + chan tell $f1 +} -cleanup { chan close $f1 - set p -} 0 -test chan-io-34.14 {Tcl_Tell after seek to end of file} { +} -result 0 +test chan-io-34.14 {Tcl_Tell after seek to end of file} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan configure $f1 -translation lf -eofchar {} chan puts $f1 "abcdefghijklmnopqrstuvwxyz" @@ -4298,12 +4415,13 @@ test chan-io-34.14 {Tcl_Tell after seek to end of file} { chan close $f1 set f1 [open $path(test1) r] chan seek $f1 0 end - set c1 [chan tell $f1] + chan tell $f1 +} -cleanup { chan close $f1 - set c1 -} 54 -test chan-io-34.15 {Tcl_Tell combined with seeking} { +} -result 54 +test chan-io-34.15 {Tcl_Tell combined with seeking} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan configure $f1 -translation lf -eofchar {} chan puts $f1 "abcdefghijklmnopqrstuvwxyz" @@ -4313,18 +4431,18 @@ test chan-io-34.15 {Tcl_Tell combined with seeking} { chan seek $f1 10 start set c1 [chan tell $f1] chan seek $f1 10 current - set c2 [chan tell $f1] + list $c1 [chan tell $f1] +} -cleanup { chan close $f1 - list $c1 $c2 -} {10 20} -test chan-io-34.16 {Tcl_Tell on pipe: always -1} {stdio openpipe} { - set f1 [open "|[list [interpreter]]" r+] - set c [chan tell $f1] +} -result {10 20} +test chan-io-34.16 {Tcl_Tell on pipe: always -1} -constraints {stdio openpipe} -body { + set f1 [openpipe] + chan tell $f1 +} -cleanup { chan close $f1 - set c -} -1 +} -result -1 test chan-io-34.17 {Tcl_Tell on pipe: always -1} {stdio openpipe} { - set f1 [open "|[list [interpreter]]" r+] + set f1 [openpipe] chan puts $f1 {chan puts hello} chan flush $f1 set c [chan tell $f1] @@ -4332,8 +4450,9 @@ test chan-io-34.17 {Tcl_Tell on pipe: always -1} {stdio openpipe} { chan close $f1 set c } -1 -test chan-io-34.18 {Tcl_Tell combined with seeking and reading} { +test chan-io-34.18 {Tcl_Tell combined with seeking and reading} -setup { file delete $path(test2) +} -body { set f [open $path(test2) w] chan configure $f -translation lf -eofchar {} chan puts -nonewline $f "line1\nline2\nline3\nline4\nline5\n" @@ -4349,23 +4468,24 @@ test chan-io-34.18 {Tcl_Tell combined with seeking and reading} { lappend x [chan tell $f] chan seek $f 0 end lappend x [chan tell $f] +} -cleanup { chan close $f - set x -} {0 3 2 12 30} -test chan-io-34.19 {Tcl_Tell combined with opening in append mode} { +} -result {0 3 2 12 30} +test chan-io-34.19 {Tcl_Tell combined with opening in append mode} -body { set f [open $path(test3) w] chan configure $f -translation lf -eofchar {} chan puts $f "abcdefghijklmnopqrstuvwxyz" chan puts $f "abcdefghijklmnopqrstuvwxyz" chan close $f set f [open $path(test3) a] - set c [chan tell $f] + chan tell $f +} -cleanup { chan close $f - set c -} 54 -test chan-io-34.20 {Tcl_Tell combined with writing} { - set f [open $path(test3) w] +} -result 54 +test chan-io-34.20 {Tcl_Tell combined with writing} -setup { set l "" +} -body { + set f [open $path(test3) w] chan seek $f 29 start lappend l [chan tell $f] chan puts -nonewline $f a @@ -4375,14 +4495,15 @@ test chan-io-34.20 {Tcl_Tell combined with writing} { lappend l [chan tell $f] chan seek $f 407 end lappend l [chan tell $f] +} -cleanup { chan close $f - set l -} {29 39 40 447} -test chan-io-34.21 {Tcl_Seek and Tcl_Tell on large files} {largefileSupport} { +} -result {29 39 40 447} +test chan-io-34.21 {Tcl_Seek and Tcl_Tell on large files} -setup { file delete $path(test3) + set l "" +} -constraints {largefileSupport} -body { set f [open $path(test3) w] chan configure $f -encoding binary - set l "" lappend l [chan tell $f] chan puts -nonewline $f abcdef lappend l [chan tell $f] @@ -4398,13 +4519,13 @@ test chan-io-34.21 {Tcl_Seek and Tcl_Tell on large files} {largefileSupport} { # truncate... chan close [open $path(test3) w] lappend l [file size $f] - set l -} {0 6 6 4294967296 4294967302 4294967302 0} +} -result {0 6 6 4294967296 4294967302 4294967302 0} # Test Tcl_Eof -test chan-io-35.1 {Tcl_Eof} { +test chan-io-35.1 {Tcl_Eof} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan puts $f hello chan puts $f hello @@ -4419,16 +4540,17 @@ test chan-io-35.1 {Tcl_Eof} { chan gets $f lappend x [chan eof $f] lappend x [chan eof $f] +} -cleanup { chan close $f - set x -} {0 0 0 0 1 1} -test chan-io-35.2 {Tcl_Eof with pipe} {stdio openpipe} { +} -result {0 0 0 0 1 1} +test chan-io-35.2 {Tcl_Eof with pipe} -constraints {stdio openpipe} -setup { file delete $path(pipe) +} -body { set f1 [open $path(pipe) w] chan puts $f1 {chan gets stdin} chan puts $f1 {chan puts hello} chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] chan puts $f1 hello set x [chan eof $f1] chan flush $f1 @@ -4437,16 +4559,17 @@ test chan-io-35.2 {Tcl_Eof with pipe} {stdio openpipe} { lappend x [chan eof $f1] chan gets $f1 lappend x [chan eof $f1] +} -cleanup { chan close $f1 - set x -} {0 0 0 1} -test chan-io-35.3 {Tcl_Eof with pipe} {stdio openpipe} { +} -result {0 0 0 1} +test chan-io-35.3 {Tcl_Eof with pipe} -constraints {stdio openpipe} -setup { file delete $path(pipe) +} -body { set f1 [open $path(pipe) w] chan puts $f1 {chan gets stdin} chan puts $f1 {chan puts hello} chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] chan puts $f1 hello set x [chan eof $f1] chan flush $f1 @@ -4459,37 +4582,39 @@ test chan-io-35.3 {Tcl_Eof with pipe} {stdio openpipe} { lappend x [chan eof $f1] chan gets $f1 lappend x [chan eof $f1] +} -cleanup { chan close $f1 - set x -} {0 0 0 1 1 1} -test chan-io-35.4 {Tcl_Eof, eof detection on nonblocking file} {nonBlockFiles} { +} -result {0 0 0 1 1 1} +test chan-io-35.4 {Tcl_Eof, eof detection on nonblocking file} -setup { file delete $path(test1) - set f [open $path(test1) w] - chan close $f + set l "" +} -constraints {nonBlockFiles} -body { + chan close [open $path(test1) w] set f [open $path(test1) r] chan configure $f -blocking off - set l "" lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {{} 1} -test chan-io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} {stdio openpipe} { +} -result {{} 1} +test chan-io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} -setup { file delete $path(pipe) + set l "" +} -constraints {stdio openpipe} -body { set f [open $path(pipe) w] chan puts $f { exit } chan close $f - set f [open "|[list [interpreter] $path(pipe)]" r] - set l "" + set f [openpipe r $path(pipe)] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {{} 1} -test chan-io-35.6 {Tcl_Eof, eof char, lf write, auto read} { +} -result {{} 1} +test chan-io-35.6 {Tcl_Eof, eof char, lf write, auto read} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation lf -eofchar \x1a chan puts $f abc\ndef @@ -4497,13 +4622,13 @@ test chan-io-35.6 {Tcl_Eof, eof char, lf write, auto read} { set s [file size $path(test1)] set f [open $path(test1) r] chan configure $f -translation auto -eofchar \x1a - set l [string length [chan read $f]] - set e [chan eof $f] + list $s [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $s $l $e -} {9 8 1} -test chan-io-35.7 {Tcl_Eof, eof char, lf write, lf read} { +} -result {9 8 1} +test chan-io-35.7 {Tcl_Eof, eof char, lf write, lf read} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation lf -eofchar \x1a chan puts $f abc\ndef @@ -4511,13 +4636,13 @@ test chan-io-35.7 {Tcl_Eof, eof char, lf write, lf read} { set s [file size $path(test1)] set f [open $path(test1) r] chan configure $f -translation lf -eofchar \x1a - set l [string length [chan read $f]] - set e [chan eof $f] + list $s [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $s $l $e -} {9 8 1} -test chan-io-35.8 {Tcl_Eof, eof char, cr write, auto read} { +} -result {9 8 1} +test chan-io-35.8 {Tcl_Eof, eof char, cr write, auto read} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation cr -eofchar \x1a chan puts $f abc\ndef @@ -4525,13 +4650,13 @@ test chan-io-35.8 {Tcl_Eof, eof char, cr write, auto read} { set s [file size $path(test1)] set f [open $path(test1) r] chan configure $f -translation auto -eofchar \x1a - set l [string length [chan read $f]] - set e [chan eof $f] + list $s [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $s $l $e -} {9 8 1} -test chan-io-35.9 {Tcl_Eof, eof char, cr write, cr read} { +} -result {9 8 1} +test chan-io-35.9 {Tcl_Eof, eof char, cr write, cr read} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation cr -eofchar \x1a chan puts $f abc\ndef @@ -4539,13 +4664,13 @@ test chan-io-35.9 {Tcl_Eof, eof char, cr write, cr read} { set s [file size $path(test1)] set f [open $path(test1) r] chan configure $f -translation cr -eofchar \x1a - set l [string length [chan read $f]] - set e [chan eof $f] + list $s [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $s $l $e -} {9 8 1} -test chan-io-35.10 {Tcl_Eof, eof char, crlf write, auto read} { +} -result {9 8 1} +test chan-io-35.10 {Tcl_Eof, eof char, crlf write, auto read} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation crlf -eofchar \x1a chan puts $f abc\ndef @@ -4553,13 +4678,13 @@ test chan-io-35.10 {Tcl_Eof, eof char, crlf write, auto read} { set s [file size $path(test1)] set f [open $path(test1) r] chan configure $f -translation auto -eofchar \x1a - set l [string length [chan read $f]] - set e [chan eof $f] + list $s [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $s $l $e -} {11 8 1} -test chan-io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} { +} -result {11 8 1} +test chan-io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation crlf -eofchar \x1a chan puts $f abc\ndef @@ -4567,112 +4692,106 @@ test chan-io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} { set s [file size $path(test1)] set f [open $path(test1) r] chan configure $f -translation crlf -eofchar \x1a - set l [string length [chan read $f]] - set e [chan eof $f] + list $s [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $s $l $e -} {11 8 1} -test chan-io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} { +} -result {11 8 1} +test chan-io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation lf -eofchar {} - set i [format abc\ndef\n%cqrs\nuvw 26] - chan puts $f $i + chan puts $f [format abc\ndef\n%cqrs\nuvw 26] chan close $f set c [file size $path(test1)] set f [open $path(test1) r] chan configure $f -translation auto -eofchar \x1a - set l [string length [chan read $f]] - set e [chan eof $f] + list $c [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $c $l $e -} {17 8 1} -test chan-io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} { +} -result {17 8 1} +test chan-io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation lf -eofchar {} - set i [format abc\ndef\n%cqrs\nuvw 26] - chan puts $f $i + chan puts $f [format abc\ndef\n%cqrs\nuvw 26] chan close $f set c [file size $path(test1)] set f [open $path(test1) r] chan configure $f -translation lf -eofchar \x1a - set l [string length [chan read $f]] - set e [chan eof $f] + list $c [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $c $l $e -} {17 8 1} -test chan-io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} { +} -result {17 8 1} +test chan-io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation cr -eofchar {} - set i [format abc\ndef\n%cqrs\nuvw 26] - chan puts $f $i + chan puts $f [format abc\ndef\n%cqrs\nuvw 26] chan close $f set c [file size $path(test1)] set f [open $path(test1) r] chan configure $f -translation auto -eofchar \x1a - set l [string length [chan read $f]] - set e [chan eof $f] + list $c [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $c $l $e -} {17 8 1} -test chan-io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} { +} -result {17 8 1} +test chan-io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation cr -eofchar {} - set i [format abc\ndef\n%cqrs\nuvw 26] - chan puts $f $i + chan puts $f [format abc\ndef\n%cqrs\nuvw 26] chan close $f set c [file size $path(test1)] set f [open $path(test1) r] chan configure $f -translation cr -eofchar \x1a - set l [string length [chan read $f]] - set e [chan eof $f] + list $c [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $c $l $e -} {17 8 1} -test chan-io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} { +} -result {17 8 1} +test chan-io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation crlf -eofchar {} - set i [format abc\ndef\n%cqrs\nuvw 26] - chan puts $f $i + chan puts $f [format abc\ndef\n%cqrs\nuvw 26] chan close $f set c [file size $path(test1)] set f [open $path(test1) r] chan configure $f -translation auto -eofchar \x1a - set l [string length [chan read $f]] - set e [chan eof $f] + list $c [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $c $l $e -} {21 8 1} -test chan-io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} { +} -result {21 8 1} +test chan-io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation crlf -eofchar {} - set i [format abc\ndef\n%cqrs\nuvw 26] - chan puts $f $i + chan puts $f [format abc\ndef\n%cqrs\nuvw 26] chan close $f set c [file size $path(test1)] set f [open $path(test1) r] chan configure $f -translation crlf -eofchar \x1a - set l [string length [chan read $f]] - set e [chan eof $f] + list $c [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $c $l $e -} {21 8 1} +} -result {21 8 1} # Test Tcl_InputBlocked -test chan-io-36.1 {Tcl_InputBlocked on nonblocking pipe} {stdio openpipe} { - set f1 [open "|[list [interpreter]]" r+] +test chan-io-36.1 {Tcl_InputBlocked on nonblocking pipe} -setup { + set x "" +} -constraints {stdio openpipe} -body { + set f1 [openpipe] chan puts $f1 {chan puts hello_from_pipe} chan flush $f1 chan gets $f1 chan configure $f1 -blocking off -buffering full chan puts $f1 {chan puts hello} - set x "" lappend x [chan gets $f1] lappend x [chan blocked $f1] chan flush $f1 @@ -4681,133 +4800,135 @@ test chan-io-36.1 {Tcl_InputBlocked on nonblocking pipe} {stdio openpipe} { lappend x [chan blocked $f1] lappend x [chan gets $f1] lappend x [chan blocked $f1] +} -cleanup { chan close $f1 - set x -} {{} 1 hello 0 {} 1} -test chan-io-36.2 {Tcl_InputBlocked on blocking pipe} {stdio openpipe} { - set f1 [open "|[list [interpreter]]" r+] +} -result {{} 1 hello 0 {} 1} +test chan-io-36.2 {Tcl_InputBlocked on blocking pipe} -setup { + set x "" +} -constraints {stdio openpipe} -body { + set f1 [openpipe] chan configure $f1 -buffering line chan puts $f1 {chan puts hello_from_pipe} - set x "" lappend x [chan gets $f1] lappend x [chan blocked $f1] chan puts $f1 {exit} lappend x [chan gets $f1] lappend x [chan blocked $f1] lappend x [chan eof $f1] +} -cleanup { chan close $f1 - set x -} {hello_from_pipe 0 {} 0 1} -test chan-io-36.3 {Tcl_InputBlocked vs files, short read} { +} -result {hello_from_pipe 0 {} 0 1} +test chan-io-36.3 {Tcl_InputBlocked vs files, short read} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan puts $f abcdefghijklmnop chan close $f set f [open $path(test1) r] - set l "" lappend l [chan blocked $f] lappend l [chan read $f 3] lappend l [chan blocked $f] lappend l [chan read -nonewline $f] lappend l [chan blocked $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {0 abc 0 defghijklmnop 0 1} -test chan-io-36.4 {Tcl_InputBlocked vs files, event driven read} {fileevent} { - proc in {f} { - variable l - variable x - lappend l [chan read $f 3] - if {[chan eof $f]} {lappend l eof; chan close $f; set x done} - } +} -result {0 abc 0 defghijklmnop 0 1} +test chan-io-36.4 {Tcl_InputBlocked vs files, event driven read} -setup { file delete $path(test1) + set l "" + variable x +} -constraints {fileevent} -body { set f [open $path(test1) w] chan puts $f abcdefghijklmnop chan close $f set f [open $path(test1) r] - set l "" - chan event $f readable [namespace code [list in $f]] - variable x + chan event $f readable [namespace code { + lappend l [chan read $f 3] + if {[chan eof $f]} {lappend l eof; chan close $f; set x done} + }] vwait [namespace which -variable x] - set l -} {abc def ghi jkl mno {p + return $l +} -result {abc def ghi jkl mno {p } eof} -test chan-io-36.5 {Tcl_InputBlocked vs files, short read, nonblocking} {nonBlockFiles} { +test chan-io-36.5 {Tcl_InputBlocked vs files, short read, nonblocking} -setup { file delete $path(test1) + set l "" +} -constraints {nonBlockFiles} -body { set f [open $path(test1) w] chan puts $f abcdefghijklmnop chan close $f set f [open $path(test1) r] chan configure $f -blocking off - set l "" lappend l [chan blocked $f] lappend l [chan read $f 3] lappend l [chan blocked $f] lappend l [chan read -nonewline $f] lappend l [chan blocked $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {0 abc 0 defghijklmnop 0 1} -test chan-io-36.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles fileevent} { - proc in {f} { - variable l - variable x - lappend l [chan read $f 3] - if {[chan eof $f]} {lappend l eof; chan close $f; set x done} - } +} -result {0 abc 0 defghijklmnop 0 1} +test chan-io-36.6 {Tcl_InputBlocked vs files, event driven read} -setup { file delete $path(test1) + set l "" + variable x +} -constraints {nonBlockFiles fileevent} -body { set f [open $path(test1) w] chan puts $f abcdefghijklmnop chan close $f set f [open $path(test1) r] chan configure $f -blocking off - set l "" - chan event $f readable [namespace code [list in $f]] - variable x + chan event $f readable [namespace code { + lappend l [chan read $f 3] + if {[chan eof $f]} {lappend l eof; chan close $f; set x done} + }] vwait [namespace which -variable x] - set l -} {abc def ghi jkl mno {p + return $l +} -result {abc def ghi jkl mno {p } eof} # Test Tcl_InputBuffered -test chan-io-37.1 {Tcl_InputBuffered} {testchannel} { +test chan-io-37.1 {Tcl_InputBuffered} -setup { + set l "" +} -constraints {testchannel} -body { set f [open $path(longfile) r] chan configure $f -buffersize 4096 chan read $f 3 - set l "" lappend l [testchannel inputbuffered $f] lappend l [chan tell $f] +} -cleanup { chan close $f - set l -} {4093 3} -test chan-io-37.2 {Tcl_InputBuffered, test input flushing on seek} {testchannel} { +} -result {4093 3} +test chan-io-37.2 {Tcl_InputBuffered, test input flushing on seek} -setup { + set l "" +} -constraints {testchannel} -body { set f [open $path(longfile) r] chan configure $f -buffersize 4096 chan read $f 3 - set l "" lappend l [testchannel inputbuffered $f] lappend l [chan tell $f] chan seek $f 0 current lappend l [testchannel inputbuffered $f] lappend l [chan tell $f] +} -cleanup { chan close $f - set l -} {4093 3 0 3} +} -result {4093 3 0 3} # Test Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize -test chan-io-38.1 {Tcl_GetChannelBufferSize, default buffer size} { +test chan-io-38.1 {Tcl_GetChannelBufferSize, default buffer size} -body { set f [open $path(longfile) r] - set s [chan configure $f -buffersize] + chan configure $f -buffersize +} -cleanup { chan close $f - set s -} 4096 -test chan-io-38.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} { - set f [open $path(longfile) r] +} -result 4096 +test chan-io-38.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} -setup { set l "" +} -body { + set f [open $path(longfile) r] lappend l [chan configure $f -buffersize] chan configure $f -buffersize 10000 lappend l [chan configure $f -buffersize] @@ -4821,9 +4942,9 @@ test chan-io-38.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} { lappend l [chan configure $f -buffersize] chan configure $f -buffersize 10000000 lappend l [chan configure $f -buffersize] +} -cleanup { chan close $f - set l -} {4096 10000 1 1 1 100000 1048576} +} -result {4096 10000 1 1 1 100000 1048576} test chan-io-38.3 {Tcl_SetChannelBufferSize, changing buffersize between reads} { # This test crashes the interp if Bug #427196 is not fixed set chan [open [info script] r] @@ -4836,35 +4957,39 @@ test chan-io-38.3 {Tcl_SetChannelBufferSize, changing buffersize between reads} # Test Tcl_SetChannelOption, Tcl_GetChannelOption -test chan-io-39.1 {Tcl_GetChannelOption} { +test chan-io-39.1 {Tcl_GetChannelOption} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] - set x [chan configure $f1 -blocking] + chan configure $f1 -blocking +} -cleanup { chan close $f1 - set x -} 1 +} -result 1 # # Test 17.2 was removed. # -test chan-io-39.2 {Tcl_GetChannelOption} { +test chan-io-39.2 {Tcl_GetChannelOption} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] - set x [chan configure $f1 -buffering] + chan configure $f1 -buffering +} -cleanup { chan close $f1 - set x -} full -test chan-io-39.3 {Tcl_GetChannelOption} { +} -result full +test chan-io-39.3 {Tcl_GetChannelOption} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan configure $f1 -buffering line - set x [chan configure $f1 -buffering] + chan configure $f1 -buffering +} -cleanup { chan close $f1 - set x -} line -test chan-io-39.4 {Tcl_GetChannelOption, Tcl_SetChannelOption} { +} -result line +test chan-io-39.4 {Tcl_GetChannelOption, Tcl_SetChannelOption} -setup { file delete $path(test1) - set f1 [open $path(test1) w] set l "" +} -body { + set f1 [open $path(test1) w] lappend l [chan configure $f1 -buffering] chan configure $f1 -buffering line lappend l [chan configure $f1 -buffering] @@ -4874,47 +4999,51 @@ test chan-io-39.4 {Tcl_GetChannelOption, Tcl_SetChannelOption} { lappend l [chan configure $f1 -buffering] chan configure $f1 -buffering full lappend l [chan configure $f1 -buffering] +} -cleanup { chan close $f1 - set l -} {full line none line full} -test chan-io-39.5 {Tcl_GetChannelOption, invariance} { +} -result {full line none line full} +test chan-io-39.5 {Tcl_GetChannelOption, invariance} -setup { file delete $path(test1) - set f1 [open $path(test1) w] set l "" +} -body { + set f1 [open $path(test1) w] lappend l [chan configure $f1 -buffering] lappend l [list [catch {chan configure $f1 -buffering green} msg] $msg] lappend l [chan configure $f1 -buffering] +} -cleanup { chan close $f1 - set l -} {full {1 {bad value for -buffering: must be one of full, line, or none}} full} -test chan-io-39.6 {Tcl_SetChannelOption, multiple options} { +} -result {full {1 {bad value for -buffering: must be one of full, line, or none}} full} +test chan-io-39.6 {Tcl_SetChannelOption, multiple options} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan configure $f1 -translation lf -buffering line chan puts $f1 hello chan puts $f1 bye - set x [file size $path(test1)] + file size $path(test1) +} -cleanup { chan close $f1 - set x -} 10 -test chan-io-39.7 {Tcl_SetChannelOption, buffering, translation} { +} -result 10 +test chan-io-39.7 {Tcl_SetChannelOption, buffering, translation} -setup { file delete $path(test1) + set x "" +} -body { set f1 [open $path(test1) w] chan configure $f1 -translation lf chan puts $f1 hello chan puts $f1 bye - set x "" chan configure $f1 -buffering line lappend x [file size $path(test1)] chan puts $f1 really_bye lappend x [file size $path(test1)] +} -cleanup { chan close $f1 - set x -} {0 21} -test chan-io-39.8 {Tcl_SetChannelOption, different buffering options} { +} -result {0 21} +test chan-io-39.8 {Tcl_SetChannelOption, different buffering options} -setup { file delete $path(test1) - set f1 [open $path(test1) w] set l "" +} -body { + set f1 [open $path(test1) w] chan configure $f1 -translation lf -buffering none -eofchar {} chan puts -nonewline $f1 hello lappend l [file size $path(test1)] @@ -4929,14 +5058,14 @@ test chan-io-39.8 {Tcl_SetChannelOption, different buffering options} { lappend l [file size $path(test1)] chan close $f1 lappend l [file size $path(test1)] - set l -} {5 10 10 10 20 20} -test chan-io-39.9 {Tcl_SetChannelOption, blocking mode} {nonBlockFiles} { +} -result {5 10 10 10 20 20} +test chan-io-39.9 {Tcl_SetChannelOption, blocking mode} -setup { file delete $path(test1) + set x "" +} -constraints {nonBlockFiles} -body { set f1 [open $path(test1) w] chan close $f1 set f1 [open $path(test1) r] - set x "" lappend x [chan configure $f1 -blocking] chan configure $f1 -blocking off lappend x [chan configure $f1 -blocking] @@ -4944,11 +5073,13 @@ test chan-io-39.9 {Tcl_SetChannelOption, blocking mode} {nonBlockFiles} { lappend x [chan read $f1 1000] lappend x [chan blocked $f1] lappend x [chan eof $f1] +} -cleanup { chan close $f1 - set x -} {1 0 {} {} 0 1} -test chan-io-39.10 {Tcl_SetChannelOption, blocking mode} {stdio openpipe} { +} -result {1 0 {} {} 0 1} +test chan-io-39.10 {Tcl_SetChannelOption, blocking mode} -setup { file delete $path(pipe) + set x "" +} -constraints {stdio openpipe} -body { set f1 [open $path(pipe) w] chan puts $f1 { chan gets stdin @@ -4957,8 +5088,7 @@ test chan-io-39.10 {Tcl_SetChannelOption, blocking mode} {stdio openpipe} { chan gets stdin } chan close $f1 - set x "" - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] chan configure $f1 -blocking off -buffering line lappend x [chan configure $f1 -blocking] lappend x [chan gets $f1] @@ -4980,71 +5110,78 @@ test chan-io-39.10 {Tcl_SetChannelOption, blocking mode} {stdio openpipe} { lappend x [chan eof $f1] lappend x [chan gets $f1] lappend x [chan eof $f1] +} -cleanup { chan close $f1 - set x -} {0 {} 1 {} 1 {} 1 1 hi 0 0 {} 1} -test chan-io-39.11 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size clipped to lower bound} { +} -result {0 {} 1 {} 1 {} 1 1 hi 0 0 {} 1} +test chan-io-39.11 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size clipped to lower bound} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -buffersize -10 - set x [chan configure $f -buffersize] + chan configure $f -buffersize +} -cleanup { chan close $f - set x -} 1 -test chan-io-39.12 {Tcl_SetChannelOption, Tcl_GetChannelOption buffer size clipped to upper bound} { +} -result 1 +test chan-io-39.12 {Tcl_SetChannelOption, Tcl_GetChannelOption buffer size clipped to upper bound} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -buffersize 10000000 - set x [chan configure $f -buffersize] + chan configure $f -buffersize +} -cleanup { chan close $f - set x -} 1048576 -test chan-io-39.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { +} -result 1048576 +test chan-io-39.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -buffersize 40000 - set x [chan configure $f -buffersize] + chan configure $f -buffersize +} -cleanup { chan close $f - set x -} 40000 -test chan-io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} { +} -result 40000 +test chan-io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -encoding {} chan puts -nonewline $f \xe7\x89\xa6 chan close $f set f [open $path(test1) r] chan configure $f -encoding utf-8 - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} \u7266 -test chan-io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} { +} -result \u7266 +test chan-io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -encoding binary chan puts -nonewline $f \xe7\x89\xa6 chan close $f set f [open $path(test1) r] chan configure $f -encoding utf-8 - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} \u7266 -test chan-io-39.16 {Tcl_SetChannelOption: -encoding, errors} { +} -result \u7266 +test chan-io-39.16 {Tcl_SetChannelOption: -encoding, errors} -setup { file delete $path(test1) set f [open $path(test1) w] - set result [list [catch {chan configure $f -encoding foobar} msg] $msg] +} -body { + chan configure $f -encoding foobar +} -returnCodes error -cleanup { chan close $f - set result -} {1 {unknown encoding "foobar"}} -test chan-io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} {stdio openpipe fileevent} { - set f [open "|[list [interpreter] $path(cat)]" r+] +} -result {unknown encoding "foobar"} +test chan-io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} -setup { + variable x {} +} -constraints {stdio openpipe fileevent} -body { + set f [openpipe r+ $path(cat)] chan configure $f -encoding binary chan puts -nonewline $f "\xe7" chan flush $f chan configure $f -encoding utf-8 -blocking 0 - variable x {} chan event $f readable [namespace code { lappend x [chan read $f] }] vwait [namespace which -variable x] after 300 [namespace code { lappend x timeout }] @@ -5057,105 +5194,113 @@ test chan-io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_ vwait [namespace which -variable x] after 300 [namespace code { lappend x timeout }] vwait [namespace which -variable x] + return $x +} -cleanup { chan close $f - set x -} "{} timeout {} timeout \xe7 timeout" +} -result "{} timeout {} timeout \xe7 timeout" test chan-io-39.18 {Tcl_SetChannelOption, setting read mode independently} \ - {socket} { + -constraints {socket} -body { proc accept {s a p} {chan close $s} set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0] set port [lindex [chan configure $s1 -sockname] 2] set s2 [socket 127.0.0.1 $port] update chan configure $s2 -translation {auto lf} - set modes [chan configure $s2 -translation] + chan configure $s2 -translation +} -cleanup { chan close $s1 chan close $s2 - set modes -} {auto lf} +} -result {auto lf} test chan-io-39.19 {Tcl_SetChannelOption, setting read mode independently} \ - {socket} { + -constraints {socket} -body { proc accept {s a p} {chan close $s} set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0] set port [lindex [chan configure $s1 -sockname] 2] set s2 [socket 127.0.0.1 $port] update chan configure $s2 -translation {auto crlf} - set modes [chan configure $s2 -translation] + chan configure $s2 -translation +} -cleanup { chan close $s1 chan close $s2 - set modes -} {auto crlf} +} -result {auto crlf} test chan-io-39.20 {Tcl_SetChannelOption, setting read mode independently} \ - {socket} { + -constraints {socket} -body { proc accept {s a p} {chan close $s} set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0] set port [lindex [chan configure $s1 -sockname] 2] set s2 [socket 127.0.0.1 $port] update chan configure $s2 -translation {auto cr} - set modes [chan configure $s2 -translation] + chan configure $s2 -translation +} -cleanup { chan close $s1 chan close $s2 - set modes -} {auto cr} +} -result {auto cr} test chan-io-39.21 {Tcl_SetChannelOption, setting read mode independently} \ - {socket} { + -constraints {socket} -body { proc accept {s a p} {chan close $s} set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0] set port [lindex [chan configure $s1 -sockname] 2] set s2 [socket 127.0.0.1 $port] update chan configure $s2 -translation {auto auto} - set modes [chan configure $s2 -translation] + chan configure $s2 -translation +} -cleanup { chan close $s1 chan close $s2 - set modes -} {auto crlf} -test chan-io-39.22 {Tcl_SetChannelOption, invariance} {unix} { +} -result {auto crlf} +test chan-io-39.22 {Tcl_SetChannelOption, invariance} -setup { file delete $path(test1) - set f1 [open $path(test1) w+] set l "" +} -constraints {unix} -body { + set f1 [open $path(test1) w+] lappend l [chan configure $f1 -eofchar] chan configure $f1 -eofchar {ON GO} lappend l [chan configure $f1 -eofchar] chan configure $f1 -eofchar D lappend l [chan configure $f1 -eofchar] +} -cleanup { chan close $f1 - set l -} {{{} {}} {O G} {D D}} -test chan-io-39.22a {Tcl_SetChannelOption, invariance} { +} -result {{{} {}} {O G} {D D}} +test chan-io-39.22a {Tcl_SetChannelOption, invariance} -setup { file delete $path(test1) - set f1 [open $path(test1) w+] set l [list] +} -body { + set f1 [open $path(test1) w+] chan configure $f1 -eofchar {ON GO} lappend l [chan configure $f1 -eofchar] chan configure $f1 -eofchar D lappend l [chan configure $f1 -eofchar] lappend l [list [catch {chan configure $f1 -eofchar {1 2 3}} msg] $msg] +} -cleanup { chan close $f1 - set l -} {{O G} {D D} {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}} -test chan-io-39.23 {Tcl_GetChannelOption, server socket is not readable or - writeable, it should still have valid -eofchar and -translation options } { +} -result {{O G} {D D} {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}} +test chan-io-39.23 {Tcl_GetChannelOption, server socket is not readable or\ + writeable, it should still have valid -eofchar and -translation options} -setup { set l [list] +} -body { set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0] - lappend l [chan configure $sock -eofchar] [chan configure $sock -translation] + lappend l [chan configure $sock -eofchar] \ + [chan configure $sock -translation] +} -cleanup { chan close $sock - set l -} {{{}} auto} -test chan-io-39.24 {Tcl_SetChannelOption, server socket is not readable or - writable so we can't change -eofchar or -translation } { +} -result {{{}} auto} +test chan-io-39.24 {Tcl_SetChannelOption, server socket is not readable or\ + writable so we can't change -eofchar or -translation} -setup { set l [list] +} -body { set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0] chan configure $sock -eofchar D -translation lf - lappend l [chan configure $sock -eofchar] [chan configure $sock -translation] + lappend l [chan configure $sock -eofchar] \ + [chan configure $sock -translation] +} -cleanup { chan close $sock - set l -} {{{}} auto} +} -result {{{}} auto} -test chan-io-40.1 {POSIX open access modes: RDWR} { +test chan-io-40.1 {POSIX open access modes: RDWR} -setup { file delete $path(test3) +} -body { set f [open $path(test3) w] chan puts $f xyzzy chan close $f @@ -5166,11 +5311,12 @@ test chan-io-40.1 {POSIX open access modes: RDWR} { chan close $f set f [open $path(test3) r] lappend x [chan gets $f] +} -cleanup { chan close $f - set x -} {zzy abzzy} -test chan-io-40.2 {POSIX open access modes: CREAT} {unix} { +} -result {zzy abzzy} +test chan-io-40.2 {POSIX open access modes: CREAT} -setup { file delete $path(test3) +} -constraints {unix} -body { set f [open $path(test3) {WRONLY CREAT} 0600] file stat $path(test3) stats set x [format "0%o" [expr $stats(mode)&0o777]] @@ -5178,19 +5324,20 @@ test chan-io-40.2 {POSIX open access modes: CREAT} {unix} { chan close $f set f [open $path(test3) r] lappend x [chan gets $f] +} -cleanup { chan close $f - set x -} {0600 {line 1}} -test chan-io-40.3 {POSIX open access modes: CREAT} {unix umask} { - # This test only works if your umask is 2, like ouster's. +} -result {0600 {line 1}} +test chan-io-40.3 {POSIX open access modes: CREAT} -setup { file delete $path(test3) - set f [open $path(test3) {WRONLY CREAT}] - chan close $f +} -constraints {unix umask} -body { + # This test only works if your umask is 2, like ouster's. + chan close [open $path(test3) {WRONLY CREAT}] file stat $path(test3) stats format "0%o" [expr $stats(mode)&0o777] -} [format %04o [expr {0o666 & ~ $umaskValue}]] -test chan-io-40.4 {POSIX open access modes: CREAT} { +} -result [format %04o [expr {0o666 & ~ $umaskValue}]] +test chan-io-40.4 {POSIX open access modes: CREAT} -setup { file delete $path(test3) +} -body { set f [open $path(test3) w] chan configure $f -eofchar {} chan puts $f xyzzy @@ -5200,12 +5347,14 @@ test chan-io-40.4 {POSIX open access modes: CREAT} { chan puts -nonewline $f "ab" chan close $f set f [open $path(test3) r] - set x [chan gets $f] + chan gets $f +} -cleanup { chan close $f - set x -} abzzy -test chan-io-40.5 {POSIX open access modes: APPEND} { +} -result abzzy +test chan-io-40.5 {POSIX open access modes: APPEND} -setup { file delete $path(test3) + set x "" +} -body { set f [open $path(test3) w] chan configure $f -translation lf -eofchar {} chan puts $f xyzzy @@ -5218,30 +5367,32 @@ test chan-io-40.5 {POSIX open access modes: APPEND} { chan close $f set f [open $path(test3) r] chan configure $f -translation lf - set x "" chan seek $f 6 current lappend x [chan gets $f] lappend x [chan gets $f] +} -cleanup { chan close $f - set x -} {{new line} abc} -test chan-io-40.6 {POSIX open access modes: EXCL} -match regexp -body { +} -result {{new line} abc} +test chan-io-40.6 {POSIX open access modes: EXCL} -match regexp -setup { file delete $path(test3) +} -body { set f [open $path(test3) w] chan puts $f xyzzy chan close $f open $path(test3) {WRONLY CREAT EXCL} } -returnCodes error -result {(?i)couldn't open ".*test3": file (already )?exists} -test chan-io-40.7 {POSIX open access modes: EXCL} { +test chan-io-40.7 {POSIX open access modes: EXCL} -setup { file delete $path(test3) +} -body { set f [open $path(test3) {WRONLY CREAT EXCL}] chan configure $f -eofchar {} chan puts $f "A test line" chan close $f viewFile test3 -} {A test line} -test chan-io-40.8 {POSIX open access modes: TRUNC} { +} -result {A test line} +test chan-io-40.8 {POSIX open access modes: TRUNC} -setup { file delete $path(test3) +} -body { set f [open $path(test3) w] chan puts $f xyzzy chan close $f @@ -5249,32 +5400,31 @@ test chan-io-40.8 {POSIX open access modes: TRUNC} { chan puts $f abc chan close $f set f [open $path(test3) r] - set x [chan gets $f] + chan gets $f +} -cleanup { chan close $f - set x -} abc -test chan-io-40.9 {POSIX open access modes: NONBLOCK} {nonPortable unix} { +} -result abc +test chan-io-40.9 {POSIX open access modes: NONBLOCK} -setup { file delete $path(test3) +} -constraints {nonPortable unix} -body { set f [open $path(test3) {WRONLY NONBLOCK CREAT}] chan puts $f "NONBLOCK test" chan close $f set f [open $path(test3) r] - set x [chan gets $f] + chan gets $f +} -cleanup { chan close $f - set x -} {NONBLOCK test} -test chan-io-40.10 {POSIX open access modes: RDONLY} { +} -result {NONBLOCK test} +test chan-io-40.10 {POSIX open access modes: RDONLY} -body { set f [open $path(test1) w] chan puts $f "two lines: this one" chan puts $f "and this" chan close $f set f [open $path(test1) RDONLY] - set x [list [chan gets $f] [catch {chan puts $f Test} msg] $msg] + list [chan gets $f] [catch {chan puts $f Test} msg] $msg +} -cleanup { chan close $f - string compare [string tolower $x] \ - [list {two lines: this one} 1 \ - [format "channel \"%s\" wasn't opened for writing" $f]] -} 0 +} -match glob -result {{two lines: this one} 1 {channel "*" wasn't opened for writing}} test chan-io-40.11 {POSIX open access modes: RDONLY} -match regexp -body { file delete $path(test3) open $path(test3) RDONLY @@ -5283,7 +5433,7 @@ test chan-io-40.12 {POSIX open access modes: WRONLY} -match regexp -body { file delete $path(test3) open $path(test3) WRONLY } -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory} -test chan-io-40.13 {POSIX open access modes: WRONLY} { +test chan-io-40.13 {POSIX open access modes: WRONLY} -body { makeFile xyzzy test3 set f [open $path(test3) WRONLY] chan configure $f -eofchar {} @@ -5292,9 +5442,7 @@ test chan-io-40.13 {POSIX open access modes: WRONLY} { set x [list [catch {chan gets $f} msg] $msg] chan close $f lappend x [viewFile test3] - string compare [string tolower $x] \ - [list 1 "channel \"$f\" wasn't opened for reading" abzzy] -} 0 +} -match glob -result {1 {channel "*" wasn't opened for reading} abzzy} test chan-io-40.14 {POSIX open access modes: RDWR} -match regexp -body { file delete $path(test3) open $path(test3) RDWR @@ -5315,29 +5463,30 @@ test chan-io-40.16 {tilde substitution in open} -constraints makeFileInHome -set } -cleanup { removeFile _test_ ~ } -result 1 -test chan-io-40.17 {tilde substitution in open} { +test chan-io-40.17 {tilde substitution in open} -setup { set home $::env(HOME) +} -body { unset ::env(HOME) - set x [list [catch {open ~/foo} msg] $msg] + open ~/foo +} -returnCodes error -cleanup { set ::env(HOME) $home - set x -} {1 {couldn't find HOME environment variable to expand path}} +} -result {couldn't find HOME environment variable to expand path} -test chan-io-41.1 {Tcl_FileeventCmd: errors} {fileevent} { - list [catch {chan event foo} msg] $msg -} {1 {wrong # args: should be "chan event channelId event ?script?"}} -test chan-io-41.2 {Tcl_FileeventCmd: errors} {fileevent} { - list [catch {chan event foo bar baz q} msg] $msg -} {1 {wrong # args: should be "chan event channelId event ?script?"}} -test chan-io-41.3 {Tcl_FileeventCmd: errors} {fileevent} { - list [catch {chan event gorp readable} msg] $msg -} {1 {can not find channel named "gorp"}} -test chan-io-41.4 {Tcl_FileeventCmd: errors} {fileevent} { - list [catch {chan event gorp writable} msg] $msg -} {1 {can not find channel named "gorp"}} -test chan-io-41.5 {Tcl_FileeventCmd: errors} {fileevent} { - list [catch {chan event gorp who-knows} msg] $msg -} {1 {bad event name "who-knows": must be readable or writable}} +test chan-io-41.1 {Tcl_FileeventCmd: errors} -constraints fileevent -body { + chan event foo +} -returnCodes error -result {wrong # args: should be "chan event channelId event ?script?"} +test chan-io-41.2 {Tcl_FileeventCmd: errors} -constraints fileevent -body { + chan event foo bar baz q +} -returnCodes error -result {wrong # args: should be "chan event channelId event ?script?"} +test chan-io-41.3 {Tcl_FileeventCmd: errors} -constraints fileevent -body { + chan event gorp readable +} -returnCodes error -result {can not find channel named "gorp"} +test chan-io-41.4 {Tcl_FileeventCmd: errors} -constraints fileevent -body { + chan event gorp writable +} -returnCodes error -result {can not find channel named "gorp"} +test chan-io-41.5 {Tcl_FileeventCmd: errors} -constraints fileevent -body { + chan event gorp who-knows +} -returnCodes error -result {bad event name "who-knows": must be readable or writable} # # Test chan event on a file @@ -5372,7 +5521,6 @@ test chan-io-42.3 {Tcl_FileeventCmd: replacing, with NULL chars in script} {file lappend result [chan event $f readable] } {13 11 12 {}} - test chan-io-43.1 {Tcl_FileeventCmd: creating, deleting, querying} {stdio unixExecs fileevent} { set result {} chan event $f readable "script 1" @@ -5387,8 +5535,8 @@ test chan-io-43.1 {Tcl_FileeventCmd: creating, deleting, querying} {stdio unixEx test chan-io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] -} -constraints {stdio unixExecs fileevent openpipe} -body { set result {} +} -constraints {stdio unixExecs fileevent openpipe} -body { lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r] chan event $f r "chan read f" chan event $f2 r "chan read f2" @@ -5415,14 +5563,12 @@ test chan-io-44.1 {FileEventProc procedure: normal read event} -setup { chan puts $f2 text; chan flush $f2 variable x initial vwait [namespace which -variable x] - set x + return $x } -cleanup { catch {chan close $f2} catch {chan close $f3} } -result {text} -test chan-io-44.2 {FileEventProc procedure: error in read event} -constraints { - stdio unixExecs fileevent openpipe -} -setup { +test chan-io-44.2 {FileEventProc procedure: error in read event} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] proc myHandler {msg options} { @@ -5430,7 +5576,7 @@ test chan-io-44.2 {FileEventProc procedure: error in read event} -constraints { } set handler [interp bgerror {}] interp bgerror {} [namespace which myHandler] -} -body { +} -constraints {stdio unixExecs fileevent openpipe} -body { chan event $f2 readable {error bogus} chan puts $f2 text; chan flush $f2 variable x initial @@ -5457,14 +5603,12 @@ test chan-io-44.3 {FileEventProc procedure: normal write event} -setup { vwait [namespace which -variable x] vwait [namespace which -variable x] vwait [namespace which -variable x] - set x + return $x } -cleanup { catch {chan close $f2} catch {chan close $f3} } -result {initial triggered triggered triggered} -test chan-io-44.4 {FileEventProc procedure: eror in write event} -constraints { - stdio unixExecs fileevent openpipe -} -setup { +test chan-io-44.4 {FileEventProc procedure: eror in write event} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] proc myHandler {msg options} { @@ -5472,7 +5616,7 @@ test chan-io-44.4 {FileEventProc procedure: eror in write event} -constraints { } set handler [interp bgerror {}] interp bgerror {} [namespace which myHandler] -} -body { +} -constraints {stdio unixExecs fileevent openpipe} -body { chan event $f2 writable {error bad-write} variable x initial vwait [namespace which -variable x] @@ -5483,7 +5627,7 @@ test chan-io-44.4 {FileEventProc procedure: eror in write event} -constraints { catch {chan close $f3} } -result {bad-write {}} test chan-io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs openpipe fileevent} { - set f4 [open "|[list [interpreter] $path(cat) << foo]" r] + set f4 [openpipe r $path(cat) << foo] chan event $f4 readable [namespace code { if {[chan gets $f4 line] < 0} { lappend x eof @@ -5510,7 +5654,9 @@ test chan-io-45.1 {DeleteFileEvent, cleanup on chan close} {fileevent} { }] chan close $f set x initial - after 100 [namespace code { set y done }] + after 100 [namespace code { + set y done + }] variable y vwait [namespace which -variable y] set x @@ -5519,9 +5665,9 @@ test chan-io-45.2 {DeleteFileEvent, cleanup on chan close} {fileevent} { set f [open $path(foo) r] set f2 [open $path(foo) r] chan event $f readable [namespace code { - lappend x "f triggered: \"[chan gets $f]\"" - chan event $f readable {} - }] + lappend x "f triggered: \"[chan gets $f]\"" + chan event $f readable {} + }] chan event $f2 readable [namespace code { lappend x "f2 triggered: \"[chan gets $f2]\"" chan event $f2 readable {} @@ -5595,30 +5741,32 @@ test chan-io-46.3 {Tcl event loop vs multiple interpreters} testfevent { } } {0 0 {0 timer}} -test chan-io-47.1 {chan event vs multiple interpreters} {testfevent fileevent} { +test chan-io-47.1 {chan event vs multiple interpreters} -setup { set f [open $path(foo) r] set f2 [open $path(foo) r] set f3 [open $path(foo) r] + set x {} +} -constraints {testfevent fileevent} -body { chan event $f readable {script 1} testfevent create testfevent share $f2 testfevent cmd "chan event $f2 readable {script 2}" chan event $f3 readable {sript 3} - set x {} lappend x [chan event $f2 readable] testfevent delete lappend x [chan event $f readable] [chan event $f2 readable] \ [chan event $f3 readable] +} -cleanup { chan close $f chan close $f2 chan close $f3 - set x -} {{} {script 1} {} {sript 3}} -test chan-io-47.2 {deleting chan event on interpreter delete} {testfevent fileevent} { +} -result {{} {script 1} {} {sript 3}} +test chan-io-47.2 {deleting chan event on interpreter delete} -setup { set f [open $path(foo) r] set f2 [open $path(foo) r] set f3 [open $path(foo) r] set f4 [open $path(foo) r] +} -constraints {testfevent fileevent} -body { chan event $f readable {script 1} testfevent create testfevent share $f2 @@ -5627,19 +5775,20 @@ test chan-io-47.2 {deleting chan event on interpreter delete} {testfevent fileev chan event $f3 readable {script 3}" chan event $f4 readable {script 4} testfevent delete - set x [list [chan event $f readable] [chan event $f2 readable] \ - [chan event $f3 readable] [chan event $f4 readable]] + list [chan event $f readable] [chan event $f2 readable] \ + [chan event $f3 readable] [chan event $f4 readable] +} -cleanup { chan close $f chan close $f2 chan close $f3 chan close $f4 - set x -} {{script 1} {} {} {script 4}} -test chan-io-47.3 {deleting chan event on interpreter delete} {testfevent fileevent} { +} -result {{script 1} {} {} {script 4}} +test chan-io-47.3 {deleting chan event on interpreter delete} -setup { set f [open $path(foo) r] set f2 [open $path(foo) r] set f3 [open $path(foo) r] set f4 [open $path(foo) r] +} -constraints {testfevent fileevent} -body { testfevent create testfevent share $f3 testfevent share $f4 @@ -5648,56 +5797,56 @@ test chan-io-47.3 {deleting chan event on interpreter delete} {testfevent fileev testfevent cmd "chan event $f3 readable {script 3} chan event $f4 readable {script 4}" testfevent delete - set x [list [chan event $f readable] [chan event $f2 readable] \ - [chan event $f3 readable] [chan event $f4 readable]] + list [chan event $f readable] [chan event $f2 readable] \ + [chan event $f3 readable] [chan event $f4 readable] +} -cleanup { chan close $f chan close $f2 chan close $f3 chan close $f4 - set x -} {{script 1} {script 2} {} {}} -test chan-io-47.4 {file events on shared files and multiple interpreters} {testfevent fileevent} { +} -result {{script 1} {script 2} {} {}} +test chan-io-47.4 {file events on shared files and multiple interpreters} -setup { set f [open $path(foo) r] set f2 [open $path(foo) r] +} -constraints {testfevent fileevent} -body { testfevent create testfevent share $f testfevent cmd "chan event $f readable {script 1}" chan event $f readable {script 2} chan event $f2 readable {script 3} - set x [list [chan event $f2 readable] \ - [testfevent cmd "chan event $f readable"] \ - [chan event $f readable]] + list [chan event $f2 readable] [testfevent cmd "chan event $f readable"] \ + [chan event $f readable] +} -cleanup { testfevent delete chan close $f chan close $f2 - set x -} {{script 3} {script 1} {script 2}} -test chan-io-47.5 {file events on shared files, deleting file events} {testfevent fileevent} { +} -result {{script 3} {script 1} {script 2}} +test chan-io-47.5 {file events on shared files, deleting file events} -setup { set f [open $path(foo) r] +} -body { testfevent create testfevent share $f testfevent cmd "chan event $f readable {script 1}" chan event $f readable {script 2} testfevent cmd "chan event $f readable {}" - set x [list [testfevent cmd "chan event $f readable"] \ - [chan event $f readable]] + list [testfevent cmd "chan event $f readable"] [chan event $f readable] +} -constraints {testfevent fileevent} -cleanup { testfevent delete chan close $f - set x -} {{} {script 2}} -test chan-io-47.6 {file events on shared files, deleting file events} {testfevent fileevent} { +} -result {{} {script 2}} +test chan-io-47.6 {file events on shared files, deleting file events} -setup { set f [open $path(foo) r] +} -body { testfevent create testfevent share $f testfevent cmd "chan event $f readable {script 1}" chan event $f readable {script 2} chan event $f readable {} - set x [list [testfevent cmd "chan event $f readable"] \ - [chan event $f readable]] + list [testfevent cmd "chan event $f readable"] [chan event $f readable] +} -constraints {testfevent fileevent} -cleanup { testfevent delete chan close $f - set x -} {{script 1} {}} +} -result {{script 1} {}} set path(bar) [makeFile {} bar] @@ -5710,10 +5859,7 @@ test chan-io-48.1 {testing readability conditions} {fileevent} { chan puts $f abcdefg chan close $f set f [open $path(bar) r] - chan event $f readable [namespace code [list consume $f]] - proc consume {f} { - variable l - variable x + chan event $f readable [namespace code { lappend l called if {[chan eof $f]} { chan close $f @@ -5721,7 +5867,7 @@ test chan-io-48.1 {testing readability conditions} {fileevent} { } else { chan gets $f } - } + }] set l "" variable x not_done vwait [namespace which -variable x] @@ -5736,11 +5882,7 @@ test chan-io-48.2 {testing readability conditions} {nonBlockFiles fileevent} { chan puts $f abcdefg chan close $f set f [open $path(bar) r] - chan event $f readable [namespace code [list consume $f]] - chan configure $f -blocking off - proc consume {f} { - variable x - variable l + chan event $f readable [namespace code { lappend l called if {[chan eof $f]} { chan close $f @@ -5748,14 +5890,17 @@ test chan-io-48.2 {testing readability conditions} {nonBlockFiles fileevent} { } else { chan gets $f } - } + }] + chan configure $f -blocking off set l "" variable x not_done vwait [namespace which -variable x] list $x $l } {done {called called called called called called called}} set path(my_script) [makeFile {} my_script] -test chan-io-48.3 {testing readability conditions} {stdio unix nonBlockFiles openpipe fileevent} { +test chan-io-48.3 {testing readability conditions} -setup { + set l "" +} -constraints {stdio unix nonBlockFiles openpipe fileevent} -body { set f [open $path(bar) w] chan puts $f abcdefg chan puts $f abcdefg @@ -5774,13 +5919,8 @@ test chan-io-48.3 {testing readability conditions} {stdio unix nonBlockFiles ope } } chan close $f - set f [open "|[list [interpreter]]" r+] - chan event $f readable [namespace code [list consume $f]] - chan configure $f -buffering line - chan configure $f -blocking off - proc consume {f} { - variable l - variable x + set f [openpipe] + chan event $f readable [namespace code { if {[chan eof $f]} { set x done } else { @@ -5789,28 +5929,31 @@ test chan-io-48.3 {testing readability conditions} {stdio unix nonBlockFiles ope chan gets $f lappend l [chan blocked $f] } - } - set l "" + }] + chan configure $f -buffering line + chan configure $f -blocking off variable x not_done chan puts $f [list source $path(my_script)] chan puts $f "set f \[[list open $path(bar) r]]" chan puts $f {copy_slowly $f} chan puts $f {exit} vwait [namespace which -variable x] - chan close $f list $x $l -} {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}} -test chan-io-48.4 {lf write, testing readability, ^Z termination, auto read mode} {fileevent} { +} -cleanup { + chan close $f +} -result {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}} +test chan-io-48.4 {lf write, testing readability, ^Z termination, auto read mode} -setup { file delete $path(test1) + set c 0 + set l "" +} -constraints {fileevent} -body { set f [open $path(test1) w] chan configure $f -translation lf - variable c [format "abc\ndef\n%c" 26] - chan puts -nonewline $f $c + chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f - proc consume {f} { - variable l - variable c - variable x + set f [open $path(test1) r] + chan configure $f -translation auto -eofchar \x1a + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -5818,27 +5961,23 @@ test chan-io-48.4 {lf write, testing readability, ^Z termination, auto read mode lappend l [chan gets $f] incr c } - } - set c 0 - set l "" - set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l -} {3 {abc def {}}} -test chan-io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} {fileevent} { +} -result {3 {abc def {}}} +test chan-io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} -setup { file delete $path(test1) + set c 0 + set l "" +} -constraints {fileevent} -body { set f [open $path(test1) w] chan configure $f -translation lf - set c [format "abc\ndef\n%cfoo\nbar\n" 26] - chan puts -nonewline $f $c + chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f - proc consume {f} { - variable l - variable x - variable c + set f [open $path(test1) r] + chan configure $f -eofchar \x1a -translation auto + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -5846,27 +5985,23 @@ test chan-io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} lappend l [chan gets $f] incr c } - } - set c 0 - set l "" - set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation auto - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l -} {3 {abc def {}}} -test chan-io-48.6 {cr write, testing readability, ^Z termination, auto read mode} {fileevent} { +} -result {3 {abc def {}}} +test chan-io-48.6 {cr write, testing readability, ^Z termination, auto read mode} -setup { file delete $path(test1) + set c 0 + set l "" +} -constraints {fileevent} -body { set f [open $path(test1) w] chan configure $f -translation cr - set c [format "abc\ndef\n%c" 26] - chan puts -nonewline $f $c + chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f - proc consume {f} { - variable l - variable x - variable c + set f [open $path(test1) r] + chan configure $f -translation auto -eofchar \x1a + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -5874,27 +6009,23 @@ test chan-io-48.6 {cr write, testing readability, ^Z termination, auto read mode lappend l [chan gets $f] incr c } - } - set c 0 - set l "" - set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l -} {3 {abc def {}}} -test chan-io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} {fileevent} { +} -result {3 {abc def {}}} +test chan-io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} -setup { file delete $path(test1) + set c 0 + set l "" +} -constraints {fileevent} -body { set f [open $path(test1) w] chan configure $f -translation cr - set c [format "abc\ndef\n%cfoo\nbar\n" 26] - chan puts -nonewline $f $c + chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f - proc consume {f} { - variable l - variable c - variable x + set f [open $path(test1) r] + chan configure $f -eofchar \x1a -translation auto + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -5902,27 +6033,23 @@ test chan-io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} lappend l [chan gets $f] incr c } - } - set c 0 - set l "" - set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation auto - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l -} {3 {abc def {}}} -test chan-io-48.8 {crlf write, testing readability, ^Z termination, auto read mode} {fileevent} { +} -result {3 {abc def {}}} +test chan-io-48.8 {crlf write, testing readability, ^Z termination, auto read mode} -setup { file delete $path(test1) + set c 0 + set l "" +} -constraints {fileevent} -body { set f [open $path(test1) w] chan configure $f -translation crlf - set c [format "abc\ndef\n%c" 26] - chan puts -nonewline $f $c + chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f - proc consume {f} { - variable l - variable x - variable c + set f [open $path(test1) r] + chan configure $f -translation auto -eofchar \x1a + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -5930,27 +6057,23 @@ test chan-io-48.8 {crlf write, testing readability, ^Z termination, auto read mo lappend l [chan gets $f] incr c } - } - set c 0 - set l "" - set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l -} {3 {abc def {}}} -test chan-io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode} {fileevent} { +} -result {3 {abc def {}}} +test chan-io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode} -setup { file delete $path(test1) + set c 0 + set l "" +} -constraints {fileevent} -body { set f [open $path(test1) w] chan configure $f -translation crlf - set c [format "abc\ndef\n%cfoo\nbar\n" 26] - chan puts -nonewline $f $c + chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f - proc consume {f} { - variable l - variable c - variable x + set f [open $path(test1) r] + chan configure $f -eofchar \x1a -translation auto + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -5958,27 +6081,23 @@ test chan-io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode lappend l [chan gets $f] incr c } - } - set c 0 - set l "" - set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation auto - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l -} {3 {abc def {}}} -test chan-io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} {fileevent} { +} -result {3 {abc def {}}} +test chan-io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} -setup { file delete $path(test1) + set c 0 + set l "" +} -constraints {fileevent} -body { set f [open $path(test1) w] chan configure $f -translation lf - set c [format "abc\ndef\n%cfoo\nbar\n" 26] - chan puts -nonewline $f $c + chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f - proc consume {f} { - variable l - variable c - variable x + set f [open $path(test1) r] + chan configure $f -eofchar \x1a -translation lf + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -5986,27 +6105,23 @@ test chan-io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} { lappend l [chan gets $f] incr c } - } - set c 0 - set l "" - set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation lf - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l -} {3 {abc def {}}} -test chan-io-48.11 {lf write, testing readability, ^Z termination, lf read mode} {fileevent} { +} -result {3 {abc def {}}} +test chan-io-48.11 {lf write, testing readability, ^Z termination, lf read mode} -setup { file delete $path(test1) + set c 0 + set l "" +} -constraints {fileevent} -body { set f [open $path(test1) w] chan configure $f -translation lf - set c [format "abc\ndef\n%c" 26] - chan puts -nonewline $f $c + chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f - proc consume {f} { - variable l - variable x - variable c + set f [open $path(test1) r] + chan configure $f -translation lf -eofchar \x1a + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -6014,27 +6129,23 @@ test chan-io-48.11 {lf write, testing readability, ^Z termination, lf read mode} lappend l [chan gets $f] incr c } - } - set c 0 - set l "" - set f [open $path(test1) r] - chan configure $f -translation lf -eofchar \x1a - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l -} {3 {abc def {}}} -test chan-io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} {fileevent} { +} -result {3 {abc def {}}} +test chan-io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} -setup { file delete $path(test1) + set c 0 + set l "" +} -constraints {fileevent} -body { set f [open $path(test1) w] chan configure $f -translation cr - set c [format "abc\ndef\n%cfoo\nbar\n" 26] - chan puts -nonewline $f $c + chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f - proc consume {f} { - variable l - variable x - variable c + set f [open $path(test1) r] + chan configure $f -eofchar \x1a -translation cr + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -6042,27 +6153,23 @@ test chan-io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} { lappend l [chan gets $f] incr c } - } - set c 0 - set l "" - set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation cr - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l -} {3 {abc def {}}} -test chan-io-48.13 {cr write, testing readability, ^Z termination, cr read mode} {fileevent} { +} -result {3 {abc def {}}} +test chan-io-48.13 {cr write, testing readability, ^Z termination, cr read mode} -setup { file delete $path(test1) + set c 0 + set l "" +} -constraints {fileevent} -body { set f [open $path(test1) w] chan configure $f -translation cr - set c [format "abc\ndef\n%c" 26] - chan puts -nonewline $f $c + chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f - proc consume {f} { - variable c - variable x - variable l + set f [open $path(test1) r] + chan configure $f -translation cr -eofchar \x1a + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -6070,27 +6177,23 @@ test chan-io-48.13 {cr write, testing readability, ^Z termination, cr read mode} lappend l [chan gets $f] incr c } - } - set c 0 - set l "" - set f [open $path(test1) r] - chan configure $f -translation cr -eofchar \x1a - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l -} {3 {abc def {}}} -test chan-io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mode} {fileevent} { +} -result {3 {abc def {}}} +test chan-io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mode} -setup { file delete $path(test1) + set c 0 + set l "" +} -constraints {fileevent} -body { set f [open $path(test1) w] chan configure $f -translation crlf - set c [format "abc\ndef\n%cfoo\nbar\n" 26] - chan puts -nonewline $f $c + chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f - proc consume {f} { - variable c - variable x - variable l + set f [open $path(test1) r] + chan configure $f -eofchar \x1a -translation crlf + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -6098,27 +6201,23 @@ test chan-io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mod lappend l [chan gets $f] incr c } - } - set c 0 - set l "" - set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation crlf - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l -} {3 {abc def {}}} -test chan-io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} {fileevent} { +} -result {3 {abc def {}}} +test chan-io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} -setup { file delete $path(test1) + set c 0 + set l "" +} -constraints {fileevent} -body { set f [open $path(test1) w] chan configure $f -translation crlf - set c [format "abc\ndef\n%c" 26] - chan puts -nonewline $f $c + chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f - proc consume {f} { - variable c - variable x - variable l + set f [open $path(test1) r] + chan configure $f -translation crlf -eofchar \x1a + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -6126,25 +6225,21 @@ test chan-io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} { lappend l [chan gets $f] incr c } - } - set c 0 - set l "" - set f [open $path(test1) r] - chan configure $f -translation crlf -eofchar \x1a - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l -} {3 {abc def {}}} +} -result {3 {abc def {}}} -test chan-io-49.1 {testing crlf reading, leftover cr disgorgment} { +test chan-io-49.1 {testing crlf reading, leftover cr disgorgment} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "a\rb\rc\r\n" chan close $f set f [open $path(test1) r] - set l "" lappend l [file size $path(test1)] chan configure $f -translation crlf lappend l [chan read $f 1] @@ -6162,18 +6257,19 @@ test chan-io-49.1 {testing crlf reading, leftover cr disgorgment} { lappend l [chan eof $f] lappend l [chan read $f 1] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} "7 a 1 [list \r] 2 b 3 [list \r] 4 c 5 { +} -result "7 a 1 [list \r] 2 b 3 [list \r] 4 c 5 { } 7 0 {} 1" -test chan-io-49.2 {testing crlf reading, leftover cr disgorgment} { +test chan-io-49.2 {testing crlf reading, leftover cr disgorgment} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "a\rb\rc\r\n" chan close $f set f [open $path(test1) r] - set l "" lappend l [file size $path(test1)] chan configure $f -translation crlf lappend l [chan read $f 2] @@ -6186,17 +6282,18 @@ test chan-io-49.2 {testing crlf reading, leftover cr disgorgment} { lappend l [chan read $f 2] lappend l [chan tell $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} "7 [list a\r] 2 [list b\r] 4 [list c\n] 7 0 {} 7 1" -test chan-io-49.3 {testing crlf reading, leftover cr disgorgment} { +} -result "7 [list a\r] 2 [list b\r] 4 [list c\n] 7 0 {} 7 1" +test chan-io-49.3 {testing crlf reading, leftover cr disgorgment} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "a\rb\rc\r\n" chan close $f set f [open $path(test1) r] - set l "" lappend l [file size $path(test1)] chan configure $f -translation crlf lappend l [chan read $f 3] @@ -6207,17 +6304,18 @@ test chan-io-49.3 {testing crlf reading, leftover cr disgorgment} { lappend l [chan read $f 3] lappend l [chan tell $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} "7 [list a\rb] 3 [list \rc\n] 7 0 {} 7 1" -test chan-io-49.4 {testing crlf reading, leftover cr disgorgment} { +} -result "7 [list a\rb] 3 [list \rc\n] 7 0 {} 7 1" +test chan-io-49.4 {testing crlf reading, leftover cr disgorgment} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "a\rb\rc\r\n" chan close $f set f [open $path(test1) r] - set l "" lappend l [file size $path(test1)] chan configure $f -translation crlf lappend l [chan read $f 3] @@ -6228,17 +6326,18 @@ test chan-io-49.4 {testing crlf reading, leftover cr disgorgment} { lappend l [chan gets $f] lappend l [chan tell $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} "7 [list a\rb] 3 [list \rc] 7 0 {} 7 1" -test chan-io-49.5 {testing crlf reading, leftover cr disgorgment} { +} -result "7 [list a\rb] 3 [list \rc] 7 0 {} 7 1" +test chan-io-49.5 {testing crlf reading, leftover cr disgorgment} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "a\rb\rc\r\n" chan close $f set f [open $path(test1) r] - set l "" lappend l [file size $path(test1)] chan configure $f -translation crlf lappend l [set x [chan gets $f]] @@ -6246,30 +6345,31 @@ test chan-io-49.5 {testing crlf reading, leftover cr disgorgment} { lappend l [chan gets $f] lappend l [chan tell $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} [list 7 a\rb\rc 7 {} 7 1] +} -result [list 7 a\rb\rc 7 {} 7 1] -test chan-io-50.1 {testing handler deletion} {testchannelevent} { +test chan-io-50.1 {testing handler deletion} -setup { file delete $path(test1) +} -constraints {testchannelevent} -body { set f [open $path(test1) w] chan close $f set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list delhandler $f]] - proc delhandler {f} { - variable z - set z called + testchannelevent $f add readable [namespace code { + variable z called testchannelevent $f delete 0 - } - set z not_called + }] + variable z not_called update + return $z +} -cleanup { chan close $f - set z -} called -test chan-io-50.2 {testing handler deletion with multiple handlers} {testchannelevent} { +} -result called +test chan-io-50.2 {testing handler deletion with multiple handlers} -setup { file delete $path(test1) - set f [open $path(test1) w] - chan close $f + chan close [open $path(test1) w] + set z "" +} -constraints {testchannelevent} -body { set f [open $path(test1) r] testchannelevent $f add readable [namespace code [list delhandler $f 1]] testchannelevent $f add readable [namespace code [list delhandler $f 0]] @@ -6278,20 +6378,20 @@ test chan-io-50.2 {testing handler deletion with multiple handlers} {testchannel lappend z "called delhandler $f $i" testchannelevent $f delete 0 } - set z "" update - chan close $f - string compare [string tolower $z] \ + string equal $z \ [list [list called delhandler $f 0] [list called delhandler $f 1]] -} 0 -test chan-io-50.3 {testing handler deletion with multiple handlers} {testchannelevent} { - file delete $path(test1) - set f [open $path(test1) w] +} -cleanup { chan close $f +} -result 1 +test chan-io-50.3 {testing handler deletion with multiple handlers} -setup { + file delete $path(test1) + chan close [open $path(test1) w] + set z "" +} -constraints {testchannelevent} -body { set f [open $path(test1) r] testchannelevent $f add readable [namespace code [list notcalled $f 1]] testchannelevent $f add readable [namespace code [list delhandler $f 0]] - set z "" proc notcalled {f i} { variable z lappend z "notcalled was called!! $f $i" @@ -6303,23 +6403,21 @@ test chan-io-50.3 {testing handler deletion with multiple handlers} {testchannel testchannelevent $f delete 0 lappend z "delhandler $f $i deleted myself" } - set z "" update - chan close $f - string compare [string tolower $z] \ + string equal $z \ [list [list delhandler $f 0 called] \ [list delhandler $f 0 deleted myself]] -} 0 -test chan-io-50.4 {testing handler deletion vs reentrant calls} {testchannelevent} { +} -cleanup { + chan close $f +} -result 1 +test chan-io-50.4 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f +} -constraints {testchannelevent} -body { set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list delrecursive $f]] - proc delrecursive {f} { - variable z - variable u - if {"$u" == "recursive"} { + testchannelevent $f add readable [namespace code { + if {$u eq "recursive"} { testchannelevent $f delete 0 lappend z "delrecursive deleting recursive" } else { @@ -6327,18 +6425,19 @@ test chan-io-50.4 {testing handler deletion vs reentrant calls} {testchanneleven set u recursive update } - } + }] variable u toplevel variable z "" update + return $z +} -cleanup { chan close $f - string compare [string tolower $z] \ - {{delrecursive calling recursive} {delrecursive deleting recursive}} -} 0 -test chan-io-50.5 {testing handler deletion vs reentrant calls} {testchannelevent} { +} -result {{delrecursive calling recursive} {delrecursive deleting recursive}} +test chan-io-50.5 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f +} -constraints {testchannelevent} -body { set f [open $path(test1) r] testchannelevent $f add readable [namespace code [list notcalled $f]] testchannelevent $f add readable [namespace code [list del $f]] @@ -6349,7 +6448,7 @@ test chan-io-50.5 {testing handler deletion vs reentrant calls} {testchanneleven proc del {f} { variable u variable z - if {"$u" == "recursive"} { + if {$u eq "recursive"} { testchannelevent $f delete 1 testchannelevent $f delete 0 lappend z "del deleted notcalled" @@ -6364,22 +6463,23 @@ test chan-io-50.5 {testing handler deletion vs reentrant calls} {testchanneleven set z "" set u toplevel update + return $z +} -cleanup { chan close $f - string compare [string tolower $z] \ - [list {del calling recursive} {del deleted notcalled} \ - {del deleted myself} {del after update}] -} 0 -test chan-io-50.6 {testing handler deletion vs reentrant calls} {testchannelevent} { +} -result [list {del calling recursive} {del deleted notcalled} \ + {del deleted myself} {del after update}] +test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f +} -constraints {testchannelevent} -body { set f [open $path(test1) r] testchannelevent $f add readable [namespace code [list second $f]] testchannelevent $f add readable [namespace code [list first $f]] proc first {f} { variable u variable z - if {"$u" == "toplevel"} { + if {$u eq "toplevel"} { lappend z "first called" set u first update @@ -6391,11 +6491,11 @@ test chan-io-50.6 {testing handler deletion vs reentrant calls} {testchanneleven proc second {f} { variable u variable z - if {"$u" == "first"} { + if {$u eq "first"} { lappend z "second called, first time" set u second testchannelevent $f delete 0 - } elseif {"$u" == "second"} { + } elseif {$u eq "second"} { lappend z "second called, second time" testchannelevent $f delete 0 } else { @@ -6406,74 +6506,74 @@ test chan-io-50.6 {testing handler deletion vs reentrant calls} {testchanneleven set z "" set u toplevel update + return $z +} -cleanup { chan close $f - string compare [string tolower $z] \ - [list {first called} {first called not toplevel} \ - {second called, first time} {second called, second time} \ - {first after update}] -} 0 +} -result [list {first called} {first called not toplevel} \ + {second called, first time} {second called, second time} \ + {first after update}] -test chan-io-51.1 {Test old socket deletion on Macintosh} {socket} { +test chan-io-51.1 {Test old socket deletion on Macintosh} -setup { set x 0 set result "" + variable wait "" +} -constraints {socket} -body { proc accept {s a p} { variable x - variable wait chan configure $s -blocking off chan puts $s "sock[incr x]" chan close $s - set wait done + variable wait done } set ss [socket -server [namespace code accept] -myaddr 127.0.0.1 0] set port [lindex [chan configure $ss -sockname] 2] - variable wait "" set cs [socket 127.0.0.1 $port] vwait [namespace which -variable wait] lappend result [chan gets $cs] chan close $cs - set wait "" set cs [socket 127.0.0.1 $port] vwait [namespace which -variable wait] lappend result [chan gets $cs] chan close $cs - set wait "" set cs [socket 127.0.0.1 $port] vwait [namespace which -variable wait] lappend result [chan gets $cs] chan close $cs - set wait "" set cs [socket 127.0.0.1 $port] vwait [namespace which -variable wait] lappend result [chan gets $cs] +} -cleanup { chan close $cs chan close $ss - set result -} {sock1 sock2 sock3 sock4} +} -result {sock1 sock2 sock3 sock4} -test chan-io-52.1 {TclCopyChannel} {fcopy} { +test chan-io-52.1 {TclCopyChannel} -constraints {fcopy} -setup { file delete $path(test1) +} -body { set f1 [open $thisScript] set f2 [open $path(test1) w] - chan copy $f1 $f2 -command { # } - catch { chan copy $f1 $f2 } msg + chan copy $f1 $f2 -command " # " + chan copy $f1 $f2 +} -returnCodes error -cleanup { chan close $f1 chan close $f2 - string compare $msg "channel \"$f1\" is busy" -} {0} -test chan-io-52.2 {TclCopyChannel} {fcopy} { +} -match glob -result {channel "*" is busy} +test chan-io-52.2 {TclCopyChannel} -constraints {fcopy} -setup { file delete $path(test1) +} -body { set f1 [open $thisScript] set f2 [open $path(test1) w] set f3 [open $thisScript] - chan copy $f1 $f2 -command { # } - catch { chan copy $f3 $f2 } msg + chan copy $f1 $f2 -command " # " + chan copy $f3 $f2 +} -returnCodes error -cleanup { chan close $f1 chan close $f2 chan close $f3 - string compare $msg "channel \"$f2\" is busy" -} {0} -test chan-io-52.3 {TclCopyChannel} {fcopy} { +} -match glob -result {channel "*" is busy} +test chan-io-52.3 {TclCopyChannel} -constraints {fcopy} -setup { file delete $path(test1) +} -body { set f1 [open $thisScript] set f2 [open $path(test1) w] chan configure $f1 -translation lf -blocking 0 @@ -6484,13 +6584,14 @@ test chan-io-52.3 {TclCopyChannel} {fcopy} { chan close $f2 set s1 [file size $thisScript] set s2 [file size $path(test1)] - if {("$s1" == "$s2") && ($s0 == $s1)} { + if {($s1 == $s2) && ($s0 == $s1)} { lappend result ok } - set result -} {0 0 ok} -test chan-io-52.4 {TclCopyChannel} {fcopy} { + return $result +} -result {0 0 ok} +test chan-io-52.4 {TclCopyChannel} -constraints {fcopy} -setup { file delete $path(test1) +} -body { set f1 [open $thisScript] set f2 [open $path(test1) w] chan configure $f1 -translation lf -blocking 0 @@ -6500,9 +6601,10 @@ test chan-io-52.4 {TclCopyChannel} {fcopy} { chan close $f1 chan close $f2 lappend result [file size $path(test1)] -} {0 0 40} -test chan-io-52.5 {TclCopyChannel, all} {fcopy} { +} -result {0 0 40} +test chan-io-52.5 {TclCopyChannel, all} -constraints {fcopy} -setup { file delete $path(test1) +} -body { set f1 [open $thisScript] set f2 [open $path(test1) w] chan configure $f1 -translation lf -blocking 0 @@ -6511,15 +6613,14 @@ test chan-io-52.5 {TclCopyChannel, all} {fcopy} { set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] chan close $f1 chan close $f2 - set s1 [file size $thisScript] - set s2 [file size $path(test1)] - if {"$s1" == "$s2"} { + if {[file size $thisScript] == [file size $path(test1)]} { lappend result ok } - set result -} {0 0 ok} -test chan-io-52.5a {TclCopyChannel, all, other negative value} {fcopy} { + return $result +} -result {0 0 ok} +test chan-io-52.5a {TclCopyChannel, all, other negative value} -setup { file delete $path(test1) +} -constraints {fcopy} -body { set f1 [open $thisScript] set f2 [open $path(test1) w] chan configure $f1 -translation lf -blocking 0 @@ -6528,15 +6629,14 @@ test chan-io-52.5a {TclCopyChannel, all, other negative value} {fcopy} { set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] chan close $f1 chan close $f2 - set s1 [file size $thisScript] - set s2 [file size $path(test1)] - if {"$s1" == "$s2"} { + if {[file size $thisScript] == [file size $path(test1)]} { lappend result ok } - set result -} {0 0 ok} -test chan-io-52.5b {TclCopyChannel, all, wrap to negative value} {fcopy} { + return $result +} -result {0 0 ok} +test chan-io-52.5b {TclCopyChannel, all, wrap to negative value} -setup { file delete $path(test1) +} -constraints {fcopy} -body { set f1 [open $thisScript] set f2 [open $path(test1) w] chan configure $f1 -translation lf -blocking 0 @@ -6545,15 +6645,14 @@ test chan-io-52.5b {TclCopyChannel, all, wrap to negative value} {fcopy} { set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] chan close $f1 chan close $f2 - set s1 [file size $thisScript] - set s2 [file size $path(test1)] - if {"$s1" == "$s2"} { + if {[file size $thisScript] == [file size $path(test1)]} { lappend result ok } - set result -} {0 0 ok} -test chan-io-52.6 {TclCopyChannel} {fcopy} { + return $result +} -result {0 0 ok} +test chan-io-52.6 {TclCopyChannel} -setup { file delete $path(test1) +} -constraints {fcopy} -body { set f1 [open $thisScript] set f2 [open $path(test1) w] chan configure $f1 -translation lf -blocking 0 @@ -6564,31 +6663,32 @@ test chan-io-52.6 {TclCopyChannel} {fcopy} { chan close $f2 set s1 [file size $thisScript] set s2 [file size $path(test1)] - if {("$s1" == "$s2") && ($s0 == $s1)} { + if {($s1 == $s2) && ($s0 == $s1)} { lappend result ok } - set result -} {0 0 ok} -test chan-io-52.7 {TclCopyChannel} {fcopy} { + return $result +} -result {0 0 ok} +test chan-io-52.7 {TclCopyChannel} -constraints {fcopy} -setup { file delete $path(test1) +} -body { set f1 [open $thisScript] set f2 [open $path(test1) w] chan configure $f1 -translation lf -blocking 0 chan configure $f2 -translation lf -blocking 0 chan copy $f1 $f2 set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] - set s1 [file size $thisScript] - set s2 [file size $path(test1)] - chan close $f1 - chan close $f2 - if {"$s1" == "$s2"} { + if {[file size $thisScript] == [file size $path(test1)]} { lappend result ok } - set result -} {0 0 ok} -test chan-io-52.8 {TclCopyChannel} {stdio openpipe fcopy} { + return $result +} -cleanup { + chan close $f1 + chan close $f2 +} -result {0 0 ok} +test chan-io-52.8 {TclCopyChannel} -setup { file delete $path(test1) file delete $path(pipe) +} -constraints {stdio openpipe fcopy} -body { set f1 [open $path(pipe) w] chan configure $f1 -translation lf chan puts $f1 " @@ -6600,7 +6700,7 @@ test chan-io-52.8 {TclCopyChannel} {stdio openpipe fcopy} { chan close \$f1 " chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] chan configure $f1 -translation lf chan gets $f1 chan puts $f1 ready @@ -6611,7 +6711,7 @@ test chan-io-52.8 {TclCopyChannel} {stdio openpipe fcopy} { catch {chan close $f1} chan close $f2 list $s0 [file size $path(test1)] -} {40 40} +} -result {40 40} # Empty files, to register them with the test facility set path(kyrillic.txt) [makeFile {} kyrillic.txt] set path(utf8-fcopy.txt) [makeFile {} utf8-fcopy.txt] @@ -6668,8 +6768,9 @@ test chan-io-52.11 {TclCopyChannel & encodings} {fcopy} { file size $path(kyrillic.txt) } 3 -test chan-io-53.1 {CopyData} {fcopy} { +test chan-io-53.1 {CopyData} -setup { file delete $path(test1) +} -constraints {fcopy} -body { set f1 [open $thisScript] set f2 [open $path(test1) w] chan configure $f1 -translation lf -blocking 0 @@ -6679,9 +6780,10 @@ test chan-io-53.1 {CopyData} {fcopy} { chan close $f1 chan close $f2 lappend result [file size $path(test1)] -} {0 0 0} -test chan-io-53.2 {CopyData} {fcopy} { +} -result {0 0 0} +test chan-io-53.2 {CopyData} -setup { file delete $path(test1) +} -constraints {fcopy} -body { set f1 [open $thisScript] set f2 [open $path(test1) w] chan configure $f1 -translation lf -blocking 0 @@ -6694,18 +6796,19 @@ test chan-io-53.2 {CopyData} {fcopy} { chan close $f2 set s1 [file size $thisScript] set s2 [file size $path(test1)] - if {("$s1" == "$s2") && ($s0 == $s1)} { + if {($s1 == $s2) && ($s0 == $s1)} { lappend result ok } - set result -} {0 0 ok} -test chan-io-53.3 {CopyData: background read underflow} {stdio unix openpipe fcopy} { + return $result +} -result {0 0 ok} +test chan-io-53.3 {CopyData: background read underflow} -setup { file delete $path(test1) file delete $path(pipe) +} -constraints {stdio unix openpipe fcopy} -body { set f1 [open $path(pipe) w] chan puts -nonewline $f1 { chan puts ready - chan flush stdout ;# Don't assume line buffered! + chan flush stdout ;# Don't assume line buffered! chan copy stdin stdout -command { set x } vwait x set f [} @@ -6716,7 +6819,7 @@ test chan-io-53.3 {CopyData: background read underflow} {stdio unix openpipe fco chan close $f } chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] set result [chan gets $f1] chan puts $f1 line1 chan flush $f1 @@ -6728,10 +6831,10 @@ test chan-io-53.3 {CopyData: background read underflow} {stdio unix openpipe fco after 500 set f [open $path(test1)] lappend result [chan read $f] +} -cleanup { chan close $f - set result -} "ready line1 line2 {done\n}" -test chan-io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileevent fcopy} { +} -result "ready line1 line2 {done\n}" +test chan-io-53.4 {CopyData: background write overflow} -setup { set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n variable x for {set x 0} {$x < 12} {incr x} { @@ -6739,6 +6842,7 @@ test chan-io-53.4 {CopyData: background write overflow} {stdio unix openpipe fil } file delete $path(test1) file delete $path(pipe) +} -constraints {stdio unix openpipe fileevent fcopy} -body { set f1 [open $path(pipe) w] chan puts $f1 { chan puts ready @@ -6750,7 +6854,7 @@ test chan-io-53.4 {CopyData: background write overflow} {stdio unix openpipe fil chan close $f } chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] set result [chan gets $f1] chan configure $f1 -blocking 0 chan puts $f1 $big @@ -6764,10 +6868,11 @@ test chan-io-53.4 {CopyData: background write overflow} {stdio unix openpipe fil } }] vwait [namespace which -variable x] - chan close $f1 + return $x +} -cleanup { set big {} - set x -} done + chan close $f1 +} -result done set result {} proc FcopyTestAccept {sock args} { after 1000 "chan close $sock" @@ -6796,25 +6901,27 @@ test chan-io-53.5 {CopyData: error during chan copy} {socket fcopy} { chan close $out set fcopyTestDone ;# 1 for error condition } 1 -test chan-io-53.6 {CopyData: error during chan copy} {stdio openpipe fcopy} { +test chan-io-53.6 {CopyData: error during chan copy} -setup { variable fcopyTestDone file delete $path(pipe) file delete $path(test1) catch {unset fcopyTestDone} +} -constraints {stdio openpipe fcopy} -body { set f1 [open $path(pipe) w] chan puts $f1 "exit 1" chan close $f1 - set in [open "|[list [interpreter] $path(pipe)]" r+] + set in [openpipe r+ $path(pipe)] set out [open $path(test1) w] chan copy $in $out -command [namespace code FcopyTestDone] variable fcopyTestDone if ![info exists fcopyTestDone] { vwait [namespace which -variable fcopyTestDone] } + return $fcopyTestDone ;# 0 for plain end of file +} -cleanup { catch {chan close $in} chan close $out - set fcopyTestDone ;# 0 for plain end of file -} {0} +} -result 0 proc doFcopy {in out {bytes 0} {error {}}} { variable fcopyTestDone variable fcopyTestCount @@ -6829,10 +6936,11 @@ proc doFcopy {in out {bytes 0} {error {}}} { -command [namespace code [list doFcopy $in $out]]] } } -test chan-io-53.7 {CopyData: Flooding chan copy from pipe} {stdio openpipe fcopy} { +test chan-io-53.7 {CopyData: Flooding chan copy from pipe} -setup { variable fcopyTestDone file delete $path(pipe) catch {unset fcopyTestDone} +} -constraints {stdio openpipe fcopy} -body { set fcopyTestCount 0 set f1 [open $path(pipe) w] chan puts $f1 { @@ -6851,21 +6959,22 @@ test chan-io-53.7 {CopyData: Flooding chan copy from pipe} {stdio openpipe fcopy exit 0 } chan close $f1 - set in [open "|[list [interpreter] $path(pipe) &]" r+] + set in [openpipe r+ $path(pipe) &] set out [open $path(test1) w] doFcopy $in $out variable fcopyTestDone - if ![info exists fcopyTestDone] { + if {![info exists fcopyTestDone]} { vwait [namespace which -variable fcopyTestDone] } - catch {chan close $in} - chan close $out # -1=error 0=script error N=number of bytes expr ($fcopyTestDone == 0) ? $fcopyTestCount : -1 -} {3450} +} -cleanup { + catch {chan close $in} + chan close $out +} -result {3450} test chan-io-53.8 {CopyData: async callback and error handling, Bug 1932639} -setup { # copy progress callback. errors out intentionally - proc ::cmd args { + proc cmd args { lappend ::RES "CMD $args" error !STOP } @@ -6885,12 +6994,12 @@ test chan-io-53.8 {CopyData: async callback and error handling, Bug 1932639} -se # Record input size, so that result is always defined lappend ::RES [file size $bar] # Run the copy. Should not invoke -command now. - chan copy $f $g -size 2 -command ::cmd + chan copy $f $g -size 2 -command [namespace code cmd] # Check that -command was not called synchronously set sbs [file size $bar] lappend ::RES [expr {($sbs > 0) ? "sync/FAIL" : "sync/OK"}] $sbs - # Now let the async part happen. Should capture the error in cmd - # via bgerror. If not break the event loop via timer. + # Now let the async part happen. Should capture the error in cmd via + # bgerror. If not break the event loop via timer. set token [after 1000 { lappend ::RES {bgerror/FAIL timeout} set ::forever has-been-reached @@ -6898,20 +7007,19 @@ test chan-io-53.8 {CopyData: async callback and error handling, Bug 1932639} -se vwait ::forever catch {after cancel $token} # Report - set ::RES + return $::RES } -cleanup { chan close $f chan close $g catch {unset ::RES} catch {unset ::forever} - rename ::cmd {} rename ::bgerror {} removeFile foo removeFile bar } -result {0 sync/OK 0 {CMD 2} {bgerror/OK !STOP}} test chan-io-53.8a {CopyData: async callback and error handling, Bug 1932639, at eof} -setup { - # copy progress callback. errors out intentionally - proc ::cmd args { + # copy progress callback. + proc cmd args { lappend ::RES "CMD $args" set ::forever has-been-reached return @@ -6927,7 +7035,7 @@ test chan-io-53.8a {CopyData: async callback and error handling, Bug 1932639, at chan seek $f 0 end ; chan read $f 1 set ::RES [chan eof $f] # Run the copy. Should not invoke -command now. - chan copy $f $g -size 2 -command ::cmd + chan copy $f $g -size 2 -command [namespace code cmd] # Check that -command was not called synchronously lappend ::RES [expr {([llength $::RES] > 1) ? "sync/FAIL" : "sync/OK"}] # Now let the async part happen. Should capture the eof in cmd @@ -6939,13 +7047,12 @@ test chan-io-53.8a {CopyData: async callback and error handling, Bug 1932639, at vwait ::forever catch {after cancel $token} # Report - set ::RES + return $::RES } -cleanup { chan close $f chan close $g catch {unset ::RES} catch {unset ::forever} - rename ::cmd {} removeFile foo removeFile bar } -result {1 sync/OK {CMD 0}} @@ -6992,8 +7099,10 @@ test chan-io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup { } -cleanup { chan close $pipe rename ::done {} - after 1000; # Allow Windows time to figure out that the + if {[testConstraint win]} { + after 1000; # Allow Windows time to figure out that the # process is gone + } catch {close $out} catch {removeFile out} catch {removeFile err} @@ -7021,7 +7130,7 @@ test chan-io-53.10 {Bug 1350564, multi-directional fcopy} -setup { global l srv chan configure $sok -translation binary -buffering none lappend l $sok - if {[llength $l]==2} { + if {[llength $l] == 2} { chan close $srv foreach {a b} $l break chan copy $a $b -command [list geof $a] @@ -7041,7 +7150,7 @@ test chan-io-53.10 {Bug 1350564, multi-directional fcopy} -setup { # wait for OK from server. chan gets $pipe # Now the two clients. - proc ::done {sock} { + proc done {sock} { if {[chan eof $sock]} { chan close $sock ; return } lappend ::forever [chan gets $sock] return @@ -7050,8 +7159,8 @@ test chan-io-53.10 {Bug 1350564, multi-directional fcopy} -setup { set b [socket 127.0.0.1 9999] chan configure $a -translation binary -buffering none chan configure $b -translation binary -buffering none - chan event $a readable [list ::done $a] - chan event $b readable [list ::done $b] + chan event $a readable [namespace code "done $a"] + chan event $b readable [namespace code "done $b"] } -constraints {stdio openpipe fcopy} -body { # Now pass data through the server in both directions. set ::forever {} @@ -7064,8 +7173,9 @@ test chan-io-53.10 {Bug 1350564, multi-directional fcopy} -setup { catch {chan close $a} catch {chan close $b} chan close $pipe - rename ::done {} - after 1000 ;# Give Windows time to kill the process + if {[testConstraint win]} { + after 1000 ;# Give Windows time to kill the process + } removeFile err catch {unset ::forever} } -result {AB BA} @@ -7095,7 +7205,9 @@ test chan-io-54.1 {Recursive channel events} {socket fileevent} { # completes. set done 0 for {set i 0} {$i < 10} {incr i} { - if {![catch {set cs [socket 127.0.0.1 [lindex [chan configure $ss -sockname] 2]]}]} { + if {![catch { + set cs [socket 127.0.0.1 [lindex [chan configure $ss -sockname] 2]] + }]} then { set done 1 break } @@ -7121,9 +7233,11 @@ test chan-io-54.1 {Recursive channel events} {socket fileevent} { chan close $cs list $result $x } {{{line 1} 1 2} 2} -test chan-io-54.2 {Testing for busy-wait in recursive channel events} {socket fileevent} { +test chan-io-54.2 {Testing for busy-wait in recursive channel events} -setup { set accept {} set after {} + variable done 0 +} -constraints {socket fileevent} -body { variable s [socket -server [namespace code accept] -myaddr 127.0.0.1 0] proc accept {s a p} { variable counter 0 @@ -7135,17 +7249,20 @@ test chan-io-54.2 {Testing for busy-wait in recursive channel events} {socket fi variable counter variable after incr counter - set l [chan gets $s] - if {"$l" == ""} { + if {[chan gets $s] eq ""} { chan event $s readable [namespace code "doit1 $s"] - set after [after 1000 [namespace code newline]] + set after [after 1000 [namespace code { + chan puts $writer hello + chan flush $writer + set done 1 + }]] } } proc doit1 {s} { variable counter variable accept incr counter - set l [chan gets $s] + chan gets $s chan close $s set accept {} } @@ -7157,22 +7274,15 @@ test chan-io-54.2 {Testing for busy-wait in recursive channel events} {socket fi chan puts -nonewline $writer hello chan flush $writer } - proc newline {} { - variable done - variable writer - chan puts $writer hello - chan flush $writer - set done 1 - } producer - variable done vwait [namespace which -variable done] chan close $writer chan close $s after cancel $after + return $counter +} -cleanup { if {$accept ne {}} {chan close $accept} - set counter -} 1 +} -result 1 set path(fooBar) [makeFile {} fooBar] @@ -7196,7 +7306,7 @@ test chan-io-55.1 {ChannelEventScriptInvoker: deletion} -constraints { chan event $f writable [namespace code [list eventScript $f]] variable x not_done vwait [namespace which -variable x] - set x + return $x } -cleanup { interp bgerror {} $handler } -result {got_error} @@ -7222,14 +7332,15 @@ test chan-io-56.1 {ChannelTimerProc} {testchannelevent} { lappend result $y } {2 done} -test chan-io-57.1 {buffered data and file events, gets} {fileevent} { +test chan-io-57.1 {buffered data and file events, gets} -setup { + variable s2 +} -constraints {fileevent} -body { proc accept {sock args} { variable s2 set s2 $sock } set server [socket -server [namespace code accept] -myaddr 127.0.0.1 0] set s [socket 127.0.0.1 [lindex [chan configure $server -sockname] 2]] - variable s2 vwait [namespace which -variable s2] update chan event $s2 readable [namespace code {lappend result readable}] @@ -7240,19 +7351,21 @@ test chan-io-57.1 {buffered data and file events, gets} {fileevent} { vwait [namespace which -variable result] lappend result [chan gets $s2] vwait [namespace which -variable result] + return $result +} -cleanup { chan close $s chan close $s2 chan close $server - set result -} {12 readable 34567890 timer} -test chan-io-57.2 {buffered data and file events, read} {fileevent} { +} -result {12 readable 34567890 timer} +test chan-io-57.2 {buffered data and file events, read} -setup { + variable s2 +} -constraints {fileevent} -body { proc accept {sock args} { variable s2 set s2 $sock } set server [socket -server [namespace code accept] -myaddr 127.0.0.1 0] set s [socket 127.0.0.1 [lindex [chan configure $server -sockname] 2]] - variable s2 vwait [namespace which -variable s2] update chan event $s2 readable [namespace code {lappend result readable}] @@ -7263,11 +7376,12 @@ test chan-io-57.2 {buffered data and file events, read} {fileevent} { vwait [namespace which -variable result] lappend result [chan read $s2 9] vwait [namespace which -variable result] + return $result +} -cleanup { chan close $s chan close $s2 chan close $server - set result -} {1 readable 234567890 timer} +} -result {1 readable 234567890 timer} test chan-io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrPc openpipe fileevent} { set out [open $path(script) w] @@ -7288,7 +7402,7 @@ test chan-io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrPc ope } } chan close $out - set pipe [open "|[list [interpreter] $path(script)]" r] + set pipe [openpipe r $path(script)] chan event $pipe readable [namespace code [list readit $pipe]] variable x "" set result "" @@ -7327,7 +7441,7 @@ test chan-io-60.1 {writing illegal utf sequences} {openpipe fileevent} { } } chan close $out - set pipe [open "|[list [interpreter] $path(script)]" r] + set pipe [openpipe r $path(script)] chan event $pipe readable [namespace code [list readit $pipe]] variable x "" set result "" @@ -7358,9 +7472,8 @@ test chan-io-61.1 {Reset eof state after changing the eof char} -setup { #chan seek $f 0 start #chan seek $f 0 current #lappend res [chan read $f; chan tell $f] - chan close $f - set res } -cleanup { + chan close $f removeFile eofchar } -result {77 = 23431} @@ -7369,19 +7482,20 @@ test chan-io-61.1 {Reset eof state after changing the eof char} -setup { # can also be used to emulate transfer of channels between threads, and is # used for that here. -test chan-io-70.0 {Cutting & Splicing channels} {testchannel} { +test chan-io-70.0 {Cutting & Splicing channels} -setup { set f [makeFile {... dummy ...} cutsplice] + set res {} +} -constraints {testchannel} -body { set c [open $f r] - set res {} lappend res [catch {chan seek $c 0 start}] testchannel cut $c lappend res [catch {chan seek $c 0 start}] testchannel splice $c lappend res [catch {chan seek $c 0 start}] +} -cleanup { chan close $c removeFile cutsplice - set res -} {0 1 0} +} -result {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. @@ -7395,10 +7509,11 @@ if {[testConstraint testthread]} { # ignore } } -test chan-io-70.1 {Transfer channel} {testchannel testthread} { +test chan-io-70.1 {Transfer channel} -setup { set f [makeFile {... dummy ...} cutsplice] + set res {} +} -constraints {testchannel testthread} -body { set c [open $f r] - set res {} lappend res [catch {chan seek $c 0 start}] testchannel cut $c lappend res [catch {chan seek $c 0 start}] @@ -7410,10 +7525,10 @@ test chan-io-70.1 {Transfer channel} {testchannel testthread} { chan close $c set res }] +} -cleanup { tcltest::threadReap removeFile cutsplice - set res -} {0 1 0} +} -result {0 1 0} # ### ### ### ######### ######### ######### @@ -7578,28 +7693,30 @@ foreach {n msg expected} { 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 chan-io-71.$n {Tcl_SetChannelError} {testchannel} { + test chan-io-71.$n {Tcl_SetChannelError} -setup { set f [makeFile {... dummy ...} cutsplice] + } -constraints {testchannel} -body { set c [open $f r] - set res [testchannel setchannelerror $c [lrange $msg 0 end]] + testchannel setchannelerror $c [lrange $msg 0 end] + } -cleanup { chan close $c removeFile cutsplice - set res - } [lrange $expected 0 end] - test chan-io-72.$n {Tcl_SetChannelErrorInterp} {testchannel} { + } -result [lrange $expected 0 end] + test chan-io-72.$n {Tcl_SetChannelErrorInterp} -setup { set f [makeFile {... dummy ...} cutsplice] + } -constraints {testchannel} -body { set c [open $f r] - set res [testchannel setchannelerrorinterp $c [lrange $msg 0 end]] + testchannel setchannelerrorinterp $c [lrange $msg 0 end] + } -cleanup { chan close $c removeFile cutsplice - set res - } [lrange $expected 0 end] + } -result [lrange $expected 0 end] } -test chan-io-73.1 {channel Tcl_Obj SetChannelFromAny} {} { +test chan-io-73.1 {channel Tcl_Obj SetChannelFromAny} -body { # Test for Bug 1847044 - don't spoil type unless we have a valid channel - catch {chan close [lreplace [list a] 0 end]} -} {1} + chan close [lreplace [list a] 0 end] +} -returnCodes error -match glob -result * # ### ### ### ######### ######### ######### diff --git a/tests/error.test b/tests/error.test index a6e487d..2e75c27 100644 --- a/tests/error.test +++ b/tests/error.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: error.test,v 1.33.2.1 2010/10/23 15:49:54 kennykb Exp $ +# RCS: @(#) $Id: error.test,v 1.33.2.2 2010/12/01 16:42:36 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -912,6 +912,72 @@ test error-19.10 {compiled try with chained clauses} -setup { } -cleanup { unset RES } -result {handler {ok good finally}} +test error-19.11 {compiled try and errors on variable write} -setup { + set RES {} +} -body { + apply {{} { + array set foo {bar boo} + set bar unset + catch { + try { + addmsg body + return a + } on return {bar foo} { + addmsg handler + return b + } finally { + addmsg finally,$bar + } + } msg + addmsg $msg + } ::tcl::test::error} +} -cleanup { + unset RES +} -result {body finally,a {can't set "foo": variable is array}} +test error-19.12 {interpreted try and errors on variable write} -setup { + set RES {} +} -body { + apply {try { + array set foo {bar boo} + set bar unset + catch { + $try { + addmsg body + return a + } on return {bar foo} { + addmsg handler + return b + } finally { + addmsg finally,$bar + } + } msg + addmsg $msg + } ::tcl::test::error} try +} -cleanup { + unset RES +} -result {body finally,a {can't set "foo": variable is array}} +test error-19.13 {compiled try and errors on variable write} -setup { + set RES {} +} -body { + apply {{} { + array set foo {bar boo} + set bar unset + catch { + try { + addmsg body + return a + } on return {bar foo} - on error {bar foo} { + addmsg handler + return b + } finally { + addmsg finally,$bar + } + } msg + addmsg $msg + } ::tcl::test::error} +} -cleanup { + unset RES +} -result {body finally,a {can't set "foo": variable is array}} rename addmsg {} # FIXME test what vars get set on fallthough ... what is the correct behavior? diff --git a/tests/info.test b/tests/info.test index fd126a7..810c57d 100644 --- a/tests/info.test +++ b/tests/info.test @@ -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: info.test,v 1.78 2010/08/03 20:15:53 andreas_kupries Exp $ +# RCS: @(#) $Id: info.test,v 1.78.2.1 2010/12/01 16:42:37 kennykb Exp $ if {{::tcltest} ni [namespace children]} { package require tcltest 2 @@ -690,14 +690,12 @@ test info-21.5 {miscellaneous error conditions} -returnCodes error -body { ## # ### ### ### ######### ######### ######### ## info frame - ## Helper # For the more complex results we cut the file name down to remove path # dependencies, and we use only part of the first line of the reported # command. The latter is required because otherwise the whole test case may # appear in some results, but the result is part of the testcase. An infinite # string would be required to describe that. The cutting-down breaks this. - proc reduce {frame} { set pos [lsearch -exact $frame cmd] incr pos @@ -714,7 +712,9 @@ proc reduce {frame} { } set frame } - +proc subinterp {} { interp create sub ; interp debug sub -frame 1; + interp eval sub [list proc reduce [info args reduce] [info body reduce]] +} ## Helper # Generate a stacktrace from the current location to top. This code # not only depends on the exact location of things, but also on the @@ -1363,14 +1363,14 @@ test info-38.1 {location information for uplevel, dv, direct-var} -match glob -b * {type eval line 3 cmd etrace proc ::tcltest::RunTest} * {type source line 1361 file info.test cmd {uplevel \\#0 $script} proc ::tcltest::RunTest}} -cleanup {unset script y} -test info-38.2 {location information for uplevel, dl, direct-literal} -match glob -body { - join [lrange [uplevel \#0 { - set y DL. - etrace - }] 0 2] \n -} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} -* {type source line 1369 file info.test cmd etrace proc ::tcltest::RunTest} -* {type source line 1367 file info.test cmd uplevel\\ \\\\ proc ::tcltest::RunTest}} -cleanup {unset y} +# 38.2 moved to bottom to not disturb other tests with the necessary changes to this one. + + + + + + + test info-38.3 {location information for uplevel, dpv, direct-proc-var} -match glob -body { set script { @@ -1383,15 +1383,15 @@ test info-38.3 {location information for uplevel, dpv, direct-proc-var} -match g * {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control} * {type source line 1380 file info.test cmd {control y $script} proc ::tcltest::RunTest}} -cleanup {unset script y} -test info-38.4 {location information for uplevel, dpv, direct-proc-literal} -match glob -body { - join [lrange [control y { - set y DPL - etrace - }] 0 3] \n -} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} -* {type source line 1389 file info.test cmd etrace proc ::control} -* {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control} -* {type source line 1387 file info.test cmd control proc ::tcltest::RunTest}} -cleanup {unset y} +# 38.4 moved to bottom to not disturb other tests with the necessary changes to this one. + + + + + + + + test info-38.5 {location information for uplevel, ppv, proc-proc-var} -match glob -body { join [lrange [datav] 0 4] \n @@ -1401,13 +1401,13 @@ test info-38.5 {location information for uplevel, ppv, proc-proc-var} -match glo * {type source line 1353 file info.test cmd {control y $script} proc ::datav level 1} * {type source line 1397 file info.test cmd datav proc ::tcltest::RunTest}} -test info-38.6 {location information for uplevel, ppl, proc-proc-literal} -match glob -body { - join [lrange [datal] 0 4] \n -} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} -* {type source line 1344 file info.test cmd etrace proc ::control} -* {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control} -* {type source line 1342 file info.test cmd control proc ::datal level 1} -* {type source line 1405 file info.test cmd datal proc ::tcltest::RunTest}} +# 38.6 moved to bottom to not disturb other tests with the necessary changes to this one. + + + + + + testConstraint testevalex [llength [info commands testevalex]] test info-38.7 {location information for arg substitution} -constraints testevalex -match glob -body { @@ -1543,18 +1543,18 @@ test info-30.12 {bs+nl in computed word, nested eval} -body { } -cleanup {unset res x} -result { type source line 1541 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.13 {bs+nl in literal words, uplevel script, with nested words} -body { - uplevel #0 { + subinterp ; set res [interp eval sub { uplevel #0 { if {1} \ { set ::res \ [reduce [info frame 0]];# line 1550 } } - return $res -} -cleanup {unset res} -result {type source line 1550 file info.test cmd {info frame 0} proc ::tcltest::RunTest} + set res }] ; interp delete sub ; set res +} -cleanup {unset res} -result {type source line 1550 file info.test cmd {info frame 0} level 0} test info-30.14 {bs+nl, literal word, uplevel through proc} { - proc abra {script} { + subinterp ; set res [interp eval sub { proc abra {script} { uplevel 1 $script } set res [abra { @@ -1562,7 +1562,7 @@ test info-30.14 {bs+nl, literal word, uplevel through proc} { [reduce [info frame 0]]";# line 1562 }] rename abra {} - set res + set res }] ; interp delete sub ; set res } { type source line 1562 file info.test cmd {info frame 0} proc ::abra} test info-30.15 {bs+nl in literal words, nested proc body, compiled} { @@ -1879,6 +1879,83 @@ test info-39.1 {location information not confused by literal sharing, bug 293308 type source line 1859 file info.test cmd print_one proc ::test_info_frame level 1} # ------------------------------------------------------------------------- +# Tests moved to the end to not disturb other tests and their locations. + +test info-38.6 {location information for uplevel, ppl, proc-proc-literal} -match glob -setup {subinterp} -body { + interp eval sub { + proc etrace {} { + set res {} + set level [info frame] + while {$level} { + lappend res [list $level [reduce [info frame $level]]] + incr level -1 + } + return $res + } + proc control {vv script} { + upvar 1 $vv var + return [uplevel 1 $script] + } + proc datal {} { + control y { + set y PPL + etrace + } + } + join [lrange [datal] 0 4] \n + } +} -result {* {type source line 1890 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type source line 1902 file info.test cmd etrace proc ::control} +* {type source line 1897 file info.test cmd {uplevel 1 $script} proc ::control} +* {type source line 1900 file info.test cmd control proc ::datal level 1} +* {type source line 1905 file info.test cmd datal level 2}} -cleanup {interp delete sub} + +test info-38.4 {location information for uplevel, dpv, direct-proc-literal} -match glob -setup {subinterp} -body { + interp eval sub { + proc etrace {} { + set res {} + set level [info frame] + while {$level} { + lappend res [list $level [reduce [info frame $level]]] + incr level -1 + } + return $res + } + proc control {vv script} { + upvar 1 $vv var + return [uplevel 1 $script] + } + join [lrange [control y { + set y DPL + etrace + }] 0 3] \n + } +} -result {* {type source line 1919 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type source line 1930 file info.test cmd etrace proc ::control} +* {type source line 1926 file info.test cmd {uplevel 1 $script} proc ::control} +* {type source line 1928 file info.test cmd control level 1}} -cleanup {interp delete sub} + +test info-38.2 {location information for uplevel, dl, direct-literal} -match glob -setup {subinterp} -body { + interp eval sub { + proc etrace {} { + set res {} + set level [info frame] + while {$level} { + lappend res [list $level [reduce [info frame $level]]] + incr level -1 + } + return $res + } + join [lrange [uplevel \#0 { + set y DL. + etrace + }] 0 2] \n + } +} -result {* {type source line 1944 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type source line 1951 file info.test cmd etrace level 1} +* {type source line 1949 file info.test cmd uplevel\\ \\\\ level 1}} -cleanup {interp delete sub} + +# ------------------------------------------------------------------------- unset -nocomplain res # cleanup diff --git a/tests/interp.test b/tests/interp.test index 45254ad..6c35cfd 100644 --- a/tests/interp.test +++ b/tests/interp.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: interp.test,v 1.68 2009/12/29 14:55:42 dkf Exp $ +# RCS: @(#) $Id: interp.test,v 1.68.4.1 2010/12/01 16:42:37 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 @@ -31,7 +31,7 @@ test interp-1.1 {options for interp command} -returnCodes error -body { } -result {wrong # args: should be "interp cmd ?arg ...?"} test interp-1.2 {options for interp command} -returnCodes error -body { interp frobox -} -result {bad option "frobox": must be alias, aliases, bgerror, cancel, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "frobox": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} test interp-1.3 {options for interp command} { interp delete } "" @@ -49,13 +49,13 @@ test interp-1.6 {options for interp command} -returnCodes error -body { } -result {wrong # args: should be "interp slaves ?path?"} test interp-1.7 {options for interp command} -returnCodes error -body { interp hello -} -result {bad option "hello": must be alias, aliases, bgerror, cancel, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "hello": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} test interp-1.8 {options for interp command} -returnCodes error -body { interp -froboz -} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} test interp-1.9 {options for interp command} -returnCodes error -body { interp -froboz -safe -} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} test interp-1.10 {options for interp command} -returnCodes error -body { interp target } -result {wrong # args: should be "interp target path alias"} @@ -3596,6 +3596,50 @@ test interp-37.1 {safe interps and min() and max(): Bug 2895741} -setup { unset result interp delete a } -result {26 26} + +test interp-38.1 {interp debug one-way switch} -setup { + catch {interp delete a} + interp create a + interp debug a -frame 1 +} -body { + # TIP #3xx interp debug frame is a one-way switch + interp debug a -frame 0 +} -cleanup { + interp delete a +} -result {1} +test interp-38.2 {interp debug env var} -setup { + catch {interp delete a} + set ::env(TCL_INTERP_DEBUG_FRAME) 1 + interp create a +} -body { + interp debug a +} -cleanup { + unset ::env(TCL_INTERP_DEBUG_FRAME) + interp delete a +} -result {-frame 1} +test interp-38.3 {interp debug wrong args} -body { + interp debug +} -returnCodes { + error +} -result {wrong # args: should be "interp debug path ?-frame ?bool??"} +test interp-38.4 {interp debug basic setup} -body { + interp debug {} +} -result {-frame 0} +test interp-38.5 {interp debug basic setup} -body { + interp debug {} -f +} -result {0} +test interp-38.6 {interp debug basic setup} -body { + interp debug -frames +} -returnCodes error -result {could not find interpreter "-frames"} +test interp-38.7 {interp debug basic setup} -body { + interp debug {} -frames +} -returnCodes error -result {bad debug option "-frames": must be -frame} +test interp-38.8 {interp debug basic setup} -body { + interp debug {} -frame 0 bogus +} -returnCodes { + error +} -result {wrong # args: should be "interp debug path ?-frame ?bool??"} + # cleanup foreach i [interp slaves] { diff --git a/tests/ioTrans.test b/tests/ioTrans.test index 8932874..049b0ce 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.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: ioTrans.test,v 1.9 2010/08/04 16:49:02 andreas_kupries Exp $ +# RCS: @(#) $Id: ioTrans.test,v 1.9.2.1 2010/12/01 16:42:37 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -19,8 +19,8 @@ if {[lsearch [namespace children] ::tcltest] == -1} { } # Custom constraints used in this file -testConstraint testchannel [llength [info commands testchannel]] -testConstraint testthread [llength [info commands testthread]] +testConstraint testchannel [llength [info commands testchannel]] +testConstraint testthread [llength [info commands testthread]] # testchannel cut|splice Both needed to test the reflection in threads. # testthread send @@ -30,9 +30,9 @@ testConstraint testthread [llength [info commands testthread]] # ### ### ### ######### ######### ######### ## Testing the reflected transformation. -# Helper commands to record the arguments to handler methods. Stored -# in a script so that the tests needing this code do not need their -# own copy but can access this variable. +# Helper commands to record the arguments to handler methods. Stored in a +# script so that the tests needing this code do not need their own copy but +# can access this variable. set helperscript { if {[lsearch [namespace children] ::tcltest] == -1} { @@ -40,69 +40,61 @@ set helperscript { namespace import -force ::tcltest::* } - proc note {item} {global res; lappend res $item; return} - #proc note {item} {global res; lappend res $item; puts $item ; flush stdout ; return} - proc track {} {upvar args item; note $item; return} - proc notes {items} {foreach i $items {note $i}} - - # Use to prevent *'s in pattern to match beyond the expected end - # of the recording. - proc endnote {} {note |} - - # This forces the return options to be in the order that the test - # expects! - proc noteOpts opts {global res; lappend res [dict merge { + # This forces the return options to be in the order that the test expects! + variable optorder { -code !?! -level !?! -errorcode !?! -errorline !?! -errorinfo !?! - } $opts]; return} + -errorstack !?! + } + proc noteOpts opts { + variable optorder + lappend ::res [dict merge $optorder $opts] + } # Helper command, canned result for 'initialize' method. Gets the - # optional methods as arguments. Use return features to post the - # result higher up. + # optional methods as arguments. Use return features to post the result + # higher up. - proc init {args} { - lappend args initialize finalize read write - return -code return $args - } - proc oninit {args} { + proc handle.initialize {args} { upvar args hargs - if {[lindex $hargs 0] ne "initialize"} {return} - lappend args initialize finalize read write - return -code return $args + if {[lindex $hargs 0] eq "initialize"} { + return -code return [list {*}$args initialize finalize read write] + } } - proc onfinal {} { + proc handle.finalize {} { upvar args hargs - if {[lindex $hargs 0] ne "finalize"} {return} - return -code return "" + if {[lindex $hargs 0] eq "finalize"} { + return -code return "" + } } - proc onread {} { + proc handle.read {} { upvar args hargs - if {[lindex $hargs 0] ne "read"} {return} - return -code return "@" + if {[lindex $hargs 0] eq "read"} { + return -code return "@" + } } - proc ondrain {} { + proc handle.drain {} { upvar args hargs - if {[lindex $hargs 0] ne "drain"} {return} - return -code return "<>" + if {[lindex $hargs 0] eq "drain"} { + return -code return "<>" + } } - proc onclear {} { + proc handle.clear {} { upvar args hargs - if {[lindex $hargs 0] ne "clear"} {return} - return -code return "" + if {[lindex $hargs 0] eq "clear"} { + return -code return "" + } } proc tempchan {{mode r+}} { - global tempchan - set tempchan [open [makeFile {test data} tempchanfile] $mode] - return $tempchan + global tempchan + return [set tempchan [open [makeFile {test data} tempchanfile] $mode]] } - proc tempdone {} { global tempchan catch {close $tempchan} removeFile tempchanfile return } - proc tempview {} { viewFile tempchanfile } } @@ -110,379 +102,446 @@ set helperscript { eval $helperscript #puts <<[file channels]>> - + # ### ### ### ######### ######### ######### -test iortrans-1.0 {chan, wrong#args} { - catch {chan} msg - set msg -} {wrong # args: should be "chan subcommand ?arg ...?"} -test iortrans-1.1 {chan, unknown method} -body { +test iortrans-1.0 {chan, wrong#args} -returnCodes error -body { + chan +} -result {wrong # args: should be "chan subcommand ?arg ...?"} +test iortrans-1.1 {chan, unknown method} -returnCodes error -body { chan foo -} -returnCodes error -match glob -result {unknown or ambiguous subcommand "foo": must be*} +} -match glob -result {unknown or ambiguous subcommand "foo": must be*} # --- --- --- --------- --------- --------- # chan push, and method "initalize" -test iortrans-2.0 {chan push, wrong#args, not enough} { - catch {chan push} msg - set msg -} {wrong # args: should be "chan push channel cmdprefix"} -test iortrans-2.1 {chan push, wrong#args, too many} { - catch {chan push a b c} msg - set msg -} {wrong # args: should be "chan push channel cmdprefix"} -test iortrans-2.2 {chan push, invalid channel} { +test iortrans-2.0 {chan push, wrong#args, not enough} -returnCodes error -body { + chan push +} -result {wrong # args: should be "chan push channel cmdprefix"} +test iortrans-2.1 {chan push, wrong#args, too many} -returnCodes error -body { + chan push a b c +} -result {wrong # args: should be "chan push channel cmdprefix"} +test iortrans-2.2 {chan push, invalid channel} -setup { proc foo {} {} - catch {chan push {} foo} msg +} -returnCodes error -body { + chan push {} foo +} -cleanup { rename foo {} - set msg -} {can not find channel named ""} -test iortrans-2.3 {chan push, bad handler, not a list} { - catch {chan push [tempchan] "foo \{"} msg +} -result {can not find channel named ""} +test iortrans-2.3 {chan push, bad handler, not a list} -body { + chan push [tempchan] "foo \{" +} -returnCodes error -cleanup { tempdone - set msg -} {unmatched open brace in list} -test iortrans-2.4 {chan push, bad handler, not a command} { - catch {chan push [tempchan] foo} msg +} -result {unmatched open brace in list} +test iortrans-2.4 {chan push, bad handler, not a command} -body { + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone - set msg -} {invalid command name "foo"} -test iortrans-2.5 {chan push, initialize failed, bad signature} { +} -result {invalid command name "foo"} +test iortrans-2.5 {chan push, initialize failed, bad signature} -body { proc foo {} {} - catch {chan push [tempchan] foo} msg + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg -} {wrong # args: should be "foo"} -test iortrans-2.6 {chan push, initialize failed, bad signature} { +} -result {wrong # args: should be "foo"} +test iortrans-2.6 {chan push, initialize failed, bad signature} -body { proc foo {} {} - catch {chan push [tempchan] ::foo} msg + chan push [tempchan] ::foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg -} {wrong # args: should be "::foo"} +} -result {wrong # args: should be "::foo"} test iortrans-2.7 {chan push, initialize failed, bad result, not a list} -body { proc foo {args} {return "\{"} - catch {chan push [tempchan] foo} msg + catch {chan push [tempchan] foo} + return $::errorInfo +} -cleanup { tempdone rename foo {} - set ::errorInfo } -match glob -result {chan handler "foo initialize" returned non-list: *} test iortrans-2.8 {chan push, initialize failed, bad result, not a list} -body { proc foo {args} {return \{\{\}} - catch {chan push [tempchan] foo} msg + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg } -match glob -result {chan handler "foo initialize" returned non-list: *} test iortrans-2.9 {chan push, initialize failed, bad result, empty list} -body { proc foo {args} {} - catch {chan push [tempchan] foo} msg + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg } -match glob -result {*all required methods*} test iortrans-2.10 {chan push, initialize failed, bad result, bogus method name} -body { proc foo {args} {return 1} - catch {chan push [tempchan] foo} msg + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg } -match glob -result {*bad method "1": must be *} test iortrans-2.11 {chan push, initialize failed, bad result, bogus method name} -body { proc foo {args} {return {a b c}} - catch {chan push [tempchan] foo} msg + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg } -match glob -result {*bad method "c": must be *} test iortrans-2.12 {chan push, initialize failed, bad result, required methods missing} -body { # Required: initialize, and finalize. proc foo {args} {return {initialize}} - catch {chan push [tempchan] foo} msg + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg } -match glob -result {*all required methods*} test iortrans-2.13 {chan push, initialize failed, bad result, illegal method name} -body { proc foo {args} {return {initialize finalize BOGUS}} - catch {chan push [tempchan] foo} msg + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg } -match glob -result {*returned bad method "BOGUS": must be clear, drain, finalize, flush, initialize, limit?, read, or write} test iortrans-2.14 {chan push, initialize failed, bad result, mode/handler mismatch} -body { proc foo {args} {return {initialize finalize}} - catch {chan push [tempchan] foo} msg + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg } -match glob -result {*makes the channel inacessible} # iortrans-2.15 event/watch methods elimimated, removed these tests. # iortrans-2.16 test iortrans-2.17 {chan push, initialize failed, bad result, drain/read mismatch} -body { proc foo {args} {return {initialize finalize drain write}} - catch {chan push [tempchan] foo} msg + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg } -match glob -result {*supports "drain" but not "read"} test iortrans-2.18 {chan push, initialize failed, bad result, flush/write mismatch} -body { proc foo {args} {return {initialize finalize flush read}} - catch {chan push [tempchan] foo} msg + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg } -match glob -result {*supports "flush" but not "write"} -test iortrans-2.19 {chan push, initialize ok, creates channel} -match glob -body { +test iortrans-2.19 {chan push, initialize ok, creates channel} -setup { + set res {} +} -match glob -body { proc foo {args} { - global res + global res lappend res $args if {[lindex $args 0] ne "initialize"} {return} return {initialize finalize drain flush read write} } - set res {} lappend res [file channel rt*] lappend res [chan push [tempchan] foo] lappend res [close [lindex $res end]] lappend res [file channel rt*] +} -cleanup { tempdone rename foo {} - set res } -result {{} {initialize rt* {read write}} file* {drain rt*} {flush rt*} {finalize rt*} {} {}} -test iortrans-2.20 {chan push, init failure -> no channel, no finalize} -match glob -body { +test iortrans-2.20 {chan push, init failure -> no channel, no finalize} -setup { + set res {} +} -match glob -body { proc foo {args} { - global res + global res lappend res $args - return {} + return } - set res {} lappend res [file channel rt*] - lappend res [catch {chan push [tempchan] foo} msg] - lappend res $msg + lappend res [catch {chan push [tempchan] foo} msg] $msg lappend res [file channel rt*] +} -cleanup { tempdone rename foo {} - set res } -result {{} {initialize rt* {read write}} 1 {*all required methods*} {}} # --- --- --- --------- --------- --------- # method finalize (via close) -# General note: file channels rt* finds the transform channel, however -# the name reported will be that of the underlying base driver, fileXX -# here. This actually allows us to see if the whole channel is gone, -# or only the transformation, but not the base. +# General note: file channels rt* finds the transform channel, however the +# name reported will be that of the underlying base driver, fileXX here. This +# actually allows us to see if the whole channel is gone, or only the +# transformation, but not the base. -test iortrans-3.1 {chan finalize, handler destruction has no effect on channel} -match glob -body { +test iortrans-3.1 {chan finalize, handler destruction has no effect on channel} -setup { set res {} - proc foo {args} {track; oninit; return} - note [set c [chan push [tempchan] foo]] +} -match glob -body { + proc foo {args} { + lappend ::res $args + handle.initialize + return + } + lappend res [set c [chan push [tempchan] foo]] rename foo {} - note [file channels file*] - note [file channels rt*] - note [catch {close $c} msg]; note $msg - note [file channels file*] - note [file channels rt*] - set res + lappend res [file channels file*] + lappend res [file channels rt*] + lappend res [catch {close $c} msg] $msg + lappend res [file channels file*] + lappend res [file channels rt*] } -result {{initialize rt* {read write}} file* file* {} 1 {invalid command name "foo"} {} {}} -test iortrans-3.2 {chan finalize, for close} -match glob -body { +test iortrans-3.2 {chan finalize, for close} -setup { set res {} - proc foo {args} {track; oninit; return {}} - note [set c [chan push [tempchan] foo]] +} -match glob -body { + proc foo {args} { + lappend ::res $args + handle.initialize + return + } + lappend res [set c [chan push [tempchan] foo]] close $c # Close deleted the channel. - note [file channels rt*] + lappend res [file channels rt*] # Channel destruction does not kill handler command! - note [info command foo] + lappend res [info command foo] +} -cleanup { rename foo {} - set res } -result {{initialize rt* {read write}} file* {finalize rt*} {} foo} -test iortrans-3.3 {chan finalize, for close, error, close error} -match glob -body { +test iortrans-3.3 {chan finalize, for close, error, close error} -setup { set res {} - proc foo {args} {track; oninit; return -code error 5} - note [set c [chan push [tempchan] foo]] - note [catch {close $c} msg]; note $msg +} -match glob -body { + proc foo {args} { + lappend ::res $args + handle.initialize + return -code error 5 + } + lappend res [set c [chan push [tempchan] foo]] + lappend res [catch {close $c} msg] $msg # Channel is gone despite error. - note [file channels rt*] + lappend res [file channels rt*] +} -cleanup { rename foo {} - set res } -result {{initialize rt* {read write}} file* {finalize rt*} 1 5 {}} -test iortrans-3.4 {chan finalize, for close, error, close error} -match glob -body { +test iortrans-3.4 {chan finalize, for close, error, close error} -setup { set res {} - proc foo {args} {track; oninit; error FOO} - note [set c [chan push [tempchan] foo]] - note [catch {close $c} msg]; note $msg; note $::errorInfo +} -match glob -body { + proc foo {args} { + lappend ::res $args + handle.initialize + error FOO + } + lappend res [set c [chan push [tempchan] foo]] + lappend res [catch {close $c} msg] $msg $::errorInfo +} -cleanup { rename foo {} - set res } -result {{initialize rt* {read write}} file* {finalize rt*} 1 FOO {FOO *"close $c"}} -test iortrans-3.5 {chan finalize, for close, arbitrary result, ignored} -match glob -body { +test iortrans-3.5 {chan finalize, for close, arbitrary result, ignored} -setup { set res {} - proc foo {args} {track; oninit; return SOMETHING} - note [set c [chan push [tempchan] foo]] - note [catch {close $c} msg]; note $msg +} -match glob -body { + proc foo {args} { + lappend ::res $args + handle.initialize + return SOMETHING + } + lappend res [set c [chan push [tempchan] foo]] + lappend res [catch {close $c} msg] $msg +} -cleanup { rename foo {} - set res } -result {{initialize rt* {read write}} file* {finalize rt*} 0 {}} -test iortrans-3.6 {chan finalize, for close, break, close error} -match glob -body { +test iortrans-3.6 {chan finalize, for close, break, close error} -setup { set res {} - proc foo {args} {track; oninit; return -code 3} - note [set c [chan push [tempchan] foo]] - note [catch {close $c} msg]; note $msg +} -match glob -body { + proc foo {args} { + lappend ::res $args + handle.initialize + return -code 3 + } + lappend res [set c [chan push [tempchan] foo]] + lappend res [catch {close $c} msg] $msg +} -cleanup { rename foo {} - set res } -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} -test iortrans-3.7 {chan finalize, for close, continue, close error} -match glob -body { +test iortrans-3.7 {chan finalize, for close, continue, close error} -setup { set res {} - proc foo {args} {track; oninit; return -code 4} - note [set c [chan push [tempchan] foo]] - note [catch {close $c} msg]; note $msg +} -match glob -body { + proc foo {args} { + lappend ::res $args + handle.initialize + return -code 4 + } + lappend res [set c [chan push [tempchan] foo]] + lappend res [catch {close $c} msg] $msg +} -cleanup { rename foo {} - set res } -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} -test iortrans-3.8 {chan finalize, for close, custom code, close error} -match glob -body { +test iortrans-3.8 {chan finalize, for close, custom code, close error} -setup { set res {} - proc foo {args} {track; oninit; return -code 777 BANG} - note [set c [chan push [tempchan] foo]] - note [catch {close $c} msg]; note $msg +} -match glob -body { + proc foo {args} { + lappend ::res $args + handle.initialize + return -code 777 BANG + } + lappend res [set c [chan push [tempchan] foo]] + lappend res [catch {close $c} msg] $msg +} -cleanup { rename foo {} - set res } -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} -test iortrans-3.9 {chan finalize, for close, ignore level, close error} -match glob -setup { +test iortrans-3.9 {chan finalize, for close, ignore level, close error} -setup { set res {} } -body { - proc foo {args} {track; oninit; return -level 5 -code 777 BANG} - note [set c [chan push [tempchan] foo]] - note [catch {close $c} msg opt]; note $msg; noteOpts $opt - return $res -} -cleanup { + proc foo {args} { + lappend ::res $args + handle.initialize + return -level 5 -code 777 BANG + } + lappend res [set c [chan push [tempchan] foo]] + lappend res [catch {close $c} msg opt] $msg + noteOpts $opt +} -match glob -cleanup { rename foo {} } -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}} # --- === *** ########################### # method read (via read) -test iortrans-4.1 {chan read, transform call and return} -match glob -body { +test iortrans-4.1 {chan read, transform call and return} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return snarf } set c [chan push [tempchan] foo] - note [read $c 10] + lappend res [read $c 10] +} -cleanup { tempdone rename foo {} - set res } -result {{read rt* {test data }} snarf} -test iortrans-4.2 {chan read, for non-readable channel} -match glob -body { +test iortrans-4.2 {chan read, for non-readable channel} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit; onfinal; track; note MUST_NOT_HAPPEN + handle.initialize + handle.finalize + lappend ::res $args MUST_NOT_HAPPEN } set c [chan push [tempchan w] foo] - note [catch {read $c 2} msg]; note $msg + lappend res [catch {read $c 2} msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {1 {channel "file*" wasn't opened for reading}} -test iortrans-4.3 {chan read, error return} -match glob -body { +test iortrans-4.3 {chan read, error return} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return -code error BOOM! } set c [chan push [tempchan] foo] - note [catch {read $c 2} msg]; note $msg + lappend res [catch {read $c 2} msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {{read rt* {test data }} 1 BOOM!} -test iortrans-4.4 {chan read, break return is error} -match glob -body { +test iortrans-4.4 {chan read, break return is error} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return -code break BOOM! } set c [chan push [tempchan] foo] - note [catch {read $c 2} msg]; note $msg + lappend res [catch {read $c 2} msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {{read rt* {test data }} 1 *bad code*} -test iortrans-4.5 {chan read, continue return is error} -match glob -body { +test iortrans-4.5 {chan read, continue return is error} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return -code continue BOOM! } set c [chan push [tempchan] foo] - note [catch {read $c 2} msg]; note $msg + lappend res [catch {read $c 2} msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {{read rt* {test data }} 1 *bad code*} -test iortrans-4.6 {chan read, custom return is error} -match glob -body { +test iortrans-4.6 {chan read, custom return is error} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return -code 777 BOOM! } set c [chan push [tempchan] foo] - note [catch {read $c 2} msg]; note $msg + lappend res [catch {read $c 2} msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {{read rt* {test data }} 1 *bad code*} -test iortrans-4.7 {chan read, level is squashed} -match glob -body { +test iortrans-4.7 {chan read, level is squashed} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return -level 55 -code 777 BOOM! } set c [chan push [tempchan] foo] - note [catch {read $c 2} msg opt]; note $msg; noteOpts $opt + lappend res [catch {read $c 2} msg opt] $msg + noteOpts $opt +} -cleanup { tempdone rename foo {} - set res } -result {{read rt* {test data }} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}} -test iortrans-4.8 {chan read, read, bug 2921116} -match glob -setup { +test iortrans-4.8 {chan read, read, bug 2921116} -setup { set res {} +} -match glob -body { proc foo {fd args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args # Kill and recreate transform while it is operating - chan pop $fd + chan pop $fd chan push $fd [list foo $fd] } set c [chan push [set c [tempchan]] [list foo $c]] -} -body { - note [read $c] - #note [gets $c] - set res + lappend res [read $c] + #lappend res [gets $c] } -cleanup { tempdone rename foo {} } -result {{read rt* {test data }} file*} -test iortrans-4.9 {chan read, gets, bug 2921116} -match glob -setup { +test iortrans-4.9 {chan read, gets, bug 2921116} -setup { set res {} +} -match glob -body { proc foo {fd args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args # Kill and recreate transform while it is operating - chan pop $fd + chan pop $fd chan push $fd [list foo $fd] } set c [chan push [set c [tempchan]] [list foo $c]] -} -body { - note [gets $c] - set res + lappend res [gets $c] } -cleanup { tempdone rename foo {} @@ -492,127 +551,207 @@ test iortrans-4.9 {chan read, gets, bug 2921116} -match glob -setup { # --- === *** ########################### # method write (via puts) -test iortrans-5.1 {chan write, regular write} -match glob -body { +test iortrans-5.1 {chan write, regular write} -setup { set res {} - proc foo {args} { oninit; onfinal; track ; return transformresult } +} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return transformresult + } set c [chan push [tempchan] foo] - puts -nonewline $c snarf; flush $c + puts -nonewline $c snarf + flush $c close $c - note [tempview] + lappend res [tempview] +} -cleanup { tempdone rename foo {} - set res } -result {{write rt* snarf} transformresult} -test iortrans-5.2 {chan write, no write is ok, no change to file} -match glob -body { +test iortrans-5.2 {chan write, no write is ok, no change to file} -setup { set res {} - proc foo {args} { oninit; onfinal; track ; return {} } +} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return + } set c [chan push [tempchan] foo] - puts -nonewline $c snarfsnarfsnarf; flush $c + puts -nonewline $c snarfsnarfsnarf + flush $c close $c - note [tempview];# This has to show the original data, as nothing was written + lappend res [tempview]; # This has to show the original data, as nothing was written +} -cleanup { tempdone rename foo {} - set res } -result {{write rt* snarfsnarfsnarf} {test data}} -test iortrans-5.3 {chan write, failed write} -match glob -body { +test iortrans-5.3 {chan write, failed write} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -code error FAIL!} +} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -code error FAIL! + } set c [chan push [tempchan] foo] puts -nonewline $c snarfsnarfsnarf - note [catch {flush $c} msg] ; note $msg + lappend res [catch {flush $c} msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {{write rt* snarfsnarfsnarf} 1 FAIL!} -test iortrans-5.4 {chan write, non-writable channel} -match glob -body { +test iortrans-5.4 {chan write, non-writable channel} -setup { set res {} - proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} +} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args MUST_NOT_HAPPEN + return + } set c [chan push [tempchan r] foo] - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]; note $msg + lappend res [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg +} -cleanup { close $c tempdone rename foo {} - set res } -result {1 {channel "file*" wasn't opened for writing}} -test iortrans-5.5 {chan write, failed write, error return} -match glob -body { +test iortrans-5.5 {chan write, failed write, error return} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -code error BOOM!} +} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -code error BOOM! + } set c [chan push [tempchan] foo] - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {{write rt* snarfsnarfsnarf} 1 BOOM!} -test iortrans-5.6 {chan write, failed write, error return} -match glob -body { +test iortrans-5.6 {chan write, failed write, error return} -setup { set res {} - proc foo {args} {oninit; onfinal; track; error BOOM!} +} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + error BOOM! + } set c [chan push [tempchan] foo] - notes [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res {*}[catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {{write rt* snarfsnarfsnarf} 1 BOOM!} -test iortrans-5.7 {chan write, failed write, break return is error} -match glob -body { +test iortrans-5.7 {chan write, failed write, break return is error} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -code break BOOM!} +} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -code break BOOM! + } set c [chan push [tempchan] foo] - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {{write rt* snarfsnarfsnarf} 1 *bad code*} -test iortrans-5.8 {chan write, failed write, continue return is error} -match glob -body { +test iortrans-5.8 {chan write, failed write, continue return is error} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -code continue BOOM!} +} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -code continue BOOM! + } set c [chan push [tempchan] foo] - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {{write rt* snarfsnarfsnarf} 1 *bad code*} -test iortrans-5.9 {chan write, failed write, custom return is error} -match glob -body { +test iortrans-5.9 {chan write, failed write, custom return is error} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -code 777 BOOM!} +} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -code 777 BOOM! + } set c [chan push [tempchan] foo] - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {{write rt* snarfsnarfsnarf} 1 *bad code*} -test iortrans-5.10 {chan write, failed write, level is ignored} -match glob -body { +test iortrans-5.10 {chan write, failed write, level is ignored} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -level 55 -code 777 BOOM!} +} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -level 55 -code 777 BOOM! + } set c [chan push [tempchan] foo] - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg opt] - note $msg + lappend res [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg opt] $msg noteOpts $opt +} -cleanup { tempdone rename foo {} - set res -} -result {{write rt* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "write"*}} +} -result {{write rt* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline * -errorinfo *bad code*subcommand "write"*}} test iortrans-5.11 {chan write, bug 2921116} -match glob -setup { set res {} set level 0 +} -body { proc foo {fd args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args # pop - invokes flush - invokes 'foo write' - infinite recursion - stop it global level - if {$level} { return "" } + if {$level} { + return + } incr level # Kill and recreate transform while it is operating - chan pop $fd + chan pop $fd chan push $fd [list foo $fd] } set c [chan push [set c [tempchan]] [list foo $c]] -} -body { - note [puts -nonewline $c abcdef] - note [flush $c] - set res + lappend res [puts -nonewline $c abcdef] + lappend res [flush $c] } -cleanup { tempdone rename foo {} @@ -621,85 +760,110 @@ test iortrans-5.11 {chan write, bug 2921116} -match glob -setup { # --- === *** ########################### # method limit?, drain (via read) -test iortrans-6.1 {chan read, read limits} -match glob -body { +test iortrans-6.1 {chan read, read limits} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit limit?; onfinal; track ; onread + handle.initialize limit? + handle.finalize + lappend ::res $args + handle.read return 6 } set c [chan push [tempchan] foo] - note [read $c 10] + lappend res [read $c 10] +} -cleanup { tempdone rename foo {} - set res } -result {{limit? rt*} {read rt* {test d}} {limit? rt*} {read rt* {ata }} {limit? rt*} @@} -test iortrans-6.2 {chan read, read transform drain on eof} -match glob -body { +test iortrans-6.2 {chan read, read transform drain on eof} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit drain; onfinal; track ; onread ; ondrain + handle.initialize drain + handle.finalize + lappend ::res $args + handle.read + handle.drain return } set c [chan push [tempchan] foo] - note [read $c] - note [close $c] + lappend res [read $c] + lappend res [close $c] +} -cleanup { tempdone rename foo {} - set res } -result {{read rt* {test data }} {drain rt*} @<> {}} # --- === *** ########################### # method clear (via puts, seek) -test iortrans-7.1 {chan write, write clears read buffers} -match glob -body { +test iortrans-7.1 {chan write, write clears read buffers} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit clear; onfinal; track ; onclear + handle.initialize clear + handle.finalize + lappend ::res $args + handle.clear return transformresult } set c [chan push [tempchan] foo] - puts -nonewline $c snarf; flush $c + puts -nonewline $c snarf + flush $c + return $res +} -cleanup { tempdone rename foo {} - set res } -result {{clear rt*} {write rt* snarf}} -test iortrans-7.2 {seek clears read buffers} -match glob -body { +test iortrans-7.2 {seek clears read buffers} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit clear; onfinal; track + handle.initialize clear + handle.finalize + lappend ::res $args return } set c [chan push [tempchan] foo] seek $c 2 + return $res +} -cleanup { tempdone rename foo {} - set res } -result {{clear rt*}} -test iortrans-7.3 {clear, any result is ignored} -match glob -body { +test iortrans-7.3 {clear, any result is ignored} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit clear; onfinal; track + handle.initialize clear + handle.finalize + lappend ::res $args return -code error "X" } set c [chan push [tempchan] foo] seek $c 2 + return $res +} -cleanup { tempdone rename foo {} - set res } -result {{clear rt*}} test iortrans-7.4 {chan clear, bug 2921116} -match glob -setup { set res {} +} -body { proc foo {fd args} { - oninit clear; onfinal; track + handle.initialize clear + handle.finalize + lappend ::res $args # Kill and recreate transform while it is operating - chan pop $fd + chan pop $fd chan push $fd [list foo $fd] } set c [chan push [set c [tempchan]] [list foo $c]] -} -body { seek $c 2 - set res + return $res } -cleanup { tempdone rename foo {} @@ -708,47 +872,53 @@ test iortrans-7.4 {chan clear, bug 2921116} -match glob -setup { # --- === *** ########################### # method flush (via seek, close) -test iortrans-8.1 {seek flushes write buffers, ignores data} -match glob -body { +test iortrans-8.1 {seek flushes write buffers, ignores data} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit flush; onfinal; track + handle.initialize flush + handle.finalize + lappend ::res $args return X } set c [chan push [tempchan] foo] # Flush, no writing seek $c 2 # The close flushes again, this modifies the file! - note | ; note [close $c] ; note | - note [tempview] + lappend res | + lappend res [close $c] | [tempview] +} -cleanup { tempdone rename foo {} - set res } -result {{flush rt*} | {flush rt*} {} | {teXt data}} - -test iortrans-8.2 {close flushes write buffers, writes data} -match glob -body { +test iortrans-8.2 {close flushes write buffers, writes data} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit flush; track ; onfinal + handle.initialize flush + lappend ::res $args + handle.finalize return .flushed. } set c [chan push [tempchan] foo] close $c - note [tempview] + lappend res [tempview] +} -cleanup { tempdone rename foo {} - set res } -result {{flush rt*} {finalize rt*} .flushed.} - test iortrans-8.3 {chan flush, bug 2921116} -match glob -setup { set res {} +} -body { proc foo {fd args} { - oninit flush; onfinal; track + handle.initialize flush + handle.finalize + lappend ::res $args # Kill and recreate transform while it is operating - chan pop $fd + chan pop $fd chan push $fd [list foo $fd] } set c [chan push [set c [tempchan]] [list foo $c]] -} -body { seek $c 2 set res } -cleanup { @@ -763,139 +933,128 @@ test iortrans-8.3 {chan flush, bug 2921116} -match glob -setup { # method event - removed from TIP (rev 1.12+) # --- === *** ########################### -# 'Pull the rug' tests. Create channel in a interpreter A, move to -# other interpreter B, destroy the origin interpreter (A) before or -# during access from B. Must not crash, must return proper errors. - -test iortrans-11.0 {origin interpreter of moved transform gone} -match glob -body { - - set ida [interp create];#puts <<$ida>> - set idb [interp create];#puts <<$idb>> - +# 'Pull the rug' tests. Create channel in a interpreter A, move to other +# interpreter B, destroy the origin interpreter (A) before or during access +# from B. Must not crash, must return proper errors. +test iortrans-11.0 {origin interpreter of moved transform gone} -setup { + set ida [interp create]; #puts <<$ida>> + set idb [interp create]; #puts <<$idb>> # Magic to get the test* commands in the slaves load {} Tcltest $ida load {} Tcltest $idb - +} -constraints {testchannel} -match glob -body { # Set up channel and transform in interpreter interp eval $ida $helperscript interp eval $ida [list ::variable tempchan [tempchan]] interp transfer {} $::tempchan $ida set chan [interp eval $ida { variable tempchan - proc foo {args} {oninit clear drain flush limit? read write; onfinal; track; return} + proc foo {args} { + handle.initialize clear drain flush limit? read write + handle.finalize + lappend ::res $args + return + } set chan [chan push $tempchan foo] fconfigure $chan -buffering none set chan }] - # Move channel to 2nd interpreter, transform goes with it. - interp eval $ida [list testchannel cut $chan] + interp eval $ida [list testchannel cut $chan] interp eval $idb [list testchannel splice $chan] - # Kill origin interpreter, then access channel from 2nd interpreter. interp delete $ida - - set res {} - lappend res [catch {interp eval $idb [list puts $chan shoo]} msg] $msg - lappend res [catch {interp eval $idb [list tell $chan]} msg] $msg - lappend res [catch {interp eval $idb [list seek $chan 1]} msg] $msg - lappend res [catch {interp eval $idb [list gets $chan]} msg] $msg - lappend res [catch {interp eval $idb [list close $chan]} msg] $msg + set res {} + lappend res \ + [catch {interp eval $idb [list puts $chan shoo]} msg] $msg \ + [catch {interp eval $idb [list tell $chan]} msg] $msg \ + [catch {interp eval $idb [list seek $chan 1]} msg] $msg \ + [catch {interp eval $idb [list gets $chan]} msg] $msg \ + [catch {interp eval $idb [list close $chan]} msg] $msg #lappend res [interp eval $ida {set res}] # actions: clear|write|clear|write|clear|flush|limit?|drain|flush + # The 'tell' is ok, as it passed through the transform to the base channel + # without invoking the transform handler. +} -cleanup { tempdone - set res - # The 'tell' is ok, as it passed through the transform to the base - # channel without invoking the transform handler. -} -constraints {testchannel} \ - -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} - -test iortrans-11.1 {origin interpreter of moved transform destroyed during access} -match glob -body { - - set ida [interp create];#puts <<$ida>> - set idb [interp create];#puts <<$idb>> - +} -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} +test iortrans-11.1 {origin interpreter of moved transform destroyed during access} -setup { + set ida [interp create]; #puts <<$ida>> + set idb [interp create]; #puts <<$idb>> # Magic to get the test* commands in the slaves load {} Tcltest $ida load {} Tcltest $idb - +} -constraints {testchannel impossible} -match glob -body { # Set up channel in thread set chan [interp eval $ida $helperscript] set chan [interp eval $ida { proc foo {args} { - oninit clear drain flush limit? read write; onfinal; track; - # destroy interpreter during channel access - # Actually not possible for an interp to destroy itself. + handle.initialize clear drain flush limit? read write + handle.finalize + lappend ::res $args + # Destroy interpreter during channel access. Actually not + # possible for an interp to destroy itself. interp delete {} return} set chan [chan push [tempchan] foo] fconfigure $chan -buffering none set chan }] - # Move channel to 2nd thread, transform goes with it. - interp eval $ida [list testchannel cut $chan] + interp eval $ida [list testchannel cut $chan] interp eval $idb [list testchannel splice $chan] - - # Run access from interpreter B, this will give us a synchronous - # response. - + # Run access from interpreter B, this will give us a synchronous response. interp eval $idb [list set chan $chan] interp eval $idb [list set mid $tcltest::mainThread] set res [interp eval $idb { - # wait a bit, give the main thread the time to start its event - # loop to wait for the response from B - after 2000 + # Wait a bit, give the main thread the time to start its event loop to + # wait for the response from B + after 50 catch { puts $chan shoo } res set res }] +} -cleanup { tempdone - set res -} -constraints {testchannel impossible} \ - -result {Owner lost} - - -test iortrans-11.2 {delete interp of reflected transform} -body { +} -result {Owner lost} +test iortrans-11.2 {delete interp of reflected transform} -setup { interp create slave - # Magic to get the test* commands into the slave load {} Tcltest slave - +} -constraints {testchannel} -body { # Get base channel into the slave set c [tempchan] testchannel cut $c interp eval slave [list testchannel splice $c] interp eval slave [list set c $c] - slave eval { - proc no-op args {} - proc driver {c sub args} {return {initialize finalize read write}} + proc no-op args {} + proc driver {c sub args} { + return {initialize finalize read write} + } set t [chan push $c [list driver $c]] - chan event $c readable no-op + chan event $c readable no-op } interp delete slave -} -result {} -constraints {testchannel} - +} -result {} + # ### ### ### ######### ######### ######### -## Same tests as above, but exercising the code forwarding and -## receiving driver operations to the originator thread. +## 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 association. +## 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 +## association. -# Duplicate of code in "thread.test", and "ioCmd.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. +# Duplicate of code in "thread.test", and "ioCmd.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. if {[testConstraint testthread]} { testthread errorproc ThreadError - proc ThreadError {id info} { global threadError set threadError $info @@ -906,13 +1065,12 @@ if {[testConstraint testthread]} { } # ### ### ### ######### ######### ######### -## Helper command. Runs a script in a separate thread and returns the -## result. A channel is transfered into the thread as well, and a list -## of configuation variables +## Helper command. Runs a script in a separate thread and returns the result. +## A channel is transfered into the thread as well, and a list of configuation +## variables proc inthread {chan script args} { # Test thread. - set tid [testthread create] # Init thread configuration. @@ -926,11 +1084,15 @@ proc inthread {chan script args} { } 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} - proc noteOpts opts {global notes; lappend notes [dict merge { - -code !?! -level !?! -errorcode !?! -errorline !?! -errorinfo !?! - } $opts]} + proc notes {} { + return $::notes + } + proc noteOpts opts { + lappend ::notes [dict merge { + -code !?! -level !?! -errorcode !?! -errorline !?! + -errorinfo !?! -errorstack !?! + } $opts] + } } testthread send $tid [list proc s {} [list uplevel 1 $script]]; # (*) @@ -939,15 +1101,14 @@ proc inthread {chan script args} { 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. + # 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 (*) + after 50 + catch {s} res; # This runs the script, 's' was defined at (*) testthread send -async $mid [list set ::tres $res] } vwait ::tres @@ -959,454 +1120,579 @@ proc inthread {chan script args} { # ### ### ### ######### ######### ######### -# ### ### ### ######### ######### ######### - -test iortrans.tf-3.2 {chan finalize, for close} -match glob -body { +test iortrans.tf-3.2 {chan finalize, for close} -setup { set res {} - proc foo {args} {track; oninit; return {}} - note [set c [chan push [tempchan] foo]] - note [inthread $c { +} -constraints {testchannel testthread} -match glob -body { + proc foo {args} { + lappend ::res $args + handle.initialize + return {} + } + lappend res [set c [chan push [tempchan] foo]] + lappend res [inthread $c { close $c # Close the deleted the channel. file channels rt* } c] # Channel destruction does not kill handler command! - note [info command foo] + lappend res [info command foo] +} -cleanup { rename foo {} - set res -} -constraints {testchannel testthread} \ - -result {{initialize rt* {read write}} file* {finalize rt*} {} foo} -test iortrans.tf-3.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 push [tempchan] foo]] - notes [inthread $c { - note [catch {close $c} msg]; note $msg +} -result {{initialize rt* {read write}} file* {finalize rt*} {} foo} +test iortrans.tf-3.3 {chan finalize, for close, error, close error} -setup { + set res {} +} -constraints {testchannel testthread} -match glob -body { + proc foo {args} { + lappend ::res $args + handle.initialize + return -code error 5 + } + lappend res [set c [chan push [tempchan] foo]] + lappend res {*}[inthread $c { + lappend notes [catch {close $c} msg] $msg # Channel is gone despite error. - note [file channels rt*] + lappend notes [file channels rt*] notes } c] +} -cleanup { rename foo {} - set res -} -constraints {testchannel testthread} \ - -result {{initialize rt* {read write}} file* {finalize rt*} 1 5 {}} -test iortrans.tf-3.4 {chan finalize, for close, error, close errror} -match glob -body { - set res {} - proc foo {args} {track; oninit; error FOO} - note [set c [chan push [tempchan] foo]] - notes [inthread $c { - note [catch {close $c} msg]; note $msg +} -result {{initialize rt* {read write}} file* {finalize rt*} 1 5 {}} +test iortrans.tf-3.4 {chan finalize, for close, error, close errror} -setup { + set res {} +} -constraints {testchannel testthread} -body { + proc foo {args} { + lappend ::res $args + handle.initialize + error FOO + } + lappend res [set c [chan push [tempchan] foo]] + lappend res {*}[inthread $c { + lappend notes [catch {close $c} msg] $msg notes } c] +} -match glob -cleanup { rename foo {} - set res -} -constraints {testchannel testthread} \ - -result {{initialize rt* {read write}} file* {finalize rt*} 1 FOO} -test iortrans.tf-3.5 {chan finalize, for close, arbitrary result} -match glob -body { - set res {} - proc foo {args} {track; oninit; return SOMETHING} - note [set c [chan push [tempchan] foo]] - notes [inthread $c { - note [catch {close $c} msg]; note $msg +} -result {{initialize rt* {read write}} file* {finalize rt*} 1 FOO} +test iortrans.tf-3.5 {chan finalize, for close, arbitrary result} -setup { + set res {} +} -constraints {testchannel testthread} -match glob -body { + proc foo {args} { + lappend ::res $args + handle.initialize + return SOMETHING + } + lappend res [set c [chan push [tempchan] foo]] + lappend res {*}[inthread $c { + lappend notes [catch {close $c} msg] $msg notes } c] +} -cleanup { rename foo {} - set res -} -constraints {testchannel testthread} \ - -result {{initialize rt* {read write}} file* {finalize rt*} 0 {}} -test iortrans.tf-3.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 push [tempchan] foo]] - notes [inthread $c { - note [catch {close $c} msg]; note $msg +} -result {{initialize rt* {read write}} file* {finalize rt*} 0 {}} +test iortrans.tf-3.6 {chan finalize, for close, break, close error} -setup { + set res {} +} -constraints {testchannel testthread} -match glob -body { + proc foo {args} { + lappend ::res $args + handle.initialize + return -code 3 + } + lappend res [set c [chan push [tempchan] foo]] + lappend res {*}[inthread $c { + lappend notes [catch {close $c} msg] $msg notes } c] +} -cleanup { rename foo {} - set res -} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} \ - -constraints {testchannel testthread} - - -test iortrans.tf-3.7 {chan finalize, for close, continue, close error} -match glob -body { +} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} +test iortrans.tf-3.7 {chan finalize, for close, continue, close error} -setup { set res {} - proc foo {args} {track; oninit; return -code 4} - note [set c [chan push [tempchan] foo]] - notes [inthread $c { - note [catch {close $c} msg]; note $msg +} -constraints {testchannel testthread} -match glob -body { + proc foo {args} { + lappend ::res $args + handle.initialize + return -code 4 + } + lappend res [set c [chan push [tempchan] foo]] + lappend res {*}[inthread $c { + lappend notes [catch {close $c} msg] $msg notes } c] +} -cleanup { rename foo {} - set res -} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} \ - -constraints {testchannel testthread} -test iortrans.tf-3.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 push [tempchan] foo]] - notes [inthread $c { - note [catch {close $c} msg]; note $msg +} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} +test iortrans.tf-3.8 {chan finalize, for close, custom code, close error} -setup { + set res {} +} -constraints {testchannel testthread} -match glob -body { + proc foo {args} { + lappend ::res $args + handle.initialize + return -code 777 BANG + } + lappend res [set c [chan push [tempchan] foo]] + lappend res {*}[inthread $c { + lappend notes [catch {close $c} msg] $msg notes } c] +} -cleanup { rename foo {} - set res -} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} \ - -constraints {testchannel testthread} -test iortrans.tf-3.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 push [tempchan] foo]] - notes [inthread $c { - note [catch {close $c} msg opt]; note $msg; noteOpts $opt +} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} +test iortrans.tf-3.9 {chan finalize, for close, ignore level, close error} -setup { + set res {} +} -constraints {testchannel testthread} -match glob -body { + proc foo {args} { + lappend ::res $args + handle.initialize + return -level 5 -code 777 BANG + } + lappend res [set c [chan push [tempchan] foo]] + lappend res {*}[inthread $c { + lappend notes [catch {close $c} msg opt] $msg + noteOpts $opt notes } c] +} -cleanup { rename foo {} - set res -} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}} \ - -constraints {testchannel testthread} +} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}} # --- === *** ########################### # method read -test iortrans.tf-4.1 {chan read, transform call and return} -match glob -body { +test iortrans.tf-4.1 {chan read, transform call and return} -setup { set res {} +} -constraints {testchannel testthread} -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return snarf } set c [chan push [tempchan] foo] - notes [inthread $c { - note [read $c 10] + lappend res {*}[inthread $c { + lappend notes [read $c 10] close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -constraints {testchannel testthread} -result {{read rt* {test data +} -match glob -result {{read rt* {test data }} snarf} - -test iortrans.tf-4.2 {chan read, for non-readable channel} -match glob -body { +test iortrans.tf-4.2 {chan read, for non-readable channel} -setup { set res {} +} -constraints {testchannel testthread} -body { proc foo {args} { - oninit; onfinal; track; note MUST_NOT_HAPPEN + handle.initialize + handle.finalize + lappend ::res $args MUST_NOT_HAPPEN } set c [chan push [tempchan w] foo] - notes [inthread $c { - note [catch {[read $c 2]} msg]; note $msg + lappend res {*}[inthread $c { + lappend notes [catch {[read $c 2]} msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -constraints {testchannel testthread} -result {1 {channel "file*" wasn't opened for reading}} -test iortrans.tf-4.3 {chan read, error return} -match glob -body { +} -match glob -result {1 {channel "file*" wasn't opened for reading}} +test iortrans.tf-4.3 {chan read, error return} -setup { set res {} +} -constraints {testchannel testthread} -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return -code error BOOM! } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {read $c 2} msg]; note $msg + lappend res {*}[inthread $c { + lappend notes [catch {read $c 2} msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -result {{read rt* {test data -}} 1 BOOM!} \ - -constraints {testchannel testthread} -test iortrans.tf-4.4 {chan read, break return is error} -match glob -body { +} -match glob -result {{read rt* {test data +}} 1 BOOM!} +test iortrans.tf-4.4 {chan read, break return is error} -setup { set res {} +} -constraints {testchannel testthread} -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return -code break BOOM! } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {read $c 2} msg]; note $msg + lappend res {*}[inthread $c { + lappend notes [catch {read $c 2} msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -result {{read rt* {test data -}} 1 *bad code*} \ - -constraints {testchannel testthread} -test iortrans.tf-4.5 {chan read, continue return is error} -match glob -body { +} -match glob -result {{read rt* {test data +}} 1 *bad code*} +test iortrans.tf-4.5 {chan read, continue return is error} -setup { set res {} +} -constraints {testchannel testthread} -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return -code continue BOOM! } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {read $c 2} msg]; note $msg + lappend res {*}[inthread $c { + lappend notes [catch {read $c 2} msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -result {{read rt* {test data -}} 1 *bad code*} \ - -constraints {testchannel testthread} -test iortrans.tf-4.6 {chan read, custom return is error} -match glob -body { +} -match glob -result {{read rt* {test data +}} 1 *bad code*} +test iortrans.tf-4.6 {chan read, custom return is error} -setup { set res {} +} -constraints {testchannel testthread} -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return -code 777 BOOM! } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {read $c 2} msg]; note $msg + lappend res {*}[inthread $c { + lappend notes [catch {read $c 2} msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -result {{read rt* {test data -}} 1 *bad code*} \ - -constraints {testchannel testthread} - -test iortrans.tf-4.7 {chan read, level is squashed} -match glob -body { +} -match glob -result {{read rt* {test data +}} 1 *bad code*} +test iortrans.tf-4.7 {chan read, level is squashed} -setup { set res {} +} -constraints {testchannel testthread} -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return -level 55 -code 777 BOOM! } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {read $c 2} msg opt]; note $msg; noteOpts $opt + lappend res {*}[inthread $c { + lappend notes [catch {read $c 2} msg opt] $msg + noteOpts $opt close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -result {{read rt* {test data -}} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}} \ - -constraints {testchannel testthread} +} -match glob -result {{read rt* {test data +}} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}} # --- === *** ########################### # method write -test iortrans.tf-5.1 {chan write, regular write} -match glob -body { +test iortrans.tf-5.1 {chan write, regular write} -setup { set res {} - proc foo {args} { oninit; onfinal; track ; return transformresult } +} -constraints {testchannel testthread} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return transformresult + } set c [chan push [tempchan] foo] inthread $c { - puts -nonewline $c snarf; flush $c + puts -nonewline $c snarf + flush $c close $c } c - note [tempview] + lappend res [tempview] +} -cleanup { tempdone rename foo {} - set res -} -constraints {testchannel testthread} -result {{write rt* snarf} transformresult} -test iortrans.tf-5.2 {chan write, no write is ok, no change to file} -match glob -body { +} -result {{write rt* snarf} transformresult} +test iortrans.tf-5.2 {chan write, no write is ok, no change to file} -setup { set res {} - proc foo {args} { oninit; onfinal; track ; return {} } +} -constraints {testchannel testthread} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return + } set c [chan push [tempchan] foo] inthread $c { - puts -nonewline $c snarfsnarfsnarf; flush $c + puts -nonewline $c snarfsnarfsnarf + flush $c close $c } c - note [tempview];# This has to show the original data, as nothing was written + lappend res [tempview]; # This has to show the original data, as nothing was written +} -cleanup { tempdone rename foo {} - set res -} -constraints {testchannel testthread} \ - -result {{write rt* snarfsnarfsnarf} {test data}} -test iortrans.tf-5.3 {chan write, failed write} -match glob -body { +} -result {{write rt* snarfsnarfsnarf} {test data}} +test iortrans.tf-5.3 {chan write, failed write} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -code error FAIL!} +} -constraints {testchannel testthread} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -code error FAIL! + } set c [chan push [tempchan] foo] - notes [inthread $c { + lappend res {*}[inthread $c { puts -nonewline $c snarfsnarfsnarf - note [catch {flush $c} msg] - note $msg + lappend notes [catch {flush $c} msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -constraints {testchannel testthread} \ - -result {{write rt* snarfsnarfsnarf} 1 FAIL!} -test iortrans.tf-5.4 {chan write, non-writable channel} -match glob -body { +} -result {{write rt* snarfsnarfsnarf} 1 FAIL!} +test iortrans.tf-5.4 {chan write, non-writable channel} -setup { set res {} - proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} +} -constraints {testchannel testthread} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args MUST_NOT_HAPPEN + return + } set c [chan push [tempchan r] foo] - notes [inthread $c { - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res {*}[inthread $c { + lappend notes [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -constraints {testchannel testthread} \ - -result {1 {channel "file*" wasn't opened for writing}} -test iortrans.tf-5.5 {chan write, failed write, error return} -match glob -body { +} -result {1 {channel "file*" wasn't opened for writing}} +test iortrans.tf-5.5 {chan write, failed write, error return} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -code error BOOM!} +} -constraints {testchannel testthread} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -code error BOOM! + } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res {*}[inthread $c { + lappend notes [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -result {{write rt* snarfsnarfsnarf} 1 BOOM!} \ - -constraints {testchannel testthread} -test iortrans.tf-5.6 {chan write, failed write, error return} -match glob -body { +} -result {{write rt* snarfsnarfsnarf} 1 BOOM!} +test iortrans.tf-5.6 {chan write, failed write, error return} -setup { set res {} - proc foo {args} {oninit; onfinal; track; error BOOM!} +} -constraints {testchannel testthread} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + error BOOM! + } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res {*}[inthread $c { + lappend notes [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -result {{write rt* snarfsnarfsnarf} 1 BOOM!} \ - -constraints {testchannel testthread} - - -test iortrans.tf-5.7 {chan write, failed write, break return is error} -match glob -body { +} -result {{write rt* snarfsnarfsnarf} 1 BOOM!} +test iortrans.tf-5.7 {chan write, failed write, break return is error} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -code break BOOM!} +} -constraints {testchannel testthread} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -code break BOOM! + } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res {*}[inthread $c { + lappend notes [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} \ - -constraints {testchannel testthread} -test iortrans.tf-5.8 {chan write, failed write, continue return is error} -match glob -body { +} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} +test iortrans.tf-5.8 {chan write, failed write, continue return is error} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -code continue BOOM!} +} -constraints {testchannel testthread} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -code continue BOOM! + } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res {*}[inthread $c { + lappend notes [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg close $c notes } c] +} -cleanup { rename foo {} - set res -} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} \ - -constraints {testchannel testthread} -test iortrans.tf-5.9 {chan write, failed write, custom return is error} -match glob -body { +} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} +test iortrans.tf-5.9 {chan write, failed write, custom return is error} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -code 777 BOOM!} +} -constraints {testchannel testthread} -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -code 777 BOOM! + } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res {*}[inthread $c { + lappend notes [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} \ - -constraints {testchannel testthread} -test iortrans.tf-5.10 {chan write, failed write, level is ignored} -match glob -body { +} -match glob -result {{write rt* snarfsnarfsnarf} 1 *bad code*} +test iortrans.tf-5.10 {chan write, failed write, level is ignored} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -level 55 -code 777 BOOM!} +} -constraints {testchannel testthread} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -level 55 -code 777 BOOM! + } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg opt] - note $msg + lappend res {*}[inthread $c { + lappend notes [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg opt] $msg noteOpts $opt close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -result {{write rt* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "write"*}} \ - -constraints {testchannel testthread} - +} -result {{write rt* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline * -errorinfo *bad code*subcommand "write"*}} # --- === *** ########################### # method limit?, drain (via read) -test iortrans.tf-6.1 {chan read, read limits} -match glob -body { +test iortrans.tf-6.1 {chan read, read limits} -setup { set res {} +} -constraints {testchannel testthread} -match glob -body { proc foo {args} { - oninit limit?; onfinal; track ; onread + handle.initialize limit? + handle.finalize + lappend ::res $args + handle.read return 6 } set c [chan push [tempchan] foo] - notes [inthread $c { - note [read $c 10] + lappend res {*}[inthread $c { + lappend notes [read $c 10] close $c - set notes + notes } c] +} -cleanup { tempdone rename foo {} - set res } -result {{limit? rt*} {read rt* {test d}} {limit? rt*} {read rt* {ata -}} {limit? rt*} @@} -constraints {testchannel testthread} -test iortrans.tf-6.2 {chan read, read transform drain on eof} -match glob -body { +}} {limit? rt*} @@} +test iortrans.tf-6.2 {chan read, read transform drain on eof} -setup { set res {} +} -constraints {testchannel testthread} -match glob -body { proc foo {args} { - oninit drain; onfinal; track ; onread ; ondrain + handle.initialize drain + handle.finalize + lappend ::res $args + handle.read + handle.drain return } set c [chan push [tempchan] foo] - notes [inthread $c { - note [read $c] - note [close $c] + lappend res {*}[inthread $c { + lappend notes [read $c] + lappend notes [close $c] } c] +} -cleanup { tempdone rename foo {} - set res } -result {{read rt* {test data -}} {drain rt*} @<> {}} -constraints {testchannel testthread} +}} {drain rt*} @<> {}} # --- === *** ########################### # method clear (via puts, seek) -test iortrans.tf-7.1 {chan write, write clears read buffers} -match glob -body { +test iortrans.tf-7.1 {chan write, write clears read buffers} -setup { set res {} +} -constraints {testchannel testthread} -match glob -body { proc foo {args} { - oninit clear; onfinal; track ; onclear + handle.initialize clear + handle.finalize + lappend ::res $args + handle.clear return transformresult } set c [chan push [tempchan] foo] inthread $c { - puts -nonewline $c snarf; flush $c + puts -nonewline $c snarf + flush $c close $c } c + return $res +} -cleanup { tempdone rename foo {} - set res -} -result {{clear rt*} {write rt* snarf}} -constraints {testchannel testthread} -test iortrans.tf-7.2 {seek clears read buffers} -match glob -body { +} -result {{clear rt*} {write rt* snarf}} +test iortrans.tf-7.2 {seek clears read buffers} -setup { set res {} +} -constraints {testchannel testthread} -match glob -body { proc foo {args} { - oninit clear; onfinal; track + handle.initialize clear + handle.finalize + lappend ::res $args return } set c [chan push [tempchan] foo] @@ -1414,14 +1700,18 @@ test iortrans.tf-7.2 {seek clears read buffers} -match glob -body { seek $c 2 close $c } c + return $res +} -cleanup { tempdone rename foo {} - set res -} -result {{clear rt*}} -constraints {testchannel testthread} -test iortrans.tf-7.3 {clear, any result is ignored} -match glob -body { +} -result {{clear rt*}} +test iortrans.tf-7.3 {clear, any result is ignored} -setup { set res {} +} -constraints {testchannel testthread} -match glob -body { proc foo {args} { - oninit clear; onfinal; track + handle.initialize clear + handle.finalize + lappend ::res $args return -code error "X" } set c [chan push [tempchan] foo] @@ -1429,56 +1719,60 @@ test iortrans.tf-7.3 {clear, any result is ignored} -match glob -body { seek $c 2 close $c } c + return $res +} -cleanup { tempdone rename foo {} - set res -} -result {{clear rt*}} -constraints {testchannel testthread} +} -result {{clear rt*}} # --- === *** ########################### # method flush (via seek, close) -test iortrans.tf-8.1 {seek flushes write buffers, ignores data} -match glob -body { +test iortrans.tf-8.1 {seek flushes write buffers, ignores data} -setup { set res {} +} -constraints {testchannel testthread} -match glob -body { proc foo {args} { - oninit flush; onfinal; track + handle.initialize flush + handle.finalize + lappend ::res $args return X } set c [chan push [tempchan] foo] - notes [inthread $c { + lappend res {*}[inthread $c { # Flush, no writing seek $c 2 # The close flushes again, this modifies the file! - note | ; note [close $c] ; note | - # NOTE: The flush generated by the close is recorded - # immediately, the other note's here are defered until after - # the thread is done. This changes the order of the result a - # bit from the non-threaded case (The first | moves one to the - # right). This is an artifact of the 'inthread' framework, not - # of the transformation itself. + lappend notes | [close $c] | + # NOTE: The flush generated by the close is recorded immediately, the + # other note's here are defered until after the thread is done. This + # changes the order of the result a bit from the non-threaded case + # (The first | moves one to the right). This is an artifact of the + # 'inthread' framework, not of the transformation itself. notes } c] - note [tempview] + lappend res [tempview] +} -cleanup { tempdone rename foo {} - set res -} -result {{flush rt*} {flush rt*} | {} | {teXt data}} -constraints {testchannel testthread} - -test iortrans.tf-8.2 {close flushes write buffers, writes data} -match glob -body { +} -result {{flush rt*} {flush rt*} | {} | {teXt data}} +test iortrans.tf-8.2 {close flushes write buffers, writes data} -setup { set res {} +} -constraints {testchannel testthread} -match glob -body { proc foo {args} { - oninit flush; track ; onfinal + handle.initialize flush + lappend ::res $args + handle.finalize return .flushed. } set c [chan push [tempchan] foo] inthread $c { close $c } c - note [tempview] + lappend res [tempview] +} -cleanup { tempdone rename foo {} - set res -} -result {{flush rt*} {finalize rt*} .flushed.} -constraints {testchannel testthread} - +} -result {{flush rt*} {finalize rt*} .flushed.} # --- === *** ########################### # method watch - removed from TIP (rev 1.12+) @@ -1487,97 +1781,89 @@ test iortrans.tf-8.2 {close flushes write buffers, writes data} -match glob -bod # method event - removed from TIP (rev 1.12+) # --- === *** ########################### -# 'Pull the rug' tests. Create channel in a thread A, move to other -# thread B, destroy the origin thread (A) before or during access from -# B. Must not crash, must return proper errors. - -test iortrans.tf-11.0 {origin thread of moved transform gone} -match glob -body { +# 'Pull the rug' tests. Create channel in a thread A, move to other thread B, +# destroy the origin thread (A) before or during access from B. Must not +# crash, must return proper errors. +test iortrans.tf-11.0 {origin thread of moved transform gone} -setup { #puts <<$tcltest::mainThread>>main - set tida [testthread create];#puts <<$tida>> - set tidb [testthread create];#puts <<$tidb>> - + set tida [testthread create]; #puts <<$tida>> + set tidb [testthread create]; #puts <<$tidb>> +} -constraints {testchannel testthread} -match glob -body { # Set up channel in thread testthread send $tida $helperscript set chan [testthread send $tida { - proc foo {args} {oninit clear drain flush limit? read write; onfinal; track; return} + proc foo {args} { + handle.initialize clear drain flush limit? read write + handle.finalize + lappend ::res $args + return + } set chan [chan push [tempchan] foo] fconfigure $chan -buffering none set chan }] - # Move channel to 2nd thread, transform goes with it. - testthread send $tida [list testchannel cut $chan] + testthread send $tida [list testchannel cut $chan] testthread send $tidb [list testchannel splice $chan] - # Kill origin thread, then access channel from 2nd thread. testthread send -async $tida {testthread exit} - after 100 - - set res {} - lappend res [catch {testthread send $tidb [list puts $chan shoo]} msg] $msg - lappend res [catch {testthread send $tidb [list tell $chan]} msg] $msg - lappend res [catch {testthread send $tidb [list seek $chan 1]} msg] $msg - lappend res [catch {testthread send $tidb [list gets $chan]} msg] $msg - lappend res [catch {testthread send $tidb [list close $chan]} msg] $msg - tcltest::threadReap - tempdone - set res + after 50 + set res {} + lappend res [catch {testthread send $tidb [list puts $chan shoo]} msg] $msg + lappend res [catch {testthread send $tidb [list tell $chan]} msg] $msg + lappend res [catch {testthread send $tidb [list seek $chan 1]} msg] $msg + lappend res [catch {testthread send $tidb [list gets $chan]} msg] $msg + lappend res [catch {testthread send $tidb [list close $chan]} msg] $msg # The 'tell' is ok, as it passed through the transform to the base # channel without invoking the transform handler. - -} -constraints {testchannel testthread} \ - -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} - -test iortrans.tf-11.1 {origin thread of moved transform destroyed during access} -match glob -body { - +} -cleanup { + tcltest::threadReap + tempdone +} -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} +test iortrans.tf-11.1 {origin thread of moved transform destroyed during access} -setup { #puts <<$tcltest::mainThread>>main - set tida [testthread create];#puts <<$tida>> - set tidb [testthread create];#puts <<$tidb>> - + set tida [testthread create]; #puts <<$tida>> + set tidb [testthread create]; #puts <<$tidb>> +} -constraints {testchannel testthread} -match glob -body { # Set up channel in thread set chan [testthread send $tida $helperscript] set chan [testthread send $tida { proc foo {args} { - oninit clear drain flush limit? read write; onfinal; track; + handle.initialize clear drain flush limit? read write + handle.finalize + lappend ::res $args # destroy thread during channel access testthread exit - return} + return + } set chan [chan push [tempchan] foo] fconfigure $chan -buffering none set chan }] - # Move channel to 2nd thread, transform goes with it. - testthread send $tida [list testchannel cut $chan] + testthread send $tida [list testchannel cut $chan] testthread send $tidb [list testchannel splice $chan] - - # Run access from thread B, wait for response from A (A is not - # using event loop at this point, so the event pile up in the - # queue. - + # Run access from thread B, wait for response from A (A is not using event + # loop at this point, so the event pile up in the queue. testthread send $tidb [list set chan $chan] testthread send $tidb [list set mid $tcltest::mainThread] testthread send -async $tidb { - # wait a bit, give the main thread the time to start its event - # loop to wait for the response from B - after 2000 + # Wait a bit, give the main thread the time to start its event loop to + # wait for the response from B + after 50 catch { puts $chan shoo } res catch { close $chan } testthread send -async $mid [list set ::res $res] } vwait ::res - + return $res +} -cleanup { tcltest::threadReap tempdone - set res -} -constraints {testchannel testthread} \ - -result {Owner lost} - -# ### ### ### ######### ######### ######### - +} -result {Owner lost} + # ### ### ### ######### ######### ######### -rename track {} cleanupTests return diff --git a/tests/iogt.test b/tests/iogt.test index c45d97d..d2e1997 100644 --- a/tests/iogt.test +++ b/tests/iogt.test @@ -3,14 +3,14 @@ # # This file contains a collection of tests for Giot # -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Copyright (c) 2000 Ajuba Solutions. # Copyright (c) 2000 Andreas Kupries. # All rights reserved. # -# RCS: @(#) $Id: iogt.test,v 1.16 2006/11/03 11:45:34 dkf Exp $ +# RCS: @(#) $Id: iogt.test,v 1.16.10.1 2010/12/01 16:42:37 kennykb Exp $ if {[catch {package require tcltest 2.1}]} { puts stderr "Skipping tests in [info script]. tcltest 2.1 required." @@ -38,41 +38,38 @@ set path(__echo_srv__.tcl) [makeFile { # delay between blocks # blocksize ... -set port [lindex $argv 0] +set port [lindex $argv 0] set fdelay [lindex $argv 1] set idelay [lindex $argv 2] set bsizes [lrange $argv 3 end] -set c 0 +set c 0 proc newconn {sock rhost rport} { variable fdelay variable c - incr c - variable c$c + incr c + namespace upvar [namespace current] c$c conn #puts stdout "C $sock $rhost $rport / $fdelay" ; flush stdout - upvar 0 c$c conn set conn(after) {} set conn(state) 0 - set conn(size) 0 - set conn(data) "" + set conn(size) 0 + set conn(data) "" set conn(delay) $fdelay - fileevent $sock readable [list echoGet $c $sock] + fileevent $sock readable [list echoGet $c $sock] fconfigure $sock -translation binary -buffering none -blocking 0 } proc echoGet {c sock} { variable fdelay - variable c$c - upvar 0 c$c conn + namespace upvar [namespace current] c$c conn if {[eof $sock]} { # one-shot echo exit } - append conn(data) [read $sock] #puts stdout "G $c $sock $conn(data) <<$conn(data)>>" ; flush stdout @@ -86,8 +83,7 @@ proc echoPut {c sock} { variable idelay variable fdelay variable bsizes - variable c$c - upvar 0 c$c conn + namespace upvar [namespace current] c$c conn if {[string length $conn(data)] == 0} { #puts stdout "C $c $sock" ; flush stdout @@ -98,9 +94,7 @@ proc echoPut {c sock} { return } - set conn(delay) $idelay - set n [lindex $bsizes $conn(size)] #puts stdout "P $c $sock $n >>" ; flush stdout @@ -109,7 +103,6 @@ proc echoPut {c sock} { #parray conn #puts n=<$n> - if {[string length $conn(data)] >= $n} { puts -nonewline $sock [string range $conn(data) 0 $n] set conn(data) [string range $conn(data) [incr n] end] @@ -130,40 +123,33 @@ socket -server newconn -myaddr 127.0.0.1 $port vwait forever } __echo_srv__.tcl] - ######################################################################## proc fevent {fdelay idelay blocks script data} { - # start and initialize an echo server, prepare data - # transmission, then hand over to the test script. - # this has to start real transmission via 'flush'. - # The server is stopped after completion of the test. + # Start and initialize an echo server, prepare data transmission, then + # hand over to the test script. This has to start real transmission via + # 'flush'. The server is stopped after completion of the test. - # fixed port, not so good. lets hope for the best, for now. - set port 4000 + upvar 1 sock sk - exec tclsh __echo_srv__.tcl \ - $port $fdelay $idelay {*}$blocks >@stdout & + # Fixed port, not so good. Lets hope for the best, for now. + set port 4000 + exec tclsh __echo_srv__.tcl $port $fdelay $idelay {*}$blocks >@stdout & after 500 - #puts stdout "> $port" ; flush stdout - - set sk [socket localhost $port] - fconfigure $sk \ - -blocking 0 \ - -buffering full \ - -buffersize [expr {10+[llength $data]}] + #puts stdout "> $port"; flush stdout + set sk [socket localhost $port] + fconfigure $sk -blocking 0 -buffering full \ + -buffersize [expr {10+[llength $data]}] puts -nonewline $sk $data # The channel is prepared to go off. - #puts stdout ">>>>>" ; flush stdout - - uplevel #0 set sock $sk - set res [uplevel #0 $script] + #puts stdout ">>>>>"; flush stdout + set res [uplevel 1 $script] catch {close $sk} return $res } @@ -173,18 +159,15 @@ proc fevent {fdelay idelay blocks script data} { proc id {op data} { switch -- $op { - create/write - - create/read - - delete/write - - delete/read - - clear_read {;#ignore} - flush/write - - flush/read - - write - - read { + create/write - create/read - delete/write - delete/read - clear_read { + #ignore + } + flush/write - flush/read - write - read { return $data } - query/maxRead {return -1} + query/maxRead { + return -1 + } } } @@ -193,43 +176,34 @@ proc id_optrail {var op data} { upvar 0 $var trail lappend trail $op - switch -- $op { - create/write - create/read - - delete/write - delete/read - - flush/read - - clear/read { #ignore } - flush/write - - write - - read { + create/write - create/read - delete/write - delete/read - + flush/read - clear/read { + #ignore + } + flush/write - write - read { return $data } - query/maxRead { + query/maxRead { return -1 } - default { + default { lappend trail "error $op" error $op } } } - proc id_fulltrail {var op data} { - variable $var - upvar 0 $var trail + namespace upvar [namespace current] $var trail #puts stdout ">> $var $op $data" ; flush stdout switch -- $op { - create/write - create/read - - delete/write - delete/read - - clear_read { + create/write - create/read - delete/write - delete/read - clear_read { set res *ignored* } - flush/write - flush/read - - write - - read { + flush/write - flush/read - write - read { set res $data } query/maxRead { @@ -245,18 +219,19 @@ proc id_fulltrail {var op data} { } proc counter {var op data} { - variable $var - upvar 0 $var n + namespace upvar [namespace current] $var n switch -- $op { - create/write - create/read - - delete/write - delete/read - - clear_read {;#ignore} - flush/write - flush/read {return {}} + create/write - create/read - delete/write - delete/read - clear_read { + #ignore + } + flush/write - flush/read { + return {} + } write { return $data } - read { + read { if {$n > 0} { incr n -[string length $data] if {$n < 0} { @@ -271,25 +246,20 @@ proc counter {var op data} { } } - proc counter_audit {var vtrail op data} { - variable $var - variable $vtrail - upvar 0 $var n $vtrail trail + namespace upvar [namespace current] $var n $vtrail trail switch -- $op { - create/write - create/read - - delete/write - delete/read - - clear_read { + create/write - create/read - delete/write - delete/read - clear_read { set res {} } - flush/write - flush/read { + flush/write - flush/read { set res {} } write { set res $data } - read { + read { if {$n > 0} { incr n -[string length $data] if {$n < 0} { @@ -307,36 +277,28 @@ proc counter_audit {var vtrail op data} { return $res } - proc rblocks {var vtrail n op data} { - variable $var - variable $vtrail - upvar 0 $var buf $vtrail trail + namespace upvar [namespace current] $var n $vtrail trail set res {} switch -- $op { - create/write - create/read - - delete/write - delete/read - - clear_read { + create/write - create/read - delete/write - delete/read - clear_read { set buf {} } flush/write { } - flush/read { + flush/read { set res $buf set buf {} } - write { + write { set data } - read { + read { append buf $data - set b [expr {$n * ([string length $buf] / $n)}] - append op " $n [string length $buf] :- $b" - set res [string range $buf 0 [incr b -1]] set buf [string range $buf [incr b] end] #return $res @@ -350,36 +312,28 @@ proc rblocks {var vtrail n op data} { return $res } - # -------------------------------------------------------------- # ... and convenience procedures to stack them proc identity {-attach channel} { testchannel transform $channel -command [namespace code id] } - proc audit_ops {var -attach channel} { testchannel transform $channel -command [namespace code [list id_optrail $var]] } - proc audit_flow {var -attach channel} { testchannel transform $channel -command [namespace code [list id_fulltrail $var]] } - proc stopafter {var n -attach channel} { - variable $var - upvar 0 $var vn + namespace upvar [namespace current] $var vn set vn $n testchannel transform $channel -command [namespace code [list counter $var]] } - proc stopafter_audit {var trail n -attach channel} { - variable $var - upvar 0 $var vn + namespace upvar [namespace current] $var vn set vn $n testchannel transform $channel -command [namespace code [list counter_audit $var $trail]] } - proc rblocks_t {var trail n -attach channel} { testchannel transform $channel -command [namespace code [list rblocks $var $trail $n]] } @@ -389,36 +343,31 @@ proc rblocks_t {var trail n -attach channel} { proc array_sget {v} { upvar $v a - set res [list] foreach n [lsort [array names a]] { lappend res $n $a($n) } set res } - proc asort {alist} { # sort a list of key/value pairs by key, removes duplicates too. - - array set a $alist + array set a $alist array_sget a } - + ######################################################################## test iogt-1.1 {stack/unstack} testchannel { set fh [open $path(dummy) r] identity -attach $fh testchannel unstack $fh - close $fh + close $fh } {} - test iogt-1.2 {stack/close} testchannel { set fh [open $path(dummy) r] identity -attach $fh - close $fh + close $fh } {} - test iogt-1.3 {stack/unstack, configuration, options} testchannel { set fh [open $path(dummy) r] set ca [asort [fconfigure $fh]] @@ -427,79 +376,53 @@ test iogt-1.3 {stack/unstack, configuration, options} testchannel { testchannel unstack $fh set cc [asort [fconfigure $fh]] close $fh - - # With this system none of the buffering, translation and - # encoding option may change their values with channels - # stacked upon each other or not. - + # With this system none of the buffering, translation and encoding option + # may change their values with channels stacked upon each other or not. # cb == ca == cc - list [string equal $ca $cb] [string equal $cb $cc] [string equal $ca $cc] } {1 1 1} - -test iogt-1.4 {stack/unstack, configuration} testchannel { +test iogt-1.4 {stack/unstack, configuration} -setup { set fh [open $path(dummy) r] +} -constraints testchannel -body { set ca [asort [fconfigure $fh]] identity -attach $fh - fconfigure $fh \ - -buffering line \ - -translation cr \ - -encoding shiftjis + fconfigure $fh -buffering line -translation cr -encoding shiftjis testchannel unstack $fh set cc [asort [fconfigure $fh]] - - set res [list \ - [string equal $ca $cc] \ - [fconfigure $fh -buffering] \ - [fconfigure $fh -translation] \ - [fconfigure $fh -encoding] \ - ] - + list [string equal $ca $cc] [fconfigure $fh -buffering] \ + [fconfigure $fh -translation] [fconfigure $fh -encoding] +} -cleanup { close $fh - set res -} {0 line cr shiftjis} +} -result {0 line cr shiftjis} -test iogt-2.0 {basic I/O going through transform} testchannel { - set fin [open $path(dummy) r] +test iogt-2.0 {basic I/O going through transform} -setup { + set fin [open $path(dummy) r] set fout [open $path(dummyout) w] - +} -constraints testchannel -body { identity -attach $fin identity -attach $fout - fcopy $fin $fout - close $fin close $fout - - set fin [open $path(dummy) r] + set fin [open $path(dummy) r] set fout [open $path(dummyout) r] - - set res [string equal [set in [read $fin]] [set out [read $fout]]] - lappend res [string length $in] [string length $out] - + list [string equal [set in [read $fin]] [set out [read $fout]]] \ + [string length $in] [string length $out] +} -cleanup { close $fin close $fout - - set res -} {1 71 71} - - +} -result {1 71 71} test iogt-2.1 {basic I/O, operation trail} {testchannel unix} { - set fin [open $path(dummy) r] + set fin [open $path(dummy) r] set fout [open $path(dummyout) w] - - set ain [list] ; set aout [list] - audit_ops ain -attach $fin + set ain [list]; set aout [list] + audit_ops ain -attach $fin audit_ops aout -attach $fout - - fconfigure $fin -buffersize 10 + fconfigure $fin -buffersize 10 fconfigure $fout -buffersize 10 - fcopy $fin $fout - close $fin close $fout - set res "[join $ain \n]\n--------\n[join $aout \n]" } {create/read query/maxRead @@ -533,23 +456,17 @@ write write flush/write delete/write} - test iogt-2.2 {basic I/O, data trail} {testchannel unix} { - set fin [open $path(dummy) r] + set fin [open $path(dummy) r] set fout [open $path(dummyout) w] - - set ain [list] ; set aout [list] - audit_flow ain -attach $fin + set ain [list]; set aout [list] + audit_flow ain -attach $fin audit_flow aout -attach $fout - - fconfigure $fin -buffersize 10 + fconfigure $fin -buffersize 10 fconfigure $fout -buffersize 10 - fcopy $fin $fout - close $fin close $fout - set res "[join $ain \n]\n--------\n[join $aout \n]" } {create/read {} *ignored* query/maxRead {} -1 @@ -587,24 +504,17 @@ write { } flush/write {} {} delete/write {} *ignored*} - - test iogt-2.3 {basic I/O, mixed trail} {testchannel unix} { - set fin [open $path(dummy) r] + set fin [open $path(dummy) r] set fout [open $path(dummyout) w] - set trail [list] audit_flow trail -attach $fin audit_flow trail -attach $fout - - fconfigure $fin -buffersize 20 + fconfigure $fin -buffersize 20 fconfigure $fout -buffersize 10 - fcopy $fin $fout - close $fin close $fout - join $trail \n } {create/read {} *ignored* create/write {} *ignored* @@ -634,110 +544,80 @@ delete/read {} *ignored* flush/write {} {} delete/write {} *ignored*} - -test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} \ - {testchannel unknownFailure} { - # This test to check the validity of aquired Tcl_Channel references is - # not possible because even a backgrounded fcopy will immediately start - # to copy data, without waiting for the event loop. This is done only in - # case of an underflow on the read size!. So stacking transforms after the +test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} -setup { + proc DoneCopy {n {err {}}} { + variable copy 1 + } +} -constraints {testchannel hangs} -body { + # This test to check the validity of aquired Tcl_Channel references is not + # possible because even a backgrounded fcopy will immediately start to + # copy data, without waiting for the event loop. This is done only in case + # of an underflow on the read size!. So stacking transforms after the # fcopy will miss information, or are not used at all. # # I was able to circumvent this by using the echo.tcl server with a big # delay, causing the fcopy to underflow immediately. - - proc DoneCopy {n {err {}}} { - variable copy ; set copy 1 - } - - set fin [open $path(dummy) r] - + set fin [open $path(dummy) r] fevent 1000 500 {20 20 20 10 1 1} { close $fin - - set fout [open dummyout w] - - flush $sock ; # now, or fcopy will error us out - # But the 1 second delay should be enough to - # initialize everything else here. - + set fout [open dummyout w] + flush $sock; # now, or fcopy will error us out + # But the 1 second delay should be enough to initialize everything + # else here. fcopy $sock $fout -command [namespace code DoneCopy] - - # transform after fcopy got its handles ! - # They should be still valid for fcopy. - + # Transform after fcopy got its handles! They should be still valid + # for fcopy. set trail [list] audit_ops trail -attach $fout - vwait [namespace which -variable copy] - } [read $fin] ; # {} - + } [read $fin]; # {} close $fout - - rename DoneCopy {} - # Check result of copy. - - set fin [open $path(dummy) r] + set fin [open $path(dummy) r] set fout [open $path(dummyout) r] - set res [string equal [read $fin] [read $fout]] - close $fin close $fout - list $res $trail -} {1 {create/write create/read write flush/write flush/read delete/write delete/read}} - +} -cleanup { + rename DoneCopy {} +} -result {1 {create/write create/read write flush/write flush/read delete/write delete/read}} -test iogt-4.0 {fileevent readable, after transform} {testchannel unknownFailure} { - set fin [open $path(dummy) r] +test iogt-4.0 {fileevent readable, after transform} -setup { + set fin [open $path(dummy) r] set data [read $fin] close $fin - set trail [list] - set got [list] - + set got [list] proc Done {args} { - variable stop - set stop 1 + variable stop 1 } - - proc Get {sock} { - variable trail - variable got - if {[eof $sock]} { - Done - lappend trail "xxxxxxxxxxxxx" - close $sock - return - } - lappend trail "vvvvvvvvvvvvv" - lappend trail "\tgot: [lappend got "\[\[[read $sock]\]\]"]" - lappend trail "=============" - #puts stdout $__ ; flush stdout - #read $sock - } - +} -constraints {testchannel hangs} -body { fevent 1000 500 {20 20 20 10 1} { - audit_flow trail -attach $sock - rblocks_t rbuf trail 23 -attach $sock - - fileevent $sock readable [list Get $sock] - - flush $sock ; # now, or fcopy will error us out - # But the 1 second delay should be enough to - # initialize everything else here. - + audit_flow trail -attach $sock + rblocks_t rbuf trail 23 -attach $sock + fileevent $sock readable [namespace code { + if {[eof $sock]} { + Done + lappend trail "xxxxxxxxxxxxx" + close $sock + } else { + lappend trail "vvvvvvvvvvvvv" + lappend trail "\tgot: [lappend got "\[\[[read $sock]\]\]"]" + lappend trail "=============" + #puts stdout $__; flush stdout + #read $sock + } + }] + flush $sock; # Now, or fcopy will error us out + # But the 1 second delay should be enough to initialize everything + # else here. vwait [namespace which -variable stop] } $data - - - rename Done {} - rename Get {} - join [list [join $got \n] ~~~~~~~~ [join $trail \n]] \n -} {[[]] +} -cleanup { + rename Done {} +} -result {[[]] [[abcdefghijklmnopqrstuvw]] [[xyz0123456789,./?><;'\|]] [[]] @@ -818,35 +698,27 @@ rblock | delete/write {} {} | {} rblock | delete/read {} {} | {} flush/write {} {} delete/write {} *ignored* -delete/read {} *ignored*} ; # catch unescaped quote " +delete/read {} *ignored*}; # catch unescaped quote " - -test iogt-5.0 {EOF simulation} {testchannel unknownFailure} { - set fin [open $path(dummy) r] +test iogt-5.0 {EOF simulation} -setup { + set fin [open $path(dummy) r] set fout [open $path(dummyout) w] - set trail [list] - +} -constraints {testchannel unknownFailure} -result { audit_flow trail -attach $fin - stopafter_audit d trail 20 -attach $fin + stopafter_audit d trail 20 -attach $fin audit_flow trail -attach $fout - - fconfigure $fin -buffersize 20 + fconfigure $fin -buffersize 20 fconfigure $fout -buffersize 10 - - fcopy $fin $fout + fcopy $fin $fout testchannel unstack $fin - # now copy the rest in the channel lappend trail {**after unstack**} - fcopy $fin $fout - close $fin close $fout - join $trail \n -} {create/read {} *ignored* +} -result {create/read {} *ignored* counter:create/read {} {} create/write {} *ignored* counter:query/maxRead {} 20 @@ -880,59 +752,48 @@ delete/write {} *ignored*} proc constX {op data} { # replace anything coming in with a same-length string of x'es. switch -- $op { - create/write - create/read - - delete/write - delete/read - - clear_read {;#ignore} - flush/write - flush/read - - write - - read { + create/write - create/read - delete/write - delete/read - clear_read { + #ignore + } + flush/write - flush/read - write - read { return [string repeat x [string length $data]] } - query/maxRead {return -1} + query/maxRead { + return -1 + } } } - proc constx {-attach channel} { testchannel transform $channel -command [namespace code constX] } -test iogt-6.0 {Push back} testchannel { +test iogt-6.0 {Push back} -constraints testchannel -body { set f [open $path(dummy) r] - # contents of dummy = "abcdefghi..." - read $f 3 ; # skip behind "abc" - + read $f 3; # skip behind "abc" constx -attach $f - - # expect to get "xxx" from the transform because - # of unread "def" input to transform which returns "xxx". + # expect to get "xxx" from the transform because of unread "def" input to + # transform which returns "xxx". # - # Actually the IO layer pre-read the whole file and will - # read "def" directly from the buffer without bothering - # to consult the newly stacked transformation. This is - # wrong. - - set res [read $f 3] + # Actually the IO layer pre-read the whole file and will read "def" + # directly from the buffer without bothering to consult the newly stacked + # transformation. This is wrong. + read $f 3 +} -cleanup { close $f - set res -} {xxx} - -test iogt-6.1 {Push back and up} {testchannel knownBug} { +} -result {xxx} +test iogt-6.1 {Push back and up} -constraints {testchannel knownBug} -body { set f [open $path(dummy) r] - # contents of dummy = "abcdefghi..." - read $f 3 ; # skip behind "abc" - + read $f 3; # skip behind "abc" constx -attach $f set res [read $f 3] - testchannel unstack $f append res [read $f 3] +} -cleanup { close $f - set res -} {xxxghi} - - +} -result {xxxghi} + # cleanup foreach file [list dummy dummyout __echo_srv__.tcl] { removeFile $file diff --git a/tests/main.test b/tests/main.test index 24d1fb5..d4b790a 100644 --- a/tests/main.test +++ b/tests/main.test @@ -1,6 +1,6 @@ # This file contains a collection of tests for generic/tclMain.c. # -# RCS: @(#) $Id: main.test,v 1.22 2007/12/13 15:26:06 dgp Exp $ +# RCS: @(#) $Id: main.test,v 1.22.8.1 2010/12/01 16:42:37 kennykb Exp $ if {[catch {package require tcltest 2.0.2}]} { puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." @@ -68,8 +68,6 @@ namespace eval ::tcl::test::main { } -result [list [interpreter] -script 0]\n test Tcl_Main-1.3 { - Tcl_Main: encoding of arguments: done by system encoding - Note the shortcoming explained in Tcl Feature Request 491789 } -constraints { stdio } -setup { @@ -84,10 +82,8 @@ namespace eval ::tcl::test::main { [encoding convertto [encoding system] \u00c0]]] 0]\n test Tcl_Main-1.4 { - Tcl_Main: encoding of arguments: done by system encoding - Note the shortcoming explained in Tcl Feature Request 491789 } -constraints { - stdio tempNotWin + stdio } -setup { makeFile {puts [list $argv0 $argv $tcl_interactive]} script catch {set f [open "|[list [interpreter] script \u20ac]" r]} @@ -100,8 +96,6 @@ namespace eval ::tcl::test::main { [encoding convertto [encoding system] \u20ac]]] 0]\n test Tcl_Main-1.5 { - Tcl_Main: encoding of script name: system encoding loss - Note the shortcoming explained in Tcl Feature Request 491789 } -constraints { stdio } -setup { @@ -116,10 +110,8 @@ namespace eval ::tcl::test::main { [encoding convertto [encoding system] \u00c0]]] {} 0]\n test Tcl_Main-1.6 { - Tcl_Main: encoding of script name: system encoding loss - Note the shortcoming explained in Tcl Feature Request 491789 } -constraints { - stdio tempNotWin + stdio } -setup { makeFile {puts [list $argv0 $argv $tcl_interactive]} \u20ac catch {set f [open "|[list [interpreter] \u20ac]" r]} diff --git a/tests/oo.test b/tests/oo.test index 50edb11..6e24553 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: oo.test,v 1.39 2010/03/24 13:21:11 dkf Exp $ +# RCS: @(#) $Id: oo.test,v 1.39.2.1 2010/12/01 16:42:37 kennykb Exp $ package require -exact TclOO 0.6.2 ;# Must match value in generic/tclOO.h if {[lsearch [namespace children] ::tcltest] == -1} { @@ -96,6 +96,18 @@ test oo-0.7 {cleaning the core class pair; way #2} -setup { } -cleanup { interp delete t } -result {0 {} 1 {invalid command name "class"}} +test oo-0.8 {leak in variable management} -setup { + oo::class create foo +} -constraints memory -body { + oo::define foo { + constructor {} { + variable v 0 + } + } + leaktest {[foo new] destroy} +} -cleanup { + foo destroy +} -result 0 test oo-1.1 {basic test of OO functionality: no classes} { set result {} @@ -2044,6 +2056,18 @@ test oo-20.15 {OO: variable method use in non-methods [Bug 2903811]} -setup { apply {{} {fooObj variable x; set x ok; return}} return [set [fooObj varname x]] } -result ok +test oo-20.16 {variable method: leak per instance} -setup { + oo::class create foo +} -constraints memory -body { + oo::define foo { + constructor {} { + set [my variable v] 0 + } + } + leaktest {[foo new] destroy} +} -cleanup { + foo destroy +} -result 0 test oo-21.1 {OO: inheritance ordering} -setup { oo::class create A @@ -2531,6 +2555,19 @@ test oo-27.11 {variables declaration - no instance var leaks with class resolver inst1 step list [inst1 value] [inst2 value] } -result {3 2} +test oo-27.12 {variables declaration: leak per instance} -setup { + oo::class create foo +} -constraints memory -body { + oo::define foo { + variable v + constructor {} { + set v 0 + } + } + leaktest {[foo new] destroy} +} -cleanup { + foo destroy +} -result 0 # A feature that's not supported because the mechanism may change without # warning, but is supposed to work... @@ -2578,6 +2615,40 @@ test oo-30.2 {Bug 2903011: deleting an object in a constructor} -setup { } -returnCodes error -cleanup { cls destroy } -result {object deleted in constructor} + +test oo-31.1 {Bug 3111059: when objects and coroutines entangle} -setup { + oo::class create cls +} -constraints memory -body { + oo::define cls { + method justyield {} { + yield + } + constructor {} { + coroutine coro my justyield + } + } + list [leaktest {[cls new] destroy}] [info class instances cls] +} -cleanup { + cls destroy +} -result {0 {}} +test oo-31.2 {Bug 3111059: when objects and coroutines entangle} -setup { + oo::class create cls +} -constraints memory -body { + oo::define cls { + method justyield {} { + yield + } + constructor {} { + coroutine coro my justyield + } + destructor { + rename coro {} + } + } + list [leaktest {[cls new] destroy}] [info class instances cls] +} -cleanup { + cls destroy +} -result {0 {}} cleanupTests return diff --git a/tests/remote.tcl b/tests/remote.tcl index 880abc2..de827de 100644 --- a/tests/remote.tcl +++ b/tests/remote.tcl @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: remote.tcl,v 1.3.56.1 2010/09/28 15:43:01 kennykb Exp $ +# RCS: @(#) $Id: remote.tcl,v 1.3.56.2 2010/12/01 16:42:37 kennykb Exp $ # Initialize message delimitor @@ -156,5 +156,6 @@ if {[catch {set serverSocket \ [socket -myaddr $serverAddress -server __accept__ $serverPort]} msg]} { puts "Server on $serverAddress:$serverPort cannot start: $msg" } else { + puts ready vwait __server_wait_variable__ } diff --git a/tests/socket.test b/tests/socket.test index 54b92ed..e263c57 100644 --- a/tests/socket.test +++ b/tests/socket.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: socket.test,v 1.43.2.1 2010/09/28 15:43:01 kennykb Exp $ +# RCS: @(#) $Id: socket.test,v 1.43.2.2 2010/12/01 16:42:37 kennykb Exp $ # Running socket tests with a remote server: # ------------------------------------------ @@ -92,13 +92,31 @@ if {![info exists remoteServerPort]} { } } +if 0 { + # activate this to time the tests + proc test {args} { + set name [lindex $args 0] + puts "[lindex [time {uplevel [linsert $args 0 tcltest::test]}] 0] @@@ $name" + } +} + +foreach {af localhost} { + any 127.0.0.1 + inet 127.0.0.1 + inet6 ::1 +} { + set ::tcl::unsupported::socketAF $af + # Check if the family is supported and set the constraint accordingly + testConstraint supported_$af [expr {![catch {socket -server foo 0} sock]}] + catch {close $sock} + # # Check if we're supposed to do tests against the remote server # set doTestsWithRemoteServer 1 if {![info exists remoteServerIP]} { - set remoteServerIP 127.0.0.1 + set remoteServerIP $localhost } if {($doTestsWithRemoteServer == 1) && (![info exists remoteServerPort])} { set remoteServerPort [randport] @@ -123,7 +141,7 @@ if {$doTestsWithRemoteServer} { set noRemoteTestReason "can't exec" set doTestsWithRemoteServer 0 } else { - set remoteServerIP 127.0.0.1 + set remoteServerIP $localhost # Be *extra* careful in case this file is sourced from # a directory other than the current one... set remoteFile [file join [pwd] [file dirname [info script]] \ @@ -133,7 +151,7 @@ if {$doTestsWithRemoteServer} { [interpreter] $remoteFile -serverIsSilent \ -port $remoteServerPort -address $remoteServerIP]" w+] } msg]} then { - after 1000 + gets $remoteProcChan if {[catch { set commandSocket [socket $remoteServerIP $remoteServerPort] } msg] == 0} then { @@ -198,52 +216,52 @@ proc getPort sock { # ---------------------------------------------------------------------- -test socket-1.1 {arg parsing for socket command} -constraints socket -body { +test socket_$af-1.1 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -server } -returnCodes error -result {no argument given for -server option} -test socket-1.2 {arg parsing for socket command} -constraints socket -body { +test socket_$af-1.2 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -server foo } -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"} -test socket-1.3 {arg parsing for socket command} -constraints socket -body { +test socket_$af-1.3 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -myaddr } -returnCodes error -result {no argument given for -myaddr option} -test socket-1.4 {arg parsing for socket command} -constraints socket -body { - socket -myaddr 127.0.0.1 +test socket_$af-1.4 {arg parsing for socket command} -constraints [list socket supported_$af] -body { + socket -myaddr $localhost } -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"} -test socket-1.5 {arg parsing for socket command} -constraints socket -body { +test socket_$af-1.5 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -myport } -returnCodes error -result {no argument given for -myport option} -test socket-1.6 {arg parsing for socket command} -constraints socket -body { +test socket_$af-1.6 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -myport xxxx } -returnCodes error -result {expected integer but got "xxxx"} -test socket-1.7 {arg parsing for socket command} -constraints socket -body { +test socket_$af-1.7 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -myport 2522 } -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"} -test socket-1.8 {arg parsing for socket command} -constraints socket -body { +test socket_$af-1.8 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -froboz } -returnCodes error -result {bad option "-froboz": must be -async, -myaddr, -myport, or -server} -test socket-1.9 {arg parsing for socket command} -constraints socket -body { +test socket_$af-1.9 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -server foo -myport 2521 3333 } -returnCodes error -result {option -myport is not valid for servers} -test socket-1.10 {arg parsing for socket command} -constraints socket -body { +test socket_$af-1.10 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket host 2528 -junk } -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"} -test socket-1.11 {arg parsing for socket command} -constraints socket -body { +test socket_$af-1.11 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -server callback 2520 -- } -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"} -test socket-1.12 {arg parsing for socket command} -constraints socket -body { +test socket_$af-1.12 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket foo badport } -returnCodes error -result {expected integer but got "badport"} -test socket-1.13 {arg parsing for socket command} -constraints socket -body { +test socket_$af-1.13 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -async -server } -returnCodes error -result {cannot set -async option for server sockets} -test socket-1.14 {arg parsing for socket command} -constraints socket -body { +test socket_$af-1.14 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -server foo -async } -returnCodes error -result {cannot set -async option for server sockets} set path(script) [makeFile {} script] -test socket-2.1 {tcp connection} -constraints {socket stdio} -setup { +test socket_$af-2.1 {tcp connection} -constraints [list socket supported_$af stdio] -setup { file delete $path(script) set f [open $path(script) w] puts $f { @@ -267,14 +285,14 @@ test socket-2.1 {tcp connection} -constraints {socket stdio} -setup { gets $f listen } -body { # $x == "ready" at this point - set sock [socket 127.0.0.1 $listen] + set sock [socket $localhost $listen] lappend x [gets $f] close $sock lappend x [gets $f] } -cleanup { close $f } -result {ready done {}} -test socket-2.2 {tcp connection with client port specified} -setup { +test socket_$af-2.2 {tcp connection with client port specified} -setup { set port [randport] file delete $path(script) set f [open $path(script) w] @@ -297,19 +315,19 @@ test socket-2.2 {tcp connection with client port specified} -setup { set f [open "|[list [interpreter] $path(script)]" r] gets $f x gets $f listen -} -constraints {socket stdio} -body { +} -constraints [list socket supported_$af stdio] -body { # $x == "ready" at this point - set sock [socket -myport $port 127.0.0.1 $listen] + set sock [socket -myport $port $localhost $listen] puts $sock hello flush $sock lappend x [expr {[gets $f] eq "hello $port"}] close $sock return $x } -cleanup { - catch {close [socket 127.0.0.1 $listen]} + catch {close [socket $localhost $listen]} close $f } -result {ready 1} -test socket-2.3 {tcp connection with client interface specified} -setup { +test socket_$af-2.3 {tcp connection with client interface specified} -setup { file delete $path(script) set f [open $path(script) w] puts $f { @@ -331,9 +349,9 @@ test socket-2.3 {tcp connection with client interface specified} -setup { set f [open "|[list [interpreter] $path(script)]" r] gets $f listen gets $f x -} -constraints {socket stdio} -body { +} -constraints [list socket supported_$af stdio] -body { # $x == "ready" at this point - set sock [socket -myaddr 127.0.0.1 127.0.0.1 $listen] + set sock [socket -myaddr $localhost $localhost $listen] puts $sock hello flush $sock lappend x [gets $f] @@ -341,13 +359,14 @@ test socket-2.3 {tcp connection with client interface specified} -setup { return $x } -cleanup { close $f -} -result {ready {hello 127.0.0.1}} -test socket-2.4 {tcp connection with server interface specified} -setup { +} -result [list ready [list hello $localhost]] +test socket_$af-2.4 {tcp connection with server interface specified} -setup { file delete $path(script) set f [open $path(script) w] + puts $f [list set localhost $localhost] puts $f { set timer [after 2000 "set x done"] - set f [socket -server accept -myaddr 127.0.0.1 0] + set f [socket -server accept -myaddr $localhost 0] proc accept {file addr port} { global x puts "[gets $file]" @@ -364,9 +383,9 @@ test socket-2.4 {tcp connection with server interface specified} -setup { set f [open "|[list [interpreter] $path(script)]" r] gets $f x gets $f listen -} -constraints {socket stdio} -body { +} -constraints [list socket supported_$af stdio] -body { # $x == "ready" at this point - set sock [socket 127.0.0.1 $listen] + set sock [socket $localhost $listen] puts $sock hello flush $sock lappend x [gets $f] @@ -375,7 +394,7 @@ test socket-2.4 {tcp connection with server interface specified} -setup { } -cleanup { close $f } -result {ready hello} -test socket-2.5 {tcp connection with redundant server port} -setup { +test socket_$af-2.5 {tcp connection with redundant server port} -setup { file delete $path(script) set f [open $path(script) w] puts $f { @@ -397,9 +416,9 @@ test socket-2.5 {tcp connection with redundant server port} -setup { set f [open "|[list [interpreter] $path(script)]" r] gets $f x gets $f listen -} -constraints {socket stdio} -body { +} -constraints [list socket supported_$af stdio] -body { # $x == "ready" at this point - set sock [socket 127.0.0.1 $listen] + set sock [socket $localhost $listen] puts $sock hello flush $sock lappend x [gets $f] @@ -408,9 +427,9 @@ test socket-2.5 {tcp connection with redundant server port} -setup { } -cleanup { close $f } -result {ready hello} -test socket-2.6 {tcp connection} -constraints socket -body { +test socket_$af-2.6 {tcp connection} -constraints [list socket supported_$af] -body { set status ok - if {![catch {set sock [socket 127.0.0.1 [randport]]}]} { + if {![catch {set sock [socket $localhost [randport]]}]} { if {![catch {gets $sock}]} { set status broken } @@ -418,7 +437,7 @@ test socket-2.6 {tcp connection} -constraints socket -body { } set status } -result ok -test socket-2.7 {echo server, one line} -constraints {socket stdio} -setup { +test socket_$af-2.7 {echo server, one line} -constraints [list socket supported_$af stdio] -setup { file delete $path(script) set f [open $path(script) w] puts $f { @@ -450,10 +469,9 @@ test socket-2.7 {echo server, one line} -constraints {socket stdio} -setup { gets $f gets $f listen } -body { - set s [socket 127.0.0.1 $listen] + set s [socket $localhost $listen] fconfigure $s -buffering line -translation lf puts $s "hello abcdefghijklmnop" - after 1000 set x [gets $s] close $s list $x [gets $f] @@ -461,7 +479,7 @@ test socket-2.7 {echo server, one line} -constraints {socket stdio} -setup { close $f } -result {{hello abcdefghijklmnop} done} removeFile script -test socket-2.8 {echo server, loop 50 times, single connection} -setup { +test socket_$af-2.8 {echo server, loop 50 times, single connection} -setup { set path(script) [makeFile { set f [socket -server accept 0] proc accept {s a p} { @@ -492,8 +510,8 @@ test socket-2.8 {echo server, loop 50 times, single connection} -setup { set f [open "|[list [interpreter] $path(script)]" r] gets $f gets $f listen -} -constraints {socket stdio} -body { - set s [socket 127.0.0.1 $listen] +} -constraints [list socket supported_$af stdio] -body { + set s [socket $localhost $listen] fconfigure $s -buffering line catch { for {set x 0} {$x < 50} {incr x} { @@ -509,11 +527,12 @@ test socket-2.8 {echo server, loop 50 times, single connection} -setup { removeFile script } -result {done 50} set path(script) [makeFile {} script] -test socket-2.9 {socket conflict} -constraints {socket stdio} -body { +test socket_$af-2.9 {socket conflict} -constraints [list socket supported_$af stdio] -body { set s [socket -server accept 0] file delete $path(script) set f [open $path(script) w] - puts -nonewline $f "socket -server accept [lindex [fconfigure $s -sockname] 2]" + puts $f [list set ::tcl::unsupported::socketAF $::tcl::unsupported::socketAF] + puts $f "socket -server accept [lindex [fconfigure $s -sockname] 2]" close $f set f [open "|[list [interpreter] $path(script)]" r] gets $f @@ -522,10 +541,10 @@ test socket-2.9 {socket conflict} -constraints {socket stdio} -body { } -returnCodes error -cleanup { close $s } -match glob -result {couldn't open socket: address already in use*} -test socket-2.10 {close on accept, accepted socket lives} -setup { +test socket_$af-2.10 {close on accept, accepted socket lives} -setup { set done 0 set timer [after 20000 "set done timed_out"] -} -constraints socket -body { +} -constraints [list socket supported_$af] -body { set ss [socket -server accept 0] proc accept {s a p} { global ss @@ -539,7 +558,7 @@ test socket-2.10 {close on accept, accepted socket lives} -setup { close $s set done 1 } - set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]] + set cs [socket $localhost [lindex [fconfigure $ss -sockname] 2]] puts $cs hello close $cs vwait done @@ -547,7 +566,7 @@ test socket-2.10 {close on accept, accepted socket lives} -setup { } -cleanup { after cancel $timer } -result 1 -test socket-2.11 {detecting new data} -constraints socket -setup { +test socket_$af-2.11 {detecting new data} -constraints [list socket supported_$af] -setup { proc accept {s a p} { global sock set sock $s @@ -555,18 +574,20 @@ test socket-2.11 {detecting new data} -constraints socket -setup { set s [socket -server accept 0] set sock "" } -body { - set s2 [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]] + set s2 [socket $localhost [lindex [fconfigure $s -sockname] 2]] vwait sock puts $s2 one flush $s2 - after 500 + after idle {set x 1} + vwait x fconfigure $sock -blocking 0 set result a:[gets $sock] lappend result b:[gets $sock] fconfigure $sock -blocking 1 puts $s2 two flush $s2 - after 500 + after idle {set x 1} + vwait x fconfigure $sock -blocking 0 lappend result c:[gets $sock] } -cleanup { @@ -576,11 +597,12 @@ test socket-2.11 {detecting new data} -constraints socket -setup { close $sock } -result {a:one b: c:two} -test socket-3.1 {socket conflict} -constraints {socket stdio} -setup { +test socket_$af-3.1 {socket conflict} -constraints [list socket supported_$af stdio] -setup { file delete $path(script) set f [open $path(script) w] + puts $f [list set localhost $localhost] puts $f { - set f [socket -server accept -myaddr 127.0.0.1 0] + set f [socket -server accept -myaddr $localhost 0] puts ready puts [lindex [fconfigure $f -sockname] 2] gets stdin @@ -591,20 +613,21 @@ test socket-3.1 {socket conflict} -constraints {socket stdio} -setup { gets $f gets $f listen } -body { - socket -server accept -myaddr 127.0.0.1 $listen + socket -server accept -myaddr $localhost $listen } -cleanup { puts $f bye close $f } -returnCodes error -result {couldn't open socket: address already in use} -test socket-3.2 {server with several clients} -setup { +test socket_$af-3.2 {server with several clients} -setup { file delete $path(script) set f [open $path(script) w] + puts $f [list set localhost $localhost] puts $f { set t1 [after 30000 "set x timed_out"] set t2 [after 31000 "set x timed_out"] set t3 [after 32000 "set x timed_out"] set counter 0 - set s [socket -server accept -myaddr 127.0.0.1 0] + set s [socket -server accept -myaddr $localhost 0] proc accept {s a p} { fileevent $s readable [list echo $s] fconfigure $s -buffering line @@ -634,13 +657,13 @@ test socket-3.2 {server with several clients} -setup { set f [open "|[list [interpreter] $path(script)]" r+] set x [gets $f] gets $f listen -} -constraints {socket stdio} -body { +} -constraints [list socket supported_$af stdio] -body { # $x == "ready" here - set s1 [socket 127.0.0.1 $listen] + set s1 [socket $localhost $listen] fconfigure $s1 -buffering line - set s2 [socket 127.0.0.1 $listen] + set s2 [socket $localhost $listen] fconfigure $s2 -buffering line - set s3 [socket 127.0.0.1 $listen] + set s3 [socket $localhost $listen] fconfigure $s3 -buffering line for {set i 0} {$i < 100} {incr i} { puts $s1 hello,s1 @@ -658,12 +681,13 @@ test socket-3.2 {server with several clients} -setup { close $f } -result {ready done} -test socket-4.1 {server with several clients} -setup { +test socket_$af-4.1 {server with several clients} -setup { file delete $path(script) set f [open $path(script) w] + puts $f [list set localhost $localhost] puts $f { set port [gets stdin] - set s [socket 127.0.0.1 $port] + set s [socket $localhost $port] fconfigure $s -buffering line for {set i 0} {$i < 100} {incr i} { puts $s hello @@ -680,7 +704,7 @@ test socket-4.1 {server with several clients} -setup { fconfigure $p2 -buffering line set p3 [open "|[list [interpreter] $path(script)]" r+] fconfigure $p3 -buffering line -} -constraints {socket stdio} -body { +} -constraints [list socket supported_$af stdio] -body { proc accept {s a p} { fconfigure $s -buffering line fileevent $s readable [list echo $s] @@ -698,7 +722,7 @@ test socket-4.1 {server with several clients} -setup { set t1 [after 30000 "set x timed_out"] set t2 [after 31000 "set x timed_out"] set t3 [after 32000 "set x timed_out"] - set s [socket -server accept -myaddr 127.0.0.1 0] + set s [socket -server accept -myaddr $localhost 0] set listen [lindex [fconfigure $s -sockname] 2] puts $p1 $listen puts $p2 $listen @@ -722,34 +746,34 @@ test socket-4.1 {server with several clients} -setup { close $p2 close $p3 } -result {{p1 bye done} {p2 bye done} {p3 bye done}} -test socket-4.2 {byte order problems, socket numbers, htons} -body { - close [socket -server dodo -myaddr 127.0.0.1 0x3000] +test socket_$af-4.2 {byte order problems, socket numbers, htons} -body { + close [socket -server dodo -myaddr $localhost 0x3000] return ok -} -constraints socket -result ok +} -constraints [list socket supported_$af] -result ok -test socket-5.1 {byte order problems, socket numbers, htons} -body { +test socket_$af-5.1 {byte order problems, socket numbers, htons} -body { if {![catch {socket -server dodo 0x1} msg]} { close $msg return {htons problem, should be disallowed, are you running as SU?} } return {couldn't open socket: not owner} -} -constraints {socket unix notRoot} -result {couldn't open socket: not owner} -test socket-5.2 {byte order problems, socket numbers, htons} -body { +} -constraints [list socket supported_$af unix notRoot] -result {couldn't open socket: not owner} +test socket_$af-5.2 {byte order problems, socket numbers, htons} -body { if {![catch {socket -server dodo 0x10000} msg]} { close $msg return {port resolution problem, should be disallowed} } return {couldn't open socket: port number too high} -} -constraints socket -result {couldn't open socket: port number too high} -test socket-5.3 {byte order problems, socket numbers, htons} -body { +} -constraints [list socket supported_$af] -result {couldn't open socket: port number too high} +test socket_$af-5.3 {byte order problems, socket numbers, htons} -body { if {![catch {socket -server dodo 21} msg]} { close $msg return {htons problem, should be disallowed, are you running as SU?} } return {couldn't open socket: not owner} -} -constraints {socket unix notRoot} -result {couldn't open socket: not owner} +} -constraints [list socket supported_$af unix notRoot] -result {couldn't open socket: not owner} -test socket-6.1 {accept callback error} -constraints {socket stdio} -setup { +test socket_$af-6.1 {accept callback error} -constraints [list socket supported_$af stdio] -setup { proc myHandler {msg options} { variable x $msg } @@ -758,14 +782,15 @@ test socket-6.1 {accept callback error} -constraints {socket stdio} -setup { file delete $path(script) } -body { set f [open $path(script) w] + puts $f [list set localhost $localhost] puts $f { gets stdin port - socket 127.0.0.1 $port + socket $localhost $port } close $f set f [open "|[list [interpreter] $path(script)]" r+] proc accept {s a p} {expr 10 / 0} - set s [socket -server accept -myaddr 127.0.0.1 0] + set s [socket -server accept -myaddr $localhost 0] puts $f [lindex [fconfigure $s -sockname] 2] close $f set timer [after 10000 "set x timed_out"] @@ -777,7 +802,7 @@ test socket-6.1 {accept callback error} -constraints {socket stdio} -setup { interp bgerror {} $handler } -result {divide by zero} -test socket-7.1 {testing socket specific options} -setup { +test socket_$af-7.1 {testing socket specific options} -setup { file delete $path(script) set f [open $path(script) w] puts $f { @@ -797,19 +822,20 @@ test socket-7.1 {testing socket specific options} -setup { gets $f gets $f listen set l "" -} -constraints {socket stdio} -body { - set s [socket 127.0.0.1 $listen] +} -constraints [list socket supported_$af stdio] -body { + set s [socket $localhost $listen] set p [fconfigure $s -peername] close $s - lappend l [string compare [lindex $p 0] 127.0.0.1] + lappend l [string compare [lindex $p 0] $localhost] lappend l [string compare [lindex $p 2] $listen] lappend l [llength $p] } -cleanup { close $f } -result {0 0 3} -test socket-7.2 {testing socket specific options} -setup { +test socket_$af-7.2 {testing socket specific options} -setup { file delete $path(script) set f [open $path(script) w] + puts $f [list set ::tcl::unsupported::socketAF $::tcl::unsupported::socketAF] puts $f { set ss [socket -server accept 0] proc accept args { @@ -826,35 +852,35 @@ test socket-7.2 {testing socket specific options} -setup { set f [open "|[list [interpreter] $path(script)]" r] gets $f gets $f listen -} -constraints {socket stdio} -body { - set s [socket 127.0.0.1 $listen] +} -constraints [list socket supported_$af stdio] -body { + set s [socket $localhost $listen] set p [fconfigure $s -sockname] close $s list [llength $p] \ - [regexp {^(127\.0\.0\.1|0\.0\.0\.0)$} [lindex $p 0]] \ + [regexp {^(127\.0\.0\.1|0\.0\.0\.0|::1)$} [lindex $p 0]] \ [expr {[lindex $p 2] == $listen}] } -cleanup { close $f } -result {3 1 0} -test socket-7.3 {testing socket specific options} -constraints socket -body { - set s [socket -server accept -myaddr 127.0.0.1 0] +test socket_$af-7.3 {testing socket specific options} -constraints [list socket supported_$af] -body { + set s [socket -server accept -myaddr $localhost 0] set l [fconfigure $s] close $s update llength $l } -result 14 -test socket-7.4 {testing socket specific options} -constraints socket -setup { +test socket_$af-7.4 {testing socket specific options} -constraints [list socket supported_$af] -setup { set timer [after 10000 "set x timed_out"] set l "" } -body { - set s [socket -server accept -myaddr 127.0.0.1 0] + set s [socket -server accept -myaddr $localhost 0] proc accept {s a p} { global x set x [fconfigure $s -sockname] close $s } set listen [lindex [fconfigure $s -sockname] 2] - set s1 [socket 127.0.0.1 $listen] + set s1 [socket $localhost $listen] vwait x lappend l [expr {[lindex $x 2] == $listen}] [llength $x] } -cleanup { @@ -862,10 +888,10 @@ test socket-7.4 {testing socket specific options} -constraints socket -setup { close $s close $s1 } -result {1 3} -test socket-7.5 {testing socket specific options} -setup { +test socket_$af-7.5 {testing socket specific options} -setup { set timer [after 10000 "set x timed_out"] set l "" -} -constraints {socket unixOrPc} -body { +} -constraints [list socket supported_$af unixOrPc] -body { set s [socket -server accept 0] proc accept {s a p} { global x @@ -873,16 +899,16 @@ test socket-7.5 {testing socket specific options} -setup { close $s } set listen [lindex [fconfigure $s -sockname] 2] - set s1 [socket 127.0.0.1 $listen] + set s1 [socket $localhost $listen] vwait x lappend l [lindex $x 0] [expr {[lindex $x 2] == $listen}] [llength $x] } -cleanup { after cancel $timer close $s close $s1 -} -result {127.0.0.1 1 3} +} -result [list $localhost 1 3] -test socket-8.1 {testing -async flag on sockets} -constraints socket -body { +test socket_$af-8.1 {testing -async flag on sockets} -constraints [list socket supported_$af] -body { # NOTE: This test may fail on some Solaris 2.4 systems. If it does, check # that you have these patches installed (using showrev -p): # @@ -897,14 +923,14 @@ test socket-8.1 {testing -async flag on sockets} -constraints socket -body { # please email jyl@eng.sun.com. We have not observed this failure on # Solaris 2.5, so another option (instead of installing these patches) is # to upgrade to Solaris 2.5. - set s [socket -server accept -myaddr 127.0.0.1 0] + set s [socket -server accept -myaddr $localhost 0] proc accept {s a p} { global x puts $s bye close $s set x done } - set s1 [socket -async 127.0.0.1 [lindex [fconfigure $s -sockname] 2]] + set s1 [socket -async $localhost [lindex [fconfigure $s -sockname] 2]] vwait x gets $s1 } -cleanup { @@ -912,7 +938,7 @@ test socket-8.1 {testing -async flag on sockets} -constraints socket -body { close $s1 } -result bye -test socket-9.1 {testing spurious events} -constraints socket -setup { +test socket_$af-9.1 {testing spurious events} -constraints [list socket supported_$af] -setup { set len 0 set spurious 0 set done 0 @@ -936,8 +962,8 @@ test socket-9.1 {testing spurious events} -constraints socket -setup { fconfigure $s -buffering none -blocking off fileevent $s readable [list readlittle $s] } - set s [socket -server accept -myaddr 127.0.0.1 0] - set c [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]] + set s [socket -server accept -myaddr $localhost 0] + set c [socket $localhost [lindex [fconfigure $s -sockname] 2]] puts -nonewline $c 01234567890123456789012345678901234567890123456789 close $c vwait done @@ -946,7 +972,7 @@ test socket-9.1 {testing spurious events} -constraints socket -setup { } -cleanup { after cancel $timer } -result {0 50} -test socket-9.2 {testing async write, fileevents, flush on close} -constraints socket -setup { +test socket_$af-9.2 {testing async write, fileevents, flush on close} -constraints [list socket supported_$af] -setup { set firstblock "" for {set i 0} {$i < 5} {incr i} {set firstblock "a$firstblock$firstblock"} set secondblock "" @@ -954,7 +980,7 @@ test socket-9.2 {testing async write, fileevents, flush on close} -constraints s set secondblock "b$secondblock$secondblock" } set timer [after 10000 "set done timed_out"] - set l [socket -server accept -myaddr 127.0.0.1 0] + set l [socket -server accept -myaddr $localhost 0] proc accept {s a p} { fconfigure $s -blocking 0 -translation lf -buffersize 16384 \ -buffering line @@ -963,12 +989,12 @@ test socket-9.2 {testing async write, fileevents, flush on close} -constraints s proc readable {s} { set l [gets $s] fileevent $s readable {} - after 1000 respond $s + after idle respond $s } proc respond {s} { global firstblock puts -nonewline $s $firstblock - after 1000 writedata $s + after idle writedata $s } proc writedata {s} { global secondblock @@ -976,7 +1002,7 @@ test socket-9.2 {testing async write, fileevents, flush on close} -constraints s close $s } } -body { - set s [socket 127.0.0.1 [lindex [fconfigure $l -sockname] 2]] + set s [socket $localhost [lindex [fconfigure $l -sockname] 2]] fconfigure $s -blocking 0 -trans lf -buffering line set count 0 puts $s hello @@ -996,7 +1022,7 @@ test socket-9.2 {testing async write, fileevents, flush on close} -constraints s close $l after cancel $timer } -result 65566 -test socket-9.3 {testing EOF stickyness} -constraints socket -setup { +test socket_$af-9.3 {testing EOF stickyness} -constraints [list socket supported_$af] -setup { set count 0 set done false proc write_then_close {s} { @@ -1007,7 +1033,7 @@ test socket-9.3 {testing EOF stickyness} -constraints socket -setup { fconfigure $s -buffering line -translation lf fileevent $s writable "write_then_close $s" } - set s [socket -server accept -myaddr 127.0.0.1 0] + set s [socket -server accept -myaddr $localhost 0] } -body { proc count_to_eof {s} { global count done @@ -1027,7 +1053,7 @@ test socket-9.3 {testing EOF stickyness} -constraints socket -setup { set count {timer went off, eof is not sticky} close $s } - set c [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]] + set c [socket $localhost [lindex [fconfigure $s -sockname] 2]] fconfigure $c -blocking off -buffering line -translation lf fileevent $c readable "count_to_eof $c" set timer [after 1000 timerproc $c] @@ -1040,9 +1066,8 @@ test socket-9.3 {testing EOF stickyness} -constraints socket -setup { removeFile script -test socket-10.1 {testing socket accept callback error handling} -constraints { - socket -} -setup { +test socket_$af-10.1 {testing socket accept callback error handling} \ + -constraints [list socket supported_$af] -setup { variable goterror 0 proc myHandler {msg options} { variable goterror 1 @@ -1050,9 +1075,9 @@ test socket-10.1 {testing socket accept callback error handling} -constraints { set handler [interp bgerror {}] interp bgerror {} [namespace which myHandler] } -body { - set s [socket -server accept -myaddr 127.0.0.1 0] + set s [socket -server accept -myaddr $localhost 0] proc accept {s a p} {close $s; error} - set c [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]] + set c [socket $localhost [lindex [fconfigure $s -sockname] 2]] vwait goterror close $s close $c @@ -1061,7 +1086,7 @@ test socket-10.1 {testing socket accept callback error handling} -constraints { interp bgerror {} $handler } -result 1 -test socket-11.1 {tcp connection} -setup { +test socket_$af-11.1 {tcp connection} -setup { set port [sendCommand { set server [socket -server accept 0] proc accept {s a p} { @@ -1070,14 +1095,14 @@ test socket-11.1 {tcp connection} -setup { } getPort $server }] -} -constraints {socket doTestsWithRemoteServer} -body { +} -constraints [list socket supported_$af doTestsWithRemoteServer] -body { set s [socket $remoteServerIP $port] gets $s } -cleanup { close $s sendCommand {close $server} } -result done -test socket-11.2 {client specifies its port} -setup { +test socket_$af-11.2 {client specifies its port} -setup { set lport [randport] set rport [sendCommand { set server [socket -server accept 0] @@ -1087,7 +1112,7 @@ test socket-11.2 {client specifies its port} -setup { } getPort $server }] -} -constraints {socket doTestsWithRemoteServer} -body { +} -constraints [list socket supported_$af doTestsWithRemoteServer] -body { set s [socket -myport $lport $remoteServerIP $rport] set r [gets $s] expr {$r==$lport ? "ok" : "broken: $r != $port"} @@ -1095,7 +1120,7 @@ test socket-11.2 {client specifies its port} -setup { close $s sendCommand {close $server} } -result ok -test socket-11.3 {trying to connect, no server} -body { +test socket_$af-11.3 {trying to connect, no server} -body { set status ok if {![catch {set s [socket $remoteServerIp [randport]]}]} { if {![catch {gets $s}]} { @@ -1104,8 +1129,8 @@ test socket-11.3 {trying to connect, no server} -body { close $s } return $status -} -constraints {socket doTestsWithRemoteServer} -result ok -test socket-11.4 {remote echo, one line} -setup { +} -constraints [list socket supported_$af doTestsWithRemoteServer] -result ok +test socket_$af-11.4 {remote echo, one line} -setup { set port [sendCommand { set server [socket -server accept 0] proc accept {s a p} { @@ -1122,7 +1147,7 @@ test socket-11.4 {remote echo, one line} -setup { } getPort $server }] -} -constraints {socket doTestsWithRemoteServer} -body { +} -constraints [list socket supported_$af doTestsWithRemoteServer] -body { set f [socket $remoteServerIP $port] fconfigure $f -translation crlf -buffering line puts $f hello @@ -1131,7 +1156,7 @@ test socket-11.4 {remote echo, one line} -setup { catch {close $f} sendCommand {close $server} } -result hello -test socket-11.5 {remote echo, 50 lines} -setup { +test socket_$af-11.5 {remote echo, 50 lines} -setup { set port [sendCommand { set server [socket -server accept 0] proc accept {s a p} { @@ -1148,7 +1173,7 @@ test socket-11.5 {remote echo, 50 lines} -setup { } getPort $server }] -} -constraints {socket doTestsWithRemoteServer} -body { +} -constraints [list socket supported_$af doTestsWithRemoteServer] -body { set f [socket $remoteServerIP $port] fconfigure $f -translation crlf -buffering line for {set cnt 0} {$cnt < 50} {incr cnt} { @@ -1162,15 +1187,15 @@ test socket-11.5 {remote echo, 50 lines} -setup { close $f sendCommand {close $server} } -result 50 -test socket-11.6 {socket conflict} -setup { - set s1 [socket -server accept -myaddr 127.0.0.1 0] -} -constraints {socket doTestsWithRemoteServer} -body { - set s2 [socket -server accept -myaddr 127.0.0.1 [getPort $s1]] +test socket_$af-11.6 {socket conflict} -setup { + set s1 [socket -server accept -myaddr $localhost 0] +} -constraints [list socket supported_$af doTestsWithRemoteServer] -body { + set s2 [socket -server accept -myaddr $localhost [getPort $s1]] list [getPort $s2] [close $s2] } -cleanup { close $s1 } -returnCodes error -result {couldn't open socket: address already in use} -test socket-11.7 {server with several clients} -setup { +test socket_$af-11.7 {server with several clients} -setup { set port [sendCommand { set server [socket -server accept 0] proc accept {s a p} { @@ -1187,7 +1212,7 @@ test socket-11.7 {server with several clients} -setup { } getPort $server }] -} -constraints {socket doTestsWithRemoteServer} -body { +} -constraints [list socket supported_$af doTestsWithRemoteServer] -body { set s1 [socket $remoteServerIP $port] fconfigure $s1 -buffering line set s2 [socket $remoteServerIP $port] @@ -1209,7 +1234,7 @@ test socket-11.7 {server with several clients} -setup { close $s3 sendCommand {close $server} } -result 100 -test socket-11.8 {client with several servers} -setup { +test socket_$af-11.8 {client with several servers} -setup { lassign [sendCommand { set s1 [socket -server "accept server1" 0] set s2 [socket -server "accept server2" 0] @@ -1220,7 +1245,7 @@ test socket-11.8 {client with several servers} -setup { } list [getPort $s1] [getPort $s2] [getPort $s3] }] p1 p2 p3 -} -constraints {socket doTestsWithRemoteServer} -body { +} -constraints [list socket supported_$af doTestsWithRemoteServer] -body { set s1 [socket $remoteServerIP $p1] set s2 [socket $remoteServerIP $p2] set s3 [socket $remoteServerIP $p3] @@ -1236,9 +1261,7 @@ test socket-11.8 {client with several servers} -setup { close $s3 } } -result {server1 {} 1 server2 {} 1 server3 {} 1} -test socket-11.9 {accept callback error} -constraints { - socket doTestsWithRemoteServer -} -setup { +test socket_$af-11.9 {accept callback error} -constraints [list socket supported_$af doTestsWithRemoteServer] -setup { proc myHandler {msg options} { variable x $msg } @@ -1266,13 +1289,13 @@ test socket-11.9 {accept callback error} -constraints { after cancel $timer interp bgerror {} $handler } -result {divide by zero} -test socket-11.10 {testing socket specific options} -setup { +test socket_$af-11.10 {testing socket specific options} -setup { set port [sendCommand { set server [socket -server accept 0] proc accept {s a p} {close $s} getPort $server }] -} -constraints {socket doTestsWithRemoteServer} -body { +} -constraints [list socket supported_$af doTestsWithRemoteServer] -body { set s [socket $remoteServerIP $port] set p [fconfigure $s -peername] set n [fconfigure $s -sockname] @@ -1281,12 +1304,12 @@ test socket-11.10 {testing socket specific options} -setup { close $s sendCommand {close $server} } -result {1 3 3} -test socket-11.11 {testing spurious events} -setup { +test socket_$af-11.11 {testing spurious events} -setup { set port [sendCommand { set server [socket -server accept 0] proc accept {s a p} { fconfigure $s -translation "auto lf" - after 100 writesome $s + after idle writesome $s } proc writesome {s} { for {set i 0} {$i < 100} {incr i} { @@ -1300,7 +1323,7 @@ test socket-11.11 {testing spurious events} -setup { set spurious 0 set done 0 set timer [after 40000 "set done timed_out"] -} -constraints {socket doTestsWithRemoteServer} -body { +} -constraints [list socket supported_$af doTestsWithRemoteServer] -body { proc readlittle {s} { global spurious done len set l [read $s 1] @@ -1323,13 +1346,13 @@ test socket-11.11 {testing spurious events} -setup { after cancel $timer sendCommand {close $server} } -result {0 2690 1} -test socket-11.12 {testing EOF stickyness} -constraints {socket doTestsWithRemoteServer} -setup { +test socket_$af-11.12 {testing EOF stickyness} -constraints [list socket supported_$af doTestsWithRemoteServer] -setup { set counter 0 set done 0 set port [sendCommand { set server [socket -server accept 0] proc accept {s a p} { - after 100 close $s + after idle close $s } getPort $server }] @@ -1359,7 +1382,7 @@ test socket-11.12 {testing EOF stickyness} -constraints {socket doTestsWithRemot after cancel $after_id sendCommand {close $server} } -result {EOF is sticky} -test socket-11.13 {testing async write, async flush, async close} -setup { +test socket_$af-11.13 {testing async write, async flush, async close} -setup { set port [sendCommand { set firstblock "" for {set i 0} {$i < 5} {incr i} { @@ -1378,12 +1401,12 @@ test socket-11.13 {testing async write, async flush, async close} -setup { proc readable {s} { set l [gets $s] fileevent $s readable {} - after 1000 respond $s + after idle respond $s } proc respond {s} { global firstblock puts -nonewline $s $firstblock - after 1000 writedata $s + after idle writedata $s } proc writedata {s} { global secondblock @@ -1393,7 +1416,7 @@ test socket-11.13 {testing async write, async flush, async close} -setup { getPort $l }] set timer [after 10000 "set done timed_out"] -} -constraints {socket doTestsWithRemoteServer} -body { +} -constraints [list socket supported_$af doTestsWithRemoteServer] -body { proc readit {s} { global count done set l [read $s] @@ -1418,57 +1441,56 @@ test socket-11.13 {testing async write, async flush, async close} -setup { set path(script1) [makeFile {} script1] set path(script2) [makeFile {} script2] -test socket-12.1 {testing inheritance of server sockets} -setup { +test socket_$af-12.1 {testing inheritance of server sockets} -setup { file delete $path(script1) file delete $path(script2) # Script1 is just a 10 second delay. If the server socket is inherited, it # will be held open for 10 seconds set f [open $path(script1) w] puts $f { + fileevent stdin readable exit after 10000 exit vwait forever } close $f - # Script2 creates the server socket, launches script1, waits a second, and - # exits. The server socket will now be closed unless script1 inherited it. + # Script2 creates the server socket, launches script1, and exits. + # The server socket will now be closed unless script1 inherited it. set f [open $path(script2) w] puts $f [list set tcltest [interpreter]] puts $f [list set delay $path(script1)] + puts $f [list set localhost $localhost] puts $f { - set f [socket -server accept -myaddr 127.0.0.1 0] - puts [lindex [fconfigure $f -sockname] 2] + set f [socket -server accept -myaddr $localhost 0] proc accept { file addr port } { close $file } exec $tcltest $delay & + puts [lindex [fconfigure $f -sockname] 2] close $f - after 1000 exit - vwait forever + exit } close $f -} -constraints {socket stdio exec} -body { +} -constraints [list socket supported_$af stdio exec] -body { # Launch script2 and wait 5 seconds ### exec [interpreter] script2 & set p [open "|[list [interpreter] $path(script2)]" r] - gets $p listen - after 5000 { set ok_to_proceed 1 } - vwait ok_to_proceed # If we can still connect to the server, the socket got inherited. - if {[catch {close [socket 127.0.0.1 $listen]}]} { + if {[catch {close [socket $localhost $listen]}]} { return {server socket was not inherited} } else { return {server socket was inherited} } } -cleanup { - close $p + catch {close $p} } -result {server socket was not inherited} -test socket-12.2 {testing inheritance of client sockets} -setup { +test socket_$af-12.2 {testing inheritance of client sockets} -setup { file delete $path(script1) file delete $path(script2) # Script1 is just a 20 second delay. If the server socket is inherited, it # will be held open for 20 seconds set f [open $path(script1) w] puts $f { + fileevent stdin readable exit after 20000 exit vwait forever } @@ -1479,23 +1501,23 @@ test socket-12.2 {testing inheritance of client sockets} -setup { set f [open $path(script2) w] puts $f [list set tcltest [interpreter]] puts $f [list set delay $path(script1)] + puts $f [list set localhost $localhost] puts $f { gets stdin port - set f [socket 127.0.0.1 $port] + set f [socket $localhost $port] exec $tcltest $delay & puts $f testing flush $f - after 1000 exit - vwait forever + exit } close $f # If the socket doesn't hit end-of-file in 10 seconds, the script1 process # must have inherited the client. set failed 0 - after 10000 [list set failed 1] -} -constraints {socket stdio exec} -body { + set after [after 10000 [list set failed 1]] +} -constraints [list socket supported_$af stdio exec] -body { # Create the server socket - set server [socket -server accept -myaddr 127.0.0.1 0] + set server [socket -server accept -myaddr $localhost 0] proc accept { file host port } { # When the client connects, establish the read handler global server @@ -1531,16 +1553,15 @@ test socket-12.2 {testing inheritance of client sockets} -setup { vwait x return $x } -cleanup { - if {!$failed} { - vwait failed - } + after cancel $after close $p } -result {client socket was not inherited} -test socket-12.3 {testing inheritance of accepted sockets} -setup { +test socket_$af-12.3 {testing inheritance of accepted sockets} -setup { file delete $path(script1) file delete $path(script2) set f [open $path(script1) w] puts $f { + fileevent stdin readable exit after 10000 exit vwait forever } @@ -1548,27 +1569,26 @@ test socket-12.3 {testing inheritance of accepted sockets} -setup { set f [open $path(script2) w] puts $f [list set tcltest [interpreter]] puts $f [list set delay $path(script1)] + puts $f [list set localhost $localhost] puts $f { - set server [socket -server accept -myaddr 127.0.0.1 0] - puts stdout [lindex [fconfigure $server -sockname] 2] + set server [socket -server accept -myaddr $localhost 0] proc accept { file host port } { global tcltest delay puts $file {test data on socket} exec $tcltest $delay & - after 1000 exit + after idle exit } + puts stdout [lindex [fconfigure $server -sockname] 2] vwait forever } close $f -} -constraints {socket stdio exec} -body { +} -constraints [list socket supported_$af stdio exec] -body { # Launch the script2 process and connect to it. See how long the socket # stays open ## exec [interpreter] script2 & set p [open "|[list [interpreter] $path(script2)]" r] gets $p listen - after 1000 set ok_to_proceed 1 - vwait ok_to_proceed - set f [socket 127.0.0.1 $listen] + set f [socket $localhost $listen] fconfigure $f -buffering full -blocking 0 fileevent $f readable [list getdata $f] # If the socket is still open after 5 seconds, the script1 process must @@ -1604,10 +1624,10 @@ test socket-12.3 {testing inheritance of accepted sockets} -setup { catch {close $p} } -result {accepted socket was not inherited} -test socket-13.1 {Testing use of shared socket between two threads} -setup { +test socket_$af-13.1 {Testing use of shared socket between two threads} -setup { threadReap - set path(script) [makeFile { - set f [socket -server accept -myaddr 127.0.0.1 0] + set path(script) [makeFile [string map [list @localhost@ $localhost] { + set f [socket -server accept -myaddr @localhost@ 0] set listen [lindex [fconfigure $f -sockname] 2] proc accept {s a p} { fileevent $s readable [list echo $s] @@ -1630,15 +1650,14 @@ test socket-13.1 {Testing use of shared socket between two threads} -setup { close $f # thread cleans itself up. testthread exit - } script] -} -constraints {socket testthread} -body { + }] script] +} -constraints [list socket supported_$af testthread] -body { # create a thread set serverthread [testthread create [list source $path(script) ] ] update set port [testthread send $serverthread {set listen}] update - after 1000 - set s [socket 127.0.0.1 $port] + set s [socket $localhost $port] fconfigure $s -buffering line catch { puts $s "hello" @@ -1646,7 +1665,6 @@ test socket-13.1 {Testing use of shared socket between two threads} -setup { } close $s update - after 2000 append result " " [threadReap] } -cleanup { removeFile script @@ -1663,6 +1681,7 @@ if {$remoteProcChan ne ""} { } catch {close $commandSocket} catch {close $remoteProcChan} +} ::tcltest::cleanupTests flush stdout return diff --git a/tests/util.test b/tests/util.test index 994fc0f..bfb8507 100644 --- a/tests/util.test +++ b/tests/util.test @@ -7,13 +7,14 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: util.test,v 1.20 2008/10/14 16:35:44 dgp Exp $ +# RCS: @(#) $Id: util.test,v 1.20.6.1 2010/12/01 16:42:37 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } +testConstraint controversialNaN 1 testConstraint testdstring [llength [info commands testdstring]] testConstraint testconcatobj [llength [info commands testconcatobj]] @@ -43,6 +44,10 @@ proc testIEEE {} { ieeeValues(+Infinity) binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \ ieeeValues(NaN) + binary scan \x00\x00\x00\x00\x00\x00\xf8\xff d \ + ieeeValues(-NaN) + binary scan \xef\xcd\xab\x89\x67\x45\xfb\xff d \ + ieeeValues(-NaN(3456789abcdef)) set ieeeValues(littleEndian) 1 return 1 } @@ -65,6 +70,10 @@ proc testIEEE {} { ieeeValues(+Infinity) binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \ ieeeValues(NaN) + binary scan \xff\xf8\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(-NaN) + binary scan \xff\xfb\x45\x67\x89\xab\xcd\xef d \ + ieeeValues(-NaN(3456789abcdef)) set ieeeValues(littleEndian) 0 return 1 } @@ -85,6 +94,30 @@ proc convertDouble { x } { return $result } +proc verdonk_test {sig binexp shouldbe exp} { + regexp {([-+]?)([0-9a-f]+)} $sig -> signum sig + scan $sig %llx sig + if {$signum eq {-}} { + set signum [expr 1<<63] + } else { + set signum 0 + } + regexp {E([-+]?[0-9]+)} $binexp -> binexp + set word [expr {$signum | (($binexp + 0x3ff)<<52)|($sig & ~(1<<52))}] + binary scan [binary format w $word] q double + regexp {([-+])(\d+)_(\d+)\&} $shouldbe -> signum digits1 digits2 + regexp {E([-+]\d+)} $exp -> decexp + incr decexp [expr {[string length $digits1] - 1}] + lassign [testdoubledigits $double [string length $digits1] e] \ + outdigits decpt outsign + if {[string index $digits2 0] >= 5} { + incr digits1 + } + if {$outsign != $signum || $outdigits != $digits1 || $decpt != $decexp} { + return -code error "result is ${outsign}0.${outdigits}E$decpt\ + should be ${signum}0.${digits1}E$decexp" + } +} test util-1.1 {TclFindElement procedure - binary element in middle of list} { lindex {0 foo\x00help 1} 1 @@ -1106,6 +1139,774 @@ test util-11.23 {Tcl_PrintDouble - scaling} { expr 1.1e17 } {1.1e+17} +test util-12.1 {TclDoubleDigits - Inf} ieeeFloatingPoint { + testdoubledigits Inf -1 shortest +} {Infinity 9999 +} +test util-12.2 {TclDoubleDigits - -Inf} ieeeFloatingPoint { + testdoubledigits -Inf -1 shortest +} {Infinity 9999 -} +test util-12.3 {TclDoubleDigits - NaN} ieeeFloatingPoint { + testdoubledigits $ieeeValues(NaN) -1 shortest +} {NaN 9999 +} +test util-12.4 {TclDoubleDigits - NaN} {*}{ + -constraints {ieeeFloatingPoint && controversialNaN} + -body { + testdoubledigits -NaN -1 shortest + } + -result {NaN 9999 -} +} +test util-12.5 {TclDoubleDigits - 0} { + testdoubledigits 0.0 -1 shortest +} {0 0 +} +test util-12.6 {TclDoubleDigits - -0} { + testdoubledigits -0.0 -1 shortest +} {0 0 -} + +# Verdonk test vectors + +test util-13.1 {just over exact - 1 digits} {*}{ + -body { + verdonk_test 1754e31cd072da E+1008 +4_000000000000000000& E+303 + } + -result {} +} +test util-13.2 {just over exact - 1 digits} {*}{ + -body { + verdonk_test -1afcef51f0fb5f E+265 -1_000000000000000000& E+80 + } + -result {} +} +test util-13.3 {just over exact - 1 digits} {*}{ + -body { + verdonk_test 1754e31cd072da E+1006 +1_000000000000000000& E+303 + } + -result {} +} +test util-13.4 {just over exact - 1 digits} {*}{ + -body { + verdonk_test -1754e31cd072da E+1007 -2_000000000000000000& E+303 + } + -result {} +} +test util-13.5 {just over exact - 1 digits} {*}{ + -body { + verdonk_test 1e07b27dd78b14 E-848 +1_00000000000000000& E-255 + } + -result {} +} +test util-13.6 {just over exact - 1 digits} {*}{ + -body { + verdonk_test -1e29e9c56687fe E-709 -7_00000000000000000& E-214 + } + -result {} +} +test util-13.7 {just over exact - 1 digits} {*}{ + -body { + verdonk_test 1be03d0bf225c7 E-137 +1_00000000000000000& E-41 + } + -result {} +} +test util-13.8 {just over exact - 1 digits} {*}{ + -body { + verdonk_test -1a2fe76a3f9475 E-499 -1_00000000000000000& E-150 + } + -result {} +} +test util-13.9 {just under exact - 1 digits} {*}{ + -body { + verdonk_test 19a2028368022e E+1019 +8_999999999999999999& E+306 + } + -result {} +} +test util-13.10 {just under exact - 1 digits} {*}{ + -body { + verdonk_test -1317e5ef3ab327 E+509 -1_999999999999999999& E+153 + } + -result {} +} +test util-13.11 {just under exact - 1 digits} {*}{ + -body { + verdonk_test 1317e5ef3ab327 E+510 +3_99999999999999999& E+153 + } + -result {} +} +test util-13.12 {just under exact - 1 digits} {*}{ + -body { + verdonk_test -1317e5ef3ab327 E+511 -7_99999999999999999& E+153 + } + -result {} +} +test util-13.13 {just under exact - 1 digits} {*}{ + -body { + verdonk_test 1eb8e84fa0b278 E-1008 +6_999999999999999999& E-304 + } + -result {} +} +test util-13.14 {just under exact - 1 digits} {*}{ + -body { + verdonk_test -13339131c46f8b E-1004 -6_999999999999999999& E-303 + } + -result {} +} +test util-13.15 {just under exact - 1 digits} {*}{ + -body { + verdonk_test 1c0f92a6276c9d E-162 +2_999999999999999999& E-49 + } + -result {} +} +test util-13.16 {just under exact - 1 digits} {*}{ + -body { + verdonk_test -15ce1f143d7ad2 E-443 -5_99999999999999999& E-134 + } + -result {} +} +test util-13.17 {just over exact - 2 digits} {*}{ + -body { + verdonk_test 1c0794d9d40e96 E-301 +43_000000000000000000& E-92 + } + -result {} +} +test util-13.18 {just over exact - 2 digits} {*}{ + -body { + verdonk_test -1c0794d9d40e96 E-300 -86_000000000000000000& E-92 + } + -result {} +} +test util-13.19 {just over exact - 2 digits} {*}{ + -body { + verdonk_test 1cd5bee57763e6 E-241 +51_000000000000000000& E-74 + } + -result {} +} +test util-13.20 {just under exact - 2 digits} {*}{ + -body { + verdonk_test 1d1c26db7d0dae E+651 +16_999999999999999999& E+195 + } + -result {} +} +test util-13.21 {just under exact - 2 digits} {*}{ + -body { + verdonk_test -13f7ced916872b E-5 -38_999999999999999999& E-3 + } + -result {} +} +test util-13.22 {just over exact - 3 digits} {*}{ + -body { + verdonk_test 17d93193f78fc6 E+588 +151_0000000000000000000& E+175 + } + -result {} +} +test util-13.23 {just over exact - 3 digits} {*}{ + -body { + verdonk_test -1a82a1631eeb30 E-625 -119_000000000000000000& E-190 + } + -result {} +} +test util-13.24 {just under exact - 3 digits} {*}{ + -body { + verdonk_test -16c309024bab4b E+290 -282_999999999999999999& E+85 + } + -result {} +} +test util-13.25 {just over exact - 8 digits} {*}{ + -body { + verdonk_test 1dbbac6f83a821 E-800 +27869147_0000000000000000000& E-248 + } + -result {} +} +test util-13.26 {just under exact - 9 digits} {*}{ + -body { + verdonk_test -1c569e968e0944 E+430 -491080653_9999999999999999999& E+121 + } + -result {} +} +test util-13.27 {just under exact - 9 digits} {*}{ + -body { + verdonk_test 1c569e968e0944 E+429 +245540326_9999999999999999999& E+121 + } + -result {} +} +test util-13.28 {just over exact - 10 digits} {*}{ + -body { + verdonk_test -1fc575867314ee E-330 -9078555839_0000000000000000000& E-109 + } + -result {} +} +test util-13.29 {just under exact - 10 digits} {*}{ + -body { + verdonk_test -1c569e968e0944 E+428 -1227701634_9999999999999999999& E+120 + } + -result {} +} +test util-13.30 {just over exact - 11 digits} {*}{ + -body { + verdonk_test 1fc575867314ee E-329 +18157111678_0000000000000000000& E-109 + } + -result {} +} +test util-13.31 {just over exact - 14 digits} {*}{ + -body { + verdonk_test -18bf7e7fa6f02a E-196 -15400733123779_0000000000000000000& E-72 + } + -result {} +} +test util-13.32 {just over exact - 17 digits} {*}{ + -body { + verdonk_test -13de005bd620df E+217 -26153245263757307_0000000000000000000& E+49 + } + -result {} +} +test util-13.33 {just over exact - 18 digits} {*}{ + -body { + verdonk_test 1f92bacb3cb40c E+718 +272104041512242479_0000000000000000000& E+199 + } + -result {} +} +test util-13.34 {just over exact - 18 digits} {*}{ + -body { + verdonk_test -1f92bacb3cb40c E+719 -544208083024484958_0000000000000000000& E+199 + } + -result {} +} +test util-13.35 {just over half ulp - 1 digits} {*}{ + -body { + verdonk_test 142dbf25096cf5 E+148 +4_500000000000000000& E+44 + } + -result {} +} +test util-13.36 {just over half ulp - 1 digits} {*}{ + -body { + verdonk_test -1afcef51f0fb5f E+263 -2_500000000000000000& E+79 + } + -result {} +} +test util-13.37 {just over half ulp - 1 digits} {*}{ + -body { + verdonk_test 102498ea6df0c4 E+145 +4_500000000000000000& E+43 + } + -result {} +} +test util-13.38 {just over half ulp - 1 digits} {*}{ + -body { + verdonk_test -1754e31cd072da E+1004 -2_500000000000000000& E+302 + } + -result {} +} +test util-13.39 {just over half ulp - 1 digits} {*}{ + -body { + verdonk_test 12deac01e2b4f7 E-557 +2_50000000000000000& E-168 + } + -result {} +} +test util-13.40 {just over half ulp - 1 digits} {*}{ + -body { + verdonk_test -1b1df536c13eee E-307 -6_50000000000000000& E-93 + } + -result {} +} +test util-13.41 {just over half ulp - 1 digits} {*}{ + -body { + verdonk_test 10711fed5b19a4 E-154 +4_50000000000000000& E-47 + } + -result {} +} +test util-13.42 {just over half ulp - 1 digits} {*}{ + -body { + verdonk_test -148d67e8b1e00d E-151 -4_50000000000000000& E-46 + } + -result {} +} +test util-13.43 {just under half ulp - 1 digits} {*}{ + -body { + verdonk_test 1c8c574c0c6be7 E+187 +3_49999999999999999& E+56 + } + -result {} +} +test util-13.44 {just under half ulp - 1 digits} {*}{ + -body { + verdonk_test -1756183c147514 E+206 -1_49999999999999999& E+62 + } + -result {} +} +test util-13.45 {just under half ulp - 1 digits} {*}{ + -body { + verdonk_test 12ab469676c410 E+203 +1_49999999999999999& E+61 + } + -result {} +} +test util-13.46 {just under half ulp - 1 digits} {*}{ + -body { + verdonk_test -1539684e774b48 E+246 -1_49999999999999999& E+74 + } + -result {} +} +test util-13.47 {just under half ulp - 1 digits} {*}{ + -body { + verdonk_test 12e5f5dfa4fe9d E-286 +9_499999999999999999& E-87 + } + -result {} +} +test util-13.48 {just under half ulp - 1 digits} {*}{ + -body { + verdonk_test -1bdc2417bf7787 E-838 -9_499999999999999999& E-253 + } + -result {} +} +test util-13.49 {just under half ulp - 1 digits} {*}{ + -body { + verdonk_test 1eb8e84fa0b278 E-1009 +3_499999999999999999& E-304 + } + -result {} +} +test util-13.50 {just under half ulp - 1 digits} {*}{ + -body { + verdonk_test -1e3cbc9907fdc8 E-290 -9_499999999999999999& E-88 + } + -result {} +} +test util-13.51 {just over half ulp - 2 digits} {*}{ + -body { + verdonk_test 10ad836f269a17 E-324 +30_500000000000000000& E-99 + } + -result {} +} +test util-13.52 {just over half ulp - 2 digits} {*}{ + -body { + verdonk_test -1b39ae1909c31b E-687 -26_500000000000000000& E-208 + } + -result {} +} +test util-13.53 {just over half ulp - 3 digits} {*}{ + -body { + verdonk_test 1b2ab18615fcc6 E-576 +686_500000000000000000& E-176 + } + -result {} +} +test util-13.54 {just over half ulp - 3 digits} {*}{ + -body { + verdonk_test -13e1f90a573064 E-624 -178_500000000000000000& E-190 + } + -result {} +} +test util-13.55 {just under half ulp - 3 digits} {*}{ + -body { + verdonk_test 16c309024bab4b E+289 +141_499999999999999999& E+85 + } + -result {} +} +test util-13.56 {just under half ulp - 4 digits} {*}{ + -body { + verdonk_test -159bd3ad46e346 E+193 -1695_499999999999999999& E+55 + } + -result {} +} +test util-13.57 {just under half ulp - 4 digits} {*}{ + -body { + verdonk_test 1df4170f0fdecc E+124 +3981_499999999999999999& E+34 + } + -result {} +} +test util-13.58 {just over half ulp - 6 digits} {*}{ + -body { + verdonk_test 17e1e0f1c7a4ac E+415 +126300_5000000000000000000& E+120 + } + -result {} +} +test util-13.59 {just over half ulp - 6 digits} {*}{ + -body { + verdonk_test -1dda592e398dd7 E+418 -126300_5000000000000000000& E+121 + } + -result {} +} +test util-13.60 {just under half ulp - 7 digits} {*}{ + -body { + verdonk_test -1e597c0b94b7ae E+453 -4411845_499999999999999999& E+130 + } + -result {} +} +test util-13.61 {just under half ulp - 9 digits} {*}{ + -body { + verdonk_test 1c569e968e0944 E+427 +613850817_4999999999999999999& E+120 + } + -result {} +} +test util-13.62 {just under half ulp - 9 digits} {*}{ + -body { + verdonk_test -1c569e968e0944 E+428 -122770163_49999999999999999999& E+121 + } + -result {} +} +test util-13.63 {just over half ulp - 18 digits} {*}{ + -body { + verdonk_test 17ae0c186d8709 E+719 +408156062268363718_5000000000000000000& E+199 + } + -result {} +} +test util-13.64 {just over exact - 1 digits} {*}{ + -body { + verdonk_test 152d02c7e14af7 E+76 +1_0000000000000000& E+23 + } + -result {} +} +test util-13.65 {just over exact - 1 digits} {*}{ + -body { + verdonk_test -19d971e4fe8402 E+89 -1_0000000000000000& E+27 + } + -result {} +} +test util-13.66 {just over exact - 1 digits} {*}{ + -body { + verdonk_test 19d971e4fe8402 E+90 +2_0000000000000000& E+27 + } + -result {} +} +test util-13.67 {just over exact - 1 digits} {*}{ + -body { + verdonk_test -19d971e4fe8402 E+91 -4_0000000000000000& E+27 + } + -result {} +} +test util-13.68 {just over exact - 1 digits} {*}{ + -body { + verdonk_test 15798ee2308c3a E-27 +1_0000000000000000& E-8 + } + -result {} +} +test util-13.69 {just over exact - 1 digits} {*}{ + -body { + verdonk_test -15798ee2308c3a E-26 -2_0000000000000000& E-8 + } + -result {} +} +test util-13.70 {just over exact - 1 digits} {*}{ + -body { + verdonk_test 15798ee2308c3a E-25 +4_0000000000000000& E-8 + } + -result {} +} +test util-13.71 {just over exact - 1 digits} {*}{ + -body { + verdonk_test -1ef2d0f5da7dd9 E-84 -1_0000000000000000& E-25 + } + -result {} +} +test util-13.72 {just under exact - 1 digits} {*}{ + -body { + verdonk_test 1a784379d99db4 E+78 +4_9999999999999999& E+23 + } + -result {} +} +test util-13.73 {just under exact - 1 digits} {*}{ + -body { + verdonk_test -1a784379d99db4 E+80 -1_9999999999999999& E+24 + } + -result {} +} +test util-13.74 {just under exact - 1 digits} {*}{ + -body { + verdonk_test 13da329b633647 E+81 +2_9999999999999999& E+24 + } + -result {} +} +test util-13.75 {just under exact - 1 digits} {*}{ + -body { + verdonk_test -1cf389cd46047d E+85 -6_9999999999999999& E+25 + } + -result {} +} +test util-13.76 {just under exact - 1 digits} {*}{ + -body { + verdonk_test 19999999999999 E-3 +1_99999999999999999& E-1 + } + -result {} +} +test util-13.77 {just under exact - 1 digits} {*}{ + -body { + verdonk_test -13333333333333 E-2 -2_99999999999999999& E-1 + } + -result {} +} +test util-13.78 {just under exact - 1 digits} {*}{ + -body { + verdonk_test 16849b86a12b9b E-48 +4_99999999999999999& E-15 + } + -result {} +} +test util-13.79 {just under exact - 1 digits} {*}{ + -body { + verdonk_test -16849b86a12b9b E-46 -1_99999999999999999& E-14 + } + -result {} +} +test util-13.80 {just over exact - 2 digits} {*}{ + -body { + verdonk_test 17ccfc73126788 E-71 +63_00000000000000000& E-23 + } + -result {} +} +test util-13.81 {just over exact - 2 digits} {*}{ + -body { + verdonk_test -1dc03b8fd7016a E-68 -63_00000000000000000& E-22 + } + -result {} +} +test util-13.82 {just under exact - 2 digits} {*}{ + -body { + verdonk_test 13f7ced916872b E-5 +38_999999999999999999& E-3 + } + -result {} +} +test util-13.83 {just over exact - 3 digits} {*}{ + -body { + verdonk_test 1b297cad9f70b6 E+97 +269_000000000000000000& E+27 + } + -result {} +} +test util-13.84 {just over exact - 3 digits} {*}{ + -body { + verdonk_test -1b297cad9f70b6 E+98 -538_00000000000000000& E+27 + } + -result {} +} +test util-13.85 {just over exact - 3 digits} {*}{ + -body { + verdonk_test 1cdc06b20ef183 E-82 +373_00000000000000000& E-27 + } + -result {} +} +test util-13.86 {just over exact - 4 digits} {*}{ + -body { + verdonk_test 1b297cad9f70b6 E+96 +1345_00000000000000000& E+26 + } + -result {} +} +# this one is not 4 digits, it is 3, and it is covered above. +test util-13.87 {just over exact - 4 digits} {*}{ + -constraints knownBadTest + -body { + verdonk_test -1b297cad9f70b6 E+97 -2690_00000000000000000& E+26 + } + -result {} +} +test util-13.88 {just over exact - 5 digits} {*}{ + -body { + verdonk_test -150a246ecd44f3 E-63 -14257_00000000000000000& E-23 + } + -result {} +} +test util-13.89 {just under exact - 6 digits} {*}{ + -body { + verdonk_test -119b96f36ec68b E-19 -209900_999999999999999999& E-11 + } + -result {} +} +test util-13.90 {just over exact - 11 digits} {*}{ + -body { + verdonk_test 1c06d366394441 E-35 +50980203373_000000000000000000& E-21 + } + -result {} +} +test util-13.91 {just under exact - 12 digits} {*}{ + -body { + verdonk_test -1f58ac4db68c90 E+122 -104166211810_99999999999999999& E+26 + } + -result {} +} +test util-13.92 {just over half ulp - 1 digits} {*}{ + -body { + verdonk_test 19d971e4fe8402 E+87 +2_5000000000000000& E+26 + } + -result {} +} +test util-13.93 {just over half ulp - 1 digits} {*}{ + -body { + verdonk_test -1dc74be914d16b E+81 -4_500000000000000& E+24 + } + -result {} +} +test util-13.94 {just over half ulp - 1 digits} {*}{ + -body { + verdonk_test 14adf4b7320335 E+84 +2_500000000000000& E+25 + } + -result {} +} +test util-13.95 {just over half ulp - 1 digits} {*}{ + -body { + verdonk_test -1ae22487c1042b E+85 -6_5000000000000000& E+25 + } + -result {} +} +test util-13.96 {just over half ulp - 1 digits} {*}{ + -body { + verdonk_test 187fe49aab41e0 E-54 +8_5000000000000000& E-17 + } + -result {} +} +test util-13.97 {just over half ulp - 1 digits} {*}{ + -body { + verdonk_test -1f5c05e4b23fd7 E-61 -8_5000000000000000& E-19 + } + -result {} +} +test util-13.98 {just over half ulp - 1 digits} {*}{ + -body { + verdonk_test 1faa7ab552a552 E-42 +4_5000000000000000& E-13 + } + -result {} +} +test util-13.99 {just over half ulp - 1 digits} {*}{ + -body { + verdonk_test -1b7cdfd9d7bdbb E-36 -2_5000000000000000& E-11 + } + -result {} +} +test util-13.100 {just under half ulp - 1 digits} {*}{ + -body { + verdonk_test 13da329b633647 E+80 +1_4999999999999999& E+24 + } + -result {} +} +test util-13.101 {just under half ulp - 1 digits} {*}{ + -body { + verdonk_test -1cf389cd46047d E+84 -3_49999999999999999& E+25 + } + -result {} +} +test util-13.102 {just under half ulp - 1 digits} {*}{ + -body { + verdonk_test 1f04ef12cb04cf E+85 +7_4999999999999999& E+25 + } + -result {} +} +test util-13.103 {just under half ulp - 1 digits} {*}{ + -body { + verdonk_test -1f04ef12cb04cf E+86 -1_4999999999999999& E+26 + } + -result {} +} +test util-13.104 {just under half ulp - 1 digits} {*}{ + -body { + verdonk_test 13333333333333 E-3 +1_49999999999999999& E-1 + } + -result {} +} +test util-13.105 {just under half ulp - 1 digits} {*}{ + -body { + verdonk_test -107e1fe91b0b70 E-36 -1_49999999999999999& E-11 + } + -result {} +} +test util-13.106 {just under half ulp - 1 digits} {*}{ + -body { + verdonk_test 149da7e361ce4c E-33 +1_49999999999999999& E-10 + } + -result {} +} +test util-13.107 {just under half ulp - 1 digits} {*}{ + -body { + verdonk_test -19c511dc3a41df E-30 -1_49999999999999999& E-9 + } + -result {} +} +test util-13.108 {just over half ulp - 2 digits} {*}{ + -body { + verdonk_test -1aa83d74267822 E+93 -16_5000000000000000& E+27 + } + -result {} +} +test util-13.109 {just over half ulp - 2 digits} {*}{ + -body { + verdonk_test 18f1d5969453de E+89 +96_5000000000000000& E+25 + } + -result {} +} +test util-13.110 {just over half ulp - 2 digits} {*}{ + -body { + verdonk_test 11d9bd564dcda6 E-70 +94_50000000000000000& E-23 + } + -result {} +} +test util-13.111 {just over half ulp - 2 digits} {*}{ + -body { + verdonk_test -1a58973ecbede6 E-48 -58_50000000000000000& E-16 + } + -result {} +} +test util-13.112 {just over half ulp - 3 digits} {*}{ + -body { + verdonk_test 1b297cad9f70b6 E+95 +672_50000000000000000& E+26 + } + -result {} +} +test util-13.113 {just over half ulp - 3 digits} {*}{ + -body { + verdonk_test -1b297cad9f70b6 E+96 -134_500000000000000000& E+27 + } + -result {} +} +test util-13.114 {just over half ulp - 3 digits} {*}{ + -body { + verdonk_test 1cdc06b20ef183 E-83 +186_50000000000000000& E-27 + } + -result {} +} +test util-13.115 {just over half ulp - 3 digits} {*}{ + -body { + verdonk_test -136071dcae4565 E-47 -860_50000000000000000& E-17 + } + -result {} +} +test util-13.116 {just over half ulp - 6 digits} {*}{ + -body { + verdonk_test 1cb968d297dde8 E+99 +113788_50000000000000000& E+25 + } + -result {} +} +test util-13.117 {just over half ulp - 6 digits} {*}{ + -body { + verdonk_test -11f3e1839eeab1 E+103 -113788_50000000000000000& E+26 + } + -result {} +} +test util-13.118 {just under half ulp - 9 digits} {*}{ + -body { + verdonk_test 1e9cec176c96f8 E+117 +317903333_49999999999999999& E+27 + } + -result {} +} +test util-13.119 {just over half ulp - 11 digits} {*}{ + -body { + verdonk_test 1c06d366394441 E-36 +25490101686_500000000000000000& E-21 + } + -result {} +} +test util-13.120 {just under half ulp - 11 digits} {*}{ + -body { + verdonk_test 1f58ac4db68c90 E+121 +52083105905_49999999999999999& E+26 + } + -result {} +} + +test util-14.1 {funky NaN} {*}{ + -constraints {ieeeFloatingPoint && controversialNaN} + -body { + set ieeeValues(-NaN) + } + -result -NaN +} + +test util-14.2 {funky NaN} {*}{ + -constraints {ieeeFloatingPoint && controversialNaN} + -body { + set ieeeValues(-NaN(3456789abcdef)) + } + -result -NaN(3456789abcdef) +} + # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End:
\ No newline at end of file diff --git a/unix/Makefile.in b/unix/Makefile.in index 7ddd2a7..500d872 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -4,7 +4,7 @@ # "./configure", which is a configuration script generated by the "autoconf" # program (constructs like "@foo@" will get replaced in the actual Makefile. # -# RCS: @(#) $Id: Makefile.in,v 1.306.2.4 2010/10/23 16:14:24 kennykb Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.306.2.5 2010/12/01 16:42:37 kennykb Exp $ VERSION = @TCL_VERSION@ MAJOR_VERSION = @TCL_MAJOR_VERSION@ @@ -155,10 +155,11 @@ SHELL = @MAKEFILE_SHELL@ INSTALL_STRIP_PROGRAM = -s INSTALL_STRIP_LIBRARY = -S -x -INSTALL = $(UNIX_DIR)/install-sh -c +INSTALL = $(SHELL) $(UNIX_DIR)/install-sh -c INSTALL_PROGRAM = ${INSTALL} INSTALL_LIBRARY = ${INSTALL} INSTALL_DATA = ${INSTALL} -m 644 +INSTALL_DATA_DIR = ${INSTALL} -d -m 755 # NATIVE_TCLSH is the name of a tclsh executable that is available *BEFORE* # running make for the first time. Certain build targets (make genstubs) need @@ -322,12 +323,13 @@ TOMMATH_OBJS = bncore.o bn_reverse.o bn_fast_s_mp_mul_digs.o \ bn_mp_div_2d.o bn_mp_div_3.o \ bn_mp_exch.o bn_mp_expt_d.o bn_mp_grow.o bn_mp_init.o \ bn_mp_init_copy.o bn_mp_init_multi.o bn_mp_init_set.o \ - bn_mp_init_size.o bn_mp_karatsuba_mul.o \ + bn_mp_init_set_int.o bn_mp_init_size.o bn_mp_karatsuba_mul.o \ bn_mp_karatsuba_sqr.o \ bn_mp_lshd.o bn_mp_mod.o bn_mp_mod_2d.o bn_mp_mul.o bn_mp_mul_2.o \ bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_neg.o bn_mp_or.o \ bn_mp_radix_size.o bn_mp_radix_smap.o \ - bn_mp_read_radix.o bn_mp_rshd.o bn_mp_set.o bn_mp_shrink.o \ + bn_mp_read_radix.o bn_mp_rshd.o bn_mp_set.o bn_mp_set_int.o \ + bn_mp_shrink.o \ bn_mp_sqr.o bn_mp_sqrt.o bn_mp_sub.o bn_mp_sub_d.o \ bn_mp_to_unsigned_bin.o bn_mp_to_unsigned_bin_n.o \ bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_toradix_n.o \ @@ -498,6 +500,7 @@ TOMMATH_SRCS = \ $(TOMMATH_DIR)/bn_mp_init_copy.c \ $(TOMMATH_DIR)/bn_mp_init_multi.c \ $(TOMMATH_DIR)/bn_mp_init_set.c \ + $(TOMMATH_DIR)/bn_mp_init_set_int.c \ $(TOMMATH_DIR)/bn_mp_init_size.c \ $(TOMMATH_DIR)/bn_mp_karatsuba_mul.c \ $(TOMMATH_DIR)/bn_mp_karatsuba_sqr.c \ @@ -515,6 +518,7 @@ TOMMATH_SRCS = \ $(TOMMATH_DIR)/bn_mp_read_radix.c \ $(TOMMATH_DIR)/bn_mp_rshd.c \ $(TOMMATH_DIR)/bn_mp_set.c \ + $(TOMMATH_DIR)/bn_mp_set_int.c \ $(TOMMATH_DIR)/bn_mp_shrink.c \ $(TOMMATH_DIR)/bn_mp_sqr.c \ $(TOMMATH_DIR)/bn_mp_sqrt.c \ @@ -754,7 +758,13 @@ trace-test: ${TCLTEST_EXE} # Installation rules #-------------------------------------------------------------------------- -INSTALL_TARGETS = install-binaries install-libraries install-doc install-packages @EXTRA_INSTALL@ +INSTALL_BASE_TARGETS = install-binaries install-libraries install-msgs $(INSTALL_TZDATA) +INSTALL_DOC_TARGETS = install-doc +INSTALL_PACKAGE_TARGETS = install-packages +INSTALL_DEV_TARGETS = install-headers +INSTALL_EXTRA_TARGETS = @EXTRA_INSTALL@ +INSTALL_TARGETS = $(INSTALL_BASE_TARGETS) $(INSTALL_DOC_TARGETS) $(INSTALL_DEV_TARGETS) \ + $(INSTALL_PACKAGE_TARGETS) $(INSTALL_EXTRA_TARGETS) install: $(INSTALL_TARGETS) @@ -773,14 +783,10 @@ install-binaries: binaries do \ if [ ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ - mkdir -p "$$i"; \ - chmod 755 "$$i"; \ + $(INSTALL_DATA_DIR) "$$i"; \ else true; \ fi; \ done; - @if test ! -x $(UNIX_DIR)/install-sh; then \ - chmod +x $(UNIX_DIR)/install-sh; \ - fi @echo "Installing $(LIB_FILE) to @DLL_INSTALL_DIR@/" @@INSTALL_LIB@ @chmod 555 "@DLL_INSTALL_DIR@"/$(LIB_FILE) @@ -797,16 +803,15 @@ install-binaries: binaries fi @EXTRA_INSTALL_BINARIES@ @echo "Installing pkg-config file to $(LIB_INSTALL_DIR)/pkgconfig/" - @mkdir -p $(LIB_INSTALL_DIR)/pkgconfig + @$(INSTALL_DATA_DIR) $(LIB_INSTALL_DIR)/pkgconfig @$(INSTALL_DATA) tcl.pc $(LIB_INSTALL_DIR)/pkgconfig/tcl.pc -install-libraries: libraries $(INSTALL_TZDATA) install-msgs - @for i in "$(INCLUDE_INSTALL_DIR)" "$(SCRIPT_INSTALL_DIR)"; \ +install-libraries: libraries + @for i in "$(SCRIPT_INSTALL_DIR)"; \ do \ if [ ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ - mkdir -p "$$i"; \ - chmod 755 "$$i"; \ + $(INSTALL_DATA_DIR) "$$i"; \ else true; \ fi; \ done; @@ -814,37 +819,24 @@ install-libraries: libraries $(INSTALL_TZDATA) install-msgs do \ if [ ! -d "$(SCRIPT_INSTALL_DIR)"/$$i ] ; then \ echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ - mkdir -p "$(SCRIPT_INSTALL_DIR)"/$$i; \ - chmod 755 "$(SCRIPT_INSTALL_DIR)"/$$i; \ + $(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)"/$$i; \ else true; \ fi; \ done; - @if test ! -x $(UNIX_DIR)/install-sh; then \ - chmod +x $(UNIX_DIR)/install-sh; \ - fi - @echo "Installing header files"; - @for i in $(GENERIC_DIR)/tcl.h $(GENERIC_DIR)/tclDecls.h \ - $(GENERIC_DIR)/tclOO.h $(GENERIC_DIR)/tclOODecls.h \ - $(GENERIC_DIR)/tclPlatDecls.h \ - $(GENERIC_DIR)/tclTomMath.h \ - $(GENERIC_DIR)/tclTomMathDecls.h ; \ - do \ - $(INSTALL_DATA) $$i "$(INCLUDE_INSTALL_DIR)"; \ - done; - @echo "Installing library files to $(SCRIPT_INSTALL_DIR)"; + @echo "Installing library files to $(SCRIPT_INSTALL_DIR)/"; @for i in $(TOP_DIR)/library/*.tcl $(TOP_DIR)/library/tclIndex \ $(UNIX_DIR)/tclAppInit.c @LDAIX_SRC@ @DTRACE_SRC@; \ do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"; \ done; - @echo "Installing library http1.0 directory"; + @echo "Installing package http1.0 files to $(SCRIPT_INSTALL_DIR)/http1.0/"; @for i in $(TOP_DIR)/library/http1.0/*.tcl ; \ do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/http1.0; \ done; @echo "Installing package http 2.8.2 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.2.tm; - @echo "Installing library opt0.4 directory"; + @echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/"; @for i in $(TOP_DIR)/library/opt/*.tcl ; \ do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \ @@ -859,7 +851,7 @@ install-libraries: libraries $(INSTALL_TZDATA) install-msgs @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform/shell-1.1.4.tm; - @echo "Installing library encoding directory"; + @echo "Installing library encoding files to $(SCRIPT_INSTALL_DIR)/encoding/"; @for i in $(TOP_DIR)/library/encoding/*.enc ; do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/encoding; \ done; @@ -874,18 +866,26 @@ install-tzdata: ${NATIVE_TCLSH} @${NATIVE_TCLSH} $(TOOL_DIR)/installData.tcl \ $(TOP_DIR)/library/tzdata "$(SCRIPT_INSTALL_DIR)"/tzdata -install-msgs: ${NATIVE_TCLSH} - @echo "Installing message catalogs" - @${NATIVE_TCLSH} $(TOOL_DIR)/installData.tcl \ - $(TOP_DIR)/library/msgs "$(SCRIPT_INSTALL_DIR)"/msgs +install-msgs: + @for i in msgs; \ + do \ + if [ ! -d "$(SCRIPT_INSTALL_DIR)"/$$i ] ; then \ + echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ + $(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)"/$$i; \ + else true; \ + fi; \ + done; + @echo "Installing message catalog files to $(SCRIPT_INSTALL_DIR)/msgs/" + @for i in $(TOP_DIR)/library/msgs/*.msg ; do \ + $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/msgs; \ + done; install-doc: doc @for i in "$(MAN_INSTALL_DIR)" "$(MAN1_INSTALL_DIR)" "$(MAN3_INSTALL_DIR)" "$(MANN_INSTALL_DIR)" ; \ do \ if [ ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ - mkdir -p "$$i"; \ - chmod 755 "$$i"; \ + $(INSTALL_DATA_DIR) "$$i"; \ else true; \ fi; \ done; @@ -904,21 +904,36 @@ install-doc: doc $(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MANN_INSTALL_DIR)"; \ done +install-headers: + @for i in "$(INCLUDE_INSTALL_DIR)"; \ + do \ + if [ ! -d "$$i" ] ; then \ + echo "Making directory $$i"; \ + $(INSTALL_DATA_DIR) "$$i"; \ + else true; \ + fi; \ + done; + @echo "Installing header files to $(INCLUDE_INSTALL_DIR)/"; + @for i in $(GENERIC_DIR)/tcl.h $(GENERIC_DIR)/tclDecls.h \ + $(GENERIC_DIR)/tclOO.h $(GENERIC_DIR)/tclOODecls.h \ + $(GENERIC_DIR)/tclPlatDecls.h \ + $(GENERIC_DIR)/tclTomMath.h \ + $(GENERIC_DIR)/tclTomMathDecls.h ; \ + do \ + $(INSTALL_DATA) $$i "$(INCLUDE_INSTALL_DIR)"; \ + done; + # Optional target to install private headers -install-private-headers: libraries +install-private-headers: @for i in "$(PRIVATE_INCLUDE_INSTALL_DIR)"; \ do \ if [ ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ - mkdir -p "$$i"; \ - chmod 755 "$$i"; \ + $(INSTALL_DATA_DIR) "$$i"; \ else true; \ fi; \ done; - @if test ! -x $(UNIX_DIR)/install-sh; then \ - chmod +x $(UNIX_DIR)/install-sh; \ - fi - @echo "Installing private header files"; + @echo "Installing private header files to $(PRIVATE_INCLUDE_INSTALL_DIR)/"; @for i in $(GENERIC_DIR)/tclInt.h $(GENERIC_DIR)/tclIntDecls.h \ $(GENERIC_DIR)/tclIntPlatDecls.h $(GENERIC_DIR)/tclPort.h \ $(GENERIC_DIR)/tclOOInt.h $(GENERIC_DIR)/tclOOIntDecls.h \ @@ -1374,6 +1389,9 @@ bn_mp_init_multi.o: $(TOMMATH_DIR)/bn_mp_init_multi.c $(MATHHDRS) bn_mp_init_set.o: $(TOMMATH_DIR)/bn_mp_init_set.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init_set.c +bn_mp_init_set_int.o: $(TOMMATH_DIR)/bn_mp_init_set_int.c $(MATHHDRS) + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init_set_int.c + bn_mp_init_size.o:$(TOMMATH_DIR)/bn_mp_init_size.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init_size.c @@ -1425,6 +1443,9 @@ bn_mp_rshd.o: $(TOMMATH_DIR)/bn_mp_rshd.c $(MATHHDRS) bn_mp_set.o: $(TOMMATH_DIR)/bn_mp_set.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_set.c +bn_mp_set_int.o: $(TOMMATH_DIR)/bn_mp_set_int.c $(MATHHDRS) + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_set_int.c + bn_mp_shrink.o: $(TOMMATH_DIR)/bn_mp_shrink.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_shrink.c @@ -2064,7 +2085,7 @@ BUILD_HTML = \ .PHONY: install-private-headers distclean depend xttest configure-packages rpm .PHONY: packages install-packages test-packages clean-packages dist-packages .PHONY: distclean-packages genstubs checkstubs checkdoc checkuchar dist html -.PHONY: checkexports alldist allpatch html-tcl html-tk +.PHONY: checkexports alldist allpatch html-tcl html-tk install-headers #-------------------------------------------------------------------------- # DO NOT DELETE THIS LINE -- make depend depends on it. diff --git a/unix/install-sh b/unix/install-sh index 8cff938..3f83ce9 100755 --- a/unix/install-sh +++ b/unix/install-sh @@ -1,124 +1,524 @@ #!/bin/sh +# install - install a program, script, or datafile + +scriptversion=2010-02-06.18; # UTC +# This originates from X11R5 (mit/util/scripts/install.sh), which was +# later released in X11R6 (xc/config/util/install.sh) with the +# following copyright and license. # -# install - install a program, script, or datafile -# This comes from X11R5; it is not part of GNU. +# Copyright (C) 1994 X Consortium +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN +# AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNEC- +# TION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +# +# Except as contained in this notice, the name of the X Consortium shall not +# be used in advertising or otherwise to promote the sale, use or other deal- +# ings in this Software without prior written authorization from the X Consor- +# tium. +# +# +# FSF changes to this file are in the public domain. # -# $XConsortium: install.sh,v 1.2 89/12/18 14:47:22 jim Exp $ +# Calling this script install-sh is preferred over install.sh, to prevent +# `make' implicit rules from creating a file called install from it +# when there is no Makefile. # # This script is compatible with the BSD install script, but was written # from scratch. -# +nl=' +' +IFS=" "" $nl" # set DOITPROG to echo to test this script # Don't use :- since 4.3BSD and earlier shells don't like it. -doit="${DOITPROG-}" +doit=${DOITPROG-} +if test -z "$doit"; then + doit_exec=exec +else + doit_exec=$doit +fi + +# Put in absolute file names if you don't have them in your path; +# or use environment vars. +chgrpprog=${CHGRPPROG-chgrp} +chmodprog=${CHMODPROG-chmod} +chownprog=${CHOWNPROG-chown} +cmpprog=${CMPPROG-cmp} +cpprog=${CPPROG-cp} +mkdirprog=${MKDIRPROG-mkdir} +mvprog=${MVPROG-mv} +rmprog=${RMPROG-rm} +stripprog=${STRIPPROG-strip} -# put in absolute paths if you don't have them in your path; or use env. vars. +posix_glob='?' +initialize_posix_glob=' + test "$posix_glob" != "?" || { + if (set -f) 2>/dev/null; then + posix_glob= + else + posix_glob=: + fi + } +' -mvprog="${MVPROG-mv}" -cpprog="${CPPROG-cp}" -chmodprog="${CHMODPROG-chmod}" -chownprog="${CHOWNPROG-chown}" -chgrpprog="${CHGRPPROG-chgrp}" -stripprog="${STRIPPROG-strip}" -rmprog="${RMPROG-rm}" +posix_mkdir= -instcmd="$mvprog" -chmodcmd="" -chowncmd="" -chgrpcmd="" -stripcmd="" +# Desired mode of installed file. +mode=0755 + +chgrpcmd= +chmodcmd=$chmodprog +chowncmd= +mvcmd=$mvprog rmcmd="$rmprog -f" -mvcmd="$mvprog" -src="" -dst="" - -while [ x"$1" != x ]; do - case $1 in - -c) instcmd="$cpprog" - shift - continue;; - - -m) chmodcmd="$chmodprog $2" - shift - shift - continue;; - - -o) chowncmd="$chownprog $2" - shift - shift - continue;; - - -g) chgrpcmd="$chgrpprog $2" - shift - shift - continue;; - - -s) stripcmd="$stripprog" - shift - continue;; - - -S) stripcmd="$stripprog $2" - shift - shift - continue;; - - *) if [ x"$src" = x ] - then - src=$1 - else - dst=$1 - fi - shift - continue;; - esac +stripcmd= + +src= +dst= +dir_arg= +dst_arg= + +copy_on_change=false +no_target_directory= + +usage="\ +Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE + or: $0 [OPTION]... SRCFILES... DIRECTORY + or: $0 [OPTION]... -t DIRECTORY SRCFILES... + or: $0 [OPTION]... -d DIRECTORIES... + +In the 1st form, copy SRCFILE to DSTFILE. +In the 2nd and 3rd, copy all SRCFILES to DIRECTORY. +In the 4th, create DIRECTORIES. + +Options: + --help display this help and exit. + --version display version info and exit. + + -c (ignored) + -C install only if different (preserve the last data modification time) + -d create directories instead of installing files. + -g GROUP $chgrpprog installed files to GROUP. + -m MODE $chmodprog installed files to MODE. + -o USER $chownprog installed files to USER. + -s $stripprog installed files. + -t DIRECTORY install into DIRECTORY. + -T report an error if DSTFILE is a directory. + +Environment variables override the default commands: + CHGRPPROG CHMODPROG CHOWNPROG CMPPROG CPPROG MKDIRPROG MVPROG + RMPROG STRIPPROG +" + +while test $# -ne 0; do + case $1 in + -c) ;; + + -C) copy_on_change=true;; + + -d) dir_arg=true;; + + -g) chgrpcmd="$chgrpprog $2" + shift;; + + --help) echo "$usage"; exit $?;; + + -m) mode=$2 + case $mode in + *' '* | *' '* | *' +'* | *'*'* | *'?'* | *'['*) + echo "$0: invalid mode: $mode" >&2 + exit 1;; + esac + shift;; + + -o) chowncmd="$chownprog $2" + shift;; + + -s) stripcmd=$stripprog;; + + -t) dst_arg=$2 + shift;; + + -T) no_target_directory=true;; + + --version) echo "$0 $scriptversion"; exit $?;; + + --) shift + break;; + + -*) echo "$0: invalid option: $1" >&2 + exit 1;; + + *) break;; + esac + shift done -if [ x"$src" = x ] -then - echo "install: no input file specified" - exit 1 +if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then + # When -d is used, all remaining arguments are directories to create. + # When -t is used, the destination is already specified. + # Otherwise, the last argument is the destination. Remove it from $@. + for arg + do + if test -n "$dst_arg"; then + # $@ is not empty: it contains at least $arg. + set fnord "$@" "$dst_arg" + shift # fnord + fi + shift # arg + dst_arg=$arg + done fi -if [ x"$dst" = x ] -then - echo "install: no destination specified" - exit 1 +if test $# -eq 0; then + if test -z "$dir_arg"; then + echo "$0: no input file specified." >&2 + exit 1 + fi + # It's OK to call `install-sh -d' without argument. + # This can happen when creating conditional directories. + exit 0 fi +if test -z "$dir_arg"; then + do_exit='(exit $ret); exit $ret' + trap "ret=129; $do_exit" 1 + trap "ret=130; $do_exit" 2 + trap "ret=141; $do_exit" 13 + trap "ret=143; $do_exit" 15 -# If destination is a directory, append the input filename; if your system -# does not like double slashes in filenames, you may need to add some logic + # Set umask so as not to create temps with too-generous modes. + # However, 'strip' requires both read and write access to temps. + case $mode in + # Optimize common cases. + *644) cp_umask=133;; + *755) cp_umask=22;; -if [ -d "$dst" ] -then - dst="$dst/`basename "$src"`" + *[0-7]) + if test -z "$stripcmd"; then + u_plus_rw= + else + u_plus_rw='% 200' + fi + cp_umask=`expr '(' 777 - $mode % 1000 ')' $u_plus_rw`;; + *) + if test -z "$stripcmd"; then + u_plus_rw= + else + u_plus_rw=,u+rw + fi + cp_umask=$mode$u_plus_rw;; + esac fi -# Make a temp file name in the proper directory. +for src +do + # Protect names starting with `-'. + case $src in + -*) src=./$src;; + esac + + if test -n "$dir_arg"; then + dst=$src + dstdir=$dst + test -d "$dstdir" + dstdir_status=$? + else + + # Waiting for this to be detected by the "$cpprog $src $dsttmp" command + # might cause directories to be created, which would be especially bad + # if $src (and thus $dsttmp) contains '*'. + if test ! -f "$src" && test ! -d "$src"; then + echo "$0: $src does not exist." >&2 + exit 1 + fi + + if test -z "$dst_arg"; then + echo "$0: no destination specified." >&2 + exit 1 + fi + + dst=$dst_arg + # Protect names starting with `-'. + case $dst in + -*) dst=./$dst;; + esac + + # If destination is a directory, append the input filename; won't work + # if double slashes aren't ignored. + if test -d "$dst"; then + if test -n "$no_target_directory"; then + echo "$0: $dst_arg: Is a directory" >&2 + exit 1 + fi + dstdir=$dst + dst=$dstdir/`basename "$src"` + dstdir_status=0 + else + # Prefer dirname, but fall back on a substitute if dirname fails. + dstdir=` + (dirname "$dst") 2>/dev/null || + expr X"$dst" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$dst" : 'X\(//\)[^/]' \| \ + X"$dst" : 'X\(//\)$' \| \ + X"$dst" : 'X\(/\)' \| . 2>/dev/null || + echo X"$dst" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q' + ` + + test -d "$dstdir" + dstdir_status=$? + fi + fi + + obsolete_mkdir_used=false + + if test $dstdir_status != 0; then + case $posix_mkdir in + '') + # Create intermediate dirs using mode 755 as modified by the umask. + # This is like FreeBSD 'install' as of 1997-10-28. + umask=`umask` + case $stripcmd.$umask in + # Optimize common cases. + *[2367][2367]) mkdir_umask=$umask;; + .*0[02][02] | .[02][02] | .[02]) mkdir_umask=22;; -dstdir="`dirname "$dst"`" -dsttmp="$dstdir"/#inst.$$# + *[0-7]) + mkdir_umask=`expr $umask + 22 \ + - $umask % 100 % 40 + $umask % 20 \ + - $umask % 10 % 4 + $umask % 2 + `;; + *) mkdir_umask=$umask,go-w;; + esac -# Move or copy the file name to the temp name + # With -d, create the new directory with the user-specified mode. + # Otherwise, rely on $mkdir_umask. + if test -n "$dir_arg"; then + mkdir_mode=-m$mode + else + mkdir_mode= + fi -$doit $instcmd "$src" "$dsttmp" + posix_mkdir=false + case $umask in + *[123567][0-7][0-7]) + # POSIX mkdir -p sets u+wx bits regardless of umask, which + # is incompatible with FreeBSD 'install' when (umask & 300) != 0. + ;; + *) + tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$ + trap 'ret=$?; rmdir "$tmpdir/d" "$tmpdir" 2>/dev/null; exit $ret' 0 -# and set any options; do chmod last to preserve setuid bits + if (umask $mkdir_umask && + exec $mkdirprog $mkdir_mode -p -- "$tmpdir/d") >/dev/null 2>&1 + then + if test -z "$dir_arg" || { + # Check for POSIX incompatibilities with -m. + # HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or + # other-writeable bit of parent directory when it shouldn't. + # FreeBSD 6.1 mkdir -m -p sets mode of existing directory. + ls_ld_tmpdir=`ls -ld "$tmpdir"` + case $ls_ld_tmpdir in + d????-?r-*) different_mode=700;; + d????-?--*) different_mode=755;; + *) false;; + esac && + $mkdirprog -m$different_mode -p -- "$tmpdir" && { + ls_ld_tmpdir_1=`ls -ld "$tmpdir"` + test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1" + } + } + then posix_mkdir=: + fi + rmdir "$tmpdir/d" "$tmpdir" + else + # Remove any dirs left behind by ancient mkdir implementations. + rmdir ./$mkdir_mode ./-p ./-- 2>/dev/null + fi + trap '' 0;; + esac;; + esac -if [ x"$chowncmd" != x ]; then $doit $chowncmd "$dsttmp"; fi -if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd "$dsttmp"; fi -if [ x"$stripcmd" != x ]; then $doit $stripcmd "$dsttmp"; fi -if [ x"$chmodcmd" != x ]; then $doit $chmodcmd "$dsttmp"; fi + if + $posix_mkdir && ( + umask $mkdir_umask && + $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir" + ) + then : + else -# Now rename the file to the real destination. + # The umask is ridiculous, or mkdir does not conform to POSIX, + # or it failed possibly due to a race condition. Create the + # directory the slow way, step by step, checking for races as we go. -$doit $rmcmd "$dst" -$doit $mvcmd "$dsttmp" "$dst" + case $dstdir in + /*) prefix='/';; + -*) prefix='./';; + *) prefix='';; + esac + eval "$initialize_posix_glob" + + oIFS=$IFS + IFS=/ + $posix_glob set -f + set fnord $dstdir + shift + $posix_glob set +f + IFS=$oIFS + + prefixes= + + for d + do + test -z "$d" && continue + + prefix=$prefix$d + if test -d "$prefix"; then + prefixes= + else + if $posix_mkdir; then + (umask=$mkdir_umask && + $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break + # Don't fail if two instances are running concurrently. + test -d "$prefix" || exit 1 + else + case $prefix in + *\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;; + *) qprefix=$prefix;; + esac + prefixes="$prefixes '$qprefix'" + fi + fi + prefix=$prefix/ + done + + if test -n "$prefixes"; then + # Don't fail if two instances are running concurrently. + (umask $mkdir_umask && + eval "\$doit_exec \$mkdirprog $prefixes") || + test -d "$dstdir" || exit 1 + obsolete_mkdir_used=true + fi + fi + fi + + if test -n "$dir_arg"; then + { test -z "$chowncmd" || $doit $chowncmd "$dst"; } && + { test -z "$chgrpcmd" || $doit $chgrpcmd "$dst"; } && + { test "$obsolete_mkdir_used$chowncmd$chgrpcmd" = false || + test -z "$chmodcmd" || $doit $chmodcmd $mode "$dst"; } || exit 1 + else + + # Make a couple of temp file names in the proper directory. + dsttmp=$dstdir/_inst.$$_ + rmtmp=$dstdir/_rm.$$_ + + # Trap to clean up those temp files at exit. + trap 'ret=$?; rm -f "$dsttmp" "$rmtmp" && exit $ret' 0 + + # Copy the file name to the temp name. + (umask $cp_umask && $doit_exec $cpprog "$src" "$dsttmp") && + + # and set any options; do chmod last to preserve setuid bits. + # + # If any of these fail, we abort the whole thing. If we want to + # ignore errors from any of these, just make sure not to ignore + # errors from the above "$doit $cpprog $src $dsttmp" command. + # + { test -z "$chowncmd" || $doit $chowncmd "$dsttmp"; } && + { test -z "$chgrpcmd" || $doit $chgrpcmd "$dsttmp"; } && + { test -z "$stripcmd" || $doit $stripcmd "$dsttmp"; } && + { test -z "$chmodcmd" || $doit $chmodcmd $mode "$dsttmp"; } && + + # If -C, don't bother to copy if it wouldn't change the file. + if $copy_on_change && + old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` && + new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` && + + eval "$initialize_posix_glob" && + $posix_glob set -f && + set X $old && old=:$2:$4:$5:$6 && + set X $new && new=:$2:$4:$5:$6 && + $posix_glob set +f && + + test "$old" = "$new" && + $cmpprog "$dst" "$dsttmp" >/dev/null 2>&1 + then + rm -f "$dsttmp" + else + # Rename the file to the real destination. + $doit $mvcmd -f "$dsttmp" "$dst" 2>/dev/null || + + # The rename failed, perhaps because mv can't rename something else + # to itself, or perhaps because mv is so ancient that it does not + # support -f. + { + # Now remove or move aside any old file at destination location. + # We try this two ways since rm can't unlink itself on some + # systems and the destination file might be busy for other + # reasons. In this case, the final cleanup might fail but the new + # file should still install successfully. + { + test ! -f "$dst" || + $doit $rmcmd -f "$dst" 2>/dev/null || + { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null && + { $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; } + } || + { echo "$0: cannot unlink or rename $dst" >&2 + (exit 1); exit 1 + } + } && + + # Now rename the file to the real destination. + $doit $mvcmd "$dsttmp" "$dst" + } + fi || exit 1 + + trap '' 0 + fi +done -exit 0 +# Local variables: +# eval: (add-hook 'write-file-hooks 'time-stamp) +# time-stamp-start: "scriptversion=" +# time-stamp-format: "%:y-%02m-%02d.%02H" +# time-stamp-time-zone: "UTC" +# time-stamp-end: "; # UTC" +# End: diff --git a/win/.cvsignore b/win/.cvsignore index c3044c9..90b96de 100644 --- a/win/.cvsignore +++ b/win/.cvsignore @@ -29,3 +29,4 @@ tcl.suo *.pch versions.vc vercl.x +Release_VC* diff --git a/win/Makefile.in b/win/Makefile.in index ed7377a..2d1c4c4 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -4,7 +4,7 @@ # "./configure", which is a configuration script generated by the "autoconf" # program (constructs like "@foo@" will get replaced in the actual Makefile. # -# RCS: @(#) $Id: Makefile.in,v 1.184.2.1 2010/09/21 19:32:26 kennykb Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.184.2.2 2010/12/01 16:42:37 kennykb Exp $ VERSION = @TCL_VERSION@ @@ -252,6 +252,7 @@ GENERIC_OBJS = \ tclListObj.$(OBJEXT) \ tclLoad.$(OBJEXT) \ tclMain.$(OBJEXT) \ + tclMain2.$(OBJEXT) \ tclNamesp.$(OBJEXT) \ tclNotify.$(OBJEXT) \ tclOO.$(OBJEXT) \ @@ -318,6 +319,7 @@ TOMMATH_OBJS = \ bn_mp_init_copy.${OBJEXT} \ bn_mp_init_multi.${OBJEXT} \ bn_mp_init_set.${OBJEXT} \ + bn_mp_init_set_int.${OBJEXT} \ bn_mp_init_size.${OBJEXT} \ bn_mp_karatsuba_mul.${OBJEXT} \ bn_mp_karatsuba_sqr.$(OBJEXT) \ @@ -335,6 +337,7 @@ TOMMATH_OBJS = \ bn_mp_read_radix.${OBJEXT} \ bn_mp_rshd.${OBJEXT} \ bn_mp_set.${OBJEXT} \ + bn_mp_set_int.${OBJEXT} \ bn_mp_shrink.${OBJEXT} \ bn_mp_sqr.${OBJEXT} \ bn_mp_sqrt.${OBJEXT} \ @@ -500,6 +503,9 @@ tclWinPipe.${OBJEXT}: tclWinPipe.c testMain.${OBJEXT}: tclAppInit.c $(CC) -c $(CC_SWITCHES) -DTCL_TEST @DEPARG@ $(CC_OBJNAME) +tclMain2.${OBJEXT}: tclMain.c + $(CC) -c $(CC_SWITCHES) -DBUILD_tcl -DTCL_ASCII_MAIN @DEPARG@ $(CC_OBJNAME) + # TIP #59, embedding of configuration information into the binary library. # # Part of Tcl's configuration information are the paths where it was installed @@ -8,9 +8,15 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: cat.c,v 1.5 2010/01/13 06:46:56 nijtmans Exp $ + * RCS: @(#) $Id: cat.c,v 1.5.4.1 2010/12/01 16:42:37 kennykb Exp $ */ +#ifdef TCL_BROKEN_MAINARGS +/* On mingw32 and cygwin this doesn't work */ +# undef UNICODE +# undef _UNICODE +#endif + #include <stdio.h> #ifdef __CYGWIN__ # include <unistd.h> @@ -18,9 +24,10 @@ # include <io.h> #endif #include <string.h> +#include <tchar.h> int -main(void) +_tmain(void) { char buf[1024]; int n; diff --git a/win/configure b/win/configure index f6f8b81..472ad1b 100755 --- a/win/configure +++ b/win/configure @@ -4047,6 +4047,72 @@ echo "$as_me: WARNING: 64bit mode not supported with GCC on Windows" >&2;} rm -f ac$$.o ac$$.c fi + hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -mwindows -municode -Dmain=xxmain" + echo "$as_me:$LINENO: checking for working -municode linker flag" >&5 +echo $ECHO_N "checking for working -municode linker flag... $ECHO_C" >&6 +if test "${ac_cv_municode+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + + #include <windows.h> + int APIENTRY wWinMain(HINSTANCE a, HINSTANCE b, LPWSTR c, int d) {return 0;} + +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_municode=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_municode=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + +fi +echo "$as_me:$LINENO: result: $ac_cv_municode" >&5 +echo "${ECHO_T}$ac_cv_municode" >&6 + CFLAGS=$hold_cflags + if test "$ac_cv_municode" = "yes" ; then + extra_ldflags="$extra_ldflags -municode" + else + extra_cflags="$extra_cflags -DTCL_BROKEN_MAINARGS" + fi + if test "${SHARED_BUILD}" = "0" ; then # static echo "$as_me:$LINENO: result: using static flags" >&5 @@ -4461,6 +4527,10 @@ else ZLIB_OBJS=\${ZLIB_OBJS} + cat >>confdefs.h <<_ACEOF +#define NO_VIZ 1 +_ACEOF + fi diff --git a/win/configure.in b/win/configure.in index 0074038..e3a175a 100644 --- a/win/configure.in +++ b/win/configure.in @@ -3,7 +3,7 @@ # generate the file "configure", which is run during Tcl installation # to configure the system for the local environment. # -# RCS: @(#) $Id: configure.in,v 1.123.2.1 2010/09/28 15:43:01 kennykb Exp $ +# RCS: @(#) $Id: configure.in,v 1.123.2.2 2010/12/01 16:42:37 kennykb Exp $ AC_INIT(../generic/tcl.h) AC_PREREQ(2.59) @@ -326,6 +326,7 @@ AS_IF([test "$tcl_ok" = "yes"], [ AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR}/win32/zdll.lib]) ], [ AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}]) + AC_DEFINE_UNQUOTED(NO_VIZ, 1) ]) AC_DEFINE(HAVE_ZLIB, 1, [Is there an installed zlib?]) diff --git a/win/makefile.vc b/win/makefile.vc index 4586c14..cfa8770 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -13,7 +13,7 @@ # Copyright (c) 2003-2008 Pat Thoyts. # #------------------------------------------------------------------------------ -# RCS: @(#) $Id: makefile.vc,v 1.214.2.2 2010/10/20 01:50:19 kennykb Exp $ +# RCS: @(#) $Id: makefile.vc,v 1.214.2.3 2010/12/01 16:42:37 kennykb Exp $ #------------------------------------------------------------------------------ # Check to see we are configured to build with MSVC (MSDEVDIR or MSVCDIR) @@ -290,6 +290,7 @@ COREOBJS = \ $(TMP_DIR)\tclLiteral.obj \ $(TMP_DIR)\tclLoad.obj \ $(TMP_DIR)\tclMain.obj \ + $(TMP_DIR)\tclMain2.obj \ $(TMP_DIR)\tclNamesp.obj \ $(TMP_DIR)\tclNotify.obj \ $(TMP_DIR)\tclOO.obj \ @@ -369,6 +370,7 @@ TOMMATHOBJS = \ $(TMP_DIR)\bn_mp_init_copy.obj \ $(TMP_DIR)\bn_mp_init_multi.obj \ $(TMP_DIR)\bn_mp_init_set.obj \ + $(TMP_DIR)\bn_mp_init_set_int.obj \ $(TMP_DIR)\bn_mp_init_size.obj \ $(TMP_DIR)\bn_mp_karatsuba_mul.obj \ $(TMP_DIR)\bn_mp_karatsuba_sqr.obj \ @@ -386,6 +388,7 @@ TOMMATHOBJS = \ $(TMP_DIR)\bn_mp_read_radix.obj \ $(TMP_DIR)\bn_mp_rshd.obj \ $(TMP_DIR)\bn_mp_set.obj \ + $(TMP_DIR)\bn_mp_set_int.obj \ $(TMP_DIR)\bn_mp_shrink.obj \ $(TMP_DIR)\bn_mp_sqr.obj \ $(TMP_DIR)\bn_mp_sqrt.obj \ @@ -897,6 +900,10 @@ $(TMP_DIR)\testMain.obj: $(WINDIR)\tclAppInit.c -DTCL_USE_STATIC_PACKAGES=$(TCL_USE_STATIC_PACKAGES) \ -Fo$@ $? +$(TMP_DIR)\tclMain2.obj: $(GENERICDIR)\tclMain.c + $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -DTCL_ASCII_MAIN \ + -Fo$@ $? + $(TMP_DIR)\tclTest.obj: $(GENERICDIR)\tclTest.c $(cc32) $(TCL_CFLAGS) -Fo$@ $? @@ -495,6 +495,24 @@ file for information about building with Mingw.]) rm -f ac$$.o ac$$.c fi + hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -mwindows -municode -Dmain=xxmain" + AC_CACHE_CHECK(for working -municode linker flag, + ac_cv_municode, + AC_TRY_LINK([ + #include <windows.h> + int APIENTRY wWinMain(HINSTANCE a, HINSTANCE b, LPWSTR c, int d) {return 0;} + ], + [], + ac_cv_municode=yes, + ac_cv_municode=no) + ) + CFLAGS=$hold_cflags + if test "$ac_cv_municode" = "yes" ; then + extra_ldflags="$extra_ldflags -municode" + else + extra_cflags="$extra_cflags -DTCL_BROKEN_MAINARGS" + fi + if test "${SHARED_BUILD}" = "0" ; then # static AC_MSG_RESULT([using static flags]) diff --git a/win/tclAppInit.c b/win/tclAppInit.c index 6711384..eb4347b 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -12,15 +12,9 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclAppInit.c,v 1.31.2.1 2010/09/25 14:51:13 kennykb Exp $ + * RCS: @(#) $Id: tclAppInit.c,v 1.31.2.2 2010/12/01 16:42:38 kennykb Exp $ */ -/* TODO: This file does not compile in UNICODE mode. - * See [Freq 2965056]: Windows build with -DUNICODE - */ -#undef UNICODE -#undef _UNICODE - #include "tcl.h" #define WIN32_LEAN_AND_MEAN #include <windows.h> @@ -34,9 +28,15 @@ extern Tcl_PackageInitProc Tcltest_Init; extern Tcl_PackageInitProc Tcltest_SafeInit; #endif /* TCL_TEST */ -#if defined(__GNUC__) +#if defined(STATIC_BUILD) && TCL_USE_STATIC_PACKAGES +extern Tcl_PackageInitProc Registry_Init; +extern Tcl_PackageInitProc Dde_Init; +extern Tcl_PackageInitProc Dde_SafeInit; +#endif + +#ifdef TCL_BROKEN_MAINARGS static void setargv(int *argcPtr, TCHAR ***argvPtr); -#endif /* __GNUC__ */ +#endif /* * The following #if block allows you to change the AppInit function by using @@ -76,11 +76,20 @@ extern int TCL_LOCAL_MAIN_HOOK(int *argc, TCHAR ***argv); *---------------------------------------------------------------------- */ +#ifdef TCL_BROKEN_MAINARGS +int +main( + int argc, + char *dummy[]) +{ + TCHAR **argv; +#else int _tmain( int argc, TCHAR *argv[]) { +#endif TCHAR *p; /* @@ -90,11 +99,11 @@ _tmain( setlocale(LC_ALL, "C"); +#ifdef TCL_BROKEN_MAINARGS /* * Get our args from the c-runtime. Ignore lpszCmdLine. */ -#if defined(__GNUC__) setargv(&argc, &argv); #endif @@ -144,21 +153,15 @@ Tcl_AppInit( } #if defined(STATIC_BUILD) && TCL_USE_STATIC_PACKAGES - { - extern Tcl_PackageInitProc Registry_Init; - extern Tcl_PackageInitProc Dde_Init; - extern Tcl_PackageInitProc Dde_SafeInit; - - if (Registry_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } - Tcl_StaticPackage(interp, "registry", Registry_Init, NULL); + if (Registry_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + Tcl_StaticPackage(interp, "registry", Registry_Init, NULL); - if (Dde_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } - Tcl_StaticPackage(interp, "dde", Dde_Init, Dde_SafeInit); - } + if (Dde_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + Tcl_StaticPackage(interp, "dde", Dde_Init, Dde_SafeInit); #endif #ifdef TCL_TEST @@ -223,7 +226,7 @@ Tcl_AppInit( *-------------------------------------------------------------------------- */ -#if defined(__GNUC__) +#ifdef TCL_BROKEN_MAINARGS static void setargv( int *argcPtr, /* Filled with number of argument strings. */ @@ -252,10 +255,15 @@ setargv( } } } + + /* Make sure we don't call ckalloc through the (not yet initialized) stub table */ + #undef Tcl_Alloc + #undef Tcl_DbCkalloc + argSpace = (TCHAR *) ckalloc( - (unsigned) (size * sizeof(TCHAR *) + (_tcslen(cmdLine) * sizeof(TCHAR)) + 1)); + (unsigned) (size * sizeof(char *) + (_tcslen(cmdLine) * sizeof(TCHAR)) + sizeof(TCHAR))); argv = (TCHAR **) argSpace; - argSpace += size * sizeof(TCHAR *); + argSpace += size * (sizeof(char *)/sizeof(TCHAR)); size--; p = cmdLine; @@ -305,7 +313,7 @@ setargv( } p++; } - *arg = TEXT('\0'); + *arg = '\0'; argSpace = arg + 1; } argv[argc] = NULL; @@ -313,7 +321,7 @@ setargv( *argcPtr = argc; *argvPtr = argv; } -#endif /* __GNUC__ */ +#endif /* TCL_BROKEN_MAINARGS */ /* * Local Variables: diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index 673d811..eb19cea 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.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: tclWin32Dll.c,v 1.68.2.1 2010/10/20 01:50:19 kennykb Exp $ + * RCS: @(#) $Id: tclWin32Dll.c,v 1.68.2.2 2010/12/01 16:42:38 kennykb Exp $ */ #include "tclWinInt.h" @@ -522,7 +522,7 @@ TclWinDriveLetterForVolMountPoint( */ Tcl_MutexUnlock(&mountPointMap); - return dlIter->driveLetter; + return (char) dlIter->driveLetter; } } @@ -602,7 +602,7 @@ TclWinDriveLetterForVolMountPoint( dlIter = dlIter->nextPtr) { if (_tcscmp(dlIter->volumeName, mountPoint) == 0) { Tcl_MutexUnlock(&mountPointMap); - return dlIter->driveLetter; + return (char) dlIter->driveLetter; } } @@ -718,7 +718,7 @@ TclWinCPUID( unsigned int index, /* Which CPUID value to retrieve. */ unsigned int *regsPtr) /* Registers after the CPUID. */ { -#ifdef HAVE_NO_SEH +#if defined(__GNUC__) && !defined(_WIN64) EXCEPTION_REGISTRATION registration; #endif int status = TCL_ERROR; diff --git a/win/tclWinChan.c b/win/tclWinChan.c index 37e9011..caa0c9f 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinChan.c,v 1.59 2010/09/13 14:20:39 nijtmans Exp $ + * RCS: @(#) $Id: tclWinChan.c,v 1.59.2.1 2010/12/01 16:42:38 kennykb Exp $ */ #include "tclWinInt.h" @@ -1027,7 +1027,7 @@ Tcl_MakeFileChannel( int mode) /* ORed combination of TCL_READABLE and * TCL_WRITABLE to indicate file mode. */ { -#ifdef HAVE_NO_SEH +#if defined(HAVE_NO_SEH) && !defined(_WIN64) EXCEPTION_REGISTRATION registration; #endif char channelName[16 + TCL_INTEGER_SPACE]; diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index 3856ffa..149e135 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinFCmd.c,v 1.67.2.2 2010/10/20 01:50:19 kennykb Exp $ + * RCS: @(#) $Id: tclWinFCmd.c,v 1.67.2.3 2010/12/01 16:42:38 kennykb Exp $ */ #include "tclWinInt.h" @@ -177,7 +177,7 @@ DoRenameFile( const TCHAR *nativeDst) /* New pathname for file or directory * (native). */ { -#ifdef HAVE_NO_SEH +#if defined(HAVE_NO_SEH) && !defined(_WIN64) EXCEPTION_REGISTRATION registration; #endif DWORD srcAttr, dstAttr; @@ -564,7 +564,7 @@ DoCopyFile( const TCHAR *nativeSrc, /* Pathname of file to be copied (native). */ const TCHAR *nativeDst) /* Pathname of file to copy to (native). */ { -#ifdef HAVE_NO_SEH +#if defined(HAVE_NO_SEH) && !defined(_WIN64) EXCEPTION_REGISTRATION registration; #endif int retval = -1; @@ -1278,7 +1278,7 @@ TraverseWinTree( return traverseProc(nativeSource, nativeTarget, DOTREE_F, errorPtr); } - Tcl_DStringAppend(sourcePtr, (char *) L"\\*.*", 4 * sizeof(WCHAR) + 1); + Tcl_DStringAppend(sourcePtr, (char *) TEXT("\\*.*"), 4 * sizeof(TCHAR) + 1); Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1); nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr); @@ -1302,15 +1302,15 @@ TraverseWinTree( return result; } - sourceLen = oldSourceLen + sizeof(WCHAR); - Tcl_DStringAppend(sourcePtr, (char *) L"\\", sizeof(WCHAR) + 1); + sourceLen = oldSourceLen + sizeof(TCHAR); + Tcl_DStringAppend(sourcePtr, (char *) TEXT("\\"), sizeof(TCHAR) + 1); Tcl_DStringSetLength(sourcePtr, sourceLen); if (targetPtr != NULL) { oldTargetLen = Tcl_DStringLength(targetPtr); targetLen = oldTargetLen; - targetLen += sizeof(WCHAR); - Tcl_DStringAppend(targetPtr, (char *) L"\\", sizeof(WCHAR) + 1); + targetLen += sizeof(TCHAR); + Tcl_DStringAppend(targetPtr, (char *) TEXT("\\"), sizeof(TCHAR) + 1); Tcl_DStringSetLength(targetPtr, targetLen); } @@ -1319,7 +1319,7 @@ TraverseWinTree( TCHAR *nativeName; int len; - WCHAR *wp = data.cFileName; + TCHAR *wp = data.cFileName; if (*wp == '.') { wp++; if (*wp == '.') { @@ -1330,7 +1330,7 @@ TraverseWinTree( } } nativeName = (TCHAR *) data.cFileName; - len = wcslen(data.cFileName) * sizeof(WCHAR); + len = _tcslen(data.cFileName) * sizeof(TCHAR); /* * Append name after slash, and recurse on the file. diff --git a/win/tclWinFile.c b/win/tclWinFile.c index ab4eb76..1858756 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.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: tclWinFile.c,v 1.112.2.2 2010/10/20 01:50:19 kennykb Exp $ + * RCS: @(#) $Id: tclWinFile.c,v 1.112.2.3 2010/12/01 16:42:38 kennykb Exp $ */ #include "tclWinInt.h" @@ -573,6 +573,7 @@ WinReadLinkDirectory( */ offset = 0; +#ifdef UNICODE if (reparseBuffer->MountPointReparseBuffer.PathBuffer[0] == L'\\') { /* * Check whether this is a mounted volume. @@ -634,6 +635,7 @@ WinReadLinkDirectory( offset = 4; } } +#endif /* UNICODE */ Tcl_WinTCharToUtf((const TCHAR *) reparseBuffer->MountPointReparseBuffer.PathBuffer, @@ -1712,19 +1714,19 @@ static int NativeIsExec( const TCHAR *path) { - int len = wcslen(path); + int len = _tcslen(path); if (len < 5) { return 0; } - if (path[len-4] != L'.') { + if (path[len-4] != TEXT('.')) { return 0; } - if ((_wcsicmp(path+len-3, L"exe") == 0) - || (_wcsicmp(path+len-3, L"com") == 0) - || (_wcsicmp(path+len-3, L"bat") == 0)) { + if ((_tcsicmp(path+len-3, TEXT("exe")) == 0) + || (_tcsicmp(path+len-3, TEXT("com")) == 0) + || (_tcsicmp(path+len-3, TEXT("bat")) == 0)) { return 1; } return 0; @@ -3128,7 +3130,7 @@ TclNativeDupInternalRep( return NULL; } - len = sizeof(TCHAR) * (_tcslen((const WCHAR *) clientData) + 1); + len = sizeof(TCHAR) * (_tcslen((const TCHAR *) clientData) + 1); copy = (char *) ckalloc(len); memcpy(copy, clientData, len); diff --git a/win/tclWinPort.h b/win/tclWinPort.h index 689cc14..fdede5b 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.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: tclWinPort.h,v 1.61.2.1 2010/09/28 15:43:01 kennykb Exp $ + * RCS: @(#) $Id: tclWinPort.h,v 1.61.2.2 2010/12/01 16:42:38 kennykb Exp $ */ #ifndef _TCLWINPORT @@ -58,6 +58,10 @@ typedef _TCHAR TCHAR; # define _TCHAR_DEFINED #endif +#if defined(_MSC_VER) && defined(__STDC__) + /* VS2005 SP1 misses this. See [Bug #3110161] */ + typedef _TCHAR TCHAR; +#endif /* *--------------------------------------------------------------------------- diff --git a/win/tclWinReg.c b/win/tclWinReg.c index 3bc4ae3..f59ee23 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.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: tclWinReg.c,v 1.54.2.1 2010/10/20 01:50:19 kennykb Exp $ + * RCS: @(#) $Id: tclWinReg.c,v 1.54.2.2 2010/12/01 16:42:38 kennykb Exp $ */ #undef STATIC_BUILD @@ -1491,34 +1491,12 @@ AppendSystemError( MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (TCHAR *) tMsgPtrPtr, 0, NULL); if (length == 0) { - char *msgPtr; - - length = FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM - | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error, - MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (char *) &msgPtr, - 0, NULL); - if (length > 0) { - tMsgPtr = (TCHAR *) - LocalAlloc(LPTR, (length + 1) * sizeof(TCHAR)); - MultiByteToWideChar(CP_ACP, 0, msgPtr, length + 1, tMsgPtr, - length + 1); - LocalFree(msgPtr); - } - } - if (length == 0) { - if (error == ERROR_CALL_NOT_IMPLEMENTED) { - strcpy(msgBuf, "function not supported under Win32s"); - } else { - sprintf(msgBuf, "unknown error: %ld", error); - } + sprintf(msgBuf, "unknown error: %ld", error); msg = msgBuf; } else { - Tcl_Encoding encoding; char *msgPtr; - encoding = Tcl_GetEncoding(NULL, "unicode"); - Tcl_ExternalToUtfDString(encoding, (char *) tMsgPtr, -1, &ds); - Tcl_FreeEncoding(encoding); + Tcl_WinTCharToUtf(tMsgPtr, -1, &ds); LocalFree(tMsgPtr); msgPtr = Tcl_DStringValue(&ds); |