diff options
159 files changed, 5142 insertions, 2715 deletions
@@ -1,3 +1,169 @@ +2011-01-26 Donal K. Fellows <dkf@users.sf.net> + + * doc/RegExp.3: [Bug 3165108]: Corrected documentation of description + of subexpression info in Tcl_RegExpInfo structure. + +2011-01-25 Jan Nijtmans <nijtmans@users.sf.net> + + * generic/tclPreserve.c: Don't miss 64-bit address bits in panic + message. + * win/tclWinChan.c: Fix various gcc-4.5.2 64-bit warning messages + * win/tclWinConsole.c e.g. by using full 64-bits for socket fd's + * win/tclWinDde.c + * win/tclWinPipe.c + * win/tclWinReg.c + * win/tclWinSerial.c + * win/tclWinSock.c + * win/tclWinThrd.c + +2011-01-19 Jan Nijtmans <nijtmans@users.sf.net> + + * tools/genStubs.tcl: [Enh #3159920]: Tcl_ObjPrintf() crashes with + * generic/tcl.decls bad format specifier. + * generic/tcl.h + * generic/tclDecls.h + +2011-01-18 Donal K. Fellows <dkf@users.sf.net>3159920 + + * generic/tclOOMethod.c (PushMethodCallFrame): [Bug 3001438]: Make + sure that the cmdPtr field of the procPtr is correct and relevant at + all times so that [info frame] can report sensible information about a + frame after a return to it from a recursive call, instead of probably + crashing (depending on what else has overwritten the Tcl stack!) + +2011-01-18 Jan Nijtmans <nijtmans@users.sf.net> + + * generic/tclBasic.c: Various mismatches between Tcl_Panic + * generic/tclCompCmds.c: format string and its arguments, + * generic/tclCompCmdsSZ.c: discovered thanks to [Bug 3159920] + * generic/tclCompExpr.c + * generic/tclEnsemble.c + * generic/tclPreserve.c + * generic/tclTest.c + +2011-01-17 Jan Nijtmans <nijtmans@users.sf.net> + + * generic/tclIOCmd.c: [Bug 3148192]: Commands "read/puts" incorrectly + * tests/chanio.test: interpret parameters. Improved error-message + * tests/io.test regarding legacy form. + * tests/ioCmd.test + +2011-01-15 Kevin B. Kenny <kennykb@acm.org> + + * doc/tclvars.n: + * generic/tclStrToD.c: + * generic/tclUtil.c (Tcl_PrintDouble): + * tests/util.test (util-16.*): [Bug 3157475]: Restored full Tcl 8.4 + compatibility for the formatting of floating point numbers when + $::tcl_precision is not zero. Added compatibility tests to make sure + that excess trailing zeroes are suppressed for all eight major code + paths. + +2011-01-12 Jan Nijtmans <nijtmans@users.sf.net> + + * win/tclWinFile.c: Use _vsnprintf in stead of vsnprintf, because + MSVC 6 doesn't have it. Reported by andreask. + * win/tcl.m4: handle --enable-64bit=ia64 for gcc + * win/configure.in: more accurate test for correct <intrin.h> + * win/configure: (autoconf-2.59) + * win/tclWin32Dll.c: VS 2005 64-bit does not have intrin.h, and + * generic/tclPanic.c: does not need it. + +2011-01-07 Kevin B. Kenny <kennykb@acm.org> + + * tests/util.test (util-15.*): Added test cases for floating point + conversion of the largest denormal and the smallest normal number, + to avoid any possibility of the failure suffered by PHP in the + last couple of days. (They didn't fail, so no actual functional + change.) + +2011-01-05 Donal K. Fellows <dkf@users.sf.net> + + * tests/package.test, tests/pkg.test: Coalesce these tests into one + file that is concerned with the package system. Convert to use + tcltest2 properly. + * tests/autoMkindex.test, tests/pkgMkIndex.test: Convert to use + tcltest2 properly. + +2011-01-01 Donal K. Fellows <dkf@users.sf.net> + + * tests/cmdAH.test, tests/cmdMZ.test, tests/compExpr.test, + * tests/compile.test, tests/concat.test, tests/eval.test, + * tests/fileName.test, tests/fileSystem.test, tests/interp.test, + * tests/lsearch.test, tests/namespace-old.test, tests/namespace.test, + * tests/oo.test, tests/proc.test, tests/security.test, + * tests/switch.test, tests/unixInit.test, tests/var.test, + * tests/winDde.test, tests/winPipe.test: Clean up of tests and + conversion to tcltest 2. Target has been to get init and cleanup code + out of the test body and into the -setup/-cleanup stanzas. + + * tests/execute.test (execute-11.1): [Bug 3142026]: Added test that + fails (with a crash) in an unfixed memdebug build on 64-bit systems. + +2010-12-31 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclCmdIL.c (SortElement): Use unions properly in the + definition of this structure so that there is no need to use nasty + int/pointer type punning. Made it clearer what the purposes of the + various parts of the structure are. + +2010-12-31 Jan Nijtmans <nijtmans@users.sf.net> + + * unix/dltest/*.c: [Bug 3148192]: Fix broken [load] tests by ensuring + that the affected files are never compiled with -DSTATIC_BUILD. + +2010-12-30 Miguel Sofer <msofer@users.sf.net> + + * generic/tclExecute.c (GrowEvaluationStack): Off-by-one error in + sizing the new allocation - was ok in comment but wrong in the code. + Triggered by [Bug 3142026] which happened to require exactly one more + than what was in existence. + +2010-12-26 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclCmdIL.c (Tcl_LsortObjCmd): Fix crash when multiple -index + options are used. Simplified memory handling logic. + +2010-12-20 Jan Nijtmans <nijtmans@users.sf.net> + + * win/tclWin32Dll.c: [Patch 3059922]: fixes for mingw64 - gcc4.5.1 + tdm64-1: completed for all environments. + +2010-12-20 Jan Nijtmans <nijtmans@users.sf.net> + + * win/configure.in: Explicitely test for intrinsics support in + compiler, before assuming only MSVC has it. + * win/configure: (autoconf-2.59) + * generic/tclPanic.c: + +2010-12-19 Jan Nijtmans <nijtmans@users.sf.net> + + * win/tclWin32Dll.c: [Patch 3059922]: fixes for mingw64 - gcc4.5.1 + tdm64-1: Fixed for gcc, not yet for MSVC 64-bit. + +2010-12-17 Stuart Cassoff <stwo@users.sourceforge.net> + + * unix/Makefile.in: Remove unwanted/obsolete 'ddd' target. + +2010-12-17 Stuart Cassoff <stwo@users.sourceforge.net> + + * unix/Makefile.in: Clean up '.PHONY:' targets: Arrange those + common to Tcl and Tk as in Tk's Makefile.in, + add any missing ones and remove duplicates. + +2010-12-17 Stuart Cassoff <stwo@users.sourceforge.net> + + * unix/Makefile.in: [Bug 2446711]: Remove 'allpatch' target. + +2010-12-17 Stuart Cassoff <stwo@users.sourceforge.net> + + * unix/Makefile.in: [Bug 2537626]: Use 'rpmbuild', not 'rpm'. + +2010-12-16 Jan Nijtmans <nijtmans@users.sf.net> + + * generic/tclPanic.c: [Patch 3124554]: Move WishPanic from Tk to Tcl + * win/tclWinFile.c: Better communication with debugger, if present. + 2010-12-15 Kevin B. Kenny <kennykb@acm.org> [dogeen-assembler-branch] @@ -8,27 +174,28 @@ handling that appeared in the discussion of [Bug 3098302] and in tcl-core traffic beginning about 2010-10-29. -2010-12-14 Jan Nijtmans <nijtmans@users.sf.net> +2010-12-15 Jan Nijtmans <nijtmans@users.sf.net> * generic/tclPanic.c: Restore abort() as it was before. - * win/tclWinFile.c: [Patch 3124554] use ExitProcess() here, like + * win/tclWinFile.c: [Patch 3124554]: Use ExitProcess() here, like in wish. 2010-12-14 Jan Nijtmans <nijtmans@users.sf.net> - * generic/tcl.h: [Bug 3137454]: Tcl CVS HEAD does not build on GCC 3 + * generic/tcl.h: [Bug 3137454]: Tcl CVS HEAD does not build + on GCC 3. 2010-12-14 Reinhard Max <max@suse.de> * win/tclWinSock.c (CreateSocket): Swap the loops over - * unix/tclUnixSock.c (CreateClientSocket): local and remote - addresses, so that the system's address preference for the remote - side decides which family gets tried first. Cleanup and clarify - some of the comments. + * unix/tclUnixSock.c (CreateClientSocket): local and remote addresses, + so that the system's address preference for the remote side decides + which family gets tried first. Cleanup and clarify some of the + comments. 2010-12-13 Jan Nijtmans <nijtmans@users.sf.net> - * generic/tcl.h: [Bug 3135271] Link error due to hidden + * generic/tcl.h: [Bug 3135271]: Link error due to hidden * unix/tcl.m4: symbols (CentOS 4.2) * unix/configure: (autoconf-2.59) * win/tclWinFile.c: Undocumented feature, only meant to be @@ -52,7 +219,8 @@ 2010-12-10 Alexandre Ferrieux <ferrieux@users.sourceforge.net> * generic/tclIO.c: Make sure [fcopy -size ... -command ...] always - * tests/io.test: calls the callback asynchronously, even for size zero. + * tests/io.test: calls the callback asynchronously, even for size + zero. 2010-12-10 Jan Nijtmans <nijtmans@users.sf.net> @@ -64,14 +232,16 @@ * generic/tclIndexObj.c: * generic/tclIOCmd.c: * generic/tclVar.c: - * win/tcl.m4: Fix manifest-generation for 64-bit gcc (mingw-w64) - * win/configure.in: Check for availability of intptr_t and uintptr_t + * win/tcl.m4: Fix manifest-generation for 64-bit gcc + (mingw-w64) + * win/configure.in: Check for availability of intptr_t and + uintptr_t * win/configure: (autoconf-2.59) - * generic/tclInt.decls: Change first parameter of TclSockMinimumBuffers to - * generic/tclIntDecls.h: ClientData, and TclWin(Get|Set)SockOpt to SOCKET, - * generic/tclIntPlatDecls.h:because on Win64 those are 64-bit, which does not fit. - * generic/tclIOSock.c: - * win/tclWinSock.c: + * generic/tclInt.decls: Change 1st param of TclSockMinimumBuffers + * generic/tclIntDecls.h: to ClientData, and TclWin(Get|Set)SockOpt + * generic/tclIntPlatDecls.h:to SOCKET, because on Win64 those are + * generic/tclIOSock.c: 64-bit, which does not fit. + * win/tclWinSock.c: * unix/tclUnixSock.c: 2010-12-09 Donal K. Fellows <dkf@users.sf.net> @@ -677,6 +847,8 @@ * generic/tclVar.c: Use the macro HasLocalVars everywhere +2010-09-26 Miguel Sofer <msofer@users.sf.net> + * generic/tclOOMethod.c (ProcedureMethodVarResolver): avoid code duplication, let the runtime var resolver call the compiled var resolver. @@ -1,6 +1,6 @@ Recent user-visible changes to Tcl: -RCS: @(#) $Id: changes,v 1.149.2.1 2010/12/01 16:42:33 kennykb Exp $ +RCS: @(#) $Id: changes,v 1.151 2010/11/10 17:43:33 andreas_kupries Exp $ 1. No more [command1] [command2] construct for grouping multiple commands on a single command line. diff --git a/doc/RegExp.3 b/doc/RegExp.3 index 2c999ea..5c7d819 100644 --- a/doc/RegExp.3 +++ b/doc/RegExp.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: RegExp.3,v 1.29 2008/06/29 22:28:24 dkf Exp $ +'\" RCS: @(#) $Id: RegExp.3,v 1.30 2011/01/26 13:18:42 dkf Exp $ '\" .so man.macros .TH Tcl_RegExpMatch 3 8.1 Tcl "Tcl Library Procedures" @@ -348,7 +348,7 @@ typedef struct Tcl_RegExpInfo { The \fInsubs\fR field contains a count of the number of parenthesized subexpressions within the regular expression. If the \fBTCL_REG_NOSUB\fR was used, then this value will be zero. The \fImatches\fR field -points to an array of \fInsubs\fR values that indicate the bounds of each +points to an array of \fInsubs\fR+1 values that indicate the bounds of each subexpression matched. The first element in the array refers to the range matched by the entire regular expression, and subsequent elements refer to the parenthesized subexpressions in the order that they diff --git a/doc/StringObj.3 b/doc/StringObj.3 index 8091e2b..38e5857 100644 --- a/doc/StringObj.3 +++ b/doc/StringObj.3 @@ -4,7 +4,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: StringObj.3,v 1.31 2009/04/10 13:14:38 dkf Exp $ +'\" RCS: @(#) $Id: StringObj.3,v 1.32 2011/01/19 23:34:15 ferrieux Exp $ '\" .so man.macros .TH Tcl_StringObj 3 8.1 Tcl "Tcl Library Procedures" @@ -330,7 +330,10 @@ Tcl_Obj *objPtr = \fBTcl_ObjPrintf\fR("Value is %d", x); .PP If the value of \fIformat\fR contains internal inconsistencies or invalid specifier formats, the formatted string result produced by -\fBTcl_ObjPrintf\fR will be an error message describing the error. +\fBTcl_ObjPrintf\fR will be an error message describing the error. +It is impossible however to provide runtime protection against +mismatches between the format and any subsequent arguments. +Compile-time protection may be provided by some compilers. .PP \fBTcl_AppendPrintfToObj\fR is an appending alternative form of \fBTcl_ObjPrintf\fR with functionality equivalent to @@ -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.4.1 2010/12/01 16:42:33 kennykb Exp $ +'\" RCS: @(#) $Id: Tcl.n,v 1.25 2010/11/04 13:51:41 dkf Exp $ '\" .so man.macros .TH Tcl n "8.5" Tcl "Tcl Built-In Commands" diff --git a/doc/Tcl_Main.3 b/doc/Tcl_Main.3 index 252d9fe..5bae645 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.4.1 2010/12/01 16:42:33 kennykb Exp $ +'\" RCS: @(#) $Id: Tcl_Main.3,v 1.21 2010/11/04 21:48:23 nijtmans Exp $ '\" .so man.macros .TH Tcl_Main 3 8.4 Tcl "Tcl Library Procedures" @@ -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.2.1 2010/12/01 16:42:33 kennykb Exp $ +'\" RCS: @(#) $Id: file.n,v 1.61 2010/11/18 11:25:14 dkf Exp $ '\" .so man.macros .TH file n 8.3 Tcl "Tcl Built-In Commands" @@ -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: info.n,v 1.38.2.2 2010/10/23 15:49:54 kennykb Exp $ +'\" RCS: @(#) $Id: info.n,v 1.40 2010/10/20 20:52:26 ferrieux Exp $ '\" .so man.macros .TH info n 8.4 Tcl "Tcl Built-In Commands" diff --git a/doc/interp.n b/doc/interp.n index 2cb0e81..f0b4efd 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.4.1 2010/12/01 16:42:33 kennykb Exp $ +'\" RCS: @(#) $Id: interp.n,v 1.45 2010/11/15 21:34:54 andreas_kupries Exp $ '\" .so man.macros .TH interp n 8.6 Tcl "Tcl Built-In Commands" diff --git a/doc/socket.n b/doc/socket.n index 2346498..0fa8872 100644 --- a/doc/socket.n +++ b/doc/socket.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: socket.n,v 1.20.4.1 2010/09/28 15:43:01 kennykb Exp $ +'\" RCS: @(#) $Id: socket.n,v 1.21 2010/09/28 15:13:54 rmax Exp $ .so man.macros .TH socket n 8.6 Tcl "Tcl Built-In Commands" .BS diff --git a/doc/tclvars.n b/doc/tclvars.n index 385e850..45498c8 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.4.1 2010/12/01 16:42:33 kennykb Exp $ +'\" RCS: @(#) $Id: tclvars.n,v 1.44 2011/01/15 18:10:19 kennykb Exp $ '\" .so man.macros .TH tclvars n 8.0 Tcl "Tcl Built-In Commands" @@ -365,22 +365,41 @@ binary number. .RE .PP .RS -17 digits is +If \Btcl_precision\fB is not zero, then when Tcl converts a floating +point number, it creates a decimal representation of at most +\fBtcl_precision\fR significant digits; the result may be shorter if +the shorter result represents the original number exactly. If no +result of at most \fBtcl_precision\fR digits is an exact representation +of the original number, the one that is closest to the original +number is chosen. +If the original number lies precisely between two equally accurate +decimal representations, then the one with an even value for the least +significant digit is chosen; for instance, if tcl_precision is 3, then +0.3125 will convert to 0.312, not 0.313, while 0.6875 will convert to +0.688, not 0.687. Any string of trailing zeroes that remains is trimmed. +.RE +.PP +.RS +a \fBtcl_precision\fR value of 17 digits is .QW perfect for IEEE floating-point in that it allows double-precision values to be converted to strings and back to -binary with no loss of information. However, using 17 digits prevents -any rounding, which produces longer, less intuitive results. For example, -\fBexpr {1.4}\fR returns 1.3999999999999999 with \fBtcl_precision\fR -set to 17, vs. 1.4 if \fBtcl_precision\fR is 12. +binary with no loss of information. For this reason, you will often +see it as a value in legacy code that must run on Tcl versions before +8.5. It is no longer recommended; as noted above, a zero value is the +preferred method. .RE .PP .RS All interpreters in a thread share a single \fBtcl_precision\fR value: changing it in one interpreter will affect all other interpreters as -well. However, safe interpreters are not allowed to modify the +well. Safe interpreters are not allowed to modify the variable. .RE +.PP +.RS +Valid values for \Btcl_precision\fR range from 0 to 17. +.RE .TP \fBtcl_rcFileName\fR . diff --git a/generic/regc_locale.c b/generic/regc_locale.c index 9a5571f..7026885 100644 --- a/generic/regc_locale.c +++ b/generic/regc_locale.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: regc_locale.c,v 1.21.6.1 2010/10/20 01:50:19 kennykb Exp $ + * RCS: @(#) $Id: regc_locale.c,v 1.23 2010/10/15 15:25:52 nijtmans Exp $ */ /* ASCII character-name table */ diff --git a/generic/tcl.decls b/generic/tcl.decls index f7c5d4f..444ffaa 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -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: tcl.decls,v 1.181 2010/09/15 07:33:54 nijtmans Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.182 2011/01/19 14:11:23 nijtmans Exp $ library tcl @@ -62,7 +62,7 @@ declare 8 { } # Tcl_CreateFileHandler and Tcl_DeleteFileHandler are only available on unix, -# but they are part of the old interface, so we include them here for +# but they are part of the old generic interface, so we include them here for # compatibility reasons. declare 9 unix { @@ -598,7 +598,7 @@ declare 166 { } # Tcl_GetOpenFile is only available on unix, but it is a part of the old -# interface, so we inlcude it here for compatibility reasons. +# generic interface, so we inlcude it here for compatibility reasons. declare 167 unix { int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID, int forWriting, diff --git a/generic/tcl.h b/generic/tcl.h index fd67dd4..670e716 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -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: tcl.h,v 1.308.2.2 2010/12/16 01:42:18 kennykb Exp $ + * RCS: @(#) $Id: tcl.h,v 1.312 2011/01/19 14:11:23 nijtmans Exp $ */ #ifndef _TCL @@ -158,6 +158,11 @@ extern "C" { # define TCL_VARARGS_DEF(type, name) (type name, ...) # define TCL_VARARGS_START(type, name, list) (va_start(list, name), name) #endif +#if defined(__GNUC__) && (__GNUC__ > 2) +# define TCL_FORMAT_PRINTF(a,b) __attribute__ ((__format__ (__printf__, a, b))) +#else +# define TCL_FORMAT_PRINTF(a,b) +#endif /* *---------------------------------------------------------------------------- diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 816f0f6..c7bce32 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.6 2010/12/11 18:39:28 kennykb Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.473 2011/01/18 08:43:53 nijtmans Exp $ */ #include "tclInt.h" @@ -825,7 +825,7 @@ Tcl_CreateInterp(void) Tcl_DisassembleObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation", Tcl_RepresentationCmd, NULL, NULL); - + /* Adding the bytecode assembler command */ cmdPtr = (Command*) Tcl_NRCreateCommand(interp, "::tcl::unsupported::assemble", @@ -839,7 +839,7 @@ Tcl_CreateInterp(void) TclNRYieldObjCmd, INT2PTR(CORO_ACTIVATE_YIELDM), NULL); Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL, NRCoroInjectObjCmd, NULL, NULL); - + #ifdef USE_DTRACE /* * Register the tcl::dtrace command. @@ -954,11 +954,11 @@ Tcl_CreateInterp(void) Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs); if (TclTommath_Init(interp) != TCL_OK) { - Tcl_Panic(Tcl_GetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); } if (TclOOInit(interp) != TCL_OK) { - Tcl_Panic(Tcl_GetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); } /* @@ -968,7 +968,7 @@ Tcl_CreateInterp(void) #ifdef HAVE_ZLIB if (TclZlibInit(interp) != TCL_OK) { - Tcl_Panic(Tcl_GetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); } #endif @@ -8625,7 +8625,7 @@ NRCoroutineCallerCallback( NRE_ASSERT(COR_IS_SUSPENDED(corPtr)); SAVE_CONTEXT(corPtr->running); RESTORE_CONTEXT(corPtr->caller); - + if (cmdPtr->flags & CMD_IS_DELETED) { /* * The command was deleted while it was running: wind down the diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 165da34..b9af8c3 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.2.2 2010/12/11 18:39:28 kennykb Exp $ + * RCS: @(#) $Id: tclBinary.c,v 1.69 2010/12/10 13:08:54 nijtmans Exp $ */ #include "tclInt.h" diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 4ea1c78..414344a 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.3 2010/12/11 18:39:28 kennykb Exp $ + * RCS: @(#) $Id: tclCkalloc.c,v 1.43 2010/12/10 21:59:23 nijtmans Exp $ */ #include "tclInt.h" diff --git a/generic/tclClock.c b/generic/tclClock.c index c3914a6..a844205 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.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: tclClock.c,v 1.75.4.1 2010/10/01 13:34:09 kennykb Exp $ + * RCS: @(#) $Id: tclClock.c,v 1.76 2010/10/01 12:52:49 dkf Exp $ */ #include "tclInt.h" diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 2d4fc83..01e4a41 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.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: tclCmdAH.c,v 1.126.2.2 2010/12/11 18:39:28 kennykb Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.129 2010/12/10 13:08:54 nijtmans Exp $ */ #include "tclInt.h" diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 8900d14..ffb8b98 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.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: tclCmdIL.c,v 1.184.2.2 2010/12/11 18:39:28 kennykb Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.188 2011/01/01 10:49:09 dkf Exp $ */ #include "tclInt.h" @@ -29,13 +29,16 @@ */ typedef struct SortElement { - union { + union { /* The value that we sorting by. */ const char *strValuePtr; long intValue; double doubleValue; Tcl_Obj *objValuePtr; - } index; - Tcl_Obj *objPtr; /* Object being sorted, or its index. */ + } collationKey; + union { /* Object being sorted, or its index. */ + Tcl_Obj *objPtr; + int index; + } payload; struct SortElement *nextPtr;/* Next element in the list, or NULL for end * of list. */ } SortElement; @@ -3640,6 +3643,7 @@ Tcl_LsortObjCmd( group = 0; groupSize = 1; groupOffset = 0; + indexPtr = NULL; for (i = 1; i < objc-1; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index) != TCL_OK) { @@ -3672,66 +3676,40 @@ Tcl_LsortObjCmd( sortInfo.isIncreasing = 1; break; case LSORT_INDEX: { + int indexc, dummy; Tcl_Obj **indexv; - /* === START SPECIAL CASE === - * - * When reviewing code flow in this function, note that from here - * to the line a bit below (END SPECIAL CASE) the contents of the - * indexc and indexv fields of the sortInfo structure may not be - * matched, so jumping to the done2 label to exit is wrong. - */ - - if (sortInfo.indexc > 1) { - TclStackFree(interp, sortInfo.indexv); - } if (i == objc-2) { Tcl_AppendResult(interp, "\"-index\" option must be " "followed by list index", NULL); - return TCL_ERROR; + sortInfo.resultCode = TCL_ERROR; + goto done2; } - - /* - * Take copy to prevent shimmering problems. - */ - - if (TclListObjGetElements(interp, objv[i+1], &sortInfo.indexc, + if (TclListObjGetElements(interp, objv[i+1], &indexc, &indexv) != TCL_OK) { - return TCL_ERROR; - } - /* === END SPECIAL CASE === */ - - switch (sortInfo.indexc) { - case 0: - sortInfo.indexv = NULL; - break; - case 1: - sortInfo.indexv = &sortInfo.singleIndex; - break; - default: - sortInfo.indexv = - TclStackAlloc(interp, sizeof(int) * sortInfo.indexc); - allocatedIndexVector = 1; /* Cannot use indexc field, as - * it might be decreased by 1 - * later. */ + sortInfo.resultCode = TCL_ERROR; + goto done2; } - /* - * Fill the array by parsing each index. We don't know whether - * their scale is sensible yet, but we at least perform the - * syntactic check here. - */ + /* + * Check each of the indices for syntactic correctness. Note that + * we do not store the converted values here because we do not + * know if this is the only -index option yet and so we can't + * allocate any space; that happens after the scan through all the + * options is done. + */ - for (j=0 ; j<sortInfo.indexc ; j++) { + for (j=0 ; j<indexc ; j++) { if (TclGetIntForIndexM(interp, indexv[j], SORTIDX_END, - &sortInfo.indexv[j]) != TCL_OK) { + &dummy) != TCL_OK) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (-index option item number %d)", j)); sortInfo.resultCode = TCL_ERROR; goto done2; } } - i++; + indexPtr = objv[i+1]; + i++; break; } case LSORT_INTEGER: @@ -3775,6 +3753,35 @@ Tcl_LsortObjCmd( sortInfo.sortMode = SORTMODE_ASCII_NC; } + /* + * Now extract the -index list for real, if present. No failures are + * expected here; the values are all of the right type or convertible to + * it. + */ + + if (indexPtr) { + Tcl_Obj **indexv; + + TclListObjGetElements(interp, indexPtr, &sortInfo.indexc, &indexv); + switch (sortInfo.indexc) { + case 0: + sortInfo.indexv = NULL; + break; + case 1: + sortInfo.indexv = &sortInfo.singleIndex; + break; + default: + sortInfo.indexv = + TclStackAlloc(interp, sizeof(int) * sortInfo.indexc); + allocatedIndexVector = 1; /* Cannot use indexc field, as it + * might be decreased by 1 later. */ + } + for (j=0 ; j<sortInfo.indexc ; j++) { + TclGetIntForIndexM(interp, indexv[j], SORTIDX_END, + &sortInfo.indexv[j]); + } + } + listObj = objv[objc-1]; if (sortInfo.sortMode == SORTMODE_COMMAND) { @@ -3918,7 +3925,7 @@ Tcl_LsortObjCmd( */ if (sortMode == SORTMODE_ASCII) { - elementArray[i].index.strValuePtr = TclGetString(indexPtr); + elementArray[i].collationKey.strValuePtr = TclGetString(indexPtr); } else if (sortMode == SORTMODE_INTEGER) { long a; @@ -3926,7 +3933,7 @@ Tcl_LsortObjCmd( sortInfo.resultCode = TCL_ERROR; goto done1; } - elementArray[i].index.intValue = a; + elementArray[i].collationKey.intValue = a; } else if (sortInfo.sortMode == SORTMODE_REAL) { double a; @@ -3935,9 +3942,9 @@ Tcl_LsortObjCmd( sortInfo.resultCode = TCL_ERROR; goto done1; } - elementArray[i].index.doubleValue = a; + elementArray[i].collationKey.doubleValue = a; } else { - elementArray[i].index.objValuePtr = indexPtr; + elementArray[i].collationKey.objValuePtr = indexPtr; } /* @@ -3946,9 +3953,9 @@ Tcl_LsortObjCmd( */ if (indices || group) { - elementArray[i].objPtr = INT2PTR(idx); + elementArray[i].payload.index = idx; } else { - elementArray[i].objPtr = listObjPtrs[idx]; + elementArray[i].payload.objPtr = listObjPtrs[idx]; } /* @@ -3990,7 +3997,7 @@ Tcl_LsortObjCmd( newArray = &listRepPtr->elements; if (group) { for (i=0; elementPtr!=NULL ; elementPtr=elementPtr->nextPtr) { - idx = PTR2INT(elementPtr->objPtr); + idx = elementPtr->payload.index; for (j = 0; j < groupSize; j++) { if (indices) { objPtr = Tcl_NewIntObj(idx + j - groupOffset); @@ -4005,13 +4012,13 @@ Tcl_LsortObjCmd( } } else if (indices) { for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) { - objPtr = Tcl_NewIntObj(PTR2INT(elementPtr->objPtr)); + objPtr = Tcl_NewIntObj(elementPtr->payload.index); newArray[i++] = objPtr; Tcl_IncrRefCount(objPtr); } } else { for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) { - objPtr = elementPtr->objPtr; + objPtr = elementPtr->payload.objPtr; newArray[i++] = objPtr; Tcl_IncrRefCount(objPtr); } @@ -4166,25 +4173,25 @@ SortCompare( int order = 0; if (infoPtr->sortMode == SORTMODE_ASCII) { - order = strcmp(elemPtr1->index.strValuePtr, - elemPtr2->index.strValuePtr); + order = strcmp(elemPtr1->collationKey.strValuePtr, + elemPtr2->collationKey.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_ASCII_NC) { - order = strcasecmp(elemPtr1->index.strValuePtr, - elemPtr2->index.strValuePtr); + order = strcasecmp(elemPtr1->collationKey.strValuePtr, + elemPtr2->collationKey.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) { - order = DictionaryCompare(elemPtr1->index.strValuePtr, - elemPtr2->index.strValuePtr); + order = DictionaryCompare(elemPtr1->collationKey.strValuePtr, + elemPtr2->collationKey.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_INTEGER) { long a, b; - a = elemPtr1->index.intValue; - b = elemPtr2->index.intValue; + a = elemPtr1->collationKey.intValue; + b = elemPtr2->collationKey.intValue; order = ((a >= b) - (a <= b)); } else if (infoPtr->sortMode == SORTMODE_REAL) { double a, b; - a = elemPtr1->index.doubleValue; - b = elemPtr2->index.doubleValue; + a = elemPtr1->collationKey.doubleValue; + b = elemPtr2->collationKey.doubleValue; order = ((a >= b) - (a <= b)); } else { Tcl_Obj **objv, *paramObjv[2]; @@ -4201,8 +4208,8 @@ SortCompare( } - objPtr1 = elemPtr1->index.objValuePtr; - objPtr2 = elemPtr2->index.objValuePtr; + objPtr1 = elemPtr1->collationKey.objValuePtr; + objPtr2 = elemPtr2->collationKey.objValuePtr; paramObjv[0] = objPtr1; paramObjv[1] = objPtr2; diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 7c30685..c36cd8b 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.2.2 2010/12/11 18:39:28 kennykb Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.216 2010/12/10 13:08:53 nijtmans Exp $ */ #include "tclInt.h" diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index c8e8618..807c3e4 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.3 2010/12/01 16:42:34 kennykb Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.174 2011/01/18 08:43:53 nijtmans Exp $ */ #include "tclInt.h" @@ -393,7 +393,7 @@ TclCompileCatchCmd( TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); /* Stack at this point: ?script? <mark> result TCL_OK */ - /* + /* * Emit the "error case" epilogue. Push the interpreter result * and the return code. */ @@ -411,7 +411,7 @@ TclCompileCatchCmd( /* Stack at this point: ?script? result returnCode */ if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { Tcl_Panic("TclCompileCatchCmd: bad jump distance %d", - CurrentOffset(envPtr) - jumpFixup.codeOffset); + (int)(CurrentOffset(envPtr) - jumpFixup.codeOffset)); } /* Push the return options if the caller wants them */ @@ -479,7 +479,7 @@ TclCompileCatchCmd( TclEmitOpcode(INST_POP, envPtr); } - /* + /* * Result of all this, on either branch, should have been to leave * one operand -- the return code -- on the stack. */ @@ -1125,7 +1125,7 @@ TclCompileDictUpdateCmd( if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d", - CurrentOffset(envPtr) - jumpFixup.codeOffset); + (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset)); } TclStackFree(interp, keyTokenPtrs); return TCL_OK; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 8fef58d..2f86be1 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.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: tclCompCmdsSZ.c,v 1.9 2010/05/28 09:11:31 dkf Exp $ + * RCS: @(#) $Id: tclCompCmdsSZ.c,v 1.10 2011/01/18 08:43:53 nijtmans Exp $ */ #include "tclInt.h" @@ -717,7 +717,7 @@ TclSubstCompile( /* Start */ if (TclFixupForwardJumpToHere(envPtr, &startFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad start jump distance %d", - CurrentOffset(envPtr) - startFixup.codeOffset); + (int) (CurrentOffset(envPtr) - startFixup.codeOffset)); } } @@ -774,7 +774,7 @@ TclSubstCompile( /* BREAK destination */ if (TclFixupForwardJumpToHere(envPtr, &breakFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad break jump distance %d", - CurrentOffset(envPtr) - breakFixup.codeOffset); + (int) (CurrentOffset(envPtr) - breakFixup.codeOffset)); } TclEmitOpcode(INST_POP, envPtr); TclEmitOpcode(INST_POP, envPtr); @@ -789,7 +789,7 @@ TclSubstCompile( /* CONTINUE destination */ if (TclFixupForwardJumpToHere(envPtr, &continueFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %d", - CurrentOffset(envPtr) - continueFixup.codeOffset); + (int) (CurrentOffset(envPtr) - continueFixup.codeOffset)); } TclEmitOpcode(INST_POP, envPtr); TclEmitOpcode(INST_POP, envPtr); @@ -798,11 +798,11 @@ TclSubstCompile( /* RETURN + other destination */ if (TclFixupForwardJumpToHere(envPtr, &returnFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad return jump distance %d", - CurrentOffset(envPtr) - returnFixup.codeOffset); + (int) (CurrentOffset(envPtr) - returnFixup.codeOffset)); } if (TclFixupForwardJumpToHere(envPtr, &otherFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad other jump distance %d", - CurrentOffset(envPtr) - otherFixup.codeOffset); + (int) (CurrentOffset(envPtr) - otherFixup.codeOffset)); } /* @@ -826,7 +826,7 @@ TclSubstCompile( /* OK destination */ if (TclFixupForwardJumpToHere(envPtr, &okFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad ok jump distance %d", - CurrentOffset(envPtr) - okFixup.codeOffset); + (int) (CurrentOffset(envPtr) - okFixup.codeOffset)); } if (count > 1) { TclEmitInstInt1(INST_CONCAT1, count, envPtr); @@ -836,7 +836,7 @@ TclSubstCompile( /* CONTINUE jump to here */ if (TclFixupForwardJumpToHere(envPtr, &endFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad end jump distance %d", - CurrentOffset(envPtr) - endFixup.codeOffset); + (int) (CurrentOffset(envPtr) - endFixup.codeOffset)); } bline = envPtr->line; } diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index ead8f51..97410df 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.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: tclCompExpr.c,v 1.105.2.1 2010/09/27 20:33:37 kennykb Exp $ + * RCS: @(#) $Id: tclCompExpr.c,v 1.107 2011/01/18 08:43:53 nijtmans Exp $ */ #include "tclInt.h" @@ -1381,13 +1381,13 @@ ParseExpr( Tcl_AppendPrintfToObj(msg, "\nin expression \"%s%.*s%.*s%s%s%.*s%s\"", ((start - limit) < parsePtr->string) ? "" : "...", ((start - limit) < parsePtr->string) - ? (start - parsePtr->string) : limit - 3, + ? (int) (start - parsePtr->string) : limit - 3, ((start - limit) < parsePtr->string) ? parsePtr->string : start - limit + 3, (scanned < limit) ? scanned : limit - 3, start, (scanned < limit) ? "" : "...", insertMark ? mark : "", (start + scanned + limit > parsePtr->end) - ? parsePtr->end - (start + scanned) : limit-3, + ? (int) (parsePtr->end - start) - scanned : limit-3, start + scanned, (start + scanned + limit > parsePtr->end) ? "" : "..."); diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 833a920..96d9896 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.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: tclCompile.c,v 1.187.2.5 2010/12/11 18:39:28 kennykb Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.194 2010/12/10 21:59:23 nijtmans Exp $ */ #include "tclInt.h" diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 3c9350a..0df13d9 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -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: tclCompile.h,v 1.126.2.2 2010/10/23 15:49:54 kennykb Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.128 2010/10/20 20:52:28 ferrieux Exp $ */ #ifndef _TCLCOMPILATION diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 1b44b7d..33760f7 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.2 2010/12/01 16:42:35 kennykb Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.189 2011/01/19 14:11:23 nijtmans Exp $ */ #ifndef _TCLDECLS @@ -46,7 +46,7 @@ EXTERN CONST84_RETURN char * Tcl_PkgRequireEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 2 */ -EXTERN void Tcl_Panic(const char *format, ...); +EXTERN void Tcl_Panic(const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 3 */ EXTERN char * Tcl_Alloc(unsigned int size); /* 4 */ @@ -1664,10 +1664,10 @@ EXTERN int Tcl_AppendFormatToObj(Tcl_Interp *interp, Tcl_Obj *objPtr, const char *format, int objc, Tcl_Obj *const objv[]); /* 578 */ -EXTERN Tcl_Obj * Tcl_ObjPrintf(const char *format, ...); +EXTERN Tcl_Obj * Tcl_ObjPrintf(const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 579 */ EXTERN void Tcl_AppendPrintfToObj(Tcl_Obj *objPtr, - const char *format, ...); + const char *format, ...) TCL_FORMAT_PRINTF(2, 3); /* 580 */ EXTERN int Tcl_CancelEval(Tcl_Interp *interp, Tcl_Obj *resultObjPtr, ClientData clientData, @@ -1822,7 +1822,7 @@ typedef struct TclStubs { int (*tcl_PkgProvideEx) (Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 0 */ CONST84_RETURN char * (*tcl_PkgRequireEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 1 */ - void (*tcl_Panic) (const char *format, ...); /* 2 */ + void (*tcl_Panic) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 2 */ char * (*tcl_Alloc) (unsigned int size); /* 3 */ void (*tcl_Free) (char *ptr); /* 4 */ char * (*tcl_Realloc) (char *ptr, unsigned int size); /* 5 */ @@ -2422,8 +2422,8 @@ typedef struct TclStubs { void (*tcl_AppendLimitedToObj) (Tcl_Obj *objPtr, const char *bytes, int length, int limit, const char *ellipsis); /* 575 */ Tcl_Obj * (*tcl_Format) (Tcl_Interp *interp, const char *format, int objc, Tcl_Obj *const objv[]); /* 576 */ int (*tcl_AppendFormatToObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *format, int objc, Tcl_Obj *const objv[]); /* 577 */ - Tcl_Obj * (*tcl_ObjPrintf) (const char *format, ...); /* 578 */ - void (*tcl_AppendPrintfToObj) (Tcl_Obj *objPtr, const char *format, ...); /* 579 */ + Tcl_Obj * (*tcl_ObjPrintf) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 578 */ + void (*tcl_AppendPrintfToObj) (Tcl_Obj *objPtr, const char *format, ...) TCL_FORMAT_PRINTF(2, 3); /* 579 */ int (*tcl_CancelEval) (Tcl_Interp *interp, Tcl_Obj *resultObjPtr, ClientData clientData, int flags); /* 580 */ int (*tcl_Canceled) (Tcl_Interp *interp, int flags); /* 581 */ int (*tcl_CreatePipe) (Tcl_Interp *interp, Tcl_Channel *rchan, Tcl_Channel *wchan, int flags); /* 582 */ diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 8affede..358b313 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.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: tclDictObj.c,v 1.84.2.1 2010/12/11 18:39:28 kennykb Exp $ + * RCS: @(#) $Id: tclDictObj.c,v 1.85 2010/12/10 13:08:53 nijtmans Exp $ */ #include "tclInt.h" diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 4dfd8ab..add30e4 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.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: tclEncoding.c,v 1.72.2.1 2010/10/01 13:34:09 kennykb Exp $ + * RCS: @(#) $Id: tclEncoding.c,v 1.73 2010/10/01 12:52:49 dkf Exp $ */ #include "tclInt.h" diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 1bf9be1..ae90b9b 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.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: tclEnsemble.c,v 1.5.4.1 2010/12/11 18:39:28 kennykb Exp $ + * RCS: @(#) $Id: tclEnsemble.c,v 1.7 2011/01/18 08:43:53 nijtmans Exp $ */ #include "tclInt.h" @@ -1513,7 +1513,7 @@ TclMakeEnsemble( Tcl_DStringSetLength(&hiddenBuf, hiddenLen); if (Tcl_HideCommand(interp, "___tmp", Tcl_DStringAppend(&hiddenBuf, map[i].name, -1))) { - Tcl_Panic(Tcl_GetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); } } else { /* diff --git a/generic/tclEnv.c b/generic/tclEnv.c index a7ad13f..5a13044 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.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: tclEnv.c,v 1.43.2.1 2010/10/01 13:34:09 kennykb Exp $ + * RCS: @(#) $Id: tclEnv.c,v 1.44 2010/10/01 12:52:49 dkf Exp $ */ #include "tclInt.h" diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 67b3fde..ba2bb64 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclEvent.c,v 1.93.2.1 2010/09/25 14:51:12 kennykb Exp $ + * RCS: @(#) $Id: tclEvent.c,v 1.94 2010/09/23 18:08:35 dgp Exp $ */ #include "tclInt.h" diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 7a8f082..c34f975 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.9 2010/12/01 16:42:35 kennykb Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.511 2010/12/30 23:10:07 msofer Exp $ */ #include "tclInt.h" @@ -188,12 +188,12 @@ typedef struct BottomData { BP->cleanup = cleanup; \ TclNRAddCallback(interp, TEBCresume, BP, \ INT2PTR(invoke), NULL, NULL) - + #define NR_DATA_DIG() \ pc = BP->pc; \ cleanup = BP->cleanup; \ tosPtr = esPtr->tosPtr - + #define PUSH_TAUX_OBJ(objPtr) \ do { \ @@ -1062,14 +1062,14 @@ GrowEvaluationStack( /* * Reset move to hold the number of words to be moved to new stack (if - * any) and growth to hold the complete stack requirements: add the marker - * and maximal possible offset. + * any) and growth to hold the complete stack requirements: add one for + * the marker, (WALLOCALIGN-1) for the maximal possible offset. */ if (move) { moveWords = esPtr->tosPtr - MEMSTART(markerPtr) + 1; } - needed = growth + moveWords + WALLOCALIGN - 1; + needed = growth + moveWords + WALLOCALIGN; /* * Check if there is enough room in the next stack (if there is one, it diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 277afa6..050c5dc 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.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: tclFCmd.c,v 1.51.4.1 2010/12/11 18:39:28 kennykb Exp $ + * RCS: @(#) $Id: tclFCmd.c,v 1.52 2010/12/09 15:09:07 dkf Exp $ */ #include "tclInt.h" diff --git a/generic/tclHash.c b/generic/tclHash.c index d5ce21f..c7a550f 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.2.2 2010/12/11 18:39:29 kennykb Exp $ + * RCS: @(#) $Id: tclHash.c,v 1.48 2010/12/10 21:59:23 nijtmans Exp $ */ #include "tclInt.h" diff --git a/generic/tclIO.c b/generic/tclIO.c index 0f490b3..adc630f 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIO.c,v 1.175.2.1 2010/12/11 18:39:29 kennykb Exp $ + * RCS: @(#) $Id: tclIO.c,v 1.176 2010/12/10 17:00:12 ferrieux Exp $ */ #include "tclInt.h" diff --git a/generic/tclIO.h b/generic/tclIO.h index ad57391..8616c69 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIO.h,v 1.17.2.1 2010/12/11 18:39:29 kennykb Exp $ + * RCS: @(#) $Id: tclIO.h,v 1.18 2010/12/10 21:59:24 nijtmans Exp $ */ /* diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index fe7fc36..38df785 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOCmd.c,v 1.69.2.1 2010/12/11 18:39:29 kennykb Exp $ + * RCS: @(#) $Id: tclIOCmd.c,v 1.72 2011/01/17 11:27:30 nijtmans Exp $ */ #include "tclInt.h" @@ -135,32 +135,26 @@ Tcl_PutsObjCmd( break; case 4: /* [puts -nonewline $chan $x] or [puts $chan $x nonewline] */ + newline = 0; if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) { chanObjPtr = objv[2]; string = objv[3]; - } else { + break; +#if TCL_MAJOR_VERSION < 9 + } else if (strcmp(TclGetString(objv[2]), "nonewline") == 0) { /* * The code below provides backwards compatibility with an old * form of the command that is no longer recommended or - * documented. + * documented. See also [Bug #3151675]. Will be removed in Tcl 9, + * maybe even earlier. */ - const char *arg; - int length; - - arg = TclGetStringFromObj(objv[3], &length); - if ((length != 9) - || (strncmp(arg, "nonewline", (size_t) length) != 0)) { - Tcl_AppendResult(interp, "bad argument \"", arg, - "\": should be \"nonewline\"", NULL); - return TCL_ERROR; - } chanObjPtr = objv[1]; string = objv[2]; + break; +#endif } - newline = 0; - break; - + /* Fall through */ default: /* [puts] or [puts some bad number of arguments...] */ Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string"); @@ -428,25 +422,31 @@ Tcl_ReadObjCmd( i++; /* Consumed channel name. */ /* - * Compute how many bytes to read, and see whether the final newline - * should be dropped. + * Compute how many bytes to read. */ toRead = -1; if (i < objc) { - const char *arg; + if ((TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK) || (toRead < 0)) { +#if TCL_MAJOR_VERSION < 9 + /* + * The code below provides backwards compatibility with an old + * form of the command that is no longer recommended or + * documented. See also [Bug #3151675]. Will be removed in Tcl 9, + * maybe even earlier. + */ - arg = TclGetString(objv[i]); - if (isdigit(UCHAR(arg[0]))) { /* INTL: digit */ - if (TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK) { - return TCL_ERROR; + if (strcmp(TclGetString(objv[i]), "nonewline") != 0) { +#endif + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "expected non-negative integer but got \"", + TclGetString(objv[i]), "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL); + return TCL_ERROR; +#if TCL_MAJOR_VERSION < 9 } - } else if (strcmp(arg, "nonewline") == 0) { newline = 1; - } else { - Tcl_AppendResult(interp, "bad argument \"", arg, - "\": should be \"nonewline\"", NULL); - return TCL_ERROR; +#endif } } diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index a8b2674..884ec65 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.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: tclIOSock.c,v 1.11.10.4 2010/12/11 18:39:29 kennykb Exp $ + * RCS: @(#) $Id: tclIOSock.c,v 1.15 2010/12/10 15:44:54 nijtmans Exp $ */ #include "tclInt.h" diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 42ab1f3..6683ff9 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -17,7 +17,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOUtil.c,v 1.177.2.1 2010/09/22 01:08:49 kennykb Exp $ + * RCS: @(#) $Id: tclIOUtil.c,v 1.178 2010/09/22 00:57:11 hobbs Exp $ */ #include "tclInt.h" diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index dd66ec6..061ba90 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.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: tclIndexObj.c,v 1.59.2.1 2010/12/11 18:39:29 kennykb Exp $ + * RCS: @(#) $Id: tclIndexObj.c,v 1.60 2010/12/10 13:08:54 nijtmans Exp $ */ #include "tclInt.h" diff --git a/generic/tclInt.decls b/generic/tclInt.decls index ac246f0..5b7e8dc 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.4 2010/12/11 18:39:29 kennykb Exp $ +# RCS: @(#) $Id: tclInt.decls,v 1.153 2010/12/10 15:44:53 nijtmans Exp $ library tcl @@ -996,7 +996,7 @@ 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 ea8f948..b16c7df 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.6 2010/12/11 18:39:29 kennykb Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.490 2010/12/10 21:59:23 nijtmans Exp $ */ #ifndef _TCLINT diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 8be8577..cae5e4e 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.4 2010/12/11 18:39:29 kennykb Exp $ + * RCS: @(#) $Id: tclIntDecls.h,v 1.147 2010/12/10 15:44:53 nijtmans Exp $ */ #ifndef _TCLINTDECLS diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index ceda11c..b15dd84 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -9,7 +9,7 @@ * Copyright (c) 1998-1999 by Scriptics Corporation. * All rights reserved. * - * RCS: @(#) $Id: tclIntPlatDecls.h,v 1.44.2.1 2010/12/11 18:39:29 kennykb Exp $ + * RCS: @(#) $Id: tclIntPlatDecls.h,v 1.45 2010/12/10 15:44:53 nijtmans Exp $ */ #ifndef _TCLINTPLATDECLS diff --git a/generic/tclInterp.c b/generic/tclInterp.c index c32daa1..6ccde87 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.2.1 2010/12/01 16:42:36 kennykb Exp $ + * RCS: @(#) $Id: tclInterp.c,v 1.114 2010/11/15 21:34:54 andreas_kupries Exp $ */ #include "tclInt.h" diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 69aa2b2..93dd950 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.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: tclLoad.c,v 1.26.2.1 2010/10/01 13:34:09 kennykb Exp $ + * RCS: @(#) $Id: tclLoad.c,v 1.27 2010/10/01 12:52:49 dkf Exp $ */ #include "tclInt.h" diff --git a/generic/tclMain.c b/generic/tclMain.c index 4cb9c27..f1a6ce7 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.3 2010/12/01 16:42:36 kennykb Exp $ + * RCS: @(#) $Id: tclMain.c,v 1.57 2010/11/15 10:12:38 nijtmans Exp $ */ /** @@ -652,7 +652,7 @@ Tcl_MainEx( Tcl_Release(interp); Tcl_Exit(exitCode); } - + #ifndef UNICODE void Tcl_Main( diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 2e5decc..baed244 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.3 2010/12/01 16:42:36 kennykb Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.216 2010/11/18 00:44:39 msofer Exp $ */ #include "tclInt.h" diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 2fefa31..bb10ca5 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.3 2010/12/01 16:42:36 kennykb Exp $ + * RCS: @(#) $Id: tclOOMethod.c,v 1.31 2011/01/18 15:44:41 dkf Exp $ */ #ifdef HAVE_CONFIG_H @@ -41,6 +41,8 @@ typedef struct { Tcl_Obj *nameObj; /* The "name" of the command. */ Command cmd; /* The command structure. Mostly bogus. */ ExtraFrameInfo efi; /* Extra information used for [info frame]. */ + Command *oldCmdPtr; /* Saved cmdPtr so that we can be safe after a + * recursive call returns. */ struct PNI pni; /* Specialist information used in the efi * field for this type of call. */ } PMFrameData; @@ -711,6 +713,13 @@ InvokeProcedureMethod( result = pmPtr->preCallProc(pmPtr->clientData, interp, context, (Tcl_CallFrame *) fdPtr->framePtr, &isFinished); if (isFinished || result != TCL_OK) { + /* + * Restore the old cmdPtr so that a subsequent use of [info frame] + * won't crash on us. [Bug 3001438] + */ + + pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr; + Tcl_PopCallFrame(interp); TclStackFree(interp, fdPtr->framePtr); if (--pmPtr->refCount < 1) { @@ -752,6 +761,13 @@ FinalizePMCall( } /* + * Restore the old cmdPtr so that a subsequent use of [info frame] won't + * crash on us. [Bug 3001438] + */ + + pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr; + + /* * Scrap the special frame data now that we're done with it. Note that we * are inlining DeleteProcedureMethod() here; this location is highly * sensitive when it comes to performance! @@ -820,6 +836,14 @@ PushMethodCallFrame( } /* + * Save the old cmdPtr so that when this recursive call returns, we can + * restore it. To do otherwise causes crashes in [info frame] after we + * return from a recursive call. [Bug 3001438] + */ + + fdPtr->oldCmdPtr = pmPtr->procPtr->cmdPtr; + + /* * Compile the body. This operation may fail. */ @@ -845,7 +869,7 @@ PushMethodCallFrame( result = TclProcCompileProc(interp, pmPtr->procPtr, pmPtr->procPtr->bodyPtr, nsPtr, "body of method", namePtr); if (result != TCL_OK) { - return result; + goto failureReturn; } /* @@ -856,7 +880,7 @@ PushMethodCallFrame( result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, (Tcl_Namespace *) nsPtr, FRAME_IS_PROC|FRAME_IS_METHOD); if (result != TCL_OK) { - return result; + goto failureReturn; } fdPtr->framePtr->clientData = contextPtr; @@ -891,6 +915,15 @@ PushMethodCallFrame( } return TCL_OK; + + /* + * Restore the old cmdPtr so that a subsequent use of [info frame] won't + * crash on us. [Bug 3001438] + */ + + failureReturn: + pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr; + return result; } /* diff --git a/generic/tclObj.c b/generic/tclObj.c index 3161a46..4c9bd98 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclObj.c,v 1.174.2.3 2010/10/02 16:04:29 kennykb Exp $ + * RCS: @(#) $Id: tclObj.c,v 1.177 2010/10/02 11:37:02 dkf Exp $ */ #include "tclInt.h" diff --git a/generic/tclPanic.c b/generic/tclPanic.c index e8c1257..3a48afa 100644 --- a/generic/tclPanic.c +++ b/generic/tclPanic.c @@ -12,10 +12,13 @@ * 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.4.2 2010/12/16 01:42:18 kennykb Exp $ + * RCS: @(#) $Id: tclPanic.c,v 1.21 2011/01/12 20:17:03 nijtmans Exp $ */ #include "tclInt.h" +#ifdef _WIN32 + MODULE_SCOPE void tclWinDebugPanic(const char *format, ...); +#endif /* * The panicProc variable contains a pointer to an application specific panic @@ -44,6 +47,10 @@ void Tcl_SetPanicProc( Tcl_PanicProc *proc) { +#ifdef _WIN32 + /* tclWinDebugPanic only installs if there is no panicProc yet. */ + if ((proc != tclWinDebugPanic) || (panicProc == NULL)) +#endif panicProc = proc; } @@ -84,6 +91,10 @@ Tcl_PanicVA( if (panicProc != NULL) { panicProc(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); +#ifdef _WIN32 + } else if (IsDebuggerPresent()) { + tclWinDebugPanic(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); +#endif } else { fprintf(stderr, format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); @@ -91,7 +102,20 @@ Tcl_PanicVA( fflush(stderr); } /* In case the users panic proc does not abort, we do it here */ +#ifdef _WIN32 +# if defined(__GNUC__) + __builtin_trap(); +# elif defined(_WIN64) + __debugbreak(); +# elif defined(_MSC_VER) + _asm {int 3} +# else + DebugBreak(); +# endif + ExitProcess(1); +#else abort(); +#endif } /* diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 3bd4c53..fd4651f 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.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: tclPathObj.c,v 1.88.4.1 2010/09/22 01:08:49 kennykb Exp $ + * RCS: @(#) $Id: tclPathObj.c,v 1.89 2010/09/22 00:57:11 hobbs Exp $ */ #include "tclInt.h" diff --git a/generic/tclPreserve.c b/generic/tclPreserve.c index f90e4bc..5612f41 100644 --- a/generic/tclPreserve.c +++ b/generic/tclPreserve.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: tclPreserve.c,v 1.12 2009/01/09 11:21:46 dkf Exp $ + * RCS: @(#) $Id: tclPreserve.c,v 1.14 2011/01/25 07:17:26 nijtmans Exp $ */ #include "tclInt.h" @@ -240,7 +240,7 @@ Tcl_Release( * Reference not found. This is a bug in the caller. */ - Tcl_Panic("Tcl_Release couldn't find reference for 0x%x", clientData); + Tcl_Panic("Tcl_Release couldn't find reference for %p", clientData); } /* @@ -280,7 +280,7 @@ Tcl_EventuallyFree( continue; } if (refPtr->mustFree) { - Tcl_Panic("Tcl_EventuallyFree called twice for 0x%x", clientData); + Tcl_Panic("Tcl_EventuallyFree called twice for %p", clientData); } refPtr->mustFree = 1; refPtr->freeProc = freeProc; diff --git a/generic/tclProc.c b/generic/tclProc.c index 92e4169..bfc101c 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.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: tclProc.c,v 1.181.2.2 2010/12/11 18:39:29 kennykb Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.183 2010/12/10 21:59:23 nijtmans Exp $ */ #include "tclInt.h" diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index f247572..86ce07c 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.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: tclRegexp.c,v 1.34.4.1 2010/10/01 13:34:09 kennykb Exp $ + * RCS: @(#) $Id: tclRegexp.c,v 1.35 2010/10/01 12:52:50 dkf Exp $ */ #include "tclInt.h" diff --git a/generic/tclResolve.c b/generic/tclResolve.c index aaa19ea..109948e 100644 --- a/generic/tclResolve.c +++ b/generic/tclResolve.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: tclResolve.c,v 1.12.4.1 2010/10/01 13:34:09 kennykb Exp $ + * RCS: @(#) $Id: tclResolve.c,v 1.13 2010/10/01 12:52:50 dkf Exp $ */ #include "tclInt.h" diff --git a/generic/tclResult.c b/generic/tclResult.c index 2d319e9..ee15190 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.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: tclResult.c,v 1.61.2.2 2010/10/01 13:34:09 kennykb Exp $ + * RCS: @(#) $Id: tclResult.c,v 1.63 2010/10/01 12:52:50 dkf Exp $ */ #include "tclInt.h" diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 76895df..67c797f 100755 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -12,9 +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: tclStrToD.c,v 1.46.2.2 2010/12/11 18:39:29 kennykb Exp $ - * - *---------------------------------------------------------------------- + * RCS: @(#) $Id: tclStrToD.c,v 1.54 2011/01/15 19:01:31 kennykb Exp $ */ #include "tclInt.h" @@ -3088,6 +3086,11 @@ StrictInt64Conversion( if (i == ilim) { if (2*b > S || (2*b == S && (digit & 1) != 0)) { s = BumpUp(s, retval, &k); + } else { + while (*--s == '0') { + /* do nothing */ + } + ++s; } break; } @@ -3496,6 +3499,10 @@ StrictBignumConversionPowD( if (ShouldBankerRoundUpPowD(&b, sd, digit&1)) { s = BumpUp(s, retval, &k); } + while (*--s == '0') { + /* do nothing */ + } + ++s; break; } @@ -3768,7 +3775,7 @@ ShorteningBignumConversion( --s5; /* - * TODO: It might possibly be a win to fall back to int64 + * IDEA: 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 @@ -3968,6 +3975,10 @@ StrictBignumConversion( } } } + while (*--s == '0') { + /* do nothing */ + } + ++s; /* * Endgame - store the location of the decimal point and the end of the @@ -4025,9 +4036,10 @@ StrictBignumConversion( * 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_E_FORMAT|TCL_DD_SHORTEN_FLAG is supplied instead, it + * also returns fewer digits if the shorter string will still + * reconvert without loss to the given input number. In any case, + * strings of trailing zeroes are suppressed. * 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. @@ -4037,7 +4049,8 @@ StrictBignumConversion( * 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. + * reconvert without loss to the given input number. Strings of + * trailing zeroes are suppressed. * * 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 diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 146f456..96e01d0 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -33,7 +33,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStringObj.c,v 1.137.2.1 2010/10/20 01:50:19 kennykb Exp $ */ + * RCS: @(#) $Id: tclStringObj.c,v 1.138 2010/10/19 22:50:37 dkf Exp $ */ #include "tclInt.h" #include "tommath.h" diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 152a181..98ef9b7 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.2.1 2010/12/01 16:42:36 kennykb Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.199 2010/11/30 18:17:26 hobbs Exp $ */ #include "tclInt.h" diff --git a/generic/tclTest.c b/generic/tclTest.c index f03b486..e12153d 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTest.c,v 1.153.2.2 2010/12/01 16:42:36 kennykb Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.157 2011/01/18 08:43:53 nijtmans Exp $ */ #include <math.h> @@ -4492,7 +4492,7 @@ TestpanicCmd( */ argString = Tcl_Merge(argc-1, argv+1); - Tcl_Panic(argString); + Tcl_Panic("%s", argString); ckfree((char *)argString); return TCL_OK; diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index 8bc68ca..486dcda 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.4.1 2010/12/01 16:42:36 kennykb Exp $ + * RCS: @(#) $Id: tclThreadTest.c,v 1.36 2010/12/01 09:58:52 nijtmans Exp $ */ #ifndef USE_TCL_STUBS diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 6fef7ae..c5974da 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.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: tclTimer.c,v 1.42.4.1 2010/10/30 15:20:23 kennykb Exp $ + * RCS: @(#) $Id: tclTimer.c,v 1.43 2010/10/29 16:42:01 ferrieux Exp $ */ #include "tclInt.h" diff --git a/generic/tclTomMath.decls b/generic/tclTomMath.decls index fd2dc40..4f6bc70 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.2.1 2010/12/01 16:42:36 kennykb Exp $ +# RCS: @(#) $Id: tclTomMath.decls,v 1.9 2010/11/28 23:20:11 kennykb Exp $ library tcl @@ -219,4 +219,4 @@ declare 61 { } 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 849f08f..4e55ce1 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.2.1 2010/12/01 16:42:36 kennykb Exp $ + * RCS: @(#) $Id: tclTomMathDecls.h,v 1.14 2010/11/28 23:20:11 kennykb Exp $ */ #ifndef _TCLTOMMATHDECLS diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 755614a..efbfbb7 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.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: tclTrace.c,v 1.60.2.1 2010/12/11 18:39:29 kennykb Exp $ + * RCS: @(#) $Id: tclTrace.c,v 1.61 2010/12/06 09:01:49 nijtmans Exp $ */ #include "tclInt.h" diff --git a/generic/tclUniData.c b/generic/tclUniData.c index 1aacd1d..0e31b1a 100644 --- a/generic/tclUniData.c +++ b/generic/tclUniData.c @@ -8,7 +8,7 @@ * Copyright (c) 1998 by Scriptics Corporation. * All rights reserved. * - * RCS: @(#) $Id: tclUniData.c,v 1.5.2.1 2010/10/20 01:50:19 kennykb Exp $ + * RCS: @(#) $Id: tclUniData.c,v 1.7 2010/10/15 15:25:52 nijtmans Exp $ */ /* diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 2e435e6..3a42a32 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.3 2010/12/11 18:39:29 kennykb Exp $ + * RCS: @(#) $Id: tclUtil.c,v 1.124 2011/01/15 18:10:19 kennykb Exp $ */ #include "tclInt.h" @@ -2268,12 +2268,52 @@ Tcl_PrintDouble( /* * 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, + /* + * There are at least two possible interpretations for tcl_precision. + * + * The first is, "choose the decimal representation having + * $tcl_precision digits of significance that is nearest to the + * given number, breaking ties by rounding to even, and then + * trimming trailing zeros." This gives the greatest possible + * precision in the decimal string, but offers the anomaly that + * [expr 0.1] will be "0.10000000000000001". + * + * The second is "choose the decimal representation having at + * most $tcl_precision digits of significance that is nearest + * to the given number. If no such representation converts + * exactly to the given number, choose the one that is closest, + * breaking ties by rounding to even. If more than one such + * representation converts exactly to the given number, choose + * the shortest, breaking ties in favour of the nearest, breaking + * remaining ties in favour of the one ending in an even digit." + * + * Tcl 8.4 implements the first of these, which gives rise to + * anomalies in formatting: + * + * % expr 0.1 + * 0.10000000000000001 + * % expr 0.01 + * 0.01 + * % expr 1e-7 + * 9.9999999999999995e-08 + * + * For human readability, it appears better to choose the second rule, + * and let [expr 0.1] return 0.1. But for 8.4 compatibility, we + * prefer the first (the recommended zero value for tcl_precision + * avoids the problem entirely). + * + * Uncomment TCL_DD_SHORTEN_FLAG in the next call to prefer the + * method that allows floating point values to be shortened if + * it can be done without loss of precision. + */ + + digits = TclDoubleDigits(value, *precisionPtr, + TCL_DD_E_FORMAT /* | TCL_DD_SHORTEN_FLAG */, &exponent, &signum, &end); } if (signum) { @@ -2294,7 +2334,15 @@ Tcl_PrintDouble( c = *++p; } } - sprintf(dst, "e%+d", exponent); + /* + * Tcl 8.4 appears to format with at least a two-digit exponent; + * preserve that behaviour when tcl_precision != 0 + */ + if (*precisionPtr == 0) { + sprintf(dst, "e%+d", exponent); + } else { + sprintf(dst, "e%+03d", exponent); + } } else { /* * F format for others. diff --git a/generic/tclVar.c b/generic/tclVar.c index 2d67a7c..9a97146 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.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: tclVar.c,v 1.203.2.3 2010/12/11 18:39:29 kennykb Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.206 2010/12/10 13:08:53 nijtmans Exp $ */ #include "tclInt.h" diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 5a373c6..dfa58ea 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclZlib.c,v 1.38.2.1 2010/10/20 01:50:19 kennykb Exp $ + * RCS: @(#) $Id: tclZlib.c,v 1.40 2010/10/19 22:50:37 dkf Exp $ */ #include "tclInt.h" @@ -1229,7 +1229,7 @@ Tcl_ZlibDeflate( if (!interp) { return TCL_ERROR; } - + /* * Compressed format is specified by the wbits parameter. See zlib.h for * details. diff --git a/library/safe.tcl b/library/safe.tcl index c35193b..3c2a2c4 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -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: safe.tcl,v 1.41.2.1 2010/11/03 00:18:57 kennykb Exp $ +# RCS: @(#) $Id: safe.tcl,v 1.42 2010/11/02 21:42:28 stwo Exp $ # # The implementation is based on namespaces. These naming conventions are diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c index cb24258..ebcc56c 100644 --- a/macosx/tclMacOSXFCmd.c +++ b/macosx/tclMacOSXFCmd.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: tclMacOSXFCmd.c,v 1.19.2.1 2010/10/01 13:34:10 kennykb Exp $ + * RCS: @(#) $Id: tclMacOSXFCmd.c,v 1.20 2010/10/01 12:52:50 dkf Exp $ */ #include "tclInt.h" diff --git a/tests/append.test b/tests/append.test index c6120f2..21afbfb 100644 --- a/tests/append.test +++ b/tests/append.test @@ -11,14 +11,14 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: append.test,v 1.12.2.1 2010/12/11 18:39:29 kennykb Exp $ +# RCS: @(#) $Id: append.test,v 1.13 2010/12/09 10:47:53 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } unset -nocomplain x - + test append-1.1 {append command} { unset -nocomplain x list [append x 1 2 abc "long string"] $x @@ -294,7 +294,7 @@ test append-9.3 {bug 3057639, append direct eval, read trace on non-existing env } -cleanup { unset -nocomplain ::env(__DUMMY__) } -result {0 {new value}} - + unset -nocomplain i x result y catch {rename foo ""} diff --git a/tests/appendComp.test b/tests/appendComp.test index 93323fb..9d1e3a5 100644 --- a/tests/appendComp.test +++ b/tests/appendComp.test @@ -11,14 +11,14 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: appendComp.test,v 1.13.2.1 2010/12/11 18:39:30 kennykb Exp $ +# RCS: @(#) $Id: appendComp.test,v 1.14 2010/12/09 10:47:53 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } catch {unset x} - + test appendComp-1.1 {append command} -setup { unset -nocomplain x } -body { @@ -440,7 +440,7 @@ test appendComp-9.3 {bug 3057639, append direct eval, read trace on non-existing } -cleanup { unset -nocomplain ::env(__DUMMY__) } -result {0 {new value}} - + catch {unset i x result y} catch {rename foo ""} catch {rename bar ""} diff --git a/tests/autoMkindex.test b/tests/autoMkindex.test index 56e1ffb..2b15377 100644 --- a/tests/autoMkindex.test +++ b/tests/autoMkindex.test @@ -1,17 +1,17 @@ # Commands covered: auto_mkindex auto_import # -# This file contains tests related to autoloading and generating -# the autoloading index. +# This file contains tests related to autoloading and generating the +# autoloading index. # # Copyright (c) 1998 Lucent Technologies, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # -# 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. # -# RCS: @(#) $Id: autoMkindex.test,v 1.15 2004/05/25 17:44:29 dgp Exp $ +# RCS: @(#) $Id: autoMkindex.test,v 1.16 2011/01/06 10:20:39 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -19,10 +19,10 @@ if {[lsearch [namespace children] ::tcltest] == -1} { makeFile {# Test file for: # auto_mkindex # -# This file provides example cases for testing the Tcl autoloading -# facility. Things are much more complicated with namespaces and classes. -# The "auto_mkindex" facility can no longer be built on top of a simple -# regular expression parser. It must recognize constructs like this: +# This file provides example cases for testing the Tcl autoloading facility. +# Things are much more complicated with namespaces and classes. The +# "auto_mkindex" facility can no longer be built on top of a simple regular +# expression parser. It must recognize constructs like this: # # namespace eval foo { # proc test {x y} { ... } @@ -31,23 +31,23 @@ makeFile {# Test file for: # } # } # -# Note that procedures and itcl class definitions can be nested inside -# of namespaces. +# Note that procedures and itcl class definitions can be nested inside of +# namespaces. # # Copyright (c) 1993-1998 Lucent Technologies, Inc. # This shouldn't cause any problems namespace import -force blt::* -# Should be able to handle "proc" definitions, even if they are -# preceded by white space. +# Should be able to handle "proc" definitions, even if they are preceded by +# white space. proc normal {x y} {return [expr $x+$y]} proc indented {x y} {return [expr $x+$y]} # -# Should be able to handle proc declarations within namespaces, -# even if they have explicit namespace paths. +# Should be able to handle proc declarations within namespaces, even if they +# have explicit namespace paths. # namespace eval buried { proc inside {args} {return "inside: $args"} @@ -69,8 +69,8 @@ namespace eval buried { } } -# With proper hooks, we should be able to support other commands -# that create procedures +# With proper hooks, we should be able to support other commands that create +# procedures proc buried::myproc {name body args} { ::proc $name $body $args @@ -90,17 +90,15 @@ namespace eval ::buried { } {::buried::my proc} mycmd6 args {return "another"} -# A correctly functioning [auto_import] won't choke when a child -# namespace [namespace import]s from its parent. +# A correctly functioning [auto_import] won't choke when a child namespace +# [namespace import]s from its parent. # namespace eval ::parent::child { namespace import ::parent::* } proc ::parent::child::test {} {} - } autoMkindex.tcl - # Save initial state of auto_mkindex_parser auto_load auto_mkindex @@ -120,21 +118,19 @@ set result "" set origDir [pwd] cd $::tcltest::temporaryDirectory - + test autoMkindex-1.1 {remove any existing tclIndex file} { file delete tclIndex file exists tclIndex } {0} - test autoMkindex-1.2 {build tclIndex based on a test file} { auto_mkindex . autoMkindex.tcl file exists tclIndex } {1} - set element "{source [file join . autoMkindex.tcl]}" - -test autoMkindex-1.3 {examine tclIndex} { +test autoMkindex-1.3 {examine tclIndex} -setup { file delete tclIndex +} -body { auto_mkindex . autoMkindex.tcl namespace eval tcl_autoMkindex_tmp { set dir "." @@ -145,33 +141,35 @@ test autoMkindex-1.3 {examine tclIndex} { lappend ::result [list $elem $auto_index($elem)] } } + return $result +} -cleanup { namespace delete tcl_autoMkindex_tmp - set ::result -} "{::buried::explicit $element} {::buried::inside $element} {{::buried::my proc} $element} {::buried::mycmd1 $element} {::buried::mycmd4 $element} {::buried::myproc $element} {::buried::pub_one $element} {::buried::pub_two $element} {::buried::relative $element} {::buried::under::neath $element} {::buried::within $element} {::parent::child::test $element} {indented $element} {normal $element} {top $element}" - +} -result "{::buried::explicit $element} {::buried::inside $element} {{::buried::my proc} $element} {::buried::mycmd1 $element} {::buried::mycmd4 $element} {::buried::myproc $element} {::buried::pub_one $element} {::buried::pub_two $element} {::buried::relative $element} {::buried::under::neath $element} {::buried::within $element} {::parent::child::test $element} {indented $element} {normal $element} {top $element}" -test autoMkindex-2.1 {commands on the autoload path can be imported} { +test autoMkindex-2.1 {commands on the autoload path can be imported} -setup { file delete tclIndex + interp create slave +} -body { auto_mkindex . autoMkindex.tcl - set interp [interp create] - set final [$interp eval { + slave eval { namespace eval blt {} set auto_path [linsert $auto_path 0 .] set info [list [catch {namespace import buried::*} result] $result] foreach name [lsort [info commands pub_*]] { lappend info $name [namespace origin $name] } - set info - }] - interp delete $interp - set final -} "0 {} pub_one ::buried::pub_one pub_two ::buried::pub_two" + return $info + } +} -cleanup { + interp delete slave +} -result "0 {} pub_one ::buried::pub_one pub_two ::buried::pub_two" # Test auto_mkindex hooks # Slave hook executes interesting code in the interp used to watch code. - -test autoMkindex-3.1 {slaveHook} { +test autoMkindex-3.1 {slaveHook} -setup { + file delete tclIndex +} -body { auto_mkindex_parser::slavehook { _%@namespace eval ::blt { proc foo {} {} @@ -179,26 +177,23 @@ test autoMkindex-3.1 {slaveHook} { } } auto_mkindex_parser::slavehook { _%@namespace import -force ::blt::* } - file delete tclIndex auto_mkindex . autoMkindex.tcl - + file exists tclIndex +} -cleanup { # Reset initCommands to avoid trashing other tests - AutoMkindexTestReset - file exists tclIndex -} 1 - -# The auto_mkindex_parser::command is used to register commands -# that create new commands. - -test autoMkindex-3.2 {auto_mkindex_parser::command} { +} -result 1 +# The auto_mkindex_parser::command is used to register commands that create +# new commands. +test autoMkindex-3.2 {auto_mkindex_parser::command} -setup { + file delete tclIndex +} -body { auto_mkindex_parser::command buried::myproc {name args} { variable index variable scriptFile append index [list set auto_index([fullname $name])] \ " \[list source \[file join \$dir [list $scriptFile]\]\]\n" } - file delete tclIndex auto_mkindex . autoMkindex.tcl namespace eval tcl_autoMkindex_tmp { set dir "." @@ -208,17 +203,16 @@ test autoMkindex-3.2 {auto_mkindex_parser::command} { foreach elem [lsort [array names auto_index]] { lappend ::result [list $elem $auto_index($elem)] } + return $::result } +} -cleanup { namespace delete tcl_autoMkindex_tmp - # Reset initCommands to avoid trashing other tests - AutoMkindexTestReset - set ::result -} "{::buried::explicit $element} {::buried::inside $element} {{::buried::my proc} $element} {::buried::mycmd1 $element} {::buried::mycmd2 $element} {::buried::mycmd4 $element} {::buried::myproc $element} {::buried::pub_one $element} {::buried::pub_two $element} {::buried::relative $element} {::buried::under::neath $element} {::buried::within $element} {::parent::child::test $element} {indented $element} {mycmd3 $element} {normal $element} {top $element}" - - -test autoMkindex-3.3 {auto_mkindex_parser::command} {knownBug} { +} -result "{::buried::explicit $element} {::buried::inside $element} {{::buried::my proc} $element} {::buried::mycmd1 $element} {::buried::mycmd2 $element} {::buried::mycmd4 $element} {::buried::myproc $element} {::buried::pub_one $element} {::buried::pub_two $element} {::buried::relative $element} {::buried::under::neath $element} {::buried::within $element} {::parent::child::test $element} {indented $element} {mycmd3 $element} {normal $element} {top $element}" +test autoMkindex-3.3 {auto_mkindex_parser::command} -setup { + file delete tclIndex +} -constraints {knownBug} -body { auto_mkindex_parser::command {buried::my proc} {name args} { variable index variable scriptFile @@ -226,7 +220,6 @@ test autoMkindex-3.3 {auto_mkindex_parser::command} {knownBug} { append index [list set auto_index([fullname $name])] \ " \[list source \[file join \$dir [list $scriptFile]\]\]\n" } - file delete tclIndex auto_mkindex . autoMkindex.tcl namespace eval tcl_autoMkindex_tmp { set dir "." @@ -237,109 +230,93 @@ test autoMkindex-3.3 {auto_mkindex_parser::command} {knownBug} { lappend ::result [list $elem $auto_index($elem)] } } + list [lsearch -inline $::result *mycmd4*] \ + [lsearch -inline $::result *mycmd5*] \ + [lsearch -inline $::result *mycmd6*] +} -cleanup { namespace delete tcl_autoMkindex_tmp - # Reset initCommands to avoid trashing other tests - AutoMkindexTestReset - proc lvalue {list pattern} { - set ix [lsearch $list $pattern] - if {$ix >= 0} { - return [lindex $list $ix] - } else { - return {} - } - } - list [lvalue $::result *mycmd4*] [lvalue $::result *mycmd5*] [lvalue $::result *mycmd6*] -} "{::buried::mycmd4 $element} {::buried::mycmd5 $element} {mycmd6 $element}" - - -makeDirectory pkg -makeFile { -package provide football 1.0 - -namespace eval ::pro:: { - # - # export only public functions. - # - namespace export {[a-z]*} -} -namespace eval ::college:: { - # - # export only public functions. - # - namespace export {[a-z]*} -} - -proc ::pro::team {} { - puts "go packers!" - return true -} +} -result "{::buried::mycmd4 $element} {::buried::mycmd5 $element} {mycmd6 $element}" -proc ::college::team {} { - puts "go badgers!" - return true -} - -} [file join pkg samename.tcl] - - -test autoMkindex-4.1 {platform indenpendant source commands} { +test autoMkindex-4.1 {platform independent source commands} -setup { file delete tclIndex + makeDirectory pkg + makeFile { + package provide football 1.0 + namespace eval ::pro:: { + # + # export only public functions. + # + namespace export {[a-z]*} + } + namespace eval ::college:: { + # + # export only public functions. + # + namespace export {[a-z]*} + } + proc ::pro::team {} { + puts "go packers!" + return true + } + proc ::college::team {} { + puts "go badgers!" + return true + } + } [file join pkg samename.tcl] +} -body { auto_mkindex . pkg/samename.tcl set f [open tclIndex r] - set dat [split [string trim [read $f]] "\n"] - set len [llength $dat] - set result [lsort [lrange $dat [expr {$len-2}] [expr {$len-1}]]] - close $f - set result -} {{set auto_index(::college::team) [list source [file join $dir pkg samename.tcl]]} {set auto_index(::pro::team) [list source [file join $dir pkg samename.tcl]]}} - -removeFile [file join pkg samename.tcl] - -makeFile { -set dollar1 "this string contains an unescaped dollar sign -> \\$foo" -set dollar2 "this string contains an escaped dollar sign -> \$foo \\\$foo" -set bracket1 "this contains an unescaped bracket [NoSuchProc]" -set bracket2 "this contains an escaped bracket \[NoSuchProc\]" -set bracket3 "this contains nested unescaped brackets [[NoSuchProc]]" -proc testProc {} {} -} [file join pkg magicchar.tcl] - -test autoMkindex-5.1 {escape magic tcl chars in general code} { + lsort [lrange [split [string trim [read $f]] "\n"] end-1 end] +} -cleanup { + catch {close $f} + removeFile [file join pkg samename.tcl] + removeDirectory pkg +} -result {{set auto_index(::college::team) [list source [file join $dir pkg samename.tcl]]} {set auto_index(::pro::team) [list source [file join $dir pkg samename.tcl]]}} + +test autoMkindex-5.1 {escape magic tcl chars in general code} -setup { file delete tclIndex + makeDirectory pkg + makeFile { + set dollar1 "this string contains an unescaped dollar sign -> \\$foo" + set dollar2 \ + "this string contains an escaped dollar sign -> \$foo \\\$foo" + set bracket1 "this contains an unescaped bracket [NoSuchProc]" + set bracket2 "this contains an escaped bracket \[NoSuchProc\]" + set bracket3 \ + "this contains nested unescaped brackets [[NoSuchProc]]" + proc testProc {} {} + } [file join pkg magicchar.tcl] set result {} - if { ![catch {auto_mkindex . pkg/magicchar.tcl}] } { - set f [open tclIndex r] - set dat [split [string trim [read $f]] "\n"] - set result [lindex $dat end] - close $f - } - set result -} {set auto_index(testProc) [list source [file join $dir pkg magicchar.tcl]]} - -removeFile [file join pkg magicchar.tcl] - -makeFile { -proc {[magic mojo proc]} {} {} -} [file join pkg magicchar2.tcl] - -test autoMkindex-5.2 {correctly locate auto loaded procs with []} { +} -body { + auto_mkindex . pkg/magicchar.tcl + set f [open tclIndex r] + lindex [split [string trim [read $f]] "\n"] end +} -cleanup { + catch {close $f} + removeFile [file join pkg magicchar.tcl] + removeDirectory pkg +} -result {set auto_index(testProc) [list source [file join $dir pkg magicchar.tcl]]} +test autoMkindex-5.2 {correctly locate auto loaded procs with []} -setup { file delete tclIndex + makeDirectory pkg + makeFile { + proc {[magic mojo proc]} {} {} + } [file join pkg magicchar2.tcl] set result {} - if { ![catch {auto_mkindex . pkg/magicchar2.tcl}] } { - # Make a slave interp to test the autoloading - set c [interp create] - $c eval {lappend auto_path [pwd]} - set result [$c eval {catch {{[magic mojo proc]}}}] - interp delete $c - } - set result -} 0 - -removeFile [file join pkg magicchar2.tcl] -removeDirectory pkg - + interp create slave +} -body { + auto_mkindex . pkg/magicchar2.tcl + # Make a slave interp to test the autoloading + slave eval {lappend auto_path [pwd]} + slave eval {catch {{[magic mojo proc]}}} +} -cleanup { + interp delete slave + removeFile [file join pkg magicchar2.tcl] + removeDirectory pkg +} -result 0 + # Clean up. unset result @@ -357,3 +334,9 @@ if {[file exists tclIndex]} { cd $origDir ::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/binary.test b/tests/binary.test index 79fdb92..fc3d0b3 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: binary.test,v 1.41 2010/09/15 22:12:00 dkf Exp $ +# RCS: @(#) $Id: binary.test,v 1.43 2010/11/09 14:20:19 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest diff --git a/tests/chanio.test b/tests/chanio.test index 11bf23e..c191dfe 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.4.1 2010/12/01 16:42:36 kennykb Exp $ +# RCS: @(#) $Id: chanio.test,v 1.27 2011/01/17 11:27:28 nijtmans Exp $ if {[catch {package require tcltest 2}]} { chan puts stderr "Skipping tests in [info script]. tcltest 2 required." @@ -3932,7 +3932,7 @@ test chan-io-32.3 {Tcl_Read, negative byte count} -setup { chan read $f -1 } -returnCodes error -cleanup { chan close $f -} -result {bad argument "-1": should be "nonewline"} +} -result {expected non-negative integer but got "-1"} test chan-io-32.4 {Tcl_Read, positive byte count} -body { set f [open $path(longfile) r] string length [chan read $f 1024] diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 2213c57..068b6cd 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -10,9 +10,9 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: cmdAH.test,v 1.68.4.1 2010/12/11 18:39:30 kennykb Exp $ +# RCS: @(#) $Id: cmdAH.test,v 1.70 2011/01/01 15:14:43 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2.1 namespace import -force ::tcltest::* } @@ -236,14 +236,15 @@ test cmdAH-6.1 {Tcl_FileObjCmd: volumes} -returnCodes error -body { test cmdAH-6.2 {Tcl_FileObjCmd: volumes} -body { lindex [file volumes] 0 } -match glob -result ?* -test cmdAH-6.3 {Tcl_FileObjCmd: volumes} {unix} { +test cmdAH-6.3 {Tcl_FileObjCmd: volumes} -constraints unix -body { set volumeList [file volumes] - catch [list glob -nocomplain [lindex $volumeList 0]*] -} {0} -test cmdAH-6.4 {Tcl_FileObjCmd: volumes} win { + glob -nocomplain [lindex $volumeList 0]* +} -match glob -result * +test cmdAH-6.4 {Tcl_FileObjCmd: volumes} -constraints win -body { set volumeList [string tolower [file volumes]] - list [catch {lsearch $volumeList "c:/"} element] [expr {$element != -1}] [catch {list glob -nocomplain [lindex $volumeList $element]*}] -} {0 1 0} + set element [lsearch -exact $volumeList "c:/"] + list [expr {$element>-1}] [glob -nocomplain [lindex $volumeList $element]*] +} -match glob -result {1 *} # attributes test cmdAH-7.1 {Tcl_FileObjCmd - file attrs} -setup { @@ -251,11 +252,11 @@ test cmdAH-7.1 {Tcl_FileObjCmd - file attrs} -setup { catch {file delete -force $foofile} } -body { close [open $foofile w] - catch {file attributes $foofile} + file attributes $foofile } -cleanup { # We used [makeFile] so we undo with [removeFile] removeFile $foofile -} -result {0} +} -match glob -result * # dirname test cmdAH-8.1 {Tcl_FileObjCmd: dirname} -returnCodes error -body { @@ -497,33 +498,36 @@ test cmdAH-9.26 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform windows file tail {//foo/bar} } {} -test cmdAH-9.42 {Tcl_FileObjCmd: tail} testsetplatform { +test cmdAH-9.42 {Tcl_FileObjCmd: tail} -constraints testsetplatform -setup { global env set temp $env(HOME) +} -body { set env(HOME) "/home/test" testsetplatform unix - set result [file tail ~] + file tail ~ +} -cleanup { set env(HOME) $temp - set result -} test -test cmdAH-9.43 {Tcl_FileObjCmd: tail} testsetplatform { +} -result test +test cmdAH-9.43 {Tcl_FileObjCmd: tail} -constraints testsetplatform -setup { global env set temp $env(HOME) +} -body { set env(HOME) "~" testsetplatform unix - set result [file tail ~] + file tail ~ +} -cleanup { set env(HOME) $temp - set result -} {} -test cmdAH-9.44 {Tcl_FileObjCmd: tail} testsetplatform { +} -result {} +test cmdAH-9.44 {Tcl_FileObjCmd: tail} -constraints testsetplatform -setup { global env set temp $env(HOME) +} -body { set env(HOME) "/home/test" testsetplatform windows - set result [file tail ~] + file tail ~ +} -cleanup { set env(HOME) $temp - set result -} test +} -result test test cmdAH-9.46 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform unix file tail {f.oo\bar/baz.bat} @@ -923,10 +927,10 @@ test cmdAH-19.7 {Tcl_FileObjCmd: nativename} -body { test cmdAH-19.9 {Tcl_FileObjCmd: ~ : exists} { file exists ~nOsUcHuSeR } 0 -test cmdAH-19.10 {Tcl_FileObjCmd: ~ : nativename} { - # should probably be 0 in fact... - catch {file nativename ~nOsUcHuSeR} -} 1 +test cmdAH-19.10 {Tcl_FileObjCmd: ~ : nativename} -body { + # should probably be a non-error in fact... + file nativename ~nOsUcHuSeR +} -returnCodes error -match glob -result * # The test below has to be done in /tmp rather than the current directory in # order to guarantee (?) a local file system: some NFS file systems won't do # the stuff below correctly. @@ -963,7 +967,7 @@ test cmdAH-20.1 {Tcl_FileObjCmd: atime} -returnCodes error -body { file atime a b c } -result {wrong # args: should be "file atime name ?time?"} test cmdAH-20.2 {Tcl_FileObjCmd: atime} -setup { - catch {unset stat} + unset -nocomplain stat } -body { file stat $gorpfile stat list [expr {[file mtime $gorpfile] == $stat(mtime)}] \ @@ -1031,13 +1035,13 @@ test cmdAH-23.2 {Tcl_FileObjCmd: lstat} -returnCodes error -body { file lstat a b c } -result {wrong # args: should be "file lstat name varName"} test cmdAH-23.3 {Tcl_FileObjCmd: lstat} -setup { - catch {unset stat} + unset -nocomplain stat } -constraints {unix nonPortable} -body { file lstat $linkfile stat lsort [array names stat] } -result {atime ctime dev gid ino mode mtime nlink size type uid} test cmdAH-23.4 {Tcl_FileObjCmd: lstat} -setup { - catch {unset stat} + unset -nocomplain stat } -constraints {unix nonPortable} -body { file lstat $linkfile stat list $stat(nlink) [expr $stat(mode)&0777] $stat(type) @@ -1047,12 +1051,12 @@ test cmdAH-23.5 {Tcl_FileObjCmd: lstat errors} {nonPortable} { $errorCode } {1 {could not read "_bogus_": no such file or directory} {POSIX ENOENT {no such file or directory}}} test cmdAH-23.6 {Tcl_FileObjCmd: lstat errors} -setup { - catch {unset x} + unset -nocomplain x } -body { set x 44 list [catch {file lstat $gorpfile x} msg] $msg $errorCode } -result {1 {can't set "x(dev)": variable isn't array} {TCL LOOKUP VARNAME x}} -catch {unset stat} +unset -nocomplain stat # mkdir set dirA [file join [temporaryDirectory] a] set dirB [file join [temporaryDirectory] a] @@ -1128,7 +1132,7 @@ test cmdAH-24.2 {Tcl_FileObjCmd: mtime} -setup { } } -result {1} test cmdAH-24.3 {Tcl_FileObjCmd: mtime} -setup { - catch {unset stat} + unset -nocomplain stat } -body { file stat $gorpfile stat list [expr {[file mtime $gorpfile] == $stat(mtime)}] \ @@ -1294,7 +1298,7 @@ test cmdAH-28.2 {Tcl_FileObjCmd: stat} -returnCodes error -body { file stat _bogus_ a b } -result {wrong # args: should be "file stat name varName"} test cmdAH-28.3 {Tcl_FileObjCmd: stat} -setup { - catch {unset stat} + unset -nocomplain stat set stat(blocks) [set stat(blksize) {}] } -body { file stat $gorpfile stat @@ -1302,13 +1306,13 @@ test cmdAH-28.3 {Tcl_FileObjCmd: stat} -setup { lsort [array names stat] } -result {atime ctime dev gid ino mode mtime nlink size type uid} test cmdAH-28.4 {Tcl_FileObjCmd: stat} -setup { - catch {unset stat} + unset -nocomplain stat } -body { file stat $gorpfile stat list $stat(nlink) $stat(size) $stat(type) } -result {1 12 file} test cmdAH-28.5 {Tcl_FileObjCmd: stat} -constraints {unix} -setup { - catch {unset stat} + unset -nocomplain stat } -body { file stat $gorpfile stat expr {$stat(mode) & 0o777} @@ -1317,7 +1321,7 @@ test cmdAH-28.6 {Tcl_FileObjCmd: stat} { list [catch {file stat _bogus_ stat} msg] [string tolower $msg] $errorCode } {1 {could not read "_bogus_": no such file or directory} {POSIX ENOENT {no such file or directory}}} test cmdAH-28.7 {Tcl_FileObjCmd: stat} -setup { - catch {unset x} + unset -nocomplain x } -returnCodes error -body { set x 44 file stat $gorpfile x @@ -1371,7 +1375,7 @@ test cmdAH-28.12 {Tcl_FileObjCmd: stat} -setup { } -cleanup { removeFile $filename } -result 1 -catch {unset stat} +unset -nocomplain stat # type test cmdAH-29.1 {Tcl_FileObjCmd: type} -returnCodes error -body { @@ -1513,7 +1517,7 @@ test cmdAH-32.2 {file tempfile - returns a read/write channel} -body { catch {close $f} } -result ok test cmdAH-32.3 {file tempfile - makes filenames} -setup { - catch {unset name} + unset -nocomplain name } -body { set result [info exists name] set f [file tempfile name] @@ -1556,7 +1560,7 @@ interp delete simpleInterp # cleanup catch {testsetplatform $platform} -catch {unset platform} +unset -nocomplain platform # Tcl_ForObjCmd is tested in for.test diff --git a/tests/cmdIL.test b/tests/cmdIL.test index ca81ea5..b806e65 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -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: cmdIL.test,v 1.43 2009/12/22 19:49:29 dkf Exp $ +# RCS: @(#) $Id: cmdIL.test,v 1.44 2010/12/27 00:01:07 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -458,6 +458,9 @@ test cmdIL-5.5 {lsort with list style index and sharing} -body { } -result 0 -cleanup { rename test_lsort "" } +test cmdIL-5.6 {lsort with multiple list-style index options} { + lsort -index {1 2 3} -index 0 {{a b} {c d} {b e}} +} {{a b} {b e} {c d}} # Compiled version test cmdIL-6.1 {lassign command syntax} -returnCodes error -body { diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index c7f6e44..78bb329 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.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: cmdMZ.test,v 1.30 2010/04/05 19:44:45 ferrieux Exp $ +# RCS: @(#) $Id: cmdMZ.test,v 1.31 2011/01/01 15:14:43 dkf Exp $ if {[catch {package require tcltest 2.1}]} { puts stderr "Skipping tests in [info script]. tcltest 2.1 required." @@ -38,7 +38,7 @@ namespace eval ::tcl::test::cmdMZ { return 1 } customMatch listGlob [namespace which ListGlobMatch] - + # Tcl_PwdObjCmd test cmdMZ-1.1 {Tcl_PwdObjCmd} -returnCodes error -body { @@ -166,35 +166,31 @@ test cmdMZ-return-2.13 {return option handling} -body { test cmdMZ-return-2.14 {return option handling} -body { return -level 0 -code error -options {-code foo -options {-code break}} } -returnCodes break -result {} -test cmdMZ-return-2.15 {return opton handling} -setup { - proc p {} { - return -code error -errorcode {a b} c - } -} -body { - list [catch p result] $result $::errorCode -} -cleanup { - rename p {} -} -result {1 c {a b}} -test cmdMZ-return-2.16 {return opton handling} -setup { - proc p {} { - return -code error -errorcode [list a b] c - } -} -body { - list [catch p result] $result $::errorCode -} -cleanup { - rename p {} -} -result {1 c {a b}} -test cmdMZ-return-2.17 {return opton handling} -setup { - proc p {} { - return -code error -errorcode a\ b c - } -} -body { - list [catch p result] $result $::errorCode -} -cleanup { - rename p {} -} -result {1 c {a b}} +test cmdMZ-return-2.15 {return opton handling} { + list [catch { + apply {{} { + return -code error -errorcode {a b} c + }} + } result] $result $::errorCode +} {1 c {a b}} +test cmdMZ-return-2.16 {return opton handling} { + list [catch { + apply {{} { + return -code error -errorcode [list a b] c + }} + } result] $result $::errorCode +} {1 c {a b}} +test cmdMZ-return-2.17 {return opton handling} { + list [catch { + apply {{} { + return -code error -errorcode a\ b c + }} + } result] $result $::errorCode +} {1 c {a b}} test cmdMZ-return-2.18 {return option handling} { - list [catch {return -code error -errorstack [list CALL a CALL b] yo} -> foo] [dictSort $foo] [info errorstack] + list [catch { + return -code error -errorstack [list CALL a CALL b] yo + } -> foo] [dictSort $foo] [info errorstack] } {2 {-code 1 -errorcode NONE -errorstack {CALL a CALL b} -level 1} {CALL a CALL b}} # Check that the result of a [return -options $opts $result] is @@ -349,7 +345,7 @@ test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} { "time {error foo}"}} # The tests for Tcl_WhileObjCmd are in while.test - + # cleanup cleanupTests } diff --git a/tests/compExpr.test b/tests/compExpr.test index c3e68c1..afa3b56 100644 --- a/tests/compExpr.test +++ b/tests/compExpr.test @@ -1,17 +1,17 @@ -# This file contains a collection of tests for the procedures in the -# file tclCompExpr.c. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. +# This file contains a collection of tests for the procedures in the file +# tclCompExpr.c. Sourcing this file into Tcl runs the tests and generates +# output for errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # -# 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. # -# RCS: @(#) $Id: compExpr.test,v 1.17 2008/01/16 21:54:33 dgp Exp $ +# RCS: @(#) $Id: compExpr.test,v 1.18 2011/01/01 15:14:43 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2 namespace import -force ::tcltest::* } @@ -25,7 +25,7 @@ if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1" testConstraint memory [llength [info commands memory]] catch {unset a} - + test compExpr-1.1 {TclCompileExpr procedure, successful expr parse and compile} { expr 1+2 } 3 @@ -35,17 +35,17 @@ test compExpr-1.2 {TclCompileExpr procedure, error parsing expr} -body { test compExpr-1.3 {TclCompileExpr procedure, error compiling expr} -body { list [catch {expr "foo(123)"} msg] $msg } -match glob -result {1 {* "*foo"}} - test compExpr-1.4 {TclCompileExpr procedure, expr has no operators} { set a {0o00123} expr {$a} } 83 -test compExpr-2.1 {CompileSubExpr procedure, TCL_TOKEN_WORD parse token} { - catch {unset a} +test compExpr-2.1 {CompileSubExpr procedure, TCL_TOKEN_WORD parse token} -setup { + unset -nocomplain a +} -body { set a 27 expr {"foo$a" < "bar"} -} 0 +} -result 0 test compExpr-2.2 {CompileSubExpr procedure, error compiling TCL_TOKEN_WORD parse token} -body { expr {"00[expr 1+]" + 17} } -returnCodes error -match glob -result * @@ -68,30 +68,33 @@ test compExpr-2.7 {CompileSubExpr procedure, TCL_TOKEN_COMMAND parse token} { test compExpr-2.8 {CompileSubExpr procedure, error in TCL_TOKEN_COMMAND parse token} -body { expr {[foo "bar"xxx] + 17} } -returnCodes error -match glob -result * -test compExpr-2.9 {CompileSubExpr procedure, TCL_TOKEN_VARIABLE parse token} { - catch {unset a} +test compExpr-2.9 {CompileSubExpr procedure, TCL_TOKEN_VARIABLE parse token} -setup { + unset -nocomplain a +} -body { set a 123 expr {$a*2} -} 246 -test compExpr-2.10 {CompileSubExpr procedure, TCL_TOKEN_VARIABLE parse token} { - catch {unset a} - catch {unset b} +} -result 246 +test compExpr-2.10 {CompileSubExpr procedure, TCL_TOKEN_VARIABLE parse token} -setup { + unset -nocomplain a + unset -nocomplain b +} -body { set a(george) martha set b geo expr {$a(${b}rge)} -} martha -test compExpr-2.11 {CompileSubExpr procedure, error in TCL_TOKEN_VARIABLE parse token} { - catch {unset a} - list [catch {expr {$a + 17}} msg] $msg -} {1 {can't read "a": no such variable}} +} -result martha +test compExpr-2.11 {CompileSubExpr procedure, error in TCL_TOKEN_VARIABLE parse token} -body { + unset -nocomplain a + expr {$a + 17} +} -returnCodes error -result {can't read "a": no such variable} test compExpr-2.12 {CompileSubExpr procedure, TCL_TOKEN_SUB_EXPR parse token} { expr {27||3? 3<<(1+4) : 4&&9} } 96 -test compExpr-2.13 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} { - catch {unset a} +test compExpr-2.13 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} -setup { + unset -nocomplain a +} -body { set a 15 list [catch {expr {27 || "$a[expr 1+]00"}} msg] $msg -} {0 1} +} -result {0 1} test compExpr-2.14 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, op found} { expr {5*6} } 30 @@ -149,11 +152,12 @@ test compExpr-2.31 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal o test compExpr-2.32 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator, 1 operand} { expr {~4} } -5 -test compExpr-2.33 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator, comparison} { - catch {unset a} +test compExpr-2.33 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator, comparison} -setup { + unset -nocomplain a +} -body { set a 15 expr {$a==15} ;# compiled out-of-line to runtime call on Tcl_ExprObjCmd -} 1 +} -result 1 test compExpr-2.34 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} { expr {+2} } 2 @@ -175,72 +179,84 @@ test compExpr-2.39 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special test compExpr-2.40 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} { expr {4-2} } 2 -test compExpr-2.41 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} { - catch {unset a} +test compExpr-2.41 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} -setup { + unset -nocomplain a +} -body { set a true expr {0||$a} -} 1 -test compExpr-2.42 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} { - catch {unset a} +} -result 1 +test compExpr-2.42 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} -setup { + unset -nocomplain a +} -body { set a 15 list [catch {expr {27 || "$a[expr 1+]00"}} msg] $msg -} {0 1} -test compExpr-2.43 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} { - catch {unset a} +} -result {0 1} +test compExpr-2.43 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} -setup { + unset -nocomplain a +} -body { set a false expr {3&&$a} -} 0 -test compExpr-2.44 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} { - catch {unset a} +} -result 0 +test compExpr-2.44 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} -setup { + unset -nocomplain a +} -body { set a false expr {$a||1? 1 : 0} -} 1 -test compExpr-2.45 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} { - catch {unset a} +} -result 1 +test compExpr-2.45 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} -setup { + unset -nocomplain a +} -body { set a 15 list [catch {expr {1? 54 : "$a[expr 1+]00"}} msg] $msg -} {0 54} +} -result {0 54} -test compExpr-3.1 {CompileLandOrLorExpr procedure, numeric 1st operand} { - catch {unset a} +test compExpr-3.1 {CompileLandOrLorExpr procedure, numeric 1st operand} -setup { + unset -nocomplain a +} -body { set a 2 expr {[set a]||0} -} 1 -test compExpr-3.2 {CompileLandOrLorExpr procedure, nonnumeric 1st operand} { - catch {unset a} +} -result 1 +test compExpr-3.2 {CompileLandOrLorExpr procedure, nonnumeric 1st operand} -setup { + unset -nocomplain a +} -body { set a no expr {$a&&1} -} 0 +} -result 0 test compExpr-3.3 {CompileSubExpr procedure, error in 1st operand} -body { expr {[expr *2]||0} } -returnCodes error -match glob -result * -test compExpr-3.4 {CompileLandOrLorExpr procedure, result is 1 or 0} { - catch {unset a} - catch {unset b} +test compExpr-3.4 {CompileLandOrLorExpr procedure, result is 1 or 0} -setup { + unset -nocomplain a + unset -nocomplain b +} -body { set a no set b true expr {$a || $b} -} 1 -test compExpr-3.5 {CompileLandOrLorExpr procedure, short-circuit semantics} { - catch {unset a} +} -result 1 +test compExpr-3.5 {CompileLandOrLorExpr procedure, short-circuit semantics} -setup { + unset -nocomplain a +} -body { set a yes expr {$a || [exit]} -} 1 -test compExpr-3.6 {CompileLandOrLorExpr procedure, short-circuit semantics} { - catch {unset a} +} -result 1 +test compExpr-3.6 {CompileLandOrLorExpr procedure, short-circuit semantics} -setup { + unset -nocomplain a +} -body { set a no expr {$a && [exit]} -} 0 -test compExpr-3.7 {CompileLandOrLorExpr procedure, numeric 2nd operand} { - catch {unset a} +} -result 0 +test compExpr-3.7 {CompileLandOrLorExpr procedure, numeric 2nd operand} -setup { + unset -nocomplain a +} -body { set a 2 expr {0||[set a]} -} 1 -test compExpr-3.8 {CompileLandOrLorExpr procedure, nonnumeric 2nd operand} { - catch {unset a} +} -result 1 +test compExpr-3.8 {CompileLandOrLorExpr procedure, nonnumeric 2nd operand} -setup { + unset -nocomplain a +} -body { set a no expr {1&&$a} -} 0 +} -result 0 test compExpr-3.9 {CompileLandOrLorExpr procedure, error in 2nd operand} -body { expr {0||[expr %2]} } -returnCodes error -match glob -result * @@ -250,42 +266,48 @@ test compExpr-3.10 {CompileLandOrLorExpr procedure, long lor/land arm} { expr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} } 1 -test compExpr-4.1 {CompileCondExpr procedure, simple test} { - catch {unset a} +test compExpr-4.1 {CompileCondExpr procedure, simple test} -setup { + unset -nocomplain a +} -body { set a 2 expr {($a > 1)? "ok" : "nope"} -} ok -test compExpr-4.2 {CompileCondExpr procedure, complex test, convert to numeric} { - catch {unset a} +} -result ok +test compExpr-4.2 {CompileCondExpr procedure, complex test, convert to numeric} -setup { + unset -nocomplain a +} -body { set a no expr {[set a]? 27 : -54} -} -54 +} -result -54 test compExpr-4.3 {CompileCondExpr procedure, error in test} -body { expr {[expr *2]? +1 : -1} } -returnCodes error -match glob -result * -test compExpr-4.4 {CompileCondExpr procedure, simple "true" clause} { - catch {unset a} +test compExpr-4.4 {CompileCondExpr procedure, simple "true" clause} -setup { + unset -nocomplain a +} -body { set a no expr {1? (27-2) : -54} -} 25 -test compExpr-4.5 {CompileCondExpr procedure, convert "true" clause to numeric} { - catch {unset a} +} -result 25 +test compExpr-4.5 {CompileCondExpr procedure, convert "true" clause to numeric} -setup { + unset -nocomplain a +} -body { set a no expr {1? $a : -54} -} no +} -result no test compExpr-4.6 {CompileCondExpr procedure, error in "true" clause} -body { expr {1? [expr *2] : -127} } -returnCodes error -match glob -result * -test compExpr-4.7 {CompileCondExpr procedure, simple "false" clause} { - catch {unset a} +test compExpr-4.7 {CompileCondExpr procedure, simple "false" clause} -setup { + unset -nocomplain a +} -body { set a no expr {(2-2)? -3.14159 : "nope"} -} nope -test compExpr-4.8 {CompileCondExpr procedure, convert "false" clause to numeric} { - catch {unset a} +} -result nope +test compExpr-4.8 {CompileCondExpr procedure, convert "false" clause to numeric} -setup { + unset -nocomplain a +} -body { set a 0o0123 expr {0? 42 : $a} -} 83 +} -result 83 test compExpr-4.9 {CompileCondExpr procedure, error in "false" clause} { list [catch {expr {1? 15 : [expr *2]}} msg] $msg } {0 15} @@ -294,8 +316,8 @@ test compExpr-5.1 {CompileMathFuncCall procedure, math function found} { format %.6g [expr atan2(1.0, 2.0)] } 0.463648 test compExpr-5.2 {CompileMathFuncCall procedure, math function not found} -body { - list [catch {expr {do_it()}} msg] $msg -} -match glob -result {1 {* "*do_it"}} + expr {do_it()} +} -returnCodes error -match glob -result {* "*do_it"} test compExpr-5.3 {CompileMathFuncCall: call registered math function} testmathfunctions { expr 3*T1()-1 } 368 @@ -303,8 +325,8 @@ test compExpr-5.4 {CompileMathFuncCall: call registered math function} testmathf expr T2()*3 } 1035 test compExpr-5.5 {CompileMathFuncCall procedure, too few arguments} -body { - list [catch {expr {atan2(1.0)}} msg] $msg -} -match glob -result {1 {too few arguments for math function*}} + expr {atan2(1.0)} +} -returnCodes error -match glob -result {too few arguments for math function*} test compExpr-5.6 {CompileMathFuncCall procedure, complex argument} { format %.6g [expr pow(2.1, 27.5-(24.4*(5%2)))] } 9.97424 @@ -312,11 +334,11 @@ test compExpr-5.7 {CompileMathFuncCall procedure, error in argument} -body { expr {sinh(2.*)} } -returnCodes error -match glob -result * test compExpr-5.8 {CompileMathFuncCall procedure, too many arguments} -body { - list [catch {expr {sinh(2.0, 3.0)}} msg] $msg -} -match glob -result {1 {too many arguments for math function*}} + expr {sinh(2.0, 3.0)} +} -returnCodes error -match glob -result {too many arguments for math function*} test compExpr-5.9 {CompileMathFuncCall procedure, too many arguments} -body { - list [catch {expr {0 <= rand(5.2)}} msg] $msg -} -match glob -result {1 {too many arguments for math function*}} + expr {0 <= rand(5.2)} +} -returnCodes error -match glob -result {too many arguments for math function*} test compExpr-6.1 {LogSyntaxError procedure, error in expr longer than 60 chars} -body { expr {(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)/} -1 foo 3 @@ -360,9 +382,14 @@ test compExpr-7.2 {[Bug 1869989]: expr parser memleak} -constraints memory -setu unset end i tmp rename getbytes {} } -result 0 - + # cleanup catch {unset a} catch {unset b} ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/compile.test b/tests/compile.test index 021c6fe..49df0aa 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -1,17 +1,17 @@ -# This file contains tests for the files tclCompile.c, tclCompCmds.c -# and tclLiteral.c +# This file contains tests for the files tclCompile.c, tclCompCmds.c and +# tclLiteral.c # -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. +# This file contains a collection of tests for one or more of the Tcl built-in +# commands. Sourcing this file into Tcl runs the tests and generates output +# for errors. No output means no errors were found. # # Copyright (c) 1997 by Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # -# 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. # -# RCS: @(#) $Id: compile.test,v 1.51.4.1 2010/11/03 00:18:57 kennykb Exp $ +# RCS: @(#) $Id: compile.test,v 1.53 2011/01/01 15:14:43 dkf Exp $ package require tcltest 2 namespace import -force ::tcltest::* @@ -29,9 +29,10 @@ catch {unset x} catch {unset y} catch {unset a} -test compile-1.1 {TclCompileString: look up cmds in proc ns, not current ns} { +test compile-1.1 {TclCompileString: look up cmds in proc ns, not current ns} -setup { catch {namespace delete test_ns_compile} catch {unset x} +} -body { set x 123 namespace eval test_ns_compile { proc set {args} { @@ -43,63 +44,70 @@ test compile-1.1 {TclCompileString: look up cmds in proc ns, not current ns} { } } list [test_ns_compile::p] [set x] -} {{123 test_ns_compile::set} {123 test_ns_compile::set}} +} -result {{123 test_ns_compile::set} {123 test_ns_compile::set}} test compile-1.2 {TclCompileString, error result is reset if TclGetLong determines word isn't an integer} { proc p {x} {info commands 3m} list [catch {p} msg] $msg } {1 {wrong # args: should be "p x"}} -test compile-2.1 {TclCompileDollarVar: global scalar name with ::s} { + +test compile-2.1 {TclCompileDollarVar: global scalar name with ::s} -setup { catch {unset x} +} -body { set x 123 - list $::x [expr {[lsearch -exact [info globals] x] != 0}] -} {123 1} -test compile-2.2 {TclCompileDollarVar: global scalar name with ::s} { + list $::x [expr {"x" in [info globals]}] +} -result {123 1} +test compile-2.2 {TclCompileDollarVar: global scalar name with ::s} -setup { catch {unset y} +} -body { proc p {} { set ::y 789 return $::y } - list [p] $::y [expr {[lsearch -exact [info globals] y] != 0}] -} {789 789 1} -test compile-2.3 {TclCompileDollarVar: global array name with ::s} { + list [p] $::y [expr {"y" in [info globals]}] +} -result {789 789 1} +test compile-2.3 {TclCompileDollarVar: global array name with ::s} -setup { catch {unset a} +} -body { set ::a(1) 2 - list $::a(1) [set ::a($::a(1)) 3] $::a(2) [expr {[lsearch -exact [info globals] a] != 0}] -} {2 3 3 1} -test compile-2.4 {TclCompileDollarVar: global scalar name with ::s} { + list $::a(1) [set ::a($::a(1)) 3] $::a(2) [expr {"a" in [info globals]}] +} -result {2 3 3 1} +test compile-2.4 {TclCompileDollarVar: global scalar name with ::s} -setup { catch {unset a} +} -body { proc p {} { set ::a(1) 1 return $::a($::a(1)) } - list [p] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}] -} {1 1 1} -test compile-2.5 {TclCompileDollarVar: global array, called as ${arrName(0)}} { + list [p] $::a(1) [expr {"a" in [info globals]}] +} -result {1 1 1} +test compile-2.5 {TclCompileDollarVar: global array, called as ${arrName(0)}} -setup { catch {unset a} +} -body { proc p {} { global a set a(1) 1 return ${a(1)}$::a(1)$a(1) } - list [p] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}] -} {111 1 1} + list [p] $::a(1) [expr {"a" in [info globals]}] +} -result {111 1 1} -test compile-3.1 {TclCompileCatchCmd: only catch cmds with scalar vars are compiled inline} { +test compile-3.1 {TclCompileCatchCmd: only catch cmds with scalar vars are compiled inline} -setup { catch {unset a} +} -body { set a(1) xyzzyx proc p {} { global a catch {set x 123} a(1) } list [p] $a(1) -} {0 123} +} -result {0 123} test compile-3.2 {TclCompileCatchCmd: non-local variables} { set ::foo 1 proc catch-test {} { catch {set x 3} ::foo } catch-test - set ::foo + return $::foo } 3 test compile-3.3 {TclCompileCatchCmd: overagressive compiling [bug 219184]} { proc catch-test {str} { @@ -107,7 +115,7 @@ test compile-3.3 {TclCompileCatchCmd: overagressive compiling [bug 219184]} { error BAD } catch {catch-test error} ::foo - set ::foo + return $::foo } {GOOD} test compile-3.4 {TclCompileCatchCmd: bcc'ed [return] is caught} { proc foo {} { @@ -158,7 +166,6 @@ test compile-3.6 {TclCompileCatchCmd: error in storing result [Bug 3098302]} {*} -cleanup {namespace delete catchtest} } - test compile-4.1 {TclCompileForCmd: command substituted test expression} { set i 0 set j 0 @@ -187,29 +194,32 @@ test compile-5.2 {TclCompileForeachCmd: non-local variables} { set ::foo } 3 -test compile-6.1 {TclCompileSetCmd: global scalar names with ::s} { +test compile-6.1 {TclCompileSetCmd: global scalar names with ::s} -setup { catch {unset x} catch {unset y} +} -body { set x 123 proc p {} { set ::y 789 return $::y } - list $::x [expr {[lsearch -exact [info globals] x] != 0}] \ - [p] $::y [expr {[lsearch -exact [info globals] y] != 0}] -} {123 1 789 789 1} -test compile-6.2 {TclCompileSetCmd: global array names with ::s} { + list $::x [expr {"x" in [info globals]}] \ + [p] $::y [expr {"y" in [info globals]}] +} -result {123 1 789 789 1} +test compile-6.2 {TclCompileSetCmd: global array names with ::s} -setup { catch {unset a} +} -body { set ::a(1) 2 proc p {} { set ::a(1) 1 return $::a($::a(1)) } - list $::a(1) [p] [set ::a($::a(1)) 3] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}] -} {2 1 3 3 1} -test compile-6.3 {TclCompileSetCmd: namespace var names with ::s} { + list $::a(1) [p] [set ::a($::a(1)) 3] $::a(1) [expr {"a" in [info globals]}] +} -result {2 1 3 3 1} +test compile-6.3 {TclCompileSetCmd: namespace var names with ::s} -setup { catch {namespace delete test_ns_compile} catch {unset x} +} -body { namespace eval test_ns_compile { variable v hello variable arr @@ -217,7 +227,7 @@ test compile-6.3 {TclCompileSetCmd: namespace var names with ::s} { set ::test_ns_compile::arr(1) 123 } list $::x $::test_ns_compile::arr(1) -} {hello 123} +} -result {hello 123} test compile-7.1 {TclCompileWhileCmd: command substituted test expression} { set i 0 @@ -258,53 +268,45 @@ test compile-10.1 {BLACKBOX: exception stack overflow} { } } {} -test compile-11.1 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { - proc p {} { +test compile-11.1 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { + apply {{} { # shared object - Interp result && Var 'r' set r [list foobar] # command that will add error to result lindex a bogus - } - list [catch {p} msg] $msg -} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}} -test compile-11.2 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { - proc p {} { set r [list foobar] ; string index a bogus } - list [catch {p} msg] $msg -} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}} + }} +} -returnCodes error -result {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?} +test compile-11.2 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { + apply {{} { set r [list foobar] ; string index a bogus }} +} -returnCodes error -result {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?} test compile-11.3 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { - proc p {} { set r [list foobar] ; string index a 0o9 } - list [catch {p} msg] $msg -} -match glob -result {1 {*invalid octal number*}} -test compile-11.4 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { - proc p {} { set r [list foobar] ; array set var {one two many} } - list [catch {p} msg] $msg -} {1 {list must have an even number of elements}} -test compile-11.5 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { - proc p {} { set r [list foobar] ; incr foo bar baz} - list [catch {p} msg] $msg -} {1 {wrong # args: should be "incr varName ?increment?"}} -test compile-11.6 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { - proc p {} { set r [list foobar] ; incr} - list [catch {p} msg] $msg -} {1 {wrong # args: should be "incr varName ?increment?"}} + apply {{} { set r [list foobar] ; string index a 0o9 }} +} -returnCodes error -match glob -result {*invalid octal number*} +test compile-11.4 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { + apply {{} { set r [list foobar] ; array set var {one two many} }} +} -returnCodes error -result {list must have an even number of elements} +test compile-11.5 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { + apply {{} { set r [list foobar] ; incr foo bar baz}} +} -returnCodes error -result {wrong # args: should be "incr varName ?increment?"} +test compile-11.6 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { + apply {{} { set r [list foobar] ; incr}} +} -returnCodes error -result {wrong # args: should be "incr varName ?increment?"} test compile-11.7 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { - proc p {} { set r [list foobar] ; expr !a } - p + apply {{} { set r [list foobar] ; expr !a }} } -returnCodes error -match glob -result * test compile-11.8 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { - proc p {} { set r [list foobar] ; expr {!a} } - p + apply {{} { set r [list foobar] ; expr {!a} }} } -returnCodes error -match glob -result * -test compile-11.9 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { - proc p {} { set r [list foobar] ; llength "\{" } +test compile-11.9 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { + apply {{} { set r [list foobar] ; llength "\{" }} list [catch {p} msg] $msg -} {1 {unmatched open brace in list}} +} -returnCodes error -result {unmatched open brace in list} # # Special section for tests of tclLiteral.c # The following tests check for incorrect memory handling in -# TclReleaseLiteral. They are only effective when tcl is compiled -# with TCL_MEM_DEBUG +# TclReleaseLiteral. They are only effective when tcl is compiled with +# TCL_MEM_DEBUG # # Special test for leak on interp delete [Bug 467523]. test compile-12.1 {testing literal leak on interp delete} -setup { @@ -328,9 +330,9 @@ test compile-12.1 {testing literal leak on interp delete} -setup { rename getbytes {} unset -nocomplain end i tmp leakedBytes } -result 0 -# Special test for a memory error in a preliminary fix of [Bug 467523]. -# It requires executing a helpfile. Presumably the child process is -# used because when this test fails, it crashes. +# Special test for a memory error in a preliminary fix of [Bug 467523]. It +# requires executing a helpfile. Presumably the child process is used because +# when this test fails, it crashes. test compile-12.2 {testing error on literal deletion} -constraints {memory exec} -body { set sourceFile [makeFile { for {set i 0} {$i < 5} {incr i} { @@ -355,29 +357,28 @@ test compile-12.3 {check for a buffer overrun} -body { test compile-12.4 {TclCleanupLiteralTable segfault} -body { # Tcl Bug 1001997 # Here, we're trying to test a case that causes a crash in - # TclCleanupLiteralTable. The conditions that we're trying to - # establish are: - # - TclCleanupLiteralTable is attempting to clean up a bytecode - # object in the literal table. - # - The bytecode object in question contains the only reference - # to another literal. + # TclCleanupLiteralTable. The conditions that we're trying to establish + # are: + # - TclCleanupLiteralTable is attempting to clean up a bytecode object in + # the literal table. + # - The bytecode object in question contains the only reference to another + # literal. # - The literal in question is in the same hash bucket as the bytecode # object, and immediately follows it in the chain. - # Since newly registered literals are added at the FRONT of the - # bucket chains, and since the bytecode object is registered before - # its literals, this is difficult to achieve. What we do is: - # (a) do a [namespace eval] of a string that's calculated to - # hash into the same bucket as a literal that it contains. - # In this case, the script and the variable 'bugbug' - # land in the same bucket. - # (b) do a [namespace eval] of a string that contains enough - # literals to force TclRegisterLiteral to rebuild the global - # literal table. The newly created hash buckets will contain - # the literals, IN REVERSE ORDER, thus putting the bytecode - # immediately ahead of 'bugbug' and 'bug4345bug'. The bytecode - # object will contain the only references to those two literals. - # (c) Delete the interpreter to invoke TclCleanupLiteralTable - # and tickle the bug. + # Since newly registered literals are added at the FRONT of the bucket + # chains, and since the bytecode object is registered before its literals, + # this is difficult to achieve. What we do is: + # (a) do a [namespace eval] of a string that's calculated to hash into + # the same bucket as a literal that it contains. In this case, the + # script and the variable 'bugbug' land in the same bucket. + # (b) do a [namespace eval] of a string that contains enough literals to + # force TclRegisterLiteral to rebuild the global literal table. The + # newly created hash buckets will contain the literals, IN REVERSE + # ORDER, thus putting the bytecode immediately ahead of 'bugbug' and + # 'bug4345bug'. The bytecode object will contain the only references + # to those two literals. + # (c) Delete the interpreter to invoke TclCleanupLiteralTable and tickle + # the bug. proc foo {} { set i [interp create] $i eval { @@ -411,9 +412,8 @@ test compile-12.4 {TclCleanupLiteralTable segfault} -body { rename foo {} } -result ok -# Special test for underestimating the maxStackSize required for a -# compiled command. A failure will cause a segfault in the child -# process. +# Special test for underestimating the maxStackSize required for a compiled +# command. A failure will cause a segfault in the child process. test compile-13.1 {testing underestimate of maxStackSize in list cmd} {exec} { set body {set x [list} for {set i 0} {$i < 3000} {incr i} { @@ -424,8 +424,8 @@ test compile-13.1 {testing underestimate of maxStackSize in list cmd} {exec} { list [catch {exec [interpreter] << $script} msg] $msg } {0 OK} -# Special test for compiling tokens from a copy of the source -# string [Bug #599788] +# Special test for compiling tokens from a copy of the source string. [Bug +# 599788] test compile-14.1 {testing errors in element name; segfault?} {} { catch {set a([error])} msg1 catch {set bubba([join $abba $jubba]) $vol} msg2 @@ -434,34 +434,19 @@ test compile-14.1 {testing errors in element name; segfault?} {} { # Tests compile-15.* cover Tcl Bug 633204 test compile-15.1 {proper TCL_RETURN code from [return]} { - proc p {} {catch return} - set result [p] - rename p {} - set result + apply {{} {catch return}} } 2 test compile-15.2 {proper TCL_RETURN code from [return]} { - proc p {} {catch {return foo}} - set result [p] - rename p {} - set result + apply {{} {catch {return foo}}} } 2 test compile-15.3 {proper TCL_RETURN code from [return]} { - proc p {} {catch {return $::tcl_library}} - set result [p] - rename p {} - set result + apply {{} {catch {return $::tcl_library}}} } 2 test compile-15.4 {proper TCL_RETURN code from [return]} { - proc p {} {catch {return [info library]}} - set result [p] - rename p {} - set result + apply {{} {catch {return [info library]}}} } 2 test compile-15.5 {proper TCL_RETURN code from [return]} { - proc p {} {catch {set a 1}; return} - set result [p] - rename p {} - set result + apply {{} {catch {set a 1}; return}} } "" for {set noComp 0} {$noComp <= 1} {incr noComp} { @@ -536,17 +521,16 @@ test compile-16.17.$noComp {TclCompileScript: word expansion} $constraints { run {list {*}x y z} } {x y z} -# These tests note that expansion can in theory cause the number of -# arguments to a command to exceed INT_MAX, which is as big as objc -# is allowed to get. +# These tests note that expansion can in theory cause the number of arguments +# to a command to exceed INT_MAX, which is as big as objc is allowed to get. # -# In practice, it seems we will run out of memory before we confront -# this issue. Note that compiled operations run out of memory at -# smaller objc values than direct string evaluation. +# In practice, it seems we will run out of memory before we confront this +# issue. Note that compiled operations run out of memory at smaller objc +# values than direct string evaluation. # -# These tests are constrained as knownBug because they are likely -# to cause memory allocation panics somewhere, and we don't want -# panics in the test suite. +# These tests are constrained as knownBug because they are likely to cause +# memory allocation panics somewhere, and we don't want panics in the test +# suite. # test compile-16.18.$noComp {TclCompileScript: word expansion} -body { proc LongList {} {return [lrepeat [expr {1<<10}] x]} @@ -608,8 +592,8 @@ test compile-16.26.$noComp {TclCompileScript: word expansion, protected backslas } {a {\n} b} } ;# End of noComp loop -# These tests are messy because it wrecks the interpreter it runs in! -# They demonstrate issues arising from [FRQ 1101710] +# These tests are messy because it wrecks the interpreter it runs in! They +# demonstrate issues arising from [FRQ 1101710] test compile-17.1 {Command interpretation binding for compiled code} -constraints knownBug -setup { set i [interp create] } -body { @@ -732,3 +716,8 @@ catch {unset y} catch {unset a} ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/concat.test b/tests/concat.test index c369340..8988bb0 100644 --- a/tests/concat.test +++ b/tests/concat.test @@ -1,23 +1,23 @@ # Commands covered: concat # -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. +# This file contains a collection of tests for one or more of the Tcl built-in +# commands. Sourcing this file into Tcl runs the tests and generates output +# for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # -# 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. # -# RCS: @(#) $Id: concat.test,v 1.6 2004/05/19 10:55:05 dkf Exp $ +# RCS: @(#) $Id: concat.test,v 1.7 2011/01/01 15:14:43 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } - + test concat-1.1 {simple concatenation} { concat a b c d e f g } {a b c d e f g} @@ -48,7 +48,12 @@ test concat-4.2 {pruning off extra white space} { test concat-4.3 {pruning off extra white space sets length correctly} { llength [concat { {{a}} }] } 1 - + # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/dict.test b/tests/dict.test index b05208f..14e2fad 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -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: dict.test,v 1.37.2.1 2010/10/02 16:04:29 kennykb Exp $ +# RCS: @(#) $Id: dict.test,v 1.38 2010/10/02 12:38:30 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 diff --git a/tests/error.test b/tests/error.test index 2e75c27..7465a44 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.2 2010/12/01 16:42:36 kennykb Exp $ +# RCS: @(#) $Id: error.test,v 1.36 2010/11/04 15:00:41 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 diff --git a/tests/eval.test b/tests/eval.test index 98acd08..5d2813f 100644 --- a/tests/eval.test +++ b/tests/eval.test @@ -1,23 +1,23 @@ # Commands covered: eval # -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. +# This file contains a collection of tests for one or more of the Tcl built-in +# commands. Sourcing this file into Tcl runs the tests and generates output +# for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # -# 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. # -# RCS: @(#) $Id: eval.test,v 1.9 2006/10/09 19:15:44 msofer Exp $ +# RCS: @(#) $Id: eval.test,v 1.10 2011/01/01 15:14:43 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } - + test eval-1.1 {single argument} { eval {format 22} } 22 @@ -80,7 +80,12 @@ test eval-3.4 {concatenating eval and canonical lists} { unset dummy eval $cmd $cmd2 } {1 2 3 4 5} - + # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/execute.test b/tests/execute.test index 4519890..bfb3e26 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -1,22 +1,22 @@ -# This file contains tests for the tclExecute.c source file. Tests appear -# in the same order as the C code that they test. The set of tests is -# currently incomplete since it currently includes only new tests for -# code changed for the addition of Tcl namespaces. Other execution- -# related tests appear in several other test files including -# namespace.test, basic.test, eval.test, for.test, etc. +# This file contains tests for the tclExecute.c source file. Tests appear in +# the same order as the C code that they test. The set of tests is currently +# incomplete since it currently includes only new tests for code changed for +# the addition of Tcl namespaces. Other execution-related tests appear in +# several other test files including namespace.test, basic.test, eval.test, +# for.test, etc. # -# Sourcing this file into Tcl runs the tests and generates output for -# errors. No output means no errors were found. +# Sourcing this file into Tcl runs the tests and generates output for errors. +# No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # -# 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. # -# RCS: @(#) $Id: execute.test,v 1.35.2.1 2010/09/25 14:51:13 kennykb Exp $ +# RCS: @(#) $Id: execute.test,v 1.37 2011/01/01 14:44:32 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -498,10 +498,11 @@ test execute-3.77 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is non-numeri # INST_PUSH_RESULT not tested # INST_PUSH_RETURN_CODE not tested -test execute-4.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} { +test execute-4.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} - catch {unset x} - catch {unset y} + unset -nocomplain x + unset -nocomplain y +} -body { namespace eval test_ns_1 { namespace export cmd1 proc cmd1 {args} {return "cmd1: $args"} @@ -515,11 +516,12 @@ test execute-4.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} { list [namespace which -command ${x}${y}cmd1] \ [catch {namespace which -command ${x}${y}cmd2} msg] $msg \ [catch {namespace which -command ${x}${y}:cmd2} msg] $msg -} {::test_ns_1::test_ns_2::cmd1 0 {} 0 {}} -test execute-4.2 {Tcl_GetCommandFromObj, check if cached tclCmdNameType is invalid} { +} -result {::test_ns_1::test_ns_2::cmd1 0 {} 0 {}} +test execute-4.2 {Tcl_GetCommandFromObj, check if cached tclCmdNameType is invalid} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename foo ""} - catch {unset l} + unset -nocomplain l +} -body { proc foo {} { return "global foo" } @@ -536,11 +538,11 @@ test execute-4.2 {Tcl_GetCommandFromObj, check if cached tclCmdNameType is inval } } lappend l [test_ns_1::whichFoo] - set l -} {::foo ::test_ns_1::foo} -test execute-4.3 {Tcl_GetCommandFromObj, command never found} { +} -result {::foo ::test_ns_1::foo} +test execute-4.3 {Tcl_GetCommandFromObj, command never found} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename foo ""} +} -body { namespace eval test_ns_1 { proc foo {} { return "namespace foo" @@ -554,17 +556,18 @@ test execute-4.3 {Tcl_GetCommandFromObj, command never found} { list [namespace eval test_ns_1 {namespace which -command foo}] \ [rename test_ns_1::foo ""] \ [catch {namespace eval test_ns_1 {namespace which -command foo}} msg] $msg -} {::test_ns_1::foo {} 0 {}} +} -result {::test_ns_1::foo {} 0 {}} -test execute-5.1 {SetCmdNameFromAny, set cmd name to empty heap string if NULL} { +test execute-5.1 {SetCmdNameFromAny, set cmd name to empty heap string if NULL} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} - catch {unset l} + unset -nocomplain l +} -body { proc {} {} {return {}} {} set l {} lindex {} 0 {} -} {} +} -result {} test execute-6.1 {UpdateStringOfCmdName: called for duplicate of empty cmdName object} { proc {} {} {} @@ -600,7 +603,7 @@ test execute-6.4 {TclCompEvalObj: don't use cached expr bytecode [Bug 1899164]} } -cleanup { rename 0+0 {} } -result SCRIPT -test execute-6.5 {TclCompEvalObj: bytecode epoch validation} { +test execute-6.5 {TclCompEvalObj: bytecode epoch validation} -body { set script { llength {} } set result {} lappend result [if 1 $script] @@ -608,20 +611,22 @@ test execute-6.5 {TclCompEvalObj: bytecode epoch validation} { rename $origName llength.orig proc $origName {args} {return AHA!} lappend result [if 1 $script] +} -cleanup { rename $origName {} rename llength.orig $origName - set result -} {0 AHA!} -test execute-6.6 {TclCompEvalObj: proc-body bytecode invalid for script} { +} -result {0 AHA!} +test execute-6.6 {TclCompEvalObj: proc-body bytecode invalid for script} -body { proc foo {} {set a 1} set a untouched set result {} lappend result [foo] $a lappend result [if 1 [info body foo]] $a +} -cleanup { rename foo {} - set result -} {1 untouched 1 1} -test execute-6.7 {TclCompEvalObj: bytecode context validation} { +} -result {1 untouched 1 1} +test execute-6.7 {TclCompEvalObj: bytecode context validation} -setup { + namespace eval foo {} +} -body { set script { llength {} } namespace eval foo { proc llength {args} {return AHA!} @@ -629,10 +634,12 @@ test execute-6.7 {TclCompEvalObj: bytecode context validation} { set result {} lappend result [if 1 $script] lappend result [namespace eval foo $script] +} -cleanup { namespace delete foo - set result -} {0 AHA!} -test execute-6.8 {TclCompEvalObj: bytecode name resolution epoch validation} { +} -result {0 AHA!} +test execute-6.8 {TclCompEvalObj: bytecode name resolution epoch validation} -setup { + namespace eval foo {} +} -body { set script { llength {} } set result {} lappend result [namespace eval foo $script] @@ -640,20 +647,21 @@ test execute-6.8 {TclCompEvalObj: bytecode name resolution epoch validation} { proc llength {args} {return AHA!} } lappend result [namespace eval foo $script] +} -cleanup { namespace delete foo - set result -} {0 AHA!} -test execute-6.9 {TclCompEvalObj: bytecode interp validation} { - set script { llength {} } +} -result {0 AHA!} +test execute-6.9 {TclCompEvalObj: bytecode interp validation} -setup { interp create slave +} -body { + set script { llength {} } slave eval {proc llength args {return AHA!}} set result {} lappend result [if 1 $script] lappend result [slave eval $script] +} -cleanup { interp delete slave - set result -} {0 AHA!} -test execute-6.10 {TclCompEvalObj: bytecode interp validation} { +} -result {0 AHA!} +test execute-6.10 {TclCompEvalObj: bytecode interp validation} -body { set script { llength {} } interp create slave set result {} @@ -661,13 +669,14 @@ test execute-6.10 {TclCompEvalObj: bytecode interp validation} { interp delete slave interp create slave lappend result [slave eval $script] - interp delete slave - set result -} {0 0} -test execute-6.11 {Tcl_ExprObj: exprcode interp validation} testexprlongobj { +} -cleanup { + catch {interp delete slave} +} -result {0 0} +test execute-6.11 {Tcl_ExprObj: exprcode interp validation} -setup { + interp create slave +} -constraints testexprlongobj -body { set e { [llength {}]+1 } set result {} - interp create slave load {} Tcltest slave interp alias {} e slave testexprlongobj lappend result [e $e] @@ -676,23 +685,24 @@ test execute-6.11 {Tcl_ExprObj: exprcode interp validation} testexprlongobj { load {} Tcltest slave interp alias {} e slave testexprlongobj lappend result [e $e] +} -cleanup { interp delete slave - set result -} {{This is a result: 1} {This is a result: 1}} -test execute-6.12 {Tcl_ExprObj: exprcode interp validation} { +} -result {{This is a result: 1} {This is a result: 1}} +test execute-6.12 {Tcl_ExprObj: exprcode interp validation} -setup { + interp create slave +} -body { set e { [llength {}]+1 } set result {} - interp create slave interp alias {} e slave expr lappend result [e $e] interp delete slave interp create slave interp alias {} e slave expr lappend result [e $e] +} -cleanup { interp delete slave - set result -} {1 1} -test execute-6.13 {Tcl_ExprObj: exprcode epoch validation} { +} -result {1 1} +test execute-6.13 {Tcl_ExprObj: exprcode epoch validation} -body { set e { [llength {}]+1 } set result {} lappend result [expr $e] @@ -700,11 +710,13 @@ test execute-6.13 {Tcl_ExprObj: exprcode epoch validation} { rename $origName llength.orig proc $origName {args} {return 1} lappend result [expr $e] +} -cleanup { rename $origName {} rename llength.orig $origName - set result -} {1 2} -test execute-6.14 {Tcl_ExprObj: exprcode context validation} { +} -result {1 2} +test execute-6.14 {Tcl_ExprObj: exprcode context validation} -setup { + namespace eval foo {} +} -body { set e { [llength {}]+1 } namespace eval foo { proc llength {args} {return 1} @@ -712,10 +724,12 @@ test execute-6.14 {Tcl_ExprObj: exprcode context validation} { set result {} lappend result [expr $e] lappend result [namespace eval foo {expr $e}] +} -cleanup { namespace delete foo - set result -} {1 2} -test execute-6.15 {Tcl_ExprObj: exprcode name resolution epoch validation} { +} -result {1 2} +test execute-6.15 {Tcl_ExprObj: exprcode name resolution epoch validation} -setup { + namespace eval foo {} +} -body { set e { [llength {}]+1 } set result {} lappend result [namespace eval foo {expr $e}] @@ -723,42 +737,43 @@ test execute-6.15 {Tcl_ExprObj: exprcode name resolution epoch validation} { proc llength {args} {return 1} } lappend result [namespace eval foo {expr $e}] +} -cleanup { namespace delete foo - set result -} {1 2} -test execute-6.16 {Tcl_ExprObj: exprcode interp validation} { - set e { [llength {}]+1 } +} -result {1 2} +test execute-6.16 {Tcl_ExprObj: exprcode interp validation} -setup { interp create slave +} -body { + set e { [llength {}]+1 } interp alias {} e slave expr slave eval {proc llength args {return 1}} set result {} lappend result [expr $e] lappend result [e $e] +} -cleanup { interp delete slave - set result -} {1 2} -test execute-6.17 {Tcl_ExprObj: exprcode context validation} { - set e { $v } +} -result {1 2} +test execute-6.17 {Tcl_ExprObj: exprcode context validation} -body { proc foo e {set v 0; expr $e} proc bar e {set v 1; expr $e} + set e { $v } set result {} lappend result [foo $e] lappend result [bar $e] +} -cleanup { rename foo {} rename bar {} - set result -} {0 1} -test execute-6.18 {Tcl_ExprObj: exprcode context validation} { - set e { [llength $v] } +} -result {0 1} +test execute-6.18 {Tcl_ExprObj: exprcode context validation} -body { proc foo e {set v {}; expr $e} proc bar e {set v v; expr $e} + set e { [llength $v] } set result {} lappend result [foo $e] lappend result [bar $e] +} -cleanup { rename foo {} rename bar {} - set result -} {0 1} +} -result {0 1} test execute-7.0 {Wide int handling in INST_JUMP_FALSE/LAND} { set x 0x100000000 @@ -882,8 +897,8 @@ test execute-7.34 {Wide int handling} { } 1099511627776 test execute-8.1 {Stack protection} -setup { - # If [Bug #804681] has not been properly - # taken care of, this should segfault + # If [Bug #804681] has not been properly taken care of, this should + # segfault proc whatever args {llength $args} trace add variable ::errorInfo {write unset} whatever } -body { @@ -892,23 +907,27 @@ test execute-8.1 {Stack protection} -setup { trace remove variable ::errorInfo {write unset} whatever rename whatever {} } -returnCodes error -match glob -result * -test execute-8.2 {Stack restoration} -body { - # Test for [Bug #816641], correct restoration - # of the stack top after the stack is grown - proc f {args} { f bee bop } - catch f msg - set msg -} -setup { +test execute-8.2 {Stack restoration} -setup { # Avoid crashes when system stack size is limited (thread-enabled!) set limit [interp recursionlimit {}] interp recursionlimit {} 100 +} -body { + # Test for [Bug #816641], correct restoration of the stack top after the + # stack is grown + proc f {args} { f bee bop } + catch f msg + set msg } -cleanup { interp recursionlimit {} $limit } -result {too many nested evaluations (infinite loop?)} -test execute-8.3 {Stack restoration} -body { - # Test for [Bug #1055676], correct restoration - # of the stack top after the epoch is bumped and - # the stack is grown in a call from a nested evaluation +test execute-8.3 {Stack restoration} -setup { + # Avoid crashes when system stack size is limited (thread-enabled!) + set limit [interp recursionlimit {}] + interp recursionlimit {} 100 +} -body { + # Test for [Bug #1055676], correct restoration of the stack top after the + # epoch is bumped and the stack is grown in a call from a nested + # evaluation set arglst [string repeat "a " 1000] proc f {args} "f $arglst" proc run {} { @@ -919,10 +938,6 @@ test execute-8.3 {Stack restoration} -body { set msg } run -} -setup { - # Avoid crashes when system stack size is limited (thread-enabled!) - set limit [interp recursionlimit {}] - interp recursionlimit {} 100 } -cleanup { interp recursionlimit {} $limit } -result {too many nested evaluations (infinite loop?)} @@ -979,7 +994,6 @@ test execute-9.1 {Interp result resetting [Bug 1522803]} { test execute-10.1 {TclExecuteByteCode, INST_CONCAT1, bytearrays} { apply {s {binary scan $s c x; list $x [scan $s$s %c%c]}} \u0130 } {48 {304 304}} - test execute-10.2 {Bug 2802881} -setup { interp create slave } -body { @@ -992,7 +1006,6 @@ test execute-10.2 {Bug 2802881} -setup { } -cleanup { interp delete slave } -returnCodes error -match glob -result * - test execute-10.3 {Bug 3072640} -setup { proc generate {n} { for {set i 0} {$i < $n} {incr i} { @@ -1014,6 +1027,22 @@ test execute-10.3 {Bug 3072640} -setup { rename coro {} } -result 4 +test execute-11.1 {Bug 3142026: GrowEvaluationStack off-by-one} -setup { + interp create slave +} -body { + slave eval { + set x [lrepeat 1320 199] + for {set i 0} {$i < 20} {incr i} { + lappend x $i + lsort -integer $x + } + # Crashes on failure + return ok + } +} -cleanup { + interp delete slave +} -result ok + # cleanup if {[info commands testobj] != {}} { testobj freeallvars @@ -1031,4 +1060,5 @@ return # Local Variables: # mode: tcl +# fill-column: 78 # End: diff --git a/tests/expr.test b/tests/expr.test index de35640..cdda607 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: expr.test,v 1.78.4.1 2010/10/28 19:42:20 kennykb Exp $ +# RCS: @(#) $Id: expr.test,v 1.79 2010/10/26 15:05:08 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 diff --git a/tests/fCmd.test b/tests/fCmd.test index 09e2622..ee7c5b3 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.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: fCmd.test,v 1.70.4.1 2010/12/11 18:39:30 kennykb Exp $ +# RCS: @(#) $Id: fCmd.test,v 1.73 2010/12/09 15:31:02 dkf Exp $ # if {"::tcltest" ni [namespace children]} { @@ -172,7 +172,7 @@ append long $long append long $long append long $long append long $long - + test fCmd-1.1 {TclFileRenameCmd} -constraints {notRoot} -setup { cleanup } -body { @@ -2583,7 +2583,7 @@ test fCmd-30.3 {file readable on 'pagefile.sys'} -constraints {win} -body { } return $r } -result {exists 1 readable 0 stat 0 {}} - + # cleanup cleanup ::tcltest::cleanupTests diff --git a/tests/fileName.test b/tests/fileName.test index d46391a..c7c591d 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -10,9 +10,9 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: fileName.test,v 1.66 2010/01/05 18:58:36 dgp Exp $ +# RCS: @(#) $Id: fileName.test,v 1.67 2011/01/01 15:14:43 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -42,7 +42,7 @@ global env if {[testConstraint testsetplatform]} { set platform [testgetplatform] } - + # Caution: when using 'testsetplatform' to test different file name platform # descriptions in this file, one must be very careful not to combine such # platform manipulation with commands like 'cd', 'pwd'. That is because the @@ -1434,7 +1434,7 @@ test filename-16.13 {windows specific globbing} {win sharedCdrive} { } //[info hostname]/c/globTest test filename-16.14 {windows specific globbing} {win} { cd [lindex [glob -types d -dir C:/ *] 0] - expr {[lsearch -exact [glob {{.,*}*}] ".."] != -1} + expr {".." in [glob {{.,*}*}]} } {1} test filename-16.15 {windows specific globbing} {win} { cd [lindex [glob -types d -dir C:/ *] 0] @@ -1529,7 +1529,6 @@ test fileName-20.4 {Bug 1750300} -setup { removeFile TAGS $d removeDirectory foo } -result 0 - test fileName-20.5 {Bug 2837800} -setup { set dd [makeDirectory isolate] set d [makeDirectory ./~foo $dd] @@ -1544,7 +1543,6 @@ test fileName-20.5 {Bug 2837800} -setup { removeDirectory ./~foo $dd removeDirectory isolate } -result ~foo/test - test fileName-20.6 {Bug 2837800} -setup { # Recall that we have $env(HOME) set so that references # to ~ point to [temporaryDirectory] @@ -1561,7 +1559,6 @@ test fileName-20.6 {Bug 2837800} -setup { removeDirectory isolate removeFile test ~ } -result {} - test fileName-20.7 {Bug 2806250} -setup { set savewd [pwd] cd [temporaryDirectory] @@ -1574,7 +1571,6 @@ test fileName-20.7 {Bug 2806250} -setup { removeDirectory isolate cd $savewd } -result 1 - test fileName-20.8 {Bug 2806250} -setup { set savewd [pwd] cd [temporaryDirectory] @@ -1587,8 +1583,7 @@ test fileName-20.8 {Bug 2806250} -setup { removeDirectory isolate cd $savewd } -result ./~test - -test fileName-20.9 {} -setup { +test fileName-20.9 {globbing for special chars} -setup { makeFile {} test ~ set d [makeDirectory isolate] set savewd [pwd] @@ -1600,8 +1595,7 @@ test fileName-20.9 {} -setup { removeDirectory isolate removeFile test ~ } -result ~/test - -test fileName-20.10 {} -setup { +test fileName-20.10 {globbing for special chars} -setup { set s [makeDirectory sub ~] makeFile {} fileName-20.10 $s set d [makeDirectory isolate] @@ -1615,7 +1609,7 @@ test fileName-20.10 {} -setup { removeFile fileName-20.10 $s removeDirectory sub ~ } -result ~/sub/fileName-20.10 - + # cleanup catch {file delete -force C:/globTest} cd [temporaryDirectory] diff --git a/tests/fileSystem.test b/tests/fileSystem.test index 1691eb5..6ab554b 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -36,7 +36,7 @@ if {[testConstraint win]} { set vols [string map [list :/ {}] [file volumes]] for {set i 0} {$i < 26} {incr i} { set drive [format %c [expr {$i + 65}]] - if {[lsearch -exact $vols $drive] == -1} { + if {$drive ni $vols} { testConstraint unusedDrive 1 break } diff --git a/tests/http.test b/tests/http.test index b1ff1a0..5365d6d 100644 --- a/tests/http.test +++ b/tests/http.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: http.test,v 1.55.4.1 2010/10/28 19:42:20 kennykb Exp $ +# RCS: @(#) $Id: http.test,v 1.56 2010/10/28 16:38:12 dgp Exp $ package require tcltest 2 namespace import -force ::tcltest::* diff --git a/tests/info.test b/tests/info.test index 810c57d..8c37f6d 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.2.1 2010/12/01 16:42:37 kennykb Exp $ +# RCS: @(#) $Id: info.test,v 1.79 2010/11/15 21:34:54 andreas_kupries Exp $ if {{::tcltest} ni [namespace children]} { package require tcltest 2 diff --git a/tests/interp.test b/tests/interp.test index b401dcf..6057f51 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -10,9 +10,9 @@ # 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.4.2 2010/12/11 18:39:30 kennykb Exp $ +# RCS: @(#) $Id: interp.test,v 1.71 2011/01/01 15:14:43 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2.1 namespace import -force ::tcltest::* } @@ -147,7 +147,7 @@ test interp-3.8 {testing interp exists and interp slaves} -body { } -returnCodes error -result {wrong # args: should be "interp slaves ?path?"} test interp-3.9 {testing interp exists and interp slaves} { interp create {a a2} -safe - expr {[lsearch [interp slaves a] a2] >= 0} + expr {"a2" in [interp slaves a]} } 1 test interp-3.10 {testing interp exists and interp slaves} { interp exists {a a2} @@ -174,7 +174,7 @@ test interp-4.5 {testing interp delete} { interp create a interp create {a x1} interp delete {a x1} - expr {[lsearch [interp slaves a] x1] >= 0} + expr {"x1" in [interp slaves a]} } 0 test interp-4.6 {testing interp delete} { interp create c1 @@ -3569,7 +3569,7 @@ test interp-37.1 {safe interps and min() and max(): Bug 2895741} -setup { unset -nocomplain result interp delete a } -result {26 26} - + test interp-38.1 {interp debug one-way switch} -setup { catch {interp delete a} interp create a diff --git a/tests/io.test b/tests/io.test index 2077e1c..8a30260 100644 --- a/tests/io.test +++ b/tests/io.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: io.test,v 1.96.4.1 2010/12/11 18:39:30 kennykb Exp $ +# RCS: @(#) $Id: io.test,v 1.98 2011/01/17 11:27:28 nijtmans Exp $ if {[catch {package require tcltest 2}]} { puts stderr "Skipping tests in [info script]. tcltest 2 required." @@ -3858,7 +3858,7 @@ test io-32.3 {Tcl_Read, negative byte count} { set l [list [catch {read $f -1} msg] $msg] close $f set l -} {1 {bad argument "-1": should be "nonewline"}} +} {1 {expected non-negative integer but got "-1"}} test io-32.4 {Tcl_Read, positive byte count} { set f [open $path(longfile) r] set x [read $f 1024] diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 920238c..09360ff 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.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: ioCmd.test,v 1.53 2010/08/03 20:06:47 dgp Exp $ +# RCS: @(#) $Id: ioCmd.test,v 1.54 2011/01/17 11:27:28 nijtmans Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -35,7 +35,7 @@ test iocmd-1.2 {puts command} { } {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}} test iocmd-1.3 {puts command} { list [catch {puts froboz -nonewline kablooie} msg] $msg -} {1 {bad argument "kablooie": should be "nonewline"}} +} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}} test iocmd-1.4 {puts command} { list [catch {puts froboz hello} msg] $msg } {1 {can not find channel named "froboz"}} @@ -138,7 +138,7 @@ test iocmd-4.8 {read command with incorrect combination of arguments} { } {1 {wrong # args: should be "read channelId ?numChars?" or "read ?-nonewline? channelId"} {TCL WRONGARGS}} test iocmd-4.9 {read command} { list [catch {read stdin foo} msg] $msg $::errorCode -} {1 {bad argument "foo": should be "nonewline"} NONE} +} {1 {expected non-negative integer but got "foo"} {TCL VALUE NUMBER}} test iocmd-4.10 {read command} { list [catch {read file107} msg] $msg $::errorCode } {1 {can not find channel named "file107"} {TCL LOOKUP CHANNEL file107}} @@ -156,7 +156,7 @@ test iocmd-4.12 {read command} -setup { list [catch {read $f 12z} msg] $msg $::errorCode } -cleanup { close $f -} -result {1 {expected integer but got "12z"} {TCL VALUE NUMBER}} +} -result {1 {expected non-negative integer but got "12z"} {TCL VALUE NUMBER}} test iocmd-5.1 {seek command} -returnCodes error -body { seek diff --git a/tests/ioTrans.test b/tests/ioTrans.test index 049b0ce..f5358c7 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.2.1 2010/12/01 16:42:37 kennykb Exp $ +# RCS: @(#) $Id: ioTrans.test,v 1.10 2010/11/24 11:56:57 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -102,7 +102,7 @@ set helperscript { eval $helperscript #puts <<[file channels]>> - + # ### ### ### ######### ######### ######### test iortrans-1.0 {chan, wrong#args} -returnCodes error -body { @@ -1036,7 +1036,7 @@ test iortrans-11.2 {delete interp of reflected transform} -setup { } interp delete slave } -result {} - + # ### ### ### ######### ######### ######### ## Same tests as above, but exercising the code forwarding and receiving ## driver operations to the originator thread. @@ -1862,7 +1862,7 @@ test iortrans.tf-11.1 {origin thread of moved transform destroyed during access} tcltest::threadReap tempdone } -result {Owner lost} - + # ### ### ### ######### ######### ######### cleanupTests diff --git a/tests/iogt.test b/tests/iogt.test index d2e1997..527b7b7 100644 --- a/tests/iogt.test +++ b/tests/iogt.test @@ -10,7 +10,7 @@ # Copyright (c) 2000 Andreas Kupries. # All rights reserved. # -# RCS: @(#) $Id: iogt.test,v 1.16.10.1 2010/12/01 16:42:37 kennykb Exp $ +# RCS: @(#) $Id: iogt.test,v 1.17 2010/11/24 11:56:57 dkf Exp $ if {[catch {package require tcltest 2.1}]} { puts stderr "Skipping tests in [info script]. tcltest 2.1 required." @@ -354,7 +354,7 @@ proc asort {alist} { array set a $alist array_sget a } - + ######################################################################## test iogt-1.1 {stack/unstack} testchannel { @@ -793,7 +793,7 @@ test iogt-6.1 {Push back and up} -constraints {testchannel knownBug} -body { } -cleanup { close $f } -result {xxxghi} - + # cleanup foreach file [list dummy dummyout __echo_srv__.tcl] { removeFile $file diff --git a/tests/lsearch.test b/tests/lsearch.test index 634adda..fd58978 100644 --- a/tests/lsearch.test +++ b/tests/lsearch.test @@ -1,23 +1,23 @@ # Commands covered: lsearch # -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. +# This file contains a collection of tests for one or more of the Tcl built-in +# commands. Sourcing this file into Tcl runs the tests and generates output +# for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # -# 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. # -# RCS: @(#) $Id: lsearch.test,v 1.22 2008/09/29 12:25:21 dkf Exp $ +# RCS: @(#) $Id: lsearch.test,v 1.23 2011/01/01 15:14:43 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2 namespace import -force ::tcltest::* } - + set x {abcd bbcd 123 234 345} test lsearch-1.1 {lsearch command} { lsearch $x 123 @@ -47,9 +47,9 @@ test lsearch-2.4 {search modes} { test lsearch-2.5 {search modes} { lsearch -exact {foo bar cat} bar } 1 -test lsearch-2.6 {search modes} { - list [catch {lsearch -regexp {xyz bbcc *bc*} *bc*} msg] $msg -} {1 {couldn't compile regular expression pattern: quantifier operand invalid}} +test lsearch-2.6 {search modes} -returnCodes error -body { + lsearch -regexp {xyz bbcc *bc*} *bc* +} -result {couldn't compile regular expression pattern: quantifier operand invalid} test lsearch-2.7 {search modes} { lsearch -regexp {b.x ^bc xy bcx} ^bc } 3 @@ -59,9 +59,9 @@ test lsearch-2.8 {search modes} { test lsearch-2.9 {search modes} { lsearch -glob {b.x ^bc xy bcx} ^bc } 1 -test lsearch-2.10 {search modes} { - list [catch {lsearch -glib {b.x bx xy bcx} b.x} msg] $msg -} {1 {bad option "-glib": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}} +test lsearch-2.10 {search modes} -returnCodes error -body { + lsearch -glib {b.x bx xy bcx} b.x +} -result {bad option "-glib": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices} test lsearch-2.11 {search modes with -nocase} { lsearch -exact -nocase {a b c A B C} A } 0 @@ -81,27 +81,27 @@ test lsearch-2.16 {search modes without -nocase} { lsearch -regexp {a b c A B C} ^A\$ } 3 -test lsearch-3.1 {lsearch errors} { - list [catch lsearch msg] $msg -} {1 {wrong # args: should be "lsearch ?-option value ...? list pattern"}} -test lsearch-3.2 {lsearch errors} { - list [catch {lsearch a} msg] $msg -} {1 {wrong # args: should be "lsearch ?-option value ...? list pattern"}} -test lsearch-3.3 {lsearch errors} { - list [catch {lsearch a b c} msg] $msg -} {1 {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}} -test lsearch-3.4 {lsearch errors} { - list [catch {lsearch a b c d} msg] $msg -} {1 {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}} -test lsearch-3.5 {lsearch errors} { - list [catch {lsearch "\{" b} msg] $msg -} {1 {unmatched open brace in list}} -test lsearch-3.6 {lsearch errors} { - list [catch {lsearch -index a b} msg] $msg -} {1 {"-index" option must be followed by list index}} -test lsearch-3.7 {lsearch errors} { - list [catch {lsearch -subindices -exact a b} msg] $msg -} {1 {-subindices cannot be used without -index option}} +test lsearch-3.1 {lsearch errors} -returnCodes error -body { + lsearch +} -result {wrong # args: should be "lsearch ?-option value ...? list pattern"} +test lsearch-3.2 {lsearch errors} -returnCodes error -body { + lsearch a +} -result {wrong # args: should be "lsearch ?-option value ...? list pattern"} +test lsearch-3.3 {lsearch errors} -returnCodes error -body { + lsearch a b c +} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices} +test lsearch-3.4 {lsearch errors} -returnCodes error -body { + lsearch a b c d +} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices} +test lsearch-3.5 {lsearch errors} -returnCodes error -body { + lsearch "\{" b +} -result {unmatched open brace in list} +test lsearch-3.6 {lsearch errors} -returnCodes error -body { + lsearch -index a b +} -result {"-index" option must be followed by list index} +test lsearch-3.7 {lsearch errors} -returnCodes error -body { + lsearch -subindices -exact a b +} -result {-subindices cannot be used without -index option} test lsearch-4.1 {binary data} { lsearch -exact [list foo one\000two bar] bar @@ -300,12 +300,12 @@ test lsearch-10.2 {offset searching} { test lsearch-10.3 {offset searching} { lsearch -start end-4 {a b c a b c} a } 3 -test lsearch-10.4 {offset searching} { - list [catch {lsearch -start foobar {a b c a b c} a} msg] $msg -} {1 {bad index "foobar": must be integer?[+-]integer? or end?[+-]integer?}} -test lsearch-10.5 {offset searching} { - list [catch {lsearch -start 1 2} msg] $msg -} {1 {missing starting index}} +test lsearch-10.4 {offset searching} -returnCodes error -body { + lsearch -start foobar {a b c a b c} a +} -result {bad index "foobar": must be integer?[+-]integer? or end?[+-]integer?} +test lsearch-10.5 {offset searching} -returnCodes error -body { + lsearch -start 1 2 +} -result {missing starting index} test lsearch-10.6 {binary search with offset} { set res {} for {set i 0} {$i < 100} {incr i} { @@ -453,15 +453,15 @@ test lsearch-19.5 {lsearch -sunindices option} { lsearch -subindices -all -index {0 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a } {{0 0 0} {1 0 0}} -test lsearch-20.1 {lsearch -index option, index larger than sublists} { - list [catch {lsearch -index 2 {{a c} {a b} {a a}} a} msg] $msg -} {1 {element 2 missing from sublist "a c"}} -test lsearch-20.2 {lsearch -index option, malformed index} { - list [catch {lsearch -index foo {{a c} {a b} {a a}} a} msg] $msg -} {1 {bad index "foo": must be integer?[+-]integer? or end?[+-]integer?}} -test lsearch-20.3 {lsearch -index option, malformed index} { - list [catch {lsearch -index \{ {{a c} {a b} {a a}} a} msg] $msg -} {1 {unmatched open brace in list}} +test lsearch-20.1 {lsearch -index option, index larger than sublists} -body { + lsearch -index 2 {{a c} {a b} {a a}} a +} -returnCodes error -result {element 2 missing from sublist "a c"} +test lsearch-20.2 {lsearch -index option, malformed index} -body { + lsearch -index foo {{a c} {a b} {a a}} a +} -returnCodes error -result {bad index "foo": must be integer?[+-]integer? or end?[+-]integer?} +test lsearch-20.3 {lsearch -index option, malformed index} -body { + lsearch -index \{ {{a c} {a b} {a a}} a +} -returnCodes error -result {unmatched open brace in list} test lsearch-21.1 {lsearch shimmering crash} { set x 0 @@ -511,7 +511,7 @@ test lsearch-22.5 {lsearch -bisect, all equal} { test lsearch-22.6 {lsearch -sorted, all equal} { lsearch -sorted -integer {5 5 5 5} 5 } {0} - + # cleanup catch {unset res} catch {unset increasingIntegers} diff --git a/tests/main.test b/tests/main.test index d4b790a..98de6a9 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.8.1 2010/12/01 16:42:37 kennykb Exp $ +# RCS: @(#) $Id: main.test,v 1.23 2010/11/18 15:50:54 nijtmans Exp $ if {[catch {package require tcltest 2.0.2}]} { puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." diff --git a/tests/namespace-old.test b/tests/namespace-old.test index 804c233..f4d4598 100644 --- a/tests/namespace-old.test +++ b/tests/namespace-old.test @@ -14,9 +14,9 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: namespace-old.test,v 1.14 2008/12/17 15:39:55 dkf Exp $ +# RCS: @(#) $Id: namespace-old.test,v 1.15 2011/01/01 15:14:43 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2.2 namespace import -force ::tcltest::* } @@ -496,8 +496,8 @@ test namespace-old-7.1 {define test namespace} { } } {} test namespace-old-7.2 {uplevel can access namespace call frame} { - list [expr {[lsearch -exact [test_ns_uplevel::test_uplevel 1] x]>=0}] \ - [expr {[lsearch -exact [test_ns_uplevel::test_uplevel 1] y]>=0}] + list [expr {"x" in [test_ns_uplevel::test_uplevel 1]}] \ + [expr {"y" in [test_ns_uplevel::test_uplevel 1]}] } {1 1} test namespace-old-7.3 {uplevel can go beyond namespace call frame} { lsort [test_ns_uplevel::test_uplevel 2] @@ -506,8 +506,8 @@ test namespace-old-7.4 {uplevel can go up to global context} { expr {[test_ns_uplevel::test_uplevel 3] == [info globals]} } {1} test namespace-old-7.5 {absolute call frame references work too} { - list [expr {[lsearch -exact [test_ns_uplevel::test_uplevel #2] x]>=0}] \ - [expr {[lsearch -exact [test_ns_uplevel::test_uplevel #2] y]>=0}] + list [expr {"x" in [test_ns_uplevel::test_uplevel #2]}] \ + [expr {"y" in [test_ns_uplevel::test_uplevel #2]}] } {1 1} test namespace-old-7.6 {absolute call frame references work too} { lsort [test_ns_uplevel::test_uplevel #1] diff --git a/tests/namespace.test b/tests/namespace.test index c1aef53..1c39b5c 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -1,23 +1,21 @@ # Functionality covered: this file contains a collection of tests for the -# procedures in tclNamesp.c that implement Tcl's basic support for -# namespaces. Other namespace-related tests appear in variable.test. +# procedures in tclNamesp.c and tclEnsemble.c that implement Tcl's basic +# support for namespaces. Other namespace-related tests appear in +# variable.test. # -# Sourcing this file into Tcl runs the tests and generates output for -# errors. No output means no errors were found. +# Sourcing this file into Tcl runs the tests and generates output for errors. +# No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-2000 by Scriptics Corporation. # -# 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. # -# RCS: @(#) $Id: namespace.test,v 1.78 2010/01/10 16:51:25 dkf Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 - namespace import -force ::tcltest::* -} +# RCS: @(#) $Id: namespace.test,v 1.79 2011/01/01 15:14:43 dkf Exp $ +package require tcltest 2 +namespace import -force ::tcltest::* testConstraint memory [llength [info commands memory]] # @@ -27,7 +25,7 @@ testConstraint memory [llength [info commands memory]] # Clear out any namespaces called test_ns_* catch {namespace delete {*}[namespace children :: test_ns_*]} - + test namespace-1.1 {TclInitNamespaces, GetNamespaceFromObj, NamespaceChildrenCmd} { namespace children :: test_ns_* } {} @@ -47,7 +45,6 @@ test namespace-2.2 {Tcl_GetCurrentNamespace} { } } lappend l [namespace current] - set l } {:: ::test_ns_1 ::test_ns_1::foo ::} test namespace-3.1 {Tcl_GetGlobalNamespace} { @@ -594,9 +591,8 @@ test namespace-14.5 {TclGetNamespaceForQualName, relative ns names looked up onl namespace eval bar {} } namespace eval test_ns_1 { - set l [list [catch {namespace delete test_ns_2::bar} msg] $msg] + list [catch {namespace delete test_ns_2::bar} msg] $msg } - set l } {1 {unknown namespace "test_ns_2::bar" in namespace delete command}} test namespace-14.6 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} { namespace eval test_ns_1::test_ns_2 { @@ -815,7 +811,7 @@ test namespace-17.10 {Tcl_FindNamespaceVar, interference with cached varNames} { set a 0 namespace eval test_ns_1 set a 1 namespace delete test_ns_1 - set a + return $a } 1 catch {unset a} catch {unset x} @@ -837,7 +833,6 @@ test namespace-18.1 {TclResetShadowedCmdRefs, one-level check for command shadow proc foo {} {return "foo in test_ns_1"} } lappend l [test_ns_1::trigger] - set l } {{global foo} {foo in test_ns_1}} test namespace-18.2 {TclResetShadowedCmdRefs, multilevel check for command shadowing} { namespace eval test_ns_2 { @@ -858,7 +853,6 @@ test namespace-18.2 {TclResetShadowedCmdRefs, multilevel check for command shado } } lappend l [test_ns_1::trigger] - set l } {{foo in ::test_ns_2} {foo in ::test_ns_1::test_ns_2}} catch {unset l} catch {rename foo {}} @@ -890,7 +884,6 @@ test namespace-19.4 {GetNamespaceFromObj, invalidation of cached ns refs} { namespace delete test_ns_1::test_ns_2 namespace eval test_ns_1::test_ns_2::test_ns_3 {} lappend l [test_ns_1::foo] - set l } {{} ::test_ns_1::test_ns_2::test_ns_3} test namespace-20.1 {Tcl_NamespaceObjCmd, bad subcommand} { @@ -1420,16 +1413,17 @@ test namespace-39.3 {NamespaceExistsCmd error} { list [catch {namespace exists a b} msg] $msg } {1 {wrong # args: should be "namespace exists name"}} -test namespace-40.1 {Ignoring namespace proc "unknown"} { +test namespace-40.1 {Ignoring namespace proc "unknown"} -setup { rename unknown _unknown +} -body { proc unknown args {return global} namespace eval ns {proc unknown args {return local}} - set l [list [namespace eval ns aaa bbb] [namespace eval ns aaa]] + list [namespace eval ns aaa bbb] [namespace eval ns aaa] +} -cleanup { rename unknown {} rename _unknown unknown namespace delete ns - set l -} {global global} +} -result {global global} test namespace-41.1 {Shadowing byte-compiled commands, Bug: 231259} { set res {} @@ -1447,7 +1441,6 @@ test namespace-41.1 {Shadowing byte-compiled commands, Bug: 231259} { namespace delete ns set res } {0 1} - test namespace-41.2 {Shadowing byte-compiled commands, Bug: 231259} { set res {} namespace eval ns {} @@ -1461,19 +1454,16 @@ test namespace-41.2 {Shadowing byte-compiled commands, Bug: 231259} { namespace delete ns set res } {New proc is called} - test namespace-41.3 {Shadowing byte-compiled commands, Bugs: 231259, 729692} { set res {} namespace eval ns { variable b 0 } - proc ns::a {i} { variable b proc set args {return "New proc is called"} return [set b $i] } - set res [list [ns::a 1] $ns::b] namespace delete ns set res @@ -1512,18 +1502,18 @@ test namespace-42.3 {ensembles: basic} { namespace delete ns lappend result [info command ns::x1] } {1 2 1 {unknown or ambiguous subcommand "x": must be x1, or x2} ::ns::x1 {}} -test namespace-42.4 {ensembles: basic} { +test namespace-42.4 {ensembles: basic} -body { namespace eval ns { namespace export y* proc x1 {} {format 1} proc x2 {} {format 2} namespace ensemble create } - set result [list [catch {ns x} msg] $msg] + list [catch {ns x} msg] $msg +} -cleanup { namespace delete ns - set result -} {1 {unknown subcommand "x": namespace ::ns does not export any commands}} -test namespace-42.5 {ensembles: basic} { +} -result {1 {unknown subcommand "x": namespace ::ns does not export any commands}} +test namespace-42.5 {ensembles: basic} -body { namespace eval ns { namespace export x* proc x1 {} {format 1} @@ -1531,11 +1521,11 @@ test namespace-42.5 {ensembles: basic} { proc x3 {} {format 3} namespace ensemble create } - set result [list [catch {ns x} msg] $msg] + list [catch {ns x} msg] $msg +} -cleanup { namespace delete ns - set result -} {1 {unknown or ambiguous subcommand "x": must be x1, x2, or x3}} -test namespace-42.6 {ensembles: nested} { +} -result {1 {unknown or ambiguous subcommand "x": must be x1, x2, or x3}} +test namespace-42.6 {ensembles: nested} -body { namespace eval ns { namespace export x* namespace eval x0 { @@ -1548,11 +1538,11 @@ test namespace-42.6 {ensembles: nested} { proc x3 {} {format 3} namespace ensemble create } - set result [list [ns x0 z] [ns x1] [ns x2] [ns x3]] + list [ns x0 z] [ns x1] [ns x2] [ns x3] +} -cleanup { namespace delete ns - set result -} {0 1 2 3} -test namespace-42.7 {ensembles: nested} { +} -result {0 1 2 3} +test namespace-42.7 {ensembles: nested} -body { namespace eval ns { namespace export x* namespace eval x0 { @@ -1565,10 +1555,10 @@ test namespace-42.7 {ensembles: nested} { proc x3 {} {format 3} namespace ensemble create } - set result [list [ns x0 z] [ns x1] [ns x2] [ns x3]] + list [ns x0 z] [ns x1] [ns x2] [ns x3] +} -cleanup { namespace delete ns - set result -} {{1 ::ns::x0::z} 1 2 3} +} -result {{1 ::ns::x0::z} 1 2 3} test namespace-42.8 {ensembles: [Bug 1670091]} -setup { proc demo args {} variable target [list [namespace which demo] x] @@ -1595,7 +1585,7 @@ test namespace-43.1 {ensembles: dict-driven} { rename ns {} lappend result [namespace ensemble exists ns] } {1 {unknown or ambiguous subcommand "c": must be a, or b} 1 0} -test namespace-43.2 {ensembles: dict-driven} { +test namespace-43.2 {ensembles: dict-driven} -body { namespace eval ns { namespace export x* proc x1 {args} {list 1 $args} @@ -1604,10 +1594,10 @@ test namespace-43.2 {ensembles: dict-driven} { a ::ns::x1 b ::ns::x2 c {::ns::x1 .} d {::ns::x2 .} } } - set result [list [ns a] [ns b] [ns c] [ns c foo] [ns d] [ns d foo]] + list [ns a] [ns b] [ns c] [ns c foo] [ns d] [ns d foo] +} -cleanup { namespace delete ns - set result -} {{1 {}} {2 0} {1 .} {1 {. foo}} {2 1} {2 2}} +} -result {{1 {}} {2 0} {1 .} {1 {. foo}} {2 1} {2 2}} set SETUP { namespace eval ns { namespace export a b @@ -2914,7 +2904,7 @@ test namespace-54.1 {leak on namespace deletion} -constraints {memory} \ rename getbytes {} unset i ns start end } -result 0 - + # cleanup catch {rename cmd1 {}} catch {unset l} diff --git a/tests/oo.test b/tests/oo.test index 6e24553..1954d1b 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -7,11 +7,11 @@ # 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.2.1 2010/12/01 16:42:37 kennykb Exp $ +# RCS: @(#) $Id: oo.test,v 1.44 2011/01/18 13:50:03 dkf Exp $ package require -exact TclOO 0.6.2 ;# Must match value in generic/tclOO.h -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +package require tcltest 2 +if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* } @@ -2235,6 +2235,18 @@ test oo-22.1 {OO and info frame} -setup { } -cleanup { c destroy } -result {1 {{type source line * file * cmd {info frame 0} method frames class ::c level 0} {type source line * file * cmd {info frame 0} method frames object ::i level 0}} ::c} +test oo-22.2 {OO and info frame: Bug 3001438} -setup { + oo::class create c +} -body { + oo::define c method test {{x 1}} { + if {$x} {my test 0} + lsort {q w e r t y u i o p}; # Overwrite the Tcl stack + info frame 0 + } + [c new] test +} -match glob -cleanup { + c destroy +} -result {* cmd {info frame 0} method test class ::c level 0} # Prove that the issue in [Bug 1865054] isn't an issue any more test oo-23.1 {Self-like derivation; complex case!} -setup { diff --git a/tests/package.test b/tests/package.test index eb24e99..4179a47 100644 --- a/tests/package.test +++ b/tests/package.test @@ -1,38 +1,55 @@ -# This file contains tests for the ::package::* commands. +# This file contains tests for the package and ::pkg::* commands. # Note that the tests are limited to Tcl scripts only, there are no shared # libraries against which to test. # -# Sourcing this file into Tcl runs the tests and generates output for -# errors. No output means no errors were found. +# Sourcing this file into Tcl runs the tests and generates output for errors. +# No output means no errors were found. # +# Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. -# All rights reserved. +# Copyright (c) 2011 Donal K. Fellows # -# RCS: @(#) $Id: package.test,v 1.3 2000/04/10 17:19:02 ericm Exp $ +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: package.test,v 1.4 2011/01/06 10:20:39 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2 namespace import -force ::tcltest::* } -test package-1.1 {pkg::create gives error on insufficient args} { - catch {::pkg::create} -} 1 -test package-1.2 {pkg::create gives error on bad args} { - catch {::pkg::create -foo bar -bar baz -baz boo} -} 1 -test package-1.3 {pkg::create gives error on no value given} { - catch {::pkg::create -name foo -version 1.0 -source test.tcl -load} -} 1 -test package-1.4 {pkg::create gives error on no name given} { - catch {::pkg::create -version 1.0 -source test.tcl -load foo.so} -} 1 -test package-1.5 {pkg::create gives error on no version given} { - catch {::pkg::create -name foo -source test.tcl -load foo.so} -} 1 -test package-1.6 {pkg::create gives error on no source or load options} { - catch {::pkg::create -name foo -version 1.0 -version 2.0} -} 1 +# Do all this in a slave interp to avoid garbaging the package list +set i [interp create] +interp eval $i [list set argv $argv] +interp eval $i [list package require tcltest 2] +interp eval $i [list namespace import -force ::tcltest::*] +interp eval $i { + +package forget {*}[package names] +set oldPkgUnknown [package unknown] +package unknown {} +set oldPath $auto_path +set auto_path "" + +test package-1.1 {pkg::create gives error on insufficient args} -body { + ::pkg::create +} -returnCodes error -match glob -result {wrong # args: should be "*"} +test package-1.2 {pkg::create gives error on bad args} -body { + ::pkg::create -foo bar -bar baz -baz boo +} -returnCodes error -match glob -result {unknown option "bar": *} +test package-1.3 {pkg::create gives error on no value given} -body { + ::pkg::create -name foo -version 1.0 -source test.tcl -load +} -returnCodes error -match glob -result {value for "-load" missing: *} +test package-1.4 {pkg::create gives error on no name given} -body { + ::pkg::create -version 1.0 -source test.tcl -load foo.so +} -returnCodes error -match glob -result {value for "-name" missing: *} +test package-1.5 {pkg::create gives error on no version given} -body { + ::pkg::create -name foo -source test.tcl -load foo.so +} -returnCodes error -match glob -result {value for "-version" missing: *} +test package-1.6 {pkg::create gives error on no source or load options} -body { + ::pkg::create -name foo -version 1.0 -version 2.0 +} -returnCodes error -result {at least one of -load and -source must be given} test package-1.7 {pkg::create gives correct output for 1 direct source} { ::pkg::create -name foo -version 1.0 -source test.tcl } {package ifneeded foo 1.0 [list source [file join $dir test.tcl]]} @@ -67,5 +84,1200 @@ test package-1.16 {pkg::create gives correct output for 1 direct, 1 lazy} { -source {test2.tcl {foo bar}} } {package ifneeded foo 1.0 [list source [file join $dir test.tcl]]\n[list tclPkgSetup $dir foo 1.0 {{test2.tcl source {foo bar}}}]} +test package-2.1 {Tcl_PkgProvide procedure} { + package forget t + package provide t 2.3 +} {} +test package-2.2 {Tcl_PkgProvide procedure} -returnCodes error -setup { + package forget t +} -body { + package provide t 2.3 + package provide t 2.2 +} -result {conflicting versions provided for package "t": 2.3, then 2.2} +test package-2.3 {Tcl_PkgProvide procedure} -returnCodes error -setup { + package forget t +} -body { + package provide t 2.3 + package provide t 2.4 +} -result {conflicting versions provided for package "t": 2.3, then 2.4} +test package-2.4 {Tcl_PkgProvide procedure} -returnCodes error -setup { + package forget t +} -body { + package provide t 2.3 + package provide t 3.3 +} -result {conflicting versions provided for package "t": 2.3, then 3.3} +test package-2.5 {Tcl_PkgProvide procedure} -setup { + package forget t +} -body { + package provide t 2.3 + package provide t 2.3 +} -result {} +test package-2.6 {Tcl_PkgProvide procedure} { + package forget t + package provide t 2.3a1 +} {} + +set n 0 +foreach v { + 2.3k1 2a3a2 2ab3 2.a4 2.b4 2b.4 2a.4 2ba4 2a4b1 + 2b4a1 2b3b2 +} { + test package-2.7.$n {Tcl_PkgProvide procedure} -setup { + package forget t + } -returnCodes error -body " + package provide t $v + " -result "expected version number but got \"$v\"" + incr n +} + +test package-3.1 {Tcl_PkgRequire procedure, picking best version} -setup { + package forget t + set x xxx +} -body { + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + package require t + return $x +} -result {3.4} +test package-3.2 {Tcl_PkgRequire procedure, picking best version} -setup { + package forget t + set x xxx +} -body { + foreach i {1.4 3.4 2.3 2.4 2.2 3.5 3.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + package require t + return $x +} -result {3.5} +test package-3.3 {Tcl_PkgRequire procedure, picking best version} -setup { + package forget t + set x xxx +} -body { + foreach i {3.5 2.1 2.3} { + package ifneeded t $i "set x $i; package provide t $i" + } + package require t 2.2 + return $x +} -result {2.3} +test package-3.4 {Tcl_PkgRequire procedure, picking best version} -setup { + package forget t + set x xxx +} -body { + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + package require -exact t 2.3 + return $x +} -result {2.3} +test package-3.5 {Tcl_PkgRequire procedure, picking best version} -setup { + package forget t + set x xxx +} -body { + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + package require t 2.1 + return $x +} -result {2.4} +test package-3.6 {Tcl_PkgRequire procedure, can't find suitable version} -setup { + package forget t +} -returnCodes error -body { + package unknown {} + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + package require t 2.5 +} -result {can't find package t 2.5} +test package-3.7 {Tcl_PkgRequire procedure, can't find suitable version} -setup { + package forget t +} -returnCodes error -body { + package unknown {} + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + package require t 4.1 +} -result {can't find package t 4.1} +test package-3.8 {Tcl_PkgRequire procedure, can't find suitable version} -setup { + package forget t +} -returnCodes error -body { + package unknown {} + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + package require -exact t 1.3 +} -result {can't find package t exactly 1.3} +test package-3.9 {Tcl_PkgRequire procedure, can't find suitable version} -setup { + package forget t +} -returnCodes error -body { + package unknown {} + package require t +} -result {can't find package t} +test package-3.10 {Tcl_PkgRequire procedure, error in ifneeded script} -setup { + package forget t +} -body { + package ifneeded t 2.1 {package provide t 2.1; error "ifneeded test"} + list [catch {package require t 2.1} msg] $msg $::errorInfo +} -match glob -result {1 {ifneeded test} {ifneeded test + while executing +"error "ifneeded test"" + ("package ifneeded*" script) + invoked from within +"package require t 2.1"}} +test package-3.11 {Tcl_PkgRequire procedure, ifneeded script doesn't provide package} -setup { + package forget t + set x xxx +} -body { + package ifneeded t 2.1 "set x invoked" + list [catch {package require t 2.1} msg] $msg $x +} -match glob -result {1 * invoked} +test package-3.12 {Tcl_PkgRequire procedure, self-deleting script} -setup { + package forget t + set x xxx +} -body { + package ifneeded t 1.2 "package forget t; set x 1.2; package provide t 1.2" + package require t 1.2 + return $x +} -result {1.2} +test package-3.13 {Tcl_PkgRequire procedure, "package unknown" support} -setup { + package forget t + set x xxx +} -body { + proc pkgUnknown args { + # args = name requirement + # requirement = v-v (for exact version) + global x + set x $args + package provide [lindex $args 0] [lindex [split [lindex $args 1] -] 0] + } + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + package unknown pkgUnknown + package require -exact t 1.5 + return $x +} -cleanup { + package unknown {} +} -result {t 1.5-1.5} +test package-3.14 {Tcl_PkgRequire procedure, "package unknown" support} -setup { + package forget t + set x xxx +} -body { + proc pkgUnknown args { + package ifneeded t 1.2 "set x loaded; package provide t 1.2" + } + package unknown pkgUnknown + list [package require t] $x +} -cleanup { + package unknown {} +} -result {1.2 loaded} +test package-3.15 {Tcl_PkgRequire procedure, "package unknown" support} -setup { + package forget {a b} + package unknown pkgUnknown + set x xxx +} -body { + proc pkgUnknown args { + global x + set x $args + package provide [lindex $args 0] 2.0 + } + package require {a b} + return $x +} -cleanup { + package unknown {} +} -result {{a b} 0-} +test package-3.16 {Tcl_PkgRequire procedure, "package unknown" error} -setup { + package forget t +} -body { + proc pkgUnknown args { + error "testing package unknown" + } + package unknown pkgUnknown + list [catch {package require t} msg] $msg $::errorInfo +} -cleanup { + package unknown {} +} -result {1 {testing package unknown} {testing package unknown + while executing +"error "testing package unknown"" + (procedure "pkgUnknown" line 2) + invoked from within +"pkgUnknown t 0-" + ("package unknown" script) + invoked from within +"package require t"}} +test package-3.17 {Tcl_PkgRequire procedure, "package unknown" doesn't load package} -setup { + package forget t + set x xxx +} -body { + proc pkgUnknown args { + global x + set x $args + } + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + package unknown pkgUnknown + list [catch {package require -exact t 1.5} msg] $msg $x +} -cleanup { + package unknown {} +} -result {1 {can't find package t exactly 1.5} {t 1.5-1.5}} +test package-3.18 {Tcl_PkgRequire procedure, version checks} -setup { + package forget t +} -body { + package provide t 2.3 + package require t +} -result {2.3} +test package-3.19 {Tcl_PkgRequire procedure, version checks} -setup { + package forget t +} -body { + package provide t 2.3 + package require t 2.1 +} -result {2.3} +test package-3.20 {Tcl_PkgRequire procedure, version checks} -setup { + package forget t +} -body { + package provide t 2.3 + package require t 2.3 +} -result {2.3} +test package-3.21 {Tcl_PkgRequire procedure, version checks} -setup { + package forget t +} -returnCodes error -body { + package provide t 2.3 + package require t 2.4 +} -result {version conflict for package "t": have 2.3, need 2.4} +test package-3.22 {Tcl_PkgRequire procedure, version checks} -setup { + package forget t +} -returnCodes error -body { + package provide t 2.3 + package require t 1.2 +} -result {version conflict for package "t": have 2.3, need 1.2} +test package-3.23 {Tcl_PkgRequire procedure, version checks} -setup { + package forget t +} -body { + package provide t 2.3 + package require -exact t 2.3 +} -result {2.3} +test package-3.24 {Tcl_PkgRequire procedure, version checks} -setup { + package forget t +} -returnCodes error -body { + package provide t 2.3 + package require -exact t 2.2 +} -result {version conflict for package "t": have 2.3, need exactly 2.2} +test package-3.25 {Tcl_PkgRequire procedure, error in ifneeded script} -setup { + package forget t +} -body { + package ifneeded t 2.1 {package provide t 2.1; error "ifneeded test" EI} + list [catch {package require t 2.1} msg] $msg $::errorInfo +} -match glob -result {1 {ifneeded test} {EI + ("package ifneeded*" script) + invoked from within +"package require t 2.1"}} +test package-3.26 {Tcl_PkgRequire procedure, error in ifneeded script} -setup { + package forget t +} -body { + package ifneeded t 2.1 {package provide t 2.1; foreach x 1 {error "ifneeded test" EI}} + list [catch {package require t 2.1} msg] $msg $::errorInfo +} -match glob -result {1 {ifneeded test} {EI + ("foreach" body line 1) + invoked from within +"foreach x 1 {error "ifneeded test" EI}" + ("package ifneeded*" script) + invoked from within +"package require t 2.1"}} +test package-3.27 {Tcl_PkgRequire: circular dependency} -setup { + package forget foo +} -body { + package ifneeded foo 1 {package require foo 1} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result {circular package dependency:*} +test package-3.28 {Tcl_PkgRequire: circular dependency} -setup { + package forget foo +} -body { + package ifneeded foo 1 {package require foo 2} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result {circular package dependency:*} +test package-3.29 {Tcl_PkgRequire: circular dependency} -setup { + package forget foo + package forget bar +} -body { + package ifneeded foo 1 {package require bar 1; package provide foo 1} + package ifneeded bar 1 {package require foo 1; package provide bar 1} + package require foo 1 +} -cleanup { + package forget foo + package forget bar +} -returnCodes error -match glob -result {circular package dependency:*} +test package-3.30 {Tcl_PkgRequire: circular dependency} -setup { + package forget foo + package forget bar +} -body { + package ifneeded foo 1 {package require bar 1; package provide foo 1} + package ifneeded foo 2 {package provide foo 2} + package ifneeded bar 1 {package require foo 2; package provide bar 1} + package require foo 1 +} -cleanup { + package forget foo + package forget bar +} -returnCodes error -match glob -result {circular package dependency:*} +test package-3.31 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {package provide foo 1; error foo} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result foo +test package-3.32 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {package provide foo 1; error foo} + catch {package require foo 1} + package provide foo +} -cleanup { + package forget foo +} -result {} +test package-3.33 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {package provide foo 2} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result {attempt to provide package * failed:*} +test package-3.34 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {package provide foo 1.1} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result {attempt to provide package * failed:*} +test package-3.34.1 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1.1 {package provide foo 1} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result {attempt to provide package * failed:*} +test package-3.34.2 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1.1 {package provide foo 1} + package require foo 1.1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result {attempt to provide package * failed:*} +test package-3.35 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result {attempt to provide package * failed:*} +test package-3.35.1 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {break} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob \ +-result {attempt to provide package * failed: bad return code:*} +test package-3.36 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {continue} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob \ +-result {attempt to provide package * failed: bad return code:*} +test package-3.37 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {return} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob \ +-result {attempt to provide package * failed: bad return code:*} +test package-3.38 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {return -level 0 -code 10} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob \ +-result {attempt to provide package * failed: bad return code:*} +test package-3.39 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo + set saveUnknown [package unknown] + package unknown {package provide foo 2 ;#} +} -body { + package require foo 1 +} -cleanup { + package forget foo + package unknown $saveUnknown +} -returnCodes error -match glob -result * +test package-3.40 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo + set saveUnknown [package unknown] + package unknown {break ;#} +} -body { + package require foo 1 +} -cleanup { + package forget foo + package unknown $saveUnknown +} -returnCodes error -match glob -result {bad return code:*} +test package-3.41 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo + set saveUnknown [package unknown] + package unknown {continue ;#} +} -body { + package require foo 1 +} -cleanup { + package forget foo + package unknown $saveUnknown +} -returnCodes error -match glob -result {bad return code:*} +test package-3.42 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo + set saveUnknown [package unknown] + package unknown {return ;#} +} -body { + package require foo 1 +} -cleanup { + package forget foo + package unknown $saveUnknown +} -returnCodes error -match glob -result {bad return code:*} +test package-3.43 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo + set saveUnknown [package unknown] + package unknown {return -level 0 -code 10 ;#} +} -body { + package require foo 1 +} -cleanup { + package forget foo + package unknown $saveUnknown +} -returnCodes error -match glob -result {bad return code:*} +test package-3.44 {Tcl_PkgRequire: exact version matching (1578344)} -setup { + package provide demo 1.2.3 +} -body { + package require -exact demo 1.2 +} -returnCodes error -cleanup { + package forget demo +} -result {version conflict for package "demo": have 1.2.3, need exactly 1.2} +test package-3.50 {Tcl_PkgRequire procedure, picking best stable version} -setup { + package forget t + set x xxx +} -body { + foreach i {1.4 3.4 4.0a1 2.3 2.4 2.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + package require t + return $x +} -result {3.4} +test package-3.51 {Tcl_PkgRequire procedure, picking best stable version} -setup { + package forget t + set x xxx +} -body { + foreach i {1.2b1 1.2 1.3a2 1.3} { + package ifneeded t $i "set x $i; package provide t $i" + } + package require t + return $x +} -result {1.3} +test package-3.52 {Tcl_PkgRequire procedure, picking best stable version} -setup { + package forget t + set x xxx +} -body { + foreach i {1.2b1 1.2 1.3 1.3a2} { + package ifneeded t $i "set x $i; package provide t $i" + } + package require t + return $x +} -result {1.3} + +test package-4.1 {Tcl_PackageCmd procedure} -returnCodes error -body { + package +} -result {wrong # args: should be "package option ?arg ...?"} +test package-4.2 {Tcl_PackageCmd procedure, "forget" option} { + package forget {*}[package names] + package names +} {} +test package-4.3 {Tcl_PackageCmd procedure, "forget" option} { + package forget {*}[package names] + package forget foo +} {} +test package-4.4 {Tcl_PackageCmd procedure, "forget" option} -setup { + package forget {*}[package names] + set result {} +} -body { + package ifneeded t 1.1 {first script} + package ifneeded t 2.3 {second script} + package ifneeded x 1.4 {x's script} + lappend result [lsort [package names]] [package versions t] + package forget t + lappend result [lsort [package names]] [package versions t] +} -result {{t x} {1.1 2.3} x {}} +test package-4.5 {Tcl_PackageCmd procedure, "forget" option} -setup { + package forget {*}[package names] +} -body { + package ifneeded a 1.1 {first script} + package ifneeded b 2.3 {second script} + package ifneeded c 1.4 {third script} + package forget + set result [list [lsort [package names]]] + package forget a c + lappend result [lsort [package names]] +} -result {{a b c} b} +test package-4.5.1 {Tcl_PackageCmd procedure, "forget" option} -body { + # Test for Bug 415273 + package ifneeded a 1 "I should have been forgotten" + package forget no-such-package a + package ifneeded a 1 +} -cleanup { + package forget a +} -result {} +test package-4.6 {Tcl_PackageCmd procedure, "ifneeded" option} -body { + package ifneeded a +} -returnCodes error -result {wrong # args: should be "package ifneeded package version ?script?"} +test package-4.7 {Tcl_PackageCmd procedure, "ifneeded" option} -body { + package ifneeded a b c d +} -returnCodes error -result {wrong # args: should be "package ifneeded package version ?script?"} +test package-4.8 {Tcl_PackageCmd procedure, "ifneeded" option} -body { + package ifneeded t xyz +} -returnCodes error -result {expected version number but got "xyz"} +test package-4.9 {Tcl_PackageCmd procedure, "ifneeded" option} { + package forget {*}[package names] + list [package ifneeded foo 1.1] [package names] +} {{} {}} +test package-4.10 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { + package forget t +} -body { + package ifneeded t 1.4 "script for t 1.4" + list [package names] [package ifneeded t 1.4] [package versions t] +} -result {t {script for t 1.4} 1.4} +test package-4.11 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { + package forget t +} -body { + package ifneeded t 1.4 "script for t 1.4" + list [package ifneeded t 1.5] [package names] [package versions t] +} -result {{} t 1.4} +test package-4.12 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { + package forget t +} -body { + package ifneeded t 1.4 "script for t 1.4" + package ifneeded t 1.4 "second script for t 1.4" + list [package ifneeded t 1.4] [package names] [package versions t] +} -result {{second script for t 1.4} t 1.4} +test package-4.13 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { + package forget t +} -body { + package ifneeded t 1.4 "script for t 1.4" + package ifneeded t 1.2 "second script" + package ifneeded t 3.1 "last script" + list [package ifneeded t 1.2] [package versions t] +} -result {{second script} {1.4 1.2 3.1}} +test package-4.14 {Tcl_PackageCmd procedure, "names" option} -body { + package names a +} -returnCodes error -result {wrong # args: should be "package names"} +test package-4.15 {Tcl_PackageCmd procedure, "names" option} { + package forget {*}[package names] + package names +} {} +test package-4.16 {Tcl_PackageCmd procedure, "names" option} -setup { + package forget {*}[package names] +} -body { + package ifneeded x 1.2 {dummy} + package provide x 1.3 + package provide y 2.4 + catch {package require z 47.16} + lsort [package names] +} -result {x y} +test package-4.17 {Tcl_PackageCmd procedure, "provide" option} -body { + package provide +} -returnCodes error -result {wrong # args: should be "package provide package ?version?"} +test package-4.18 {Tcl_PackageCmd procedure, "provide" option} -body { + package provide a b c +} -returnCodes error -result {wrong # args: should be "package provide package ?version?"} +test package-4.19 {Tcl_PackageCmd procedure, "provide" option} -setup { + package forget t +} -body { + package provide t +} -result {} +test package-4.20 {Tcl_PackageCmd procedure, "provide" option} -setup { + package forget t +} -body { + package provide t 2.3 + package provide t +} -result {2.3} +test package-4.21 {Tcl_PackageCmd procedure, "provide" option} -setup { + package forget t +} -returnCodes error -body { + package provide t a.b +} -result {expected version number but got "a.b"} +test package-4.22 {Tcl_PackageCmd procedure, "require" option} -returnCodes error -body { + package require +} -result {wrong # args: should be "package require ?-exact? package ?requirement ...?"} +test package-4.24 {Tcl_PackageCmd procedure, "require" option} -body { + package require -exact a b c + # Exact syntax: -exact name version + # name ?requirement ...? +} -returnCodes error -result {wrong # args: should be "package require ?-exact? package ?requirement ...?"} +test package-4.26 {Tcl_PackageCmd procedure, "require" option} -body { + package require x a.b +} -returnCodes error -result {expected version number but got "a.b"} +test package-4.27 {Tcl_PackageCmd procedure, "require" option} -body { + package require -exact x a.b +} -returnCodes error -result {expected version number but got "a.b"} +test package-4.28 {Tcl_PackageCmd procedure, "require" option} -body { + package require -exact x +} -returnCodes error -result {wrong # args: should be "package require ?-exact? package ?requirement ...?"} +test package-4.29 {Tcl_PackageCmd procedure, "require" option} -body { + package require -exact +} -returnCodes error -result {wrong # args: should be "package require ?-exact? package ?requirement ...?"} +test package-4.30 {Tcl_PackageCmd procedure, "require" option} -setup { + package forget t +} -body { + package provide t 2.3 + package require t 2.1 +} -result {2.3} +test package-4.31 {Tcl_PackageCmd procedure, "require" option} -setup { + package forget t +} -body { + package require t +} -returnCodes error -result {can't find package t} +test package-4.32 {Tcl_PackageCmd procedure, "require" option} -setup { + package forget t +} -body { + package ifneeded t 2.3 "error {synthetic error}" + package require t 2.3 +} -returnCodes error -result {synthetic error} +test package-4.33 {Tcl_PackageCmd procedure, "unknown" option} -body { + package unknown a b +} -returnCodes error -result {wrong # args: should be "package unknown ?command?"} +test package-4.34 {Tcl_PackageCmd procedure, "unknown" option} { + package unknown "test script" + package unknown +} {test script} +test package-4.35 {Tcl_PackageCmd procedure, "unknown" option} { + package unknown "test script" + package unknown {} + package unknown +} {} +test package-4.36 {Tcl_PackageCmd procedure, "vcompare" option} -body { + package vcompare a +} -returnCodes error -result {wrong # args: should be "package vcompare version1 version2"} +test package-4.37 {Tcl_PackageCmd procedure, "vcompare" option} -body { + package vcompare a b c +} -returnCodes error -result {wrong # args: should be "package vcompare version1 version2"} +test package-4.38 {Tcl_PackageCmd procedure, "vcompare" option} -body { + package vcompare x.y 3.4 +} -returnCodes error -result {expected version number but got "x.y"} +test package-4.39 {Tcl_PackageCmd procedure, "vcompare" option} -body { + package vcompare 2.1 a.b +} -returnCodes error -result {expected version number but got "a.b"} +test package-4.40 {Tcl_PackageCmd procedure, "vcompare" option} { + package vc 2.1 2.3 +} {-1} +test package-4.41 {Tcl_PackageCmd procedure, "vcompare" option} { + package vc 2.2.4 2.2.4 +} {0} +test package-4.42 {Tcl_PackageCmd procedure, "versions" option} -body { + package versions +} -returnCodes error -result {wrong # args: should be "package versions package"} +test package-4.43 {Tcl_PackageCmd procedure, "versions" option} -body { + package versions a b +} -returnCodes error -result {wrong # args: should be "package versions package"} +test package-4.44 {Tcl_PackageCmd procedure, "versions" option} -body { + package forget t + package versions t +} -result {} +test package-4.45 {Tcl_PackageCmd procedure, "versions" option} -setup { + package forget t +} -body { + package provide t 2.3 + package versions t +} -result {} +test package-4.46 {Tcl_PackageCmd procedure, "versions" option} -setup { + package forget t +} -body { + package ifneeded t 2.3 x + package ifneeded t 2.4 y + package versions t +} -result {2.3 2.4} +test package-4.47 {Tcl_PackageCmd procedure, "vsatisfies" option} -body { + package vsatisfies a +} -returnCodes error -result {wrong # args: should be "package vsatisfies version ?requirement ...?"} +test package-4.49 {Tcl_PackageCmd procedure, "vsatisfies" option} -body { + package vsatisfies x.y 3.4 +} -returnCodes error -result {expected version number but got "x.y"} +test package-4.50 {Tcl_PackageCmd procedure, "vsatisfies" option} -body { + package vcompare 2.1 a.b +} -returnCodes error -result {expected version number but got "a.b"} +test package-4.51 {Tcl_PackageCmd procedure, "vsatisfies" option} { + package vs 2.3 2.1 +} {1} +test package-4.52 {Tcl_PackageCmd procedure, "vsatisfies" option} { + package vs 2.3 1.2 +} {0} +test package-4.53 {Tcl_PackageCmd procedure, "versions" option} -body { + package foo +} -returnCodes error -result {bad option "foo": must be forget, ifneeded, names, prefer, present, provide, require, unknown, vcompare, versions, or vsatisfies} +test package-4.54 {Tcl_PackageCmd procedure, "vsatisfies" option} -body { + package vsatisfies 2.1 2.1-3.2-4.5 +} -returnCodes error -result {expected versionMin-versionMax but got "2.1-3.2-4.5"} +test package-4.55 {Tcl_PackageCmd procedure, "vsatisfies" option} -body { + package vsatisfies 2.1 3.2-x.y +} -returnCodes error -result {expected version number but got "x.y"} +test package-4.56 {Tcl_PackageCmd procedure, "vsatisfies" option} -body { + package vsatisfies 2.1 x.y-3.2 +} -returnCodes error -result {expected version number but got "x.y"} + +# No tests for FindPackage; can't think up anything detectable errors. + +test package-5.1 {TclFreePackageInfo procedure} { + interp create slave + slave eval { + package ifneeded t 2.3 x + package ifneeded t 2.4 y + package ifneeded x 3.1 z + package provide q 4.3 + package unknown "will this get freed?" + } + interp delete slave +} {} +test package-5.2 {TclFreePackageInfo procedure} -body { + interp create foo + foo eval { + package ifneeded t 2.3 x + package ifneeded t 2.4 y + package ifneeded x 3.1 z + package provide q 4.3 + } + foo alias z kill + proc kill {} { + interp delete foo + } + foo eval package require x 3.1 +} -returnCodes error -match glob -result * + +test package-6.1 {CheckVersion procedure} { + package vcompare 1 2.1 +} -1 +test package-6.2 {CheckVersion procedure} -body { + package vcompare .1 2.1 +} -returnCodes error -result {expected version number but got ".1"} +test package-6.3 {CheckVersion procedure} -body { + package vcompare 111.2a.3 2.1 +} -returnCodes error -result {expected version number but got "111.2a.3"} +test package-6.4 {CheckVersion procedure} -body { + package vcompare 1.2.3. 2.1 +} -returnCodes error -result {expected version number but got "1.2.3."} +test package-6.5 {CheckVersion procedure} -body { + package vcompare 1.2..3 2.1 +} -returnCodes error -result {expected version number but got "1.2..3"} + +test package-7.1 {ComparePkgVersions procedure} { + package vcompare 1.23 1.22 +} {1} +test package-7.2 {ComparePkgVersions procedure} { + package vcompare 1.22.1.2.3 1.22.1.2.3 +} {0} +test package-7.3 {ComparePkgVersions procedure} { + package vcompare 1.21 1.22 +} {-1} +test package-7.4 {ComparePkgVersions procedure} { + package vcompare 1.21 1.21.2 +} {-1} +test package-7.5 {ComparePkgVersions procedure} { + package vcompare 1.21.1 1.21 +} {1} +test package-7.6 {ComparePkgVersions procedure} { + package vsatisfies 1.21.1 1.21 +} {1} +test package-7.7 {ComparePkgVersions procedure} { + package vsatisfies 2.22.3 1.21 +} {0} +test package-7.8 {ComparePkgVersions procedure} { + package vsatisfies 1 1 +} {1} +test package-7.9 {ComparePkgVersions procedure} { + package vsatisfies 2 1 +} {0} + +test package-8.1 {Tcl_PkgPresent procedure, any version} -setup { + package forget t +} -body { + package provide t 2.4 + package present t +} -result {2.4} +test package-8.2 {Tcl_PkgPresent procedure, correct version} -setup { + package forget t +} -body { + package provide t 2.4 + package present t 2.4 +} -result {2.4} +test package-8.3 {Tcl_PkgPresent procedure, satisfying version} -setup { + package forget t +} -body { + package provide t 2.4 + package present t 2.0 +} -result {2.4} +test package-8.4 {Tcl_PkgPresent procedure, not satisfying version} -setup { + package forget t +} -returnCodes error -body { + package provide t 2.4 + package present t 2.6 +} -result {version conflict for package "t": have 2.4, need 2.6} +test package-8.5 {Tcl_PkgPresent procedure, not satisfying version} -setup { + package forget t +} -returnCodes error -body { + package provide t 2.4 + package present t 1.0 +} -result {version conflict for package "t": have 2.4, need 1.0} +test package-8.6 {Tcl_PkgPresent procedure, exact version} -setup { + package forget t +} -body { + package provide t 2.4 + package present -exact t 2.4 +} -result {2.4} +test package-8.7 {Tcl_PkgPresent procedure, not exact version} -setup { + package forget t +} -returnCodes error -body { + package provide t 2.4 + package present -exact t 2.3 +} -result {version conflict for package "t": have 2.4, need exactly 2.3} +test package-8.8 {Tcl_PkgPresent procedure, unknown package} -body { + package forget t + package present t +} -returnCodes error -result {package t is not present} +test package-8.9 {Tcl_PkgPresent procedure, unknown package} -body { + package forget t + package present t 2.4 +} -returnCodes error -result {package t 2.4 is not present} +test package-8.10 {Tcl_PkgPresent procedure, unknown package} -body { + package forget t + package present -exact t 2.4 +} -returnCodes error -result {package t 2.4 is not present} +test package-8.11 {Tcl_PackageCmd procedure, "present" option} -body { + package present +} -returnCodes error -result {wrong # args: should be "package present ?-exact? package ?requirement ...?"} +test package-8.12 {Tcl_PackageCmd procedure, "present" option} -body { + package present a b c +} -returnCodes error -result {expected version number but got "b"} +test package-8.13 {Tcl_PackageCmd procedure, "present" option} -body { + package present -exact a b c +} -returnCodes error -result {wrong # args: should be "package present ?-exact? package ?requirement ...?"} +test package-8.14 {Tcl_PackageCmd procedure, "present" option} -body { + package present -bs a b +} -returnCodes error -result {expected version number but got "a"} +test package-8.15 {Tcl_PackageCmd procedure, "present" option} -body { + package present x a.b +} -returnCodes error -result {expected version number but got "a.b"} +test package-8.16 {Tcl_PackageCmd procedure, "present" option} -body { + package present -exact x a.b +} -returnCodes error -result {expected version number but got "a.b"} +test package-8.17 {Tcl_PackageCmd procedure, "present" option} -body { + package present -exact x +} -returnCodes error -result {wrong # args: should be "package present ?-exact? package ?requirement ...?"} +test package-8.18 {Tcl_PackageCmd procedure, "present" option} -body { + package present -exact +} -returnCodes error -result {wrong # args: should be "package present ?-exact? package ?requirement ...?"} + +set n 0 +foreach {r p vs vc} { + 8.5a0 8.5a5 1 -1 + 8.5a0 8.5b1 1 -1 + 8.5a0 8.5.1 1 -1 + 8.5a0 8.6a0 1 -1 + 8.5a0 8.6b0 1 -1 + 8.5a0 8.6.0 1 -1 + 8.5a6 8.5a5 0 1 + 8.5a6 8.5b1 1 -1 + 8.5a6 8.5.1 1 -1 + 8.5a6 8.6a0 1 -1 + 8.5a6 8.6b0 1 -1 + 8.5a6 8.6.0 1 -1 + 8.5b0 8.5a5 0 1 + 8.5b0 8.5b1 1 -1 + 8.5b0 8.5.1 1 -1 + 8.5b0 8.6a0 1 -1 + 8.5b0 8.6b0 1 -1 + 8.5b0 8.6.0 1 -1 + 8.5b2 8.5a5 0 1 + 8.5b2 8.5b1 0 1 + 8.5b2 8.5.1 1 -1 + 8.5b2 8.6a0 1 -1 + 8.5b2 8.6b0 1 -1 + 8.5b2 8.6.0 1 -1 + 8.5 8.5a5 1 1 + 8.5 8.5b1 1 1 + 8.5 8.5.1 1 -1 + 8.5 8.6a0 1 -1 + 8.5 8.6b0 1 -1 + 8.5 8.6.0 1 -1 + 8.5.0 8.5a5 0 1 + 8.5.0 8.5b1 0 1 + 8.5.0 8.5.1 1 -1 + 8.5.0 8.6a0 1 -1 + 8.5.0 8.6b0 1 -1 + 8.5.0 8.6.0 1 -1 + 10 8 0 1 + 8 10 0 -1 + 0.0.1.2 0.1.2 1 -1 +} { + test package-9.$n {package vsatisfies} { + package vsatisfies $p $r + } $vs + test package-10.$n {package vcompare} { + package vcompare $r $p + } $vc + incr n +} + +test package-11.0 {package vcompare at 32bit boundary} { + package vcompare [expr {1<<31}] [expr {(1<<31)-1}] +} 1 + +# Note: It is correct that the result of the very first test, i.e. "5.0 5.0a0" +# is 1, i.e. that version 5.0a0 satisfies a 5.0 requirement. + +# The requirement "5.0" internally translates first to "5.0-6", and then to +# its final form of "5.0a0-6a0". These translations are explicitly specified +# by the TIP (Search for "padded/extended internally with 'a0'"). This was +# done intentionally for exactly the tested case, that an alpha package can +# satisfy a requirement for the regular package. An example would be a package +# FOO requiring Tcl 8.X for its operation. It can be used with Tcl 8.Xa0. +# Without our translation that would not be possible. + +set n 0 +foreach {required provided satisfied} { + 5.0 5.0a0 1 + 5.0a0 5.0 1 + + 8.5a0- 8.5a5 1 + 8.5a0- 8.5b1 1 + 8.5a0- 8.5.1 1 + 8.5a0- 8.6a0 1 + 8.5a0- 8.6b0 1 + 8.5a0- 8.6.0 1 + 8.5a6- 8.5a5 0 + 8.5a6- 8.5b1 1 + 8.5a6- 8.5.1 1 + 8.5a6- 8.6a0 1 + 8.5a6- 8.6b0 1 + 8.5a6- 8.6.0 1 + 8.5b0- 8.5a5 0 + 8.5b0- 8.5b1 1 + 8.5b0- 8.5.1 1 + 8.5b0- 8.6a0 1 + 8.5b0- 8.6b0 1 + 8.5b0- 8.6.0 1 + 8.5b2- 8.5a5 0 + 8.5b2- 8.5b1 0 + 8.5b2- 8.5.1 1 + 8.5b2- 8.6a0 1 + 8.5b2- 8.6b0 1 + 8.5b2- 8.6.0 1 + 8.5- 8.5a5 1 + 8.5- 8.5b1 1 + 8.5- 8.5.1 1 + 8.5- 8.6a0 1 + 8.5- 8.6b0 1 + 8.5- 8.6.0 1 + 8.5.0- 8.5a5 0 + 8.5.0- 8.5b1 0 + 8.5.0- 8.5.1 1 + 8.5.0- 8.6a0 1 + 8.5.0- 8.6b0 1 + 8.5.0- 8.6.0 1 + 8.5a0-7 8.5a5 0 + 8.5a0-7 8.5b1 0 + 8.5a0-7 8.5.1 0 + 8.5a0-7 8.6a0 0 + 8.5a0-7 8.6b0 0 + 8.5a0-7 8.6.0 0 + 8.5a6-7 8.5a5 0 + 8.5a6-7 8.5b1 0 + 8.5a6-7 8.5.1 0 + 8.5a6-7 8.6a0 0 + 8.5a6-7 8.6b0 0 + 8.5a6-7 8.6.0 0 + 8.5b0-7 8.5a5 0 + 8.5b0-7 8.5b1 0 + 8.5b0-7 8.5.1 0 + 8.5b0-7 8.6a0 0 + 8.5b0-7 8.6b0 0 + 8.5b0-7 8.6.0 0 + 8.5b2-7 8.5a5 0 + 8.5b2-7 8.5b1 0 + 8.5b2-7 8.5.1 0 + 8.5b2-7 8.6a0 0 + 8.5b2-7 8.6b0 0 + 8.5b2-7 8.6.0 0 + 8.5-7 8.5a5 0 + 8.5-7 8.5b1 0 + 8.5-7 8.5.1 0 + 8.5-7 8.6a0 0 + 8.5-7 8.6b0 0 + 8.5-7 8.6.0 0 + 8.5.0-7 8.5a5 0 + 8.5.0-7 8.5b1 0 + 8.5.0-7 8.5.1 0 + 8.5.0-7 8.6a0 0 + 8.5.0-7 8.6b0 0 + 8.5.0-7 8.6.0 0 + 8.5a0-8.6.1 8.5a5 1 + 8.5a0-8.6.1 8.5b1 1 + 8.5a0-8.6.1 8.5.1 1 + 8.5a0-8.6.1 8.6a0 1 + 8.5a0-8.6.1 8.6b0 1 + 8.5a0-8.6.1 8.6.0 1 + 8.5a6-8.6.1 8.5a5 0 + 8.5a6-8.6.1 8.5b1 1 + 8.5a6-8.6.1 8.5.1 1 + 8.5a6-8.6.1 8.6a0 1 + 8.5a6-8.6.1 8.6b0 1 + 8.5a6-8.6.1 8.6.0 1 + 8.5b0-8.6.1 8.5a5 0 + 8.5b0-8.6.1 8.5b1 1 + 8.5b0-8.6.1 8.5.1 1 + 8.5b0-8.6.1 8.6a0 1 + 8.5b0-8.6.1 8.6b0 1 + 8.5b0-8.6.1 8.6.0 1 + 8.5b2-8.6.1 8.5a5 0 + 8.5b2-8.6.1 8.5b1 0 + 8.5b2-8.6.1 8.5.1 1 + 8.5b2-8.6.1 8.6a0 1 + 8.5b2-8.6.1 8.6b0 1 + 8.5b2-8.6.1 8.6.0 1 + 8.5-8.6.1 8.5a5 1 + 8.5-8.6.1 8.5b1 1 + 8.5-8.6.1 8.5.1 1 + 8.5-8.6.1 8.6a0 1 + 8.5-8.6.1 8.6b0 1 + 8.5-8.6.1 8.6.0 1 + 8.5.0-8.6.1 8.5a5 0 + 8.5.0-8.6.1 8.5b1 0 + 8.5.0-8.6.1 8.5.1 1 + 8.5.0-8.6.1 8.6a0 1 + 8.5.0-8.6.1 8.6b0 1 + 8.5.0-8.6.1 8.6.0 1 + 8.5a0-8.5a0 8.5a0 1 + 8.5a0-8.5a0 8.5b1 0 + 8.5a0-8.5a0 8.4 0 + 8.5b0-8.5b0 8.5a5 0 + 8.5b0-8.5b0 8.5b0 1 + 8.5b0-8.5b0 8.5.1 0 + 8.5-8.5 8.5a5 0 + 8.5-8.5 8.5b1 0 + 8.5-8.5 8.5 1 + 8.5-8.5 8.5.1 0 + 8.5.0-8.5.0 8.5a5 0 + 8.5.0-8.5.0 8.5b1 0 + 8.5.0-8.5.0 8.5.0 1 + 8.5.0-8.5.0 8.5.1 0 + 8.5.0-8.5.0 8.6a0 0 + 8.5.0-8.5.0 8.6b0 0 + 8.5.0-8.5.0 8.6.0 0 + 8.2 9 0 + 8.2- 9 1 + 8.2-8.5 9 0 + 8.2-9.1 9 1 + + 8.5-8.5 8.5b1 0 + 8.5a0-8.5 8.5b1 0 + 8.5a0-8.5.1 8.5b1 1 + + 8.5-8.5 8.5 1 + 8.5.0-8.5.0 8.5 1 + 8.5a0-8.5.0 8.5 0 +} { + test package-11.$n "package vsatisfies $provided $required" { + package vsatisfies $provided $required + } $satisfied + incr n +} + +test package-12.0 "package vsatisfies multiple" { + # yes no + package vsatisfies 8.4 8.4 7.3 +} 1 +test package-12.1 "package vsatisfies multiple" { + # no yes + package vsatisfies 8.4 7.3 8.4 +} 1 +test package-12.2 "package vsatisfies multiple" { + # yes yes + package vsatisfies 8.4.2 8.4 8.4.1 +} 1 +test package-12.3 "package vsatisfies multiple" { + # no no + package vsatisfies 8.4 7.3 6.1 +} 0 + +proc prefer {args} { + set ip [interp create] + try { + lappend res [$ip eval {package prefer}] + foreach mode $args { + lappend res [$ip eval [list package prefer $mode]] + } + return $res + } finally { + interp delete $ip + } +} + +test package-13.0 {package prefer defaults} { + prefer +} stable +test package-13.1 {package prefer defaults} -body { + set ::env(TCL_PKG_PREFER_LATEST) stable ;# value not relevant! + prefer +} -cleanup { + unset -nocomplain ::env(TCL_PKG_PREFER_LATEST) +} -result latest + +test package-14.0 {wrong\#args} -returnCodes error -body { + package prefer foo bar +} -result {wrong # args: should be "package prefer ?latest|stable?"} +test package-14.1 {bogus argument} -returnCodes error -body { + package prefer foo +} -result {bad preference "foo": must be latest or stable} + +test package-15.0 {set, keep} {package prefer stable} stable +test package-15.1 {set stable, keep} {prefer stable} {stable stable} +test package-15.2 {set latest, change} {prefer latest} {stable latest} +test package-15.3 {set latest, keep} { + prefer latest latest +} {stable latest latest} +test package-15.4 {set stable, rejected} { + prefer latest stable +} {stable latest latest} + +rename prefer {} + +set auto_path $oldPath +package unknown $oldPkgUnknown + +cleanupTests +} + +# cleanup +interp delete $i ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/pkg.test b/tests/pkg.test deleted file mode 100644 index 4f92d4c..0000000 --- a/tests/pkg.test +++ /dev/null @@ -1,1222 +0,0 @@ -# -*- tcl -*- -# Commands covered: pkg -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 1995-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: pkg.test,v 1.31 2008/07/19 22:50:39 nijtmans Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 - namespace import -force ::tcltest::* -} - -# Do all this in a slave interp to avoid garbaging the -# package list -set i [interp create] -interp eval $i [list set argv $argv] -interp eval $i [list package require tcltest 2] -interp eval $i [list namespace import -force ::tcltest::*] -interp eval $i { - -package forget {*}[package names] -set oldPkgUnknown [package unknown] -package unknown {} -set oldPath $auto_path -set auto_path "" - -test pkg-1.1 {Tcl_PkgProvide procedure} { - package forget t - package provide t 2.3 -} {} -test pkg-1.2 {Tcl_PkgProvide procedure} { - package forget t - package provide t 2.3 - list [catch {package provide t 2.2} msg] $msg -} {1 {conflicting versions provided for package "t": 2.3, then 2.2}} -test pkg-1.3 {Tcl_PkgProvide procedure} { - package forget t - package provide t 2.3 - list [catch {package provide t 2.4} msg] $msg -} {1 {conflicting versions provided for package "t": 2.3, then 2.4}} -test pkg-1.4 {Tcl_PkgProvide procedure} { - package forget t - package provide t 2.3 - list [catch {package provide t 3.3} msg] $msg -} {1 {conflicting versions provided for package "t": 2.3, then 3.3}} -test pkg-1.5 {Tcl_PkgProvide procedure} { - package forget t - package provide t 2.3 - package provide t 2.3 -} {} - -test pkg-1.6 {Tcl_PkgProvide procedure} { - package forget t - package provide t 2.3a1 -} {} - -set n 0 -foreach v { - 2.3k1 2a3a2 2ab3 2.a4 2.b4 2b.4 2a.4 2ba4 2a4b1 - 2b4a1 2b3b2 -} { - test pkg-1.7.$n {Tcl_PkgProvide procedure} { - package forget t - list [catch {package provide t $v} msg] $msg - } [list 1 "expected version number but got \"$v\""] - incr n -} - -test pkg-2.1 {Tcl_PkgRequire procedure, picking best version} { - package forget t - foreach i {1.4 3.4 2.3 2.4 2.2} { - package ifneeded t $i "set x $i; package provide t $i" - } - set x xxx - package require t - set x -} {3.4} -test pkg-2.2 {Tcl_PkgRequire procedure, picking best version} { - package forget t - foreach i {1.4 3.4 2.3 2.4 2.2 3.5 3.2} { - package ifneeded t $i "set x $i; package provide t $i" - } - set x xxx - package require t - set x -} {3.5} -test pkg-2.3 {Tcl_PkgRequire procedure, picking best version} { - package forget t - foreach i {3.5 2.1 2.3} { - package ifneeded t $i "set x $i; package provide t $i" - } - set x xxx - package require t 2.2 - set x -} {2.3} -test pkg-2.4 {Tcl_PkgRequire procedure, picking best version} { - package forget t - foreach i {1.4 3.4 2.3 2.4 2.2} { - package ifneeded t $i "set x $i; package provide t $i" - } - set x xxx - package require -exact t 2.3 - set x -} {2.3} -test pkg-2.5 {Tcl_PkgRequire procedure, picking best version} { - package forget t - foreach i {1.4 3.4 2.3 2.4 2.2} { - package ifneeded t $i "set x $i; package provide t $i" - } - set x xxx - package require t 2.1 - set x -} {2.4} -test pkg-2.6 {Tcl_PkgRequire procedure, can't find suitable version} { - package forget t - package unknown {} - foreach i {1.4 3.4 2.3 2.4 2.2} { - package ifneeded t $i "set x $i" - } - list [catch {package require t 2.5} msg] $msg -} {1 {can't find package t 2.5}} -test pkg-2.7 {Tcl_PkgRequire procedure, can't find suitable version} { - package forget t - package unknown {} - foreach i {1.4 3.4 2.3 2.4 2.2} { - package ifneeded t $i "set x $i" - } - list [catch {package require t 4.1} msg] $msg -} {1 {can't find package t 4.1}} -test pkg-2.8 {Tcl_PkgRequire procedure, can't find suitable version} { - package forget t - package unknown {} - foreach i {1.4 3.4 2.3 2.4 2.2} { - package ifneeded t $i "set x $i" - } - list [catch {package require -exact t 1.3} msg] $msg -} {1 {can't find package t exactly 1.3}} -test pkg-2.9 {Tcl_PkgRequire procedure, can't find suitable version} { - package forget t - package unknown {} - list [catch {package require t} msg] $msg -} {1 {can't find package t}} -test pkg-2.10 {Tcl_PkgRequire procedure, error in ifneeded script} -body { - package forget t - package ifneeded t 2.1 {package provide t 2.1; error "ifneeded test"} - list [catch {package require t 2.1} msg] $msg $::errorInfo -} -match glob -result {1 {ifneeded test} {ifneeded test - while executing -"error "ifneeded test"" - ("package ifneeded*" script) - invoked from within -"package require t 2.1"}} -test pkg-2.11 {Tcl_PkgRequire procedure, ifneeded script doesn't provide package} -body { - package forget t - package ifneeded t 2.1 "set x invoked" - set x xxx - list [catch {package require t 2.1} msg] $msg $x -} -match glob -result {1 * invoked} -test pkg-2.12 {Tcl_PkgRequire procedure, self-deleting script} { - package forget t - package ifneeded t 1.2 "package forget t; set x 1.2; package provide t 1.2" - set x xxx - package require t 1.2 - set x -} {1.2} -test pkg-2.13 {Tcl_PkgRequire procedure, "package unknown" support} { - proc pkgUnknown args { - # args = name requirement - # requirement = v-v (for exact version) - global x - set x $args - package provide [lindex $args 0] [lindex [split [lindex $args 1] -] 0] - } - package forget t - foreach i {1.4 3.4 2.3 2.4 2.2} { - package ifneeded t $i "set x $i" - } - package unknown pkgUnknown - set x xxx - package require -exact t 1.5 - package unknown {} - set x -} {t 1.5-1.5} -test pkg-2.14 {Tcl_PkgRequire procedure, "package unknown" support} { - proc pkgUnknown args { - package ifneeded t 1.2 "set x loaded; package provide t 1.2" - } - package forget t - package unknown pkgUnknown - set x xxx - set result [list [package require t] $x] - package unknown {} - set result -} {1.2 loaded} -test pkg-2.15 {Tcl_PkgRequire procedure, "package unknown" support} { - proc pkgUnknown args { - global x - set x $args - package provide [lindex $args 0] 2.0 - } - package forget {a b} - package unknown pkgUnknown - set x xxx - package require {a b} - package unknown {} - set x -} {{a b} 0-} -test pkg-2.16 {Tcl_PkgRequire procedure, "package unknown" error} { - proc pkgUnknown args { - error "testing package unknown" - } - package forget t - package unknown pkgUnknown - set result [list [catch {package require t} msg] $msg $::errorInfo] - package unknown {} - set result -} {1 {testing package unknown} {testing package unknown - while executing -"error "testing package unknown"" - (procedure "pkgUnknown" line 2) - invoked from within -"pkgUnknown t 0-" - ("package unknown" script) - invoked from within -"package require t"}} -test pkg-2.17 {Tcl_PkgRequire procedure, "package unknown" doesn't load package} { - proc pkgUnknown args { - global x - set x $args - } - package forget t - foreach i {1.4 3.4 2.3 2.4 2.2} { - package ifneeded t $i "set x $i" - } - package unknown pkgUnknown - set x xxx - set result [list [catch {package require -exact t 1.5} msg] $msg $x] - package unknown {} - set result -} {1 {can't find package t exactly 1.5} {t 1.5-1.5}} -test pkg-2.18 {Tcl_PkgRequire procedure, version checks} { - package forget t - package provide t 2.3 - package require t -} {2.3} -test pkg-2.19 {Tcl_PkgRequire procedure, version checks} { - package forget t - package provide t 2.3 - package require t 2.1 -} {2.3} -test pkg-2.20 {Tcl_PkgRequire procedure, version checks} { - package forget t - package provide t 2.3 - package require t 2.3 -} {2.3} -test pkg-2.21 {Tcl_PkgRequire procedure, version checks} { - package forget t - package provide t 2.3 - list [catch {package require t 2.4} msg] $msg -} {1 {version conflict for package "t": have 2.3, need 2.4}} -test pkg-2.22 {Tcl_PkgRequire procedure, version checks} { - package forget t - package provide t 2.3 - list [catch {package require t 1.2} msg] $msg -} {1 {version conflict for package "t": have 2.3, need 1.2}} -test pkg-2.23 {Tcl_PkgRequire procedure, version checks} { - package forget t - package provide t 2.3 - package require -exact t 2.3 -} {2.3} -test pkg-2.24 {Tcl_PkgRequire procedure, version checks} { - package forget t - package provide t 2.3 - list [catch {package require -exact t 2.2} msg] $msg -} {1 {version conflict for package "t": have 2.3, need exactly 2.2}} -test pkg-2.25 {Tcl_PkgRequire procedure, error in ifneeded script} -body { - package forget t - package ifneeded t 2.1 {package provide t 2.1; error "ifneeded test" EI} - list [catch {package require t 2.1} msg] $msg $::errorInfo -} -match glob -result {1 {ifneeded test} {EI - ("package ifneeded*" script) - invoked from within -"package require t 2.1"}} -test pkg-2.26 {Tcl_PkgRequire procedure, error in ifneeded script} -body { - package forget t - package ifneeded t 2.1 {package provide t 2.1; foreach x 1 {error "ifneeded test" EI}} - list [catch {package require t 2.1} msg] $msg $::errorInfo -} -match glob -result {1 {ifneeded test} {EI - ("foreach" body line 1) - invoked from within -"foreach x 1 {error "ifneeded test" EI}" - ("package ifneeded*" script) - invoked from within -"package require t 2.1"}} -test pkg-2.27 {Tcl_PkgRequire: circular dependency} -setup { - package forget foo -} -body { - package ifneeded foo 1 {package require foo 1} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob -result {circular package dependency:*} -test pkg-2.28 {Tcl_PkgRequire: circular dependency} -setup { - package forget foo -} -body { - package ifneeded foo 1 {package require foo 2} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob -result {circular package dependency:*} -test pkg-2.29 {Tcl_PkgRequire: circular dependency} -setup { - package forget foo - package forget bar -} -body { - package ifneeded foo 1 {package require bar 1; package provide foo 1} - package ifneeded bar 1 {package require foo 1; package provide bar 1} - package require foo 1 -} -cleanup { - package forget foo - package forget bar -} -returnCodes error -match glob -result {circular package dependency:*} -test pkg-2.30 {Tcl_PkgRequire: circular dependency} -setup { - package forget foo - package forget bar -} -body { - package ifneeded foo 1 {package require bar 1; package provide foo 1} - package ifneeded foo 2 {package provide foo 2} - package ifneeded bar 1 {package require foo 2; package provide bar 1} - package require foo 1 -} -cleanup { - package forget foo - package forget bar -} -returnCodes error -match glob -result {circular package dependency:*} -test pkg-2.31 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1 {package provide foo 1; error foo} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob -result foo -test pkg-2.32 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1 {package provide foo 1; error foo} - catch {package require foo 1} - package provide foo -} -cleanup { - package forget foo -} -result {} -test pkg-2.33 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1 {package provide foo 2} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob -result {attempt to provide package * failed:*} -test pkg-2.34 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1 {package provide foo 1.1} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob -result {attempt to provide package * failed:*} -test pkg-2.34.1 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1.1 {package provide foo 1} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob -result {attempt to provide package * failed:*} -test pkg-2.34.2 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1.1 {package provide foo 1} - package require foo 1.1 -} -cleanup { - package forget foo -} -returnCodes error -match glob -result {attempt to provide package * failed:*} -test pkg-2.35 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1 {} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob -result {attempt to provide package * failed:*} -test pkg-2.35.1 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1 {break} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob \ --result {attempt to provide package * failed: bad return code:*} -test pkg-2.36 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1 {continue} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob \ --result {attempt to provide package * failed: bad return code:*} -test pkg-2.37 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1 {return} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob \ --result {attempt to provide package * failed: bad return code:*} -test pkg-2.38 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1 {return -level 0 -code 10} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob \ --result {attempt to provide package * failed: bad return code:*} -test pkg-2.39 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo - set saveUnknown [package unknown] - package unknown {package provide foo 2 ;#} -} -body { - package require foo 1 -} -cleanup { - package forget foo - package unknown $saveUnknown -} -returnCodes error -match glob -result * -test pkg-2.40 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo - set saveUnknown [package unknown] - package unknown {break ;#} -} -body { - package require foo 1 -} -cleanup { - package forget foo - package unknown $saveUnknown -} -returnCodes error -match glob -result {bad return code:*} -test pkg-2.41 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo - set saveUnknown [package unknown] - package unknown {continue ;#} -} -body { - package require foo 1 -} -cleanup { - package forget foo - package unknown $saveUnknown -} -returnCodes error -match glob -result {bad return code:*} -test pkg-2.42 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo - set saveUnknown [package unknown] - package unknown {return ;#} -} -body { - package require foo 1 -} -cleanup { - package forget foo - package unknown $saveUnknown -} -returnCodes error -match glob -result {bad return code:*} -test pkg-2.43 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo - set saveUnknown [package unknown] - package unknown {return -level 0 -code 10 ;#} -} -body { - package require foo 1 -} -cleanup { - package forget foo - package unknown $saveUnknown -} -returnCodes error -match glob -result {bad return code:*} -test pkg-2.44 {Tcl_PkgRequire: exact version matching (1578344)} -setup { - package provide demo 1.2.3 -} -body { - package require -exact demo 1.2 -} -cleanup { - package forget demo -} -returnCodes error -result {version conflict for package "demo": have 1.2.3, need exactly 1.2} - - -test pkg-2.50 {Tcl_PkgRequire procedure, picking best stable version} { - package forget t - foreach i {1.4 3.4 4.0a1 2.3 2.4 2.2} { - package ifneeded t $i "set x $i; package provide t $i" - } - set x xxx - package require t - set x -} {3.4} - -test pkg-2.51 {Tcl_PkgRequire procedure, picking best stable version} { - package forget t - foreach i {1.2b1 1.2 1.3a2 1.3} { - package ifneeded t $i "set x $i; package provide t $i" - } - set x xxx - package require t - set x -} {1.3} - -test pkg-2.52 {Tcl_PkgRequire procedure, picking best stable version} { - package forget t - foreach i {1.2b1 1.2 1.3 1.3a2} { - package ifneeded t $i "set x $i; package provide t $i" - } - set x xxx - package require t - set x -} {1.3} - - - -test pkg-3.1 {Tcl_PackageCmd procedure} { - list [catch {package} msg] $msg -} {1 {wrong # args: should be "package option ?arg ...?"}} -test pkg-3.2 {Tcl_PackageCmd procedure, "forget" option} { - foreach i [package names] { - package forget $i - } - package names -} {} -test pkg-3.3 {Tcl_PackageCmd procedure, "forget" option} { - foreach i [package names] { - package forget $i - } - package forget foo -} {} -test pkg-3.4 {Tcl_PackageCmd procedure, "forget" option} { - foreach i [package names] { - package forget $i - } - package ifneeded t 1.1 {first script} - package ifneeded t 2.3 {second script} - package ifneeded x 1.4 {x's script} - set result {} - lappend result [lsort [package names]] [package versions t] - package forget t - lappend result [lsort [package names]] [package versions t] -} {{t x} {1.1 2.3} x {}} -test pkg-3.5 {Tcl_PackageCmd procedure, "forget" option} { - foreach i [package names] { - package forget $i - } - package ifneeded a 1.1 {first script} - package ifneeded b 2.3 {second script} - package ifneeded c 1.4 {third script} - package forget - set result [list [lsort [package names]]] - package forget a c - lappend result [lsort [package names]] -} {{a b c} b} -test pkg-3.5.1 {Tcl_PackageCmd procedure, "forget" option} { - # Test for Bug 415273 - package ifneeded a 1 "I should have been forgotten" - package forget no-such-package a - set x [package ifneeded a 1] - package forget a - set x -} {} -test pkg-3.6 {Tcl_PackageCmd procedure, "ifneeded" option} { - list [catch {package ifneeded a} msg] $msg -} {1 {wrong # args: should be "package ifneeded package version ?script?"}} -test pkg-3.7 {Tcl_PackageCmd procedure, "ifneeded" option} { - list [catch {package ifneeded a b c d} msg] $msg -} {1 {wrong # args: should be "package ifneeded package version ?script?"}} -test pkg-3.8 {Tcl_PackageCmd procedure, "ifneeded" option} { - list [catch {package ifneeded t xyz} msg] $msg -} {1 {expected version number but got "xyz"}} -test pkg-3.9 {Tcl_PackageCmd procedure, "ifneeded" option} { - foreach i [package names] { - package forget $i - } - list [package ifneeded foo 1.1] [package names] -} {{} {}} -test pkg-3.10 {Tcl_PackageCmd procedure, "ifneeded" option} { - package forget t - package ifneeded t 1.4 "script for t 1.4" - list [package names] [package ifneeded t 1.4] [package versions t] -} {t {script for t 1.4} 1.4} -test pkg-3.11 {Tcl_PackageCmd procedure, "ifneeded" option} { - package forget t - package ifneeded t 1.4 "script for t 1.4" - list [package ifneeded t 1.5] [package names] [package versions t] -} {{} t 1.4} -test pkg-3.12 {Tcl_PackageCmd procedure, "ifneeded" option} { - package forget t - package ifneeded t 1.4 "script for t 1.4" - package ifneeded t 1.4 "second script for t 1.4" - list [package ifneeded t 1.4] [package names] [package versions t] -} {{second script for t 1.4} t 1.4} -test pkg-3.13 {Tcl_PackageCmd procedure, "ifneeded" option} { - package forget t - package ifneeded t 1.4 "script for t 1.4" - package ifneeded t 1.2 "second script" - package ifneeded t 3.1 "last script" - list [package ifneeded t 1.2] [package versions t] -} {{second script} {1.4 1.2 3.1}} -test pkg-3.14 {Tcl_PackageCmd procedure, "names" option} { - list [catch {package names a} msg] $msg -} {1 {wrong # args: should be "package names"}} -test pkg-3.15 {Tcl_PackageCmd procedure, "names" option} { - foreach i [package names] { - package forget $i - } - package names -} {} -test pkg-3.16 {Tcl_PackageCmd procedure, "names" option} { - foreach i [package names] { - package forget $i - } - package ifneeded x 1.2 {dummy} - package provide x 1.3 - package provide y 2.4 - catch {package require z 47.16} - lsort [package names] -} {x y} -test pkg-3.17 {Tcl_PackageCmd procedure, "provide" option} { - list [catch {package provide} msg] $msg -} {1 {wrong # args: should be "package provide package ?version?"}} -test pkg-3.18 {Tcl_PackageCmd procedure, "provide" option} { - list [catch {package provide a b c} msg] $msg -} {1 {wrong # args: should be "package provide package ?version?"}} -test pkg-3.19 {Tcl_PackageCmd procedure, "provide" option} { - package forget t - package provide t -} {} -test pkg-3.20 {Tcl_PackageCmd procedure, "provide" option} { - package forget t - package provide t 2.3 - package provide t -} {2.3} -test pkg-3.21 {Tcl_PackageCmd procedure, "provide" option} { - package forget t - list [catch {package provide t a.b} msg] $msg -} {1 {expected version number but got "a.b"}} -test pkg-3.22 {Tcl_PackageCmd procedure, "require" option} { - list [catch {package require} msg] $msg -} {1 {wrong # args: should be "package require ?-exact? package ?requirement ...?"}} - -test pkg-3.24 {Tcl_PackageCmd procedure, "require" option} { - list [catch {package require -exact a b c} msg] $msg - # Exact syntax: -exact name version - # name ?requirement ...? -} {1 {wrong # args: should be "package require ?-exact? package ?requirement ...?"}} - -test pkg-3.26 {Tcl_PackageCmd procedure, "require" option} { - list [catch {package require x a.b} msg] $msg -} {1 {expected version number but got "a.b"}} -test pkg-3.27 {Tcl_PackageCmd procedure, "require" option} { - list [catch {package require -exact x a.b} msg] $msg -} {1 {expected version number but got "a.b"}} -test pkg-3.28 {Tcl_PackageCmd procedure, "require" option} { - list [catch {package require -exact x} msg] $msg -} {1 {wrong # args: should be "package require ?-exact? package ?requirement ...?"}} -test pkg-3.29 {Tcl_PackageCmd procedure, "require" option} { - list [catch {package require -exact} msg] $msg -} {1 {wrong # args: should be "package require ?-exact? package ?requirement ...?"}} -test pkg-3.30 {Tcl_PackageCmd procedure, "require" option} { - package forget t - package provide t 2.3 - package require t 2.1 -} {2.3} -test pkg-3.31 {Tcl_PackageCmd procedure, "require" option} { - package forget t - list [catch {package require t} msg] $msg -} {1 {can't find package t}} -test pkg-3.32 {Tcl_PackageCmd procedure, "require" option} { - package forget t - package ifneeded t 2.3 "error {synthetic error}" - list [catch {package require t 2.3} msg] $msg -} {1 {synthetic error}} -test pkg-3.33 {Tcl_PackageCmd procedure, "unknown" option} { - list [catch {package unknown a b} msg] $msg -} {1 {wrong # args: should be "package unknown ?command?"}} -test pkg-3.34 {Tcl_PackageCmd procedure, "unknown" option} { - package unknown "test script" - package unknown -} {test script} -test pkg-3.35 {Tcl_PackageCmd procedure, "unknown" option} { - package unknown "test script" - package unknown {} - package unknown -} {} -test pkg-3.36 {Tcl_PackageCmd procedure, "vcompare" option} { - list [catch {package vcompare a} msg] $msg -} {1 {wrong # args: should be "package vcompare version1 version2"}} -test pkg-3.37 {Tcl_PackageCmd procedure, "vcompare" option} { - list [catch {package vcompare a b c} msg] $msg -} {1 {wrong # args: should be "package vcompare version1 version2"}} -test pkg-3.38 {Tcl_PackageCmd procedure, "vcompare" option} { - list [catch {package vcompare x.y 3.4} msg] $msg -} {1 {expected version number but got "x.y"}} -test pkg-3.39 {Tcl_PackageCmd procedure, "vcompare" option} { - list [catch {package vcompare 2.1 a.b} msg] $msg -} {1 {expected version number but got "a.b"}} -test pkg-3.40 {Tcl_PackageCmd procedure, "vcompare" option} { - package vc 2.1 2.3 -} {-1} -test pkg-3.41 {Tcl_PackageCmd procedure, "vcompare" option} { - package vc 2.2.4 2.2.4 -} {0} -test pkg-3.42 {Tcl_PackageCmd procedure, "versions" option} { - list [catch {package versions} msg] $msg -} {1 {wrong # args: should be "package versions package"}} -test pkg-3.43 {Tcl_PackageCmd procedure, "versions" option} { - list [catch {package versions a b} msg] $msg -} {1 {wrong # args: should be "package versions package"}} -test pkg-3.44 {Tcl_PackageCmd procedure, "versions" option} { - package forget t - package versions t -} {} -test pkg-3.45 {Tcl_PackageCmd procedure, "versions" option} { - package forget t - package provide t 2.3 - package versions t -} {} -test pkg-3.46 {Tcl_PackageCmd procedure, "versions" option} { - package forget t - package ifneeded t 2.3 x - package ifneeded t 2.4 y - package versions t -} {2.3 2.4} -test pkg-3.47 {Tcl_PackageCmd procedure, "vsatisfies" option} { - list [catch {package vsatisfies a} msg] $msg -} {1 {wrong # args: should be "package vsatisfies version ?requirement ...?"}} - -test pkg-3.49 {Tcl_PackageCmd procedure, "vsatisfies" option} { - list [catch {package vsatisfies x.y 3.4} msg] $msg -} {1 {expected version number but got "x.y"}} -test pkg-3.50 {Tcl_PackageCmd procedure, "vsatisfies" option} { - list [catch {package vcompare 2.1 a.b} msg] $msg -} {1 {expected version number but got "a.b"}} -test pkg-3.51 {Tcl_PackageCmd procedure, "vsatisfies" option} { - package vs 2.3 2.1 -} {1} -test pkg-3.52 {Tcl_PackageCmd procedure, "vsatisfies" option} { - package vs 2.3 1.2 -} {0} -test pkg-3.53 {Tcl_PackageCmd procedure, "versions" option} { - list [catch {package foo} msg] $msg -} {1 {bad option "foo": must be forget, ifneeded, names, prefer, present, provide, require, unknown, vcompare, versions, or vsatisfies}} - -test pkg-3.54 {Tcl_PackageCmd procedure, "vsatisfies" option} { - list [catch {package vsatisfies 2.1 2.1-3.2-4.5} msg] $msg -} {1 {expected versionMin-versionMax but got "2.1-3.2-4.5"}} - -test pkg-3.55 {Tcl_PackageCmd procedure, "vsatisfies" option} { - list [catch {package vsatisfies 2.1 3.2-x.y} msg] $msg -} {1 {expected version number but got "x.y"}} - -test pkg-3.56 {Tcl_PackageCmd procedure, "vsatisfies" option} { - list [catch {package vsatisfies 2.1 x.y-3.2} msg] $msg -} {1 {expected version number but got "x.y"}} - - -# No tests for FindPackage; can't think up anything detectable -# errors. - -test pkg-4.1 {TclFreePackageInfo procedure} { - interp create foo - foo eval { - package ifneeded t 2.3 x - package ifneeded t 2.4 y - package ifneeded x 3.1 z - package provide q 4.3 - package unknown "will this get freed?" - } - interp delete foo -} {} -test pkg-4.2 {TclFreePackageInfo procedure} -body { - interp create foo - foo eval { - package ifneeded t 2.3 x - package ifneeded t 2.4 y - package ifneeded x 3.1 z - package provide q 4.3 - } - foo alias z kill - proc kill {} { - interp delete foo - } - foo eval package require x 3.1 -} -returnCodes error -match glob -result * - -test pkg-5.1 {CheckVersion procedure} { - list [catch {package vcompare 1 2.1} msg] $msg -} {0 -1} -test pkg-5.2 {CheckVersion procedure} { - list [catch {package vcompare .1 2.1} msg] $msg -} {1 {expected version number but got ".1"}} -test pkg-5.3 {CheckVersion procedure} { - list [catch {package vcompare 111.2a.3 2.1} msg] $msg -} {1 {expected version number but got "111.2a.3"}} -test pkg-5.4 {CheckVersion procedure} { - list [catch {package vcompare 1.2.3. 2.1} msg] $msg -} {1 {expected version number but got "1.2.3."}} -test pkg-5.5 {CheckVersion procedure} { - list [catch {package vcompare 1.2..3 2.1} msg] $msg -} {1 {expected version number but got "1.2..3"}} - -test pkg-6.1 {ComparePkgVersions procedure} { - package vcompare 1.23 1.22 -} {1} -test pkg-6.2 {ComparePkgVersions procedure} { - package vcompare 1.22.1.2.3 1.22.1.2.3 -} {0} -test pkg-6.3 {ComparePkgVersions procedure} { - package vcompare 1.21 1.22 -} {-1} -test pkg-6.4 {ComparePkgVersions procedure} { - package vcompare 1.21 1.21.2 -} {-1} -test pkg-6.5 {ComparePkgVersions procedure} { - package vcompare 1.21.1 1.21 -} {1} -test pkg-6.6 {ComparePkgVersions procedure} { - package vsatisfies 1.21.1 1.21 -} {1} -test pkg-6.7 {ComparePkgVersions procedure} { - package vsatisfies 2.22.3 1.21 -} {0} -test pkg-6.8 {ComparePkgVersions procedure} { - package vsatisfies 1 1 -} {1} -test pkg-6.9 {ComparePkgVersions procedure} { - package vsatisfies 2 1 -} {0} - -test pkg-7.1 {Tcl_PkgPresent procedure, any version} { - package forget t - package provide t 2.4 - package present t -} {2.4} -test pkg-7.2 {Tcl_PkgPresent procedure, correct version} { - package forget t - package provide t 2.4 - package present t 2.4 -} {2.4} -test pkg-7.3 {Tcl_PkgPresent procedure, satisfying version} { - package forget t - package provide t 2.4 - package present t 2.0 -} {2.4} -test pkg-7.4 {Tcl_PkgPresent procedure, not satisfying version} { - package forget t - package provide t 2.4 - list [catch {package present t 2.6} msg] $msg -} {1 {version conflict for package "t": have 2.4, need 2.6}} -test pkg-7.5 {Tcl_PkgPresent procedure, not satisfying version} { - package forget t - package provide t 2.4 - list [catch {package present t 1.0} msg] $msg -} {1 {version conflict for package "t": have 2.4, need 1.0}} -test pkg-7.6 {Tcl_PkgPresent procedure, exact version} { - package forget t - package provide t 2.4 - package present -exact t 2.4 -} {2.4} -test pkg-7.7 {Tcl_PkgPresent procedure, not exact version} { - package forget t - package provide t 2.4 - list [catch {package present -exact t 2.3} msg] $msg -} {1 {version conflict for package "t": have 2.4, need exactly 2.3}} -test pkg-7.8 {Tcl_PkgPresent procedure, unknown package} { - package forget t - list [catch {package present t} msg] $msg -} {1 {package t is not present}} -test pkg-7.9 {Tcl_PkgPresent procedure, unknown package} { - package forget t - list [catch {package present t 2.4} msg] $msg -} {1 {package t 2.4 is not present}} -test pkg-7.10 {Tcl_PkgPresent procedure, unknown package} { - package forget t - list [catch {package present -exact t 2.4} msg] $msg -} {1 {package t 2.4 is not present}} -test pkg-7.11 {Tcl_PackageCmd procedure, "present" option} { - list [catch {package present} msg] $msg -} {1 {wrong # args: should be "package present ?-exact? package ?requirement ...?"}} -test pkg-7.12 {Tcl_PackageCmd procedure, "present" option} { - list [catch {package present a b c} msg] $msg -} {1 {expected version number but got "b"}} -test pkg-7.13 {Tcl_PackageCmd procedure, "present" option} { - list [catch {package present -exact a b c} msg] $msg -} {1 {wrong # args: should be "package present ?-exact? package ?requirement ...?"}} -test pkg-7.14 {Tcl_PackageCmd procedure, "present" option} { - list [catch {package present -bs a b} msg] $msg -} {1 {expected version number but got "a"}} -test pkg-7.15 {Tcl_PackageCmd procedure, "present" option} { - list [catch {package present x a.b} msg] $msg -} {1 {expected version number but got "a.b"}} -test pkg-7.16 {Tcl_PackageCmd procedure, "present" option} { - list [catch {package present -exact x a.b} msg] $msg -} {1 {expected version number but got "a.b"}} -test pkg-7.17 {Tcl_PackageCmd procedure, "present" option} { - list [catch {package present -exact x} msg] $msg -} {1 {wrong # args: should be "package present ?-exact? package ?requirement ...?"}} -test pkg-7.18 {Tcl_PackageCmd procedure, "present" option} { - list [catch {package present -exact} msg] $msg -} {1 {wrong # args: should be "package present ?-exact? package ?requirement ...?"}} - - - - -set n 0 -foreach {r p vs vc} { - 8.5a0 8.5a5 1 -1 - 8.5a0 8.5b1 1 -1 - 8.5a0 8.5.1 1 -1 - 8.5a0 8.6a0 1 -1 - 8.5a0 8.6b0 1 -1 - 8.5a0 8.6.0 1 -1 - 8.5a6 8.5a5 0 1 - 8.5a6 8.5b1 1 -1 - 8.5a6 8.5.1 1 -1 - 8.5a6 8.6a0 1 -1 - 8.5a6 8.6b0 1 -1 - 8.5a6 8.6.0 1 -1 - 8.5b0 8.5a5 0 1 - 8.5b0 8.5b1 1 -1 - 8.5b0 8.5.1 1 -1 - 8.5b0 8.6a0 1 -1 - 8.5b0 8.6b0 1 -1 - 8.5b0 8.6.0 1 -1 - 8.5b2 8.5a5 0 1 - 8.5b2 8.5b1 0 1 - 8.5b2 8.5.1 1 -1 - 8.5b2 8.6a0 1 -1 - 8.5b2 8.6b0 1 -1 - 8.5b2 8.6.0 1 -1 - 8.5 8.5a5 1 1 - 8.5 8.5b1 1 1 - 8.5 8.5.1 1 -1 - 8.5 8.6a0 1 -1 - 8.5 8.6b0 1 -1 - 8.5 8.6.0 1 -1 - 8.5.0 8.5a5 0 1 - 8.5.0 8.5b1 0 1 - 8.5.0 8.5.1 1 -1 - 8.5.0 8.6a0 1 -1 - 8.5.0 8.6b0 1 -1 - 8.5.0 8.6.0 1 -1 - 10 8 0 1 - 8 10 0 -1 - 0.0.1.2 0.1.2 1 -1 -} { - test package-vsatisfies-1.$n {package vsatisfies} { - package vsatisfies $p $r - } $vs - - test package-vcompare-1.$n {package vcompare} { - package vcompare $r $p - } $vc - - incr n -} - -test package-vcompare-2.0 {package vcompare at 32bit boundary} { - package vcompare [expr {1<<31}] [expr {(1<<31)-1}] -} 1 - -# Note: It is correct that the result of the very first test, -# i.e. "5.0 5.0a0" is 1, i.e. that version 5.0a0 satisfies a 5.0 -# requirement. - -# The requirement "5.0" internally translates first to "5.0-6", and -# then to its final form of "5.0a0-6a0". These translations are -# explicitly specified by the TIP (Search for "padded/extended -# internally with 'a0'"). This was done intentionally for exactly the -# tested case, that an alpha package can satisfy a requirement for the -# regular package. An example would be a package FOO requiring Tcl 8.X -# for its operation. It can be used with Tcl 8.Xa0. Without our -# translation that would not be possible. - -set n 0 -foreach {required provided satisfied} { - 5.0 5.0a0 1 - 5.0a0 5.0 1 - - 8.5a0- 8.5a5 1 - 8.5a0- 8.5b1 1 - 8.5a0- 8.5.1 1 - 8.5a0- 8.6a0 1 - 8.5a0- 8.6b0 1 - 8.5a0- 8.6.0 1 - 8.5a6- 8.5a5 0 - 8.5a6- 8.5b1 1 - 8.5a6- 8.5.1 1 - 8.5a6- 8.6a0 1 - 8.5a6- 8.6b0 1 - 8.5a6- 8.6.0 1 - 8.5b0- 8.5a5 0 - 8.5b0- 8.5b1 1 - 8.5b0- 8.5.1 1 - 8.5b0- 8.6a0 1 - 8.5b0- 8.6b0 1 - 8.5b0- 8.6.0 1 - 8.5b2- 8.5a5 0 - 8.5b2- 8.5b1 0 - 8.5b2- 8.5.1 1 - 8.5b2- 8.6a0 1 - 8.5b2- 8.6b0 1 - 8.5b2- 8.6.0 1 - 8.5- 8.5a5 1 - 8.5- 8.5b1 1 - 8.5- 8.5.1 1 - 8.5- 8.6a0 1 - 8.5- 8.6b0 1 - 8.5- 8.6.0 1 - 8.5.0- 8.5a5 0 - 8.5.0- 8.5b1 0 - 8.5.0- 8.5.1 1 - 8.5.0- 8.6a0 1 - 8.5.0- 8.6b0 1 - 8.5.0- 8.6.0 1 - 8.5a0-7 8.5a5 0 - 8.5a0-7 8.5b1 0 - 8.5a0-7 8.5.1 0 - 8.5a0-7 8.6a0 0 - 8.5a0-7 8.6b0 0 - 8.5a0-7 8.6.0 0 - 8.5a6-7 8.5a5 0 - 8.5a6-7 8.5b1 0 - 8.5a6-7 8.5.1 0 - 8.5a6-7 8.6a0 0 - 8.5a6-7 8.6b0 0 - 8.5a6-7 8.6.0 0 - 8.5b0-7 8.5a5 0 - 8.5b0-7 8.5b1 0 - 8.5b0-7 8.5.1 0 - 8.5b0-7 8.6a0 0 - 8.5b0-7 8.6b0 0 - 8.5b0-7 8.6.0 0 - 8.5b2-7 8.5a5 0 - 8.5b2-7 8.5b1 0 - 8.5b2-7 8.5.1 0 - 8.5b2-7 8.6a0 0 - 8.5b2-7 8.6b0 0 - 8.5b2-7 8.6.0 0 - 8.5-7 8.5a5 0 - 8.5-7 8.5b1 0 - 8.5-7 8.5.1 0 - 8.5-7 8.6a0 0 - 8.5-7 8.6b0 0 - 8.5-7 8.6.0 0 - 8.5.0-7 8.5a5 0 - 8.5.0-7 8.5b1 0 - 8.5.0-7 8.5.1 0 - 8.5.0-7 8.6a0 0 - 8.5.0-7 8.6b0 0 - 8.5.0-7 8.6.0 0 - 8.5a0-8.6.1 8.5a5 1 - 8.5a0-8.6.1 8.5b1 1 - 8.5a0-8.6.1 8.5.1 1 - 8.5a0-8.6.1 8.6a0 1 - 8.5a0-8.6.1 8.6b0 1 - 8.5a0-8.6.1 8.6.0 1 - 8.5a6-8.6.1 8.5a5 0 - 8.5a6-8.6.1 8.5b1 1 - 8.5a6-8.6.1 8.5.1 1 - 8.5a6-8.6.1 8.6a0 1 - 8.5a6-8.6.1 8.6b0 1 - 8.5a6-8.6.1 8.6.0 1 - 8.5b0-8.6.1 8.5a5 0 - 8.5b0-8.6.1 8.5b1 1 - 8.5b0-8.6.1 8.5.1 1 - 8.5b0-8.6.1 8.6a0 1 - 8.5b0-8.6.1 8.6b0 1 - 8.5b0-8.6.1 8.6.0 1 - 8.5b2-8.6.1 8.5a5 0 - 8.5b2-8.6.1 8.5b1 0 - 8.5b2-8.6.1 8.5.1 1 - 8.5b2-8.6.1 8.6a0 1 - 8.5b2-8.6.1 8.6b0 1 - 8.5b2-8.6.1 8.6.0 1 - 8.5-8.6.1 8.5a5 1 - 8.5-8.6.1 8.5b1 1 - 8.5-8.6.1 8.5.1 1 - 8.5-8.6.1 8.6a0 1 - 8.5-8.6.1 8.6b0 1 - 8.5-8.6.1 8.6.0 1 - 8.5.0-8.6.1 8.5a5 0 - 8.5.0-8.6.1 8.5b1 0 - 8.5.0-8.6.1 8.5.1 1 - 8.5.0-8.6.1 8.6a0 1 - 8.5.0-8.6.1 8.6b0 1 - 8.5.0-8.6.1 8.6.0 1 - 8.5a0-8.5a0 8.5a0 1 - 8.5a0-8.5a0 8.5b1 0 - 8.5a0-8.5a0 8.4 0 - 8.5b0-8.5b0 8.5a5 0 - 8.5b0-8.5b0 8.5b0 1 - 8.5b0-8.5b0 8.5.1 0 - 8.5-8.5 8.5a5 0 - 8.5-8.5 8.5b1 0 - 8.5-8.5 8.5 1 - 8.5-8.5 8.5.1 0 - 8.5.0-8.5.0 8.5a5 0 - 8.5.0-8.5.0 8.5b1 0 - 8.5.0-8.5.0 8.5.0 1 - 8.5.0-8.5.0 8.5.1 0 - 8.5.0-8.5.0 8.6a0 0 - 8.5.0-8.5.0 8.6b0 0 - 8.5.0-8.5.0 8.6.0 0 - 8.2 9 0 - 8.2- 9 1 - 8.2-8.5 9 0 - 8.2-9.1 9 1 - - 8.5-8.5 8.5b1 0 - 8.5a0-8.5 8.5b1 0 - 8.5a0-8.5.1 8.5b1 1 - - 8.5-8.5 8.5 1 - 8.5.0-8.5.0 8.5 1 - 8.5a0-8.5.0 8.5 0 - -} { - test package-vsatisfies-2.$n "package vsatisfies $provided $required" { - package vsatisfies $provided $required - } $satisfied - incr n -} - -test package-vsatisfies-3.0 "package vsatisfies multiple" { - # yes no - package vsatisfies 8.4 8.4 7.3 -} 1 - -test package-vsatisfies-3.1 "package vsatisfies multiple" { - # no yes - package vsatisfies 8.4 7.3 8.4 -} 1 - -test package-vsatisfies-3.2 "package vsatisfies multiple" { - # yes yes - package vsatisfies 8.4.2 8.4 8.4.1 -} 1 - -test package-vsatisfies-3.3 "package vsatisfies multiple" { - # no no - package vsatisfies 8.4 7.3 6.1 -} 0 - - -proc prefer {args} { - set ip [interp create] - lappend res [$ip eval {package prefer}] - foreach mode $args { - lappend res [$ip eval [list package prefer $mode]] - } - interp delete $ip - return $res -} - -test package-prefer-1.0 {default} { - prefer -} stable - -test package-prefer-1.1 {default} { - set ::env(TCL_PKG_PREFER_LATEST) stable ; # value not relevant! - set res [prefer] - unset ::env(TCL_PKG_PREFER_LATEST) - set res -} latest - -test package-prefer-2.0 {wrong\#args} { - catch {package prefer foo bar} msg - set msg -} {wrong # args: should be "package prefer ?latest|stable?"} - -test package-prefer-2.1 {bogus argument} { - catch {package prefer foo} msg - set msg -} {bad preference "foo": must be latest or stable} - -test package-prefer-3.0 {set, keep} { - package prefer stable -} stable - -test package-prefer-3.1 {set stable, keep} { - prefer stable -} {stable stable} - -test package-prefer-3.2 {set latest, change} { - prefer latest -} {stable latest} - -test package-prefer-3.3 {set latest, keep} { - prefer latest latest -} {stable latest latest} - -test package-prefer-3.4 {set stable, rejected} { - prefer latest stable -} {stable latest latest} - -rename prefer {} - - -set auto_path $oldPath -package unknown $oldPkgUnknown -concat - -cleanupTests -} - -# cleanup -interp delete $i -::tcltest::cleanupTests -return diff --git a/tests/pkgMkIndex.test b/tests/pkgMkIndex.test index 0db6533..33c76d5 100644 --- a/tests/pkgMkIndex.test +++ b/tests/pkgMkIndex.test @@ -2,13 +2,13 @@ # Note that the tests are limited to Tcl scripts only, there are no shared # libraries against which to test. # -# Sourcing this file into Tcl runs the tests and generates output for -# errors. No output means no errors were found. +# Sourcing this file into Tcl runs the tests and generates output for errors. +# No output means no errors were found. # # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: pkgMkIndex.test,v 1.29 2006/11/03 00:34:53 hobbs Exp $ +# RCS: @(#) $Id: pkgMkIndex.test,v 1.30 2011/01/06 10:20:39 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -17,7 +17,6 @@ if {[lsearch [namespace children] ::tcltest] == -1} { set fullPkgPath [makeDirectory pkg] - namespace eval pkgtest { # Namespace for procs we can discard } @@ -27,8 +26,8 @@ namespace eval pkgtest { # Parse an argument list. # # Arguments: -# <flags> (optional) arguments starting with a dash are collected -# as options to pkg_mkIndex and passed to pkg_mkIndex. +# <flags> (optional) arguments starting with a dash are collected as +# options to pkg_mkIndex and passed to pkg_mkIndex. # dirPath the directory to index # pattern0 pattern to index # ... pattern to index @@ -130,13 +129,13 @@ proc pkgtest::parseIndex { filePath } { # pkgtest::createIndex -- # -# Runs pkg_mkIndex for the given directory and set of patterns. -# This procedure deletes any pkgIndex.tcl file in the target directory, -# then runs pkg_mkIndex. +# Runs pkg_mkIndex for the given directory and set of patterns. This +# procedure deletes any pkgIndex.tcl file in the target directory, then runs +# pkg_mkIndex. # # Arguments: -# <flags> (optional) arguments starting with a dash are collected -# as options to pkg_mkIndex and passed to pkg_mkIndex. +# <flags> (optional) arguments starting with a dash are collected as +# options to pkg_mkIndex and passed to pkg_mkIndex. # dirPath the directory to index # pattern0 pattern to index # ... pattern to index @@ -194,11 +193,9 @@ proc makePkgList { inList } { lappend l $s } } - source { set l $v } - default { error "can't handle $k $v" } @@ -215,8 +212,8 @@ proc makePkgList { inList } { # Runs pkg_mkIndex, parses the generated index file. # # Arguments: -# <flags> (optional) arguments starting with a dash are collected -# as options to pkg_mkIndex and passed to pkg_mkIndex. +# <flags> (optional) arguments starting with a dash are collected as +# options to pkg_mkIndex and passed to pkg_mkIndex. # dirPath the directory to index # pattern0 pattern to index # ... pattern to index @@ -226,8 +223,7 @@ proc makePkgList { inList } { # Returns a two element list: # 0: 1 if the procedure encountered an error, 0 otherwise. # 1: if no error, this is the parsed generated index file, in the format -# returned by pkgtest::parseIndex. -# If error, this is the error result. +# returned by pkgtest::parseIndex. If error, this is the error result. proc pkgtest::runCreatedIndex {rv args} { if {[lindex $rv 0] == 0} { @@ -251,9 +247,9 @@ proc pkgtest::runIndex { args } { set rv [createIndex {*}$args] return [runCreatedIndex $rv {*}$args] } - -# If there is no match to the patterns, make sure the directory hasn't -# changed on us + +# If there is no match to the patterns, make sure the directory hasn't changed +# on us test pkgMkIndex-1.1 {nothing matches pattern - current dir is the same} { list [pkgtest::runIndex -lazy $fullPkgPath nomatch.tcl] [pwd] @@ -314,8 +310,8 @@ removeFile [file join pkg global.tcl] makeFile { # This package is required by pkg1. -# This package is split into two files, to test packages that are split -# over multiple files. +# This package is split into two files, to test packages that are split over +# multiple files. package provide pkg2 1.0 namespace eval pkg2 { namespace export p2-1 @@ -327,8 +323,8 @@ proc pkg2::p2-1 { num } { makeFile { # This package is required by pkg1. -# This package is split into two files, to test packages that are split -# over multiple files. +# This package is split into two files, to test packages that are split over +# multiple files. package provide pkg2 1.0 namespace eval pkg2 { namespace export p2-2 @@ -347,8 +343,8 @@ test pkgMkIndex-4.2 {split package - direct loading} { } "0 {{pkg2:1.0 {[list source [file join $fullPkgPath pkg2_a.tcl]] [list source [file join $fullPkgPath pkg2_b.tcl]]}}}" -# Add the direct1 directory to auto_path, so that the direct1 package -# can be found. +# Add the direct1 directory to auto_path, so that the direct1 package can be +# found. set direct1 [makeDirectory direct1] lappend auto_path $direct1 makeFile { @@ -367,9 +363,9 @@ proc direct1::pd2 { stg } { pkg_mkIndex -direct $direct1 direct1.tcl makeFile { -# Does a package require of direct1, whose pkgIndex.tcl entry -# is created above with option -direct. This tests that pkg_mkIndex -# can handle code that is sourced in pkgIndex.tcl files. +# Does a package require of direct1, whose pkgIndex.tcl entry is created +# above with option -direct. This tests that pkg_mkIndex can handle code +# that is sourced in pkgIndex.tcl files. package require direct1 package provide std 1.0 namespace eval std { @@ -393,9 +389,9 @@ removeDirectory direct1 removeFile [file join pkg std.tcl] makeFile { -# This package requires pkg3, but it does -# not use any of pkg3's procs in the code that is executed by the file -# (i.e. references to pkg3's procs are in the proc bodies only). +# This package requires pkg3, but it does not use any of pkg3's procs in the +# code that is executed by the file (i.e. references to pkg3's procs are in +# the proc bodies only). package require pkg3 1.0 package provide pkg1 1.0 namespace eval pkg1 { @@ -433,8 +429,8 @@ test pkgMkIndex-6.2 {pkg1 requires pkg3 - use -direct} { removeFile [file join pkg pkg1.tcl] makeFile { -# This package requires pkg3, and it calls -# a pkg3 proc in the code that is executed by the file +# This package requires pkg3, and it calls a pkg3 proc in the code that is +# executed by the file package require pkg3 1.0 package provide pkg4 1.0 namespace eval pkg4 { @@ -462,9 +458,8 @@ removeFile [file join pkg pkg4.tcl] removeFile [file join pkg pkg3.tcl] makeFile { -# This package requires pkg2, and it calls -# a pkg2 proc in the code that is executed by the file. -# Pkg2 is a split package. +# This package requires pkg2, and it calls a pkg2 proc in the code that is +# executed by the file. Pkg2 is a split package. package require pkg2 1.0 package provide pkg5 1.0 namespace eval pkg5 { @@ -496,9 +491,9 @@ removeFile [file join pkg pkg2_a.tcl] removeFile [file join pkg pkg2_b.tcl] makeFile { -# This package requires circ2, and circ2 -# requires circ3, which in turn requires circ1. -# In case of cirularities, pkg_mkIndex should give up when it gets stuck. +# This package requires circ2, and circ2 requires circ3, which in turn +# requires circ1. In case of cirularities, pkg_mkIndex should give up when +# it gets stuck. package require circ2 1.0 package provide circ1 1.0 namespace eval circ1 { @@ -519,8 +514,8 @@ proc circ1::c1-4 {} { } [file join pkg circ1.tcl] makeFile { -# This package is required by circ1, and -# requires circ3. Circ3, in turn, requires circ1 to give us a circularity. +# This package is required by circ1, and requires circ3. Circ3, in turn, +# requires circ1 to give us a circularity. package require circ3 1.0 package provide circ2 1.0 namespace eval circ2 { @@ -535,8 +530,8 @@ proc circ2::c2-2 { num } { } [file join pkg circ2.tcl] makeFile { -# This package is required by circ2, and in -# turn requires circ1. This closes the circularity. +# This package is required by circ2, and in turn requires circ1. This closes +# the circularity. package require circ1 1.0 package provide circ3 1.0 namespace eval circ3 { @@ -577,22 +572,23 @@ proc pkga_neq { x } { testConstraint exec [llength [info commands ::exec]] test pkgMkIndex-10.1 {package in DLL and script} [list exec $dll] { - # Do all [load]ing of shared libraries in another process, so - # we can delete the file and not get stuck because we're holding - # a reference to it. + # Do all [load]ing of shared libraries in another process, so we can + # delete the file and not get stuck because we're holding a reference to + # it. set cmd [list pkg_mkIndex -lazy $fullPkgPath [file tail $x] pkga.tcl] exec [interpreter] << $cmd pkgtest::runCreatedIndex {0 {}} -lazy $fullPkgPath pkga[info sharedlibextension] pkga.tcl } "0 {{Pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}" test pkgMkIndex-10.2 {package in DLL hidden by -load} [list exec $dll] { - # Do all [load]ing of shared libraries in another process, so - # we can delete the file and not get stuck because we're holding - # a reference to it. + # Do all [load]ing of shared libraries in another process, so we can + # delete the file and not get stuck because we're holding a reference to + # it. # # This test depends on context from prior test, so repeat it. - set script "[list pkg_mkIndex -lazy $fullPkgPath [file tail $x] pkga.tcl]\n" - append script \ - "[list pkg_mkIndex -lazy -load Pkg* $fullPkgPath [file tail $x]]" + set script \ + "[list pkg_mkIndex -lazy $fullPkgPath [file tail $x] pkga.tcl]" + append script \n \ + "[list pkg_mkIndex -lazy -load Pkg* $fullPkgPath [file tail $x]]" exec [interpreter] << $script pkgtest::runCreatedIndex {0 {}} -lazy -load Pkg* -- $fullPkgPath pkga[info sharedlibextension] } {0 {}} @@ -625,9 +621,8 @@ test pkgMkIndex-11.1 {conflicting namespace imports} { removeFile [file join pkg import.tcl] -# Verify that the auto load list generated is correct even when there -# is a proc name conflict between two namespaces (ie, ::foo::baz and -# ::bar::baz) +# Verify that the auto load list generated is correct even when there is a +# proc name conflict between two namespaces (ie, ::foo::baz and ::bar::baz) makeFile { package provide football 1.0 @@ -692,7 +687,7 @@ test pkgMkIndex-14.5 {tcl::Pkg::CompareExtension} {unix} { test pkgMkIndex-14.6 {tcl::Pkg::CompareExtension} {unix} { tcl::Pkg::CompareExtension foo.so.1.2.bar .so } 0 - + # cleanup removeDirectory pkg @@ -701,3 +696,7 @@ namespace delete pkgtest ::tcltest::cleanupTests return +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/proc.test b/tests/proc.test index 789c671..ba0c20d 100644 --- a/tests/proc.test +++ b/tests/proc.test @@ -1,40 +1,36 @@ -# This file contains tests for the tclProc.c source file. Tests appear in -# the same order as the C code that they test. The set of tests is -# currently incomplete since it includes only new tests, in particular -# tests for code changed for the addition of Tcl namespaces. Other -# procedure-related tests appear in other test files such as proc-old.test. +# This file contains tests for the tclProc.c source file. Tests appear in the +# same order as the C code that they test. The set of tests is currently +# incomplete since it includes only new tests, in particular tests for code +# changed for the addition of Tcl namespaces. Other procedure-related tests +# appear in other test files such as proc-old.test. # -# Sourcing this file into Tcl runs the tests and generates output for -# errors. No output means no errors were found. +# Sourcing this file into Tcl runs the tests and generates output for errors. +# No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # -# 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. # -# RCS: @(#) $Id: proc.test,v 1.21 2009/10/29 17:21:48 dgp Exp $ +# RCS: @(#) $Id: proc.test,v 1.22 2011/01/01 15:14:43 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2 namespace import -force ::tcltest::* } -if {[catch {package require procbodytest}]} { - testConstraint procbodytest 0 -} else { - testConstraint procbodytest 1 -} - -testConstraint memory [llength [info commands memory]] +testConstraint procbodytest [expr {![catch {package require procbodytest}]}] +testConstraint memory [llength [info commands memory]] catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} catch {rename {} ""} catch {unset msg} - -test proc-1.1 {Tcl_ProcObjCmd, put proc in namespace specified in name, if any} { + +test proc-1.1 {Tcl_ProcObjCmd, put proc in namespace specified in name, if any} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1 { namespace eval baz {} } @@ -44,23 +40,26 @@ test proc-1.1 {Tcl_ProcObjCmd, put proc in namespace specified in name, if any} list [test_ns_1::baz::p] \ [namespace eval test_ns_1 {baz::p}] \ [info commands test_ns_1::baz::*] -} {{p in ::test_ns_1::baz} {p in ::test_ns_1::baz} ::test_ns_1::baz::p} -test proc-1.2 {Tcl_ProcObjCmd, namespace specified in proc name must exist} { +} -result {{p in ::test_ns_1::baz} {p in ::test_ns_1::baz} ::test_ns_1::baz::p} +test proc-1.2 {Tcl_ProcObjCmd, namespace specified in proc name must exist} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} - list [catch {proc test_ns_1::baz::p {} {}} msg] $msg -} {1 {can't create procedure "test_ns_1::baz::p": unknown namespace}} -test proc-1.3 {Tcl_ProcObjCmd, empty proc name} { +} -returnCodes error -body { + proc test_ns_1::baz::p {} {} +} -result {can't create procedure "test_ns_1::baz::p": unknown namespace} +test proc-1.3 {Tcl_ProcObjCmd, empty proc name} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { proc :: {} { return "empty called" } list [::] \ [info body {}] -} {{empty called} { +} -result {{empty called} { return "empty called" }} -test proc-1.4 {Tcl_ProcObjCmd, simple proc name and proc defined in namespace} { +test proc-1.4 {Tcl_ProcObjCmd, simple proc name and proc defined in namespace} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1 { namespace eval baz { proc p {} { @@ -70,9 +69,10 @@ test proc-1.4 {Tcl_ProcObjCmd, simple proc name and proc defined in namespace} { } list [test_ns_1::baz::p] \ [info commands test_ns_1::baz::*] -} {{p in ::test_ns_1::baz} ::test_ns_1::baz::p} -test proc-1.5 {Tcl_ProcObjCmd, qualified proc name and proc defined in namespace} { +} -result {{p in ::test_ns_1::baz} ::test_ns_1::baz::p} +test proc-1.5 {Tcl_ProcObjCmd, qualified proc name and proc defined in namespace} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1::baz {} namespace eval test_ns_1 { proc baz::p {} { @@ -82,9 +82,10 @@ test proc-1.5 {Tcl_ProcObjCmd, qualified proc name and proc defined in namespace list [test_ns_1::baz::p] \ [info commands test_ns_1::baz::*] \ [namespace eval test_ns_1::baz {namespace which p}] -} {{p in ::test_ns_1::baz} ::test_ns_1::baz::p ::test_ns_1::baz::p} -test proc-1.6 {Tcl_ProcObjCmd, namespace code ignores single ":"s in middle or end of command names} { +} -result {{p in ::test_ns_1::baz} ::test_ns_1::baz::p ::test_ns_1::baz::p} +test proc-1.6 {Tcl_ProcObjCmd, namespace code ignores single ":"s in middle or end of command names} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1 { proc q: {} {return "q:"} proc value:at: {} {return "value:at:"} @@ -96,88 +97,97 @@ test proc-1.6 {Tcl_ProcObjCmd, namespace code ignores single ":"s in middle or e [lsort [info commands test_ns_1::*]] \ [namespace eval test_ns_1 {namespace which q:}] \ [namespace eval test_ns_1 {namespace which value:at:}] -} {q: value:at: q: value:at: {::test_ns_1::q: ::test_ns_1::value:at:} ::test_ns_1::q: ::test_ns_1::value:at:} -test proc-1.7 {Tcl_ProcObjCmd, check that formal parameter names are not array elements} { +} -result {q: value:at: q: value:at: {::test_ns_1::q: ::test_ns_1::value:at:} ::test_ns_1::q: ::test_ns_1::value:at:} +test proc-1.7 {Tcl_ProcObjCmd, check that formal parameter names are not array elements} -setup { catch {rename p ""} - list [catch {proc p {a(1) a(2)} { - set z [expr $a(1)+$a(2)] - puts "$z=z, $a(1)=$a(1)" - }} msg] $msg -} {1 {formal parameter "a(1)" is an array element}} -test proc-1.8 {Tcl_ProcObjCmd, check that formal parameter names are simple names} { +} -returnCodes error -body { + proc p {a(1) a(2)} { + set z [expr $a(1)+$a(2)] + puts "$z=z, $a(1)=$a(1)" + } +} -result {formal parameter "a(1)" is an array element} +test proc-1.8 {Tcl_ProcObjCmd, check that formal parameter names are simple names} -setup { catch {rename p ""} - list [catch {proc p {b:a b::a} { - }} msg] $msg -} {1 {formal parameter "b::a" is not a simple name}} +} -body { + proc p {b:a b::a} { + } +} -returnCodes error -result {formal parameter "b::a" is not a simple name} -test proc-2.1 {TclFindProc, simple proc name and proc not in namespace} { +test proc-2.1 {TclFindProc, simple proc name and proc not in namespace} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} +} -body { proc p {} {return "p in [namespace current]"} info body p -} {return "p in [namespace current]"} -test proc-2.2 {TclFindProc, simple proc name and proc defined in namespace} { +} -result {return "p in [namespace current]"} +test proc-2.2 {TclFindProc, simple proc name and proc defined in namespace} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1 { namespace eval baz { proc p {} {return "p in [namespace current]"} } } namespace eval test_ns_1::baz {info body p} -} {return "p in [namespace current]"} -test proc-2.3 {TclFindProc, qualified proc name and proc defined in namespace} { +} -result {return "p in [namespace current]"} +test proc-2.3 {TclFindProc, qualified proc name and proc defined in namespace} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1::baz {} namespace eval test_ns_1 { proc baz::p {} {return "p in [namespace current]"} } namespace eval test_ns_1 {info body baz::p} -} {return "p in [namespace current]"} -test proc-2.4 {TclFindProc, global proc and executing in namespace} { +} -result {return "p in [namespace current]"} +test proc-2.4 {TclFindProc, global proc and executing in namespace} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} +} -body { proc p {} {return "global p"} namespace eval test_ns_1::baz {info body p} -} {return "global p"} +} -result {return "global p"} -test proc-3.1 {TclObjInterpProc, proc defined and executing in same namespace} { +test proc-3.1 {TclObjInterpProc, proc defined and executing in same namespace} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { proc p {} {return "p in [namespace current]"} p -} {p in ::} -test proc-3.2 {TclObjInterpProc, proc defined and executing in same namespace} { +} -result {p in ::} +test proc-3.2 {TclObjInterpProc, proc defined and executing in same namespace} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1::baz { proc p {} {return "p in [namespace current]"} p } -} {p in ::test_ns_1::baz} -test proc-3.3 {TclObjInterpProc, proc defined and executing in different namespaces} { +} -result {p in ::test_ns_1::baz} +test proc-3.3 {TclObjInterpProc, proc defined and executing in different namespaces} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} +} -body { proc p {} {return "p in [namespace current]"} namespace eval test_ns_1::baz { p } -} {p in ::} -test proc-3.4 {TclObjInterpProc, procs execute in the namespace in which they were defined unless renamed into new namespace} { +} -result {p in ::} +test proc-3.4 {TclObjInterpProc, procs execute in the namespace in which they were defined unless renamed into new namespace} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} +} -body { namespace eval test_ns_1::baz { proc p {} {return "p in [namespace current]"} rename ::test_ns_1::baz::p ::p list [p] [namespace which p] } -} {{p in ::} ::p} -test proc-3.5 {TclObjInterpProc, any old result is reset before appending error msg about missing arguments} { +} -result {{p in ::} ::p} +test proc-3.5 {TclObjInterpProc, any old result is reset before appending error msg about missing arguments} -body { proc p {x} {info commands 3m} - list [catch {p} msg] $msg -} {1 {wrong # args: should be "p x"}} - -test proc-3.6 {TclObjInterpProc, proper quoting of proc name, Bug 942757} { + p +} -returnCodes error -result {wrong # args: should be "p x"} +test proc-3.6 {TclObjInterpProc, proper quoting of proc name, Bug 942757} -body { proc {a b c} {x} {info commands 3m} - list [catch {{a b c}} msg] $msg -} {1 {wrong # args: should be "{a b c} x"}} + {a b c} +} -returnCodes error -result {wrong # args: should be "{a b c} x"} catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} @@ -189,116 +199,95 @@ catch {rename p ""} catch {rename t ""} # Note that the test require that procedures whose body is used to create -# procbody objects must be executed before the procbodytest::proc command -# is executed, so that the Proc struct is populated correctly (CompiledLocals -# are added at compile time). +# procbody objects must be executed before the procbodytest::proc command is +# executed, so that the Proc struct is populated correctly (CompiledLocals are +# added at compile time). -test proc-4.1 {TclCreateProc, procbody obj} procbodytest { - catch { - proc p x {return "$x:$x"} - set rv [p P] - procbodytest::proc t x p - lappend rv [t T] - set rv - } result +test proc-4.1 {TclCreateProc, procbody obj} -constraints procbodytest -body { + proc p x {return "$x:$x"} + set rv [p P] + procbodytest::proc t x p + lappend rv [t T] +} -cleanup { catch {rename p ""} catch {rename t ""} - set result -} {P:P T:T} -test proc-4.2 {TclCreateProc, procbody obj, use compiled locals} procbodytest { - catch { - proc p x { - set y [string tolower $x] - return "$x:$y" - } - set rv [p P] - procbodytest::proc t x p - lappend rv [t T] - set rv - } result +} -result {P:P T:T} +test proc-4.2 {TclCreateProc, procbody obj, use compiled locals} -body { + proc p x { + set y [string tolower $x] + return "$x:$y" + } + set rv [p P] + procbodytest::proc t x p + lappend rv [t T] +} -constraints procbodytest -cleanup { catch {rename p ""} catch {rename t ""} - set result -} {P:p T:t} -test proc-4.3 {TclCreateProc, procbody obj, too many args} procbodytest { - catch { - proc p x { - set y [string tolower $x] - return "$x:$y" - } - set rv [p P] - procbodytest::proc t {x x1 x2} p - lappend rv [t T] - set rv - } result +} -result {P:p T:t} +test proc-4.3 {TclCreateProc, procbody obj, too many args} -body { + proc p x { + set y [string tolower $x] + return "$x:$y" + } + set rv [p P] + procbodytest::proc t {x x1 x2} p + lappend rv [t T] +} -constraints procbodytest -returnCodes error -cleanup { catch {rename p ""} catch {rename t ""} - set result -} {procedure "t": arg list contains 3 entries, precompiled header expects 1} -test proc-4.4 {TclCreateProc, procbody obj, inconsistent arg name} procbodytest { - catch { - proc p {x y z} { - set v [join [list $x $y $z]] - set w [string tolower $v] - return "$v:$w" - } - set rv [p P Q R] - procbodytest::proc t {x x1 z} p - lappend rv [t S T U] - set rv - } result +} -result {procedure "t": arg list contains 3 entries, precompiled header expects 1} +test proc-4.4 {TclCreateProc, procbody obj, inconsistent arg name} -body { + proc p {x y z} { + set v [join [list $x $y $z]] + set w [string tolower $v] + return "$v:$w" + } + set rv [p P Q R] + procbodytest::proc t {x x1 z} p + lappend rv [t S T U] +} -constraints procbodytest -returnCodes error -cleanup { catch {rename p ""} catch {rename t ""} - set result -} {procedure "t": formal parameter 1 is inconsistent with precompiled body} -test proc-4.5 {TclCreateProc, procbody obj, inconsistent arg default type} procbodytest { - catch { - proc p {x y {z Z}} { - set v [join [list $x $y $z]] - set w [string tolower $v] - return "$v:$w" - } - set rv [p P Q R] - procbodytest::proc t {x y z} p - lappend rv [t S T U] - set rv - } result +} -result {procedure "t": formal parameter 1 is inconsistent with precompiled body} +test proc-4.5 {TclCreateProc, procbody obj, inconsistent arg default type} -body { + proc p {x y {z Z}} { + set v [join [list $x $y $z]] + set w [string tolower $v] + return "$v:$w" + } + set rv [p P Q R] + procbodytest::proc t {x y z} p + lappend rv [t S T U] +} -constraints procbodytest -returnCodes error -cleanup { catch {rename p ""} catch {rename t ""} - set result -} {procedure "t": formal parameter 2 is inconsistent with precompiled body} -test proc-4.6 {TclCreateProc, procbody obj, inconsistent arg default type} procbodytest { - catch { - proc p {x y z} { - set v [join [list $x $y $z]] - set w [string tolower $v] - return "$v:$w" - } - set rv [p P Q R] - procbodytest::proc t {x y {z Z}} p - lappend rv [t S T U] - set rv - } result +} -result {procedure "t": formal parameter 2 is inconsistent with precompiled body} +test proc-4.6 {TclCreateProc, procbody obj, inconsistent arg default type} -body { + proc p {x y z} { + set v [join [list $x $y $z]] + set w [string tolower $v] + return "$v:$w" + } + set rv [p P Q R] + procbodytest::proc t {x y {z Z}} p + lappend rv [t S T U] +} -returnCodes error -constraints procbodytest -cleanup { catch {rename p ""} catch {rename t ""} - set result -} {procedure "t": formal parameter 2 is inconsistent with precompiled body} -test proc-4.7 {TclCreateProc, procbody obj, inconsistent arg default value} procbodytest { - catch { - proc p {x y {z Z}} { - set v [join [list $x $y $z]] - set w [string tolower $v] - return "$v:$w" - } - set rv [p P Q R] - procbodytest::proc t {x y {z ZZ}} p - lappend rv [t S T U] - set rv - } result +} -result {procedure "t": formal parameter 2 is inconsistent with precompiled body} +test proc-4.7 {TclCreateProc, procbody obj, inconsistent arg default value} -body { + proc p {x y {z Z}} { + set v [join [list $x $y $z]] + set w [string tolower $v] + return "$v:$w" + } + set rv [p P Q R] + procbodytest::proc t {x y {z ZZ}} p + lappend rv [t S T U] +} -constraints procbodytest -returnCodes error -cleanup { catch {rename p ""} catch {rename t ""} - set result -} {procedure "t": formal parameter "z" has default value inconsistent with precompiled body} +} -result {procedure "t": formal parameter "z" has default value inconsistent with precompiled body} test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -setup { proc getbytes {} { set lines [split [memory info] "\n"] @@ -310,12 +299,9 @@ test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -set } px x } -constraints {procbodytest memory} -body { - set end [getbytes] for {set i 0} {$i < 5} {incr i} { - procbodytest::proc tx x px - set tmp $end set end [getbytes] } @@ -325,7 +311,7 @@ test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -set unset -nocomplain end i tmp leakedBytes } -result 0 -test proc-5.1 {Bytecompiling noop; test for correct argument substitution} { +test proc-5.1 {Bytecompiling noop; test for correct argument substitution} -body { proc p args {} ; # this will be bytecompiled into t proc t {} { set res {} @@ -336,20 +322,20 @@ test proc-5.1 {Bytecompiling noop; test for correct argument substitution} { p $a ccccccw {bfe} {$a} [incr b] [incr a] {[incr b]} {$a} hello set res } - set result [t] + t +} -cleanup { catch {rename p ""} catch {rename t ""} - set result -} {aba} +} -result {aba} -test proc-6.1 {ProcessProcResultCode: Bug 647307 (negative return code)} { +test proc-6.1 {ProcessProcResultCode: Bug 647307 (negative return code)} -body { proc a {} {return -code -5} proc b {} a - set result [catch b] + catch b +} -cleanup { rename a {} rename b {} - set result -} -5 +} -result -5 test proc-7.1 {Redefining a compiled cmd: Bug 729692} { proc bar args {} @@ -359,19 +345,17 @@ test proc-7.1 {Redefining a compiled cmd: Bug 729692} { } foo } bar - -test proc-7.2 {Shadowing a compiled cmd: Bug 729692} { +test proc-7.2 {Shadowing a compiled cmd: Bug 729692} -body { namespace eval ugly {} proc ugly::foo {} { proc set args {return bar} set x 1 } - set res [list [catch {ugly::foo} msg] $msg] + ugly::foo +} -cleanup { namespace delete ugly - set res -} {0 bar} - -test proc-7.3 {Returning loop exception from redefined cmd: Bug 729692} { +} -result bar +test proc-7.3 {Returning loop exception from redefined cmd: Bug 729692} -body { namespace eval ugly {} proc ugly::foo {} { set i 0 @@ -383,15 +367,18 @@ test proc-7.3 {Returning loop exception from redefined cmd: Bug 729692} { } return $i } - set res [list [catch {ugly::foo} msg] $msg] + ugly::foo +} -cleanup { namespace delete ugly - set res -} {0 4} - - - +} -result 4 + # cleanup catch {rename p ""} catch {rename t ""} ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/remote.tcl b/tests/remote.tcl index de827de..06000aa 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.2 2010/12/01 16:42:37 kennykb Exp $ +# RCS: @(#) $Id: remote.tcl,v 1.5 2010/11/04 21:38:27 rmax Exp $ # Initialize message delimitor diff --git a/tests/safe.test b/tests/safe.test index 51d2f7e..5025469 100644 --- a/tests/safe.test +++ b/tests/safe.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: safe.test,v 1.34.2.2 2010/12/11 18:39:30 kennykb Exp $ +# RCS: @(#) $Id: safe.test,v 1.36 2010/12/07 16:32:06 dkf Exp $ package require Tcl 8.5 diff --git a/tests/security.test b/tests/security.test index 2549a4a..e92775e 100644 --- a/tests/security.test +++ b/tests/security.test @@ -1,18 +1,18 @@ # security.test -- # -# Functionality covered: this file contains a collection of tests for the -# auto loading and namespaces. +# Functionality covered: this file contains a collection of tests for the auto +# loading and namespaces. # -# Sourcing this file into Tcl runs the tests and generates output for -# errors. No output means no errors were found. +# Sourcing this file into Tcl runs the tests and generates output for errors. +# No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: security.test,v 1.6 2004/05/19 13:02:10 dkf Exp $ +# RCS: @(#) $Id: security.test,v 1.7 2011/01/01 15:14:43 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -41,3 +41,7 @@ test security-1.1 {tcl_endOfPreviousWord} { # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/socket.test b/tests/socket.test index e263c57..1cc4441 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.2 2010/12/01 16:42:37 kennykb Exp $ +# RCS: @(#) $Id: socket.test,v 1.49 2010/11/04 21:38:27 rmax Exp $ # Running socket tests with a remote server: # ------------------------------------------ diff --git a/tests/stringComp.test b/tests/stringComp.test index 35c11d1..6ef94ee 100644 --- a/tests/stringComp.test +++ b/tests/stringComp.test @@ -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: stringComp.test,v 1.17.4.1 2010/09/25 14:51:13 kennykb Exp $ +# RCS: @(#) $Id: stringComp.test,v 1.18 2010/09/25 02:25:54 hobbs Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest diff --git a/tests/subst.test b/tests/subst.test index 9af2609..0c81069 100644 --- a/tests/subst.test +++ b/tests/subst.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: subst.test,v 1.20.2.1 2010/10/09 17:53:17 kennykb Exp $ +# RCS: @(#) $Id: subst.test,v 1.21 2010/10/06 18:38:45 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 diff --git a/tests/switch.test b/tests/switch.test index 738565f..3f127a4 100644 --- a/tests/switch.test +++ b/tests/switch.test @@ -11,13 +11,13 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: switch.test,v 1.25 2009/07/14 16:52:28 kennykb Exp $ +# RCS: @(#) $Id: switch.test,v 1.26 2011/01/01 15:14:43 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } - + test switch-1.1 {simple patterns} { switch a a {subst 1} b {subst 2} c {subst 3} default {subst 4} } 1 @@ -753,7 +753,7 @@ test switch-15.1 {coroutine safety of non-bytecoded switch} {*}{ rename coro {} } } - + # cleanup catch {rename foo {}} ::tcltest::cleanupTests diff --git a/tests/unixInit.test b/tests/unixInit.test index 1f4dc7a..1f5c7c1 100644 --- a/tests/unixInit.test +++ b/tests/unixInit.test @@ -1,23 +1,23 @@ # The file tests the functions in the tclUnixInit.c file. # -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. +# This file contains a collection of tests for one or more of the Tcl built-in +# commands. Sourcing this file into Tcl runs the tests and generates output +# for errors. No output means no errors were found. # # Copyright (c) 1997 by Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # -# 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. # -# RCS: @(#) $Id: unixInit.test,v 1.50 2006/11/03 11:45:35 dkf Exp $ +# RCS: @(#) $Id: unixInit.test,v 1.51 2011/01/01 15:14:43 dkf Exp $ package require tcltest 2.2 namespace import -force ::tcltest::* unset -nocomplain path catch {set oldlang $env(LANG)} set env(LANG) C - + test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unix stdio} { set x {} # Watch out for a race condition here. If tcltest is too slow to start @@ -36,13 +36,13 @@ test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unix stdio} { lappend x [catch {close $f}] set x } {0 1} -# This test is really a test of code in tclUnixChan.c, but the -# channels are set up as part of initialisation of the interpreter so -# the test seems to me to fit here as well as anywhere else. +# This test is really a test of code in tclUnixChan.c, but the channels are +# set up as part of initialisation of the interpreter so the test seems to me +# to fit here as well as anywhere else. test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio} { - # pipe1 is a connection to a server that reports what port it - # starts on, and delivers a constant string to the first client to - # connect to that port before exiting. + # pipe1 is a connection to a server that reports what port it starts on, + # and delivers a constant string to the first client to connect to that + # port before exiting. set pipe1 [open "|[list [interpreter]]" r+] puts $pipe1 { proc accept {channel host port} { @@ -53,16 +53,16 @@ test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio} puts [fconfigure [socket -server accept -myaddr 127.0.0.1 0] -sockname] vwait forever \ } - # Note the backslash above; this is important to make sure that the - # whole string is read before an [exit] can happen... + # Note the backslash above; this is important to make sure that the whole + # string is read before an [exit] can happen... flush $pipe1 set port [lindex [gets $pipe1] 2] set sock [socket localhost $port] - # pipe2 is a connection to a Tcl interpreter that takes its orders - # from the socket we hand it (i.e. the server we create above.) - # These orders will tell it to print out the details about the - # socket it is taking instructions from, hopefully identifying it - # as a socket. Which is what this test is all about. + # pipe2 is a connection to a Tcl interpreter that takes its orders from + # the socket we hand it (i.e. the server we create above.) These orders + # will tell it to print out the details about the socket it is taking + # instructions from, hopefully identifying it as a socket. Which is what + # this test is all about. set pipe2 [open "|[list [interpreter] <@$sock]" r] set result [gets $pipe2] # Clear any pending data; stops certain kinds of (non-important) errors @@ -85,8 +85,8 @@ test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio} } {OK} # The unixInit-2.* tests were written to test the internal routine, -# TclpInitLibraryPath. That routine no longer does the things it used -# to do so those tests are obsolete. Skip them. +# TclpInitLibraryPath. That routine no longer does the things it used to do +# so those tests are obsolete. Skip them. skip [concat [skip] unixInit-2.*] @@ -207,10 +207,9 @@ test unixInit-2.7 {TclpInitLibraryPath: compiled-in library path} { # [lindex $auto_path end] } {} # -# The following two tests write to the directory /tmp/sparkly instead -# of to [temporaryDirectory]. This is because the failures tested by -# these tests need paths near the "root" of the file system to present -# themselves. +# The following two tests write to the directory /tmp/sparkly instead of to +# [temporaryDirectory]. This is because the failures tested by these tests +# need paths near the "root" of the file system to present themselves. # test unixInit-2.8 {TclpInitLibraryPath: all absolute pathtype} -setup { unset -nocomplain oldlibrary @@ -219,20 +218,20 @@ test unixInit-2.8 {TclpInitLibraryPath: all absolute pathtype} -setup { } set env(TCL_LIBRARY) [info library] # Checking for Bug 219416 - # When a program that embeds the Tcl library, like tcltest, is - # installed near the "root" of the file system, there was a problem - # constructing directories relative to the executable. When a - # relative ".." went past the root, relative path names were created - # rather than absolute pathnames. In some cases, accessing past the - # root caused memory access violations too. + # When a program that embeds the Tcl library, like tcltest, is installed + # near the "root" of the file system, there was a problem constructing + # directories relative to the executable. When a relative ".." went past + # the root, relative path names were created rather than absolute + # pathnames. In some cases, accessing past the root caused memory access + # violations too. # - # The bug is now fixed, but here we check for it by making sure that - # the directories constructed relative to the executable are all - # absolute pathnames, even when the executable is installed near - # the root of the filesystem. + # The bug is now fixed, but here we check for it by making sure that the + # directories constructed relative to the executable are all absolute + # pathnames, even when the executable is installed near the root of the + # filesystem. # - # The only directory near the root we are likely to have write access - # to is /tmp. + # The only directory near the root we are likely to have write access to + # is /tmp. file delete -force /tmp/sparkly file delete -force /tmp/lib/tcl[info tclversion] file mkdir /tmp/sparkly @@ -367,12 +366,11 @@ test unixInit-3.2 {TclpSetInitialEncodings} {unix stdio} { catch {set env(LC_ALL) $oldlc_all} set validEncodings [list euc-jp] if {[string match HP-UX $tcl_platform(os)]} { - # Some older HP-UX systems need us to accept this as valid - # Bug 453883 reports that newer HP-UX systems report euc-jp - # like everybody else. + # Some older HP-UX systems need us to accept this as valid Bug 453883 + # reports that newer HP-UX systems report euc-jp like everybody else. lappend validEncodings shiftjis } - expr {[lsearch -exact $validEncodings $enc] < 0} + expr {$enc ni $validEncodings} } 0 test unixInit-4.1 {TclpSetVariables} {unix} { @@ -403,7 +401,7 @@ test unixInit-7.1 {closed standard channel: Bug 772288} -constraints { removeFile crash.tcl removeFile crashtest.tcl } -returnCodes 0 - + # cleanup catch {unset env(LANG)} catch {set env(LANG) $oldlang} @@ -411,3 +409,7 @@ unset -nocomplain path ::tcltest::cleanupTests return +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/uplevel.test b/tests/uplevel.test index 2f725bc..264edbe 100644 --- a/tests/uplevel.test +++ b/tests/uplevel.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: uplevel.test,v 1.9.6.1 2010/12/11 18:39:30 kennykb Exp $ +# RCS: @(#) $Id: uplevel.test,v 1.10 2010/12/07 16:32:06 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -26,7 +26,7 @@ proc newset {name value} { uplevel set $name $value uplevel 1 {uplevel 1 {set xyz 22}} } - + test uplevel-1.1 {simple operation} { set xyz 0 a 22 33 @@ -197,7 +197,7 @@ test uplevel-7.3 {var access, LVT in upper level} -setup { rename foo {} rename moo {} } -result {3 3 3} - + # cleanup ::tcltest::cleanupTests return diff --git a/tests/upvar.test b/tests/upvar.test index d181043..90ba0b1 100644 --- a/tests/upvar.test +++ b/tests/upvar.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: upvar.test,v 1.20.4.1 2010/12/11 18:39:30 kennykb Exp $ +# RCS: @(#) $Id: upvar.test,v 1.21 2010/12/07 16:32:06 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 diff --git a/tests/utf.test b/tests/utf.test index f2dfb8f..3a45d13 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -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: utf.test,v 1.14.10.1 2010/10/20 01:50:19 kennykb Exp $ +# RCS: @(#) $Id: utf.test,v 1.15 2010/10/18 21:47:36 nijtmans Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 diff --git a/tests/util.test b/tests/util.test index bfb8507..b16fa28 100644 --- a/tests/util.test +++ b/tests/util.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: util.test,v 1.20.6.1 2010/12/01 16:42:37 kennykb Exp $ +# RCS: @(#) $Id: util.test,v 1.23 2011/01/15 18:10:19 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -1903,10 +1903,1969 @@ test util-14.2 {funky NaN} {*}{ -result -NaN(3456789abcdef) } +test util-15.1 {largest subnormal} {*}{ + -body { + binary scan [binary format w 0x000fffffffffffff] q x + set x + } + -result 2.225073858507201e-308 + -cleanup { + unset x + } +} + +test util-15.2 {largest subnormal} {*}{ + -body { + binary scan [binary format w 0x800fffffffffffff] q x + set x + } + -result -2.225073858507201e-308 + -cleanup { + unset x + } +} + +test util-15.3 {largest subnormal} {*}{ + -body { + binary scan [binary format q 2.225073858507201e-308] w x + format %#lx $x + } + -result 0xfffffffffffff + -cleanup { + unset x + } +} + +test util-15.4 {largest subnormal} {*}{ + -body { + binary scan [binary format q -2.225073858507201e-308] w x + format %#lx $x + } + -result 0x800fffffffffffff + -cleanup { + unset x + } +} + +test util-15.5 {smallest normal} {*}{ + -body { + binary scan [binary format w 0x0010000000000000] q x + set x + } + -result 2.2250738585072014e-308 + -cleanup { + unset x + } +} + +test util-15.6 {smallest normal} {*}{ + -body { + binary scan [binary format w 0x8010000000000000] q x + set x + } + -result -2.2250738585072014e-308 + -cleanup { + unset x + } +} + +test util-15.7 {smallest normal} {*}{ + -body { + binary scan [binary format q 2.2250738585072014e-308] w x + format %#lx $x + } + -result 0x10000000000000 + -cleanup { + unset x + } +} + +test util-15.8 {smallest normal} {*}{ + -body { + binary scan [binary format q -2.2250738585072014e-308] w x + format %#lx $x + } + -result 0x8010000000000000 + -cleanup { + unset x + } +} + +set saved_precision $::tcl_precision +foreach ::tcl_precision {0 12} { + for {set e -312} {$e < -9} {incr e} { + test util-16.1.$::tcl_precision.$e {shortening of numbers} \ + "expr 1.1e$e" 1.1e$e + } +} +set tcl_precision 0 +for {set e -9} {$e < -4} {incr e} { + test util-16.1.$::tcl_precision.$e {shortening of numbers} \ + "expr 1.1e$e" 1.1e$e +} +set tcl_precision 12 +for {set e -9} {$e < -4} {incr e} { + test util-16.1.$::tcl_precision.$e {8.4 compatible formatting of doubles} \ + "expr 1.1e$e" 1.1e[format %+03d $e] +} +foreach ::tcl_precision {0 12} { + test util-16.1.$::tcl_precision.-4 {shortening of numbers} \ + {expr 1.1e-4} \ + 0.00011 + test util-16.1.$::tcl_precision.-3 {shortening of numbers} \ + {expr 1.1e-3} \ + 0.0011 + test util-16.1.$::tcl_precision.-2 {shortening of numbers} \ + {expr 1.1e-2} \ + 0.011 + test util-16.1.$::tcl_precision.-1 {shortening of numbers} \ + {expr 1.1e-1} \ + 0.11 + test util-16.1.$::tcl_precision.0 {shortening of numbers} \ + {expr 1.1} \ + 1.1 + for {set e 1} {$e < 17} {incr e} { + test util-16.1.$::tcl_precision.$e {shortening of numbers} \ + "expr 11[string repeat 0 [expr {$e-1}]].0" \ + 11[string repeat 0 [expr {$e-1}]].0 + } + for {set e 17} {$e < 309} {incr e} { + test util-16.1.$::tcl_precision.$e {shortening of numbers} \ + "expr 1.1e$e" 1.1e+$e + } +} +set tcl_precision 17 +test util-16.1.17.-300 {8.4 compatible formatting of doubles} \ + {expr 1e-300} \ + 1e-300 +test util-16.1.17.-299 {8.4 compatible formatting of doubles} \ + {expr 1e-299} \ + 9.9999999999999999e-300 +test util-16.1.17.-298 {8.4 compatible formatting of doubles} \ + {expr 1e-298} \ + 9.9999999999999991e-299 +test util-16.1.17.-297 {8.4 compatible formatting of doubles} \ + {expr 1e-297} \ + 1e-297 +test util-16.1.17.-296 {8.4 compatible formatting of doubles} \ + {expr 1e-296} \ + 1e-296 +test util-16.1.17.-295 {8.4 compatible formatting of doubles} \ + {expr 1e-295} \ + 1.0000000000000001e-295 +test util-16.1.17.-294 {8.4 compatible formatting of doubles} \ + {expr 1e-294} \ + 1e-294 +test util-16.1.17.-293 {8.4 compatible formatting of doubles} \ + {expr 1e-293} \ + 1.0000000000000001e-293 +test util-16.1.17.-292 {8.4 compatible formatting of doubles} \ + {expr 1e-292} \ + 1.0000000000000001e-292 +test util-16.1.17.-291 {8.4 compatible formatting of doubles} \ + {expr 1e-291} \ + 9.9999999999999996e-292 +test util-16.1.17.-290 {8.4 compatible formatting of doubles} \ + {expr 1e-290} \ + 1.0000000000000001e-290 +test util-16.1.17.-289 {8.4 compatible formatting of doubles} \ + {expr 1e-289} \ + 1e-289 +test util-16.1.17.-288 {8.4 compatible formatting of doubles} \ + {expr 1e-288} \ + 1.0000000000000001e-288 +test util-16.1.17.-287 {8.4 compatible formatting of doubles} \ + {expr 1e-287} \ + 1e-287 +test util-16.1.17.-286 {8.4 compatible formatting of doubles} \ + {expr 1e-286} \ + 1.0000000000000001e-286 +test util-16.1.17.-285 {8.4 compatible formatting of doubles} \ + {expr 1e-285} \ + 1.0000000000000001e-285 +test util-16.1.17.-284 {8.4 compatible formatting of doubles} \ + {expr 1e-284} \ + 1e-284 +test util-16.1.17.-283 {8.4 compatible formatting of doubles} \ + {expr 1e-283} \ + 9.9999999999999995e-284 +test util-16.1.17.-282 {8.4 compatible formatting of doubles} \ + {expr 1e-282} \ + 1e-282 +test util-16.1.17.-281 {8.4 compatible formatting of doubles} \ + {expr 1e-281} \ + 1e-281 +test util-16.1.17.-280 {8.4 compatible formatting of doubles} \ + {expr 1e-280} \ + 9.9999999999999996e-281 +test util-16.1.17.-279 {8.4 compatible formatting of doubles} \ + {expr 1e-279} \ + 1.0000000000000001e-279 +test util-16.1.17.-278 {8.4 compatible formatting of doubles} \ + {expr 1e-278} \ + 9.9999999999999994e-279 +test util-16.1.17.-277 {8.4 compatible formatting of doubles} \ + {expr 1e-277} \ + 9.9999999999999997e-278 +test util-16.1.17.-276 {8.4 compatible formatting of doubles} \ + {expr 1e-276} \ + 1.0000000000000001e-276 +test util-16.1.17.-275 {8.4 compatible formatting of doubles} \ + {expr 1e-275} \ + 9.9999999999999993e-276 +test util-16.1.17.-274 {8.4 compatible formatting of doubles} \ + {expr 1e-274} \ + 9.9999999999999997e-275 +test util-16.1.17.-273 {8.4 compatible formatting of doubles} \ + {expr 1e-273} \ + 1.0000000000000001e-273 +test util-16.1.17.-272 {8.4 compatible formatting of doubles} \ + {expr 1e-272} \ + 9.9999999999999993e-273 +test util-16.1.17.-271 {8.4 compatible formatting of doubles} \ + {expr 1e-271} \ + 9.9999999999999996e-272 +test util-16.1.17.-270 {8.4 compatible formatting of doubles} \ + {expr 1e-270} \ + 1e-270 +test util-16.1.17.-269 {8.4 compatible formatting of doubles} \ + {expr 1e-269} \ + 9.9999999999999996e-270 +test util-16.1.17.-268 {8.4 compatible formatting of doubles} \ + {expr 1e-268} \ + 9.9999999999999996e-269 +test util-16.1.17.-267 {8.4 compatible formatting of doubles} \ + {expr 1e-267} \ + 9.9999999999999998e-268 +test util-16.1.17.-266 {8.4 compatible formatting of doubles} \ + {expr 1e-266} \ + 9.9999999999999998e-267 +test util-16.1.17.-265 {8.4 compatible formatting of doubles} \ + {expr 1e-265} \ + 9.9999999999999998e-266 +test util-16.1.17.-264 {8.4 compatible formatting of doubles} \ + {expr 1e-264} \ + 1e-264 +test util-16.1.17.-263 {8.4 compatible formatting of doubles} \ + {expr 1e-263} \ + 1e-263 +test util-16.1.17.-262 {8.4 compatible formatting of doubles} \ + {expr 1e-262} \ + 1e-262 +test util-16.1.17.-261 {8.4 compatible formatting of doubles} \ + {expr 1e-261} \ + 9.9999999999999998e-262 +test util-16.1.17.-260 {8.4 compatible formatting of doubles} \ + {expr 1e-260} \ + 9.9999999999999996e-261 +test util-16.1.17.-259 {8.4 compatible formatting of doubles} \ + {expr 1e-259} \ + 1.0000000000000001e-259 +test util-16.1.17.-258 {8.4 compatible formatting of doubles} \ + {expr 1e-258} \ + 9.9999999999999995e-259 +test util-16.1.17.-257 {8.4 compatible formatting of doubles} \ + {expr 1e-257} \ + 9.9999999999999998e-258 +test util-16.1.17.-256 {8.4 compatible formatting of doubles} \ + {expr 1e-256} \ + 9.9999999999999998e-257 +test util-16.1.17.-255 {8.4 compatible formatting of doubles} \ + {expr 1e-255} \ + 1e-255 +test util-16.1.17.-254 {8.4 compatible formatting of doubles} \ + {expr 1e-254} \ + 9.9999999999999991e-255 +test util-16.1.17.-253 {8.4 compatible formatting of doubles} \ + {expr 1e-253} \ + 1.0000000000000001e-253 +test util-16.1.17.-252 {8.4 compatible formatting of doubles} \ + {expr 1e-252} \ + 9.9999999999999994e-253 +test util-16.1.17.-251 {8.4 compatible formatting of doubles} \ + {expr 1e-251} \ + 1e-251 +test util-16.1.17.-250 {8.4 compatible formatting of doubles} \ + {expr 1e-250} \ + 1.0000000000000001e-250 +test util-16.1.17.-249 {8.4 compatible formatting of doubles} \ + {expr 1e-249} \ + 1.0000000000000001e-249 +test util-16.1.17.-248 {8.4 compatible formatting of doubles} \ + {expr 1e-248} \ + 9.9999999999999998e-249 +test util-16.1.17.-247 {8.4 compatible formatting of doubles} \ + {expr 1e-247} \ + 1e-247 +test util-16.1.17.-246 {8.4 compatible formatting of doubles} \ + {expr 1e-246} \ + 9.9999999999999996e-247 +test util-16.1.17.-245 {8.4 compatible formatting of doubles} \ + {expr 1e-245} \ + 9.9999999999999993e-246 +test util-16.1.17.-244 {8.4 compatible formatting of doubles} \ + {expr 1e-244} \ + 9.9999999999999993e-245 +test util-16.1.17.-243 {8.4 compatible formatting of doubles} \ + {expr 1e-243} \ + 1e-243 +test util-16.1.17.-242 {8.4 compatible formatting of doubles} \ + {expr 1e-242} \ + 9.9999999999999997e-243 +test util-16.1.17.-241 {8.4 compatible formatting of doubles} \ + {expr 1e-241} \ + 9.9999999999999997e-242 +test util-16.1.17.-240 {8.4 compatible formatting of doubles} \ + {expr 1e-240} \ + 9.9999999999999997e-241 +test util-16.1.17.-239 {8.4 compatible formatting of doubles} \ + {expr 1e-239} \ + 1.0000000000000001e-239 +test util-16.1.17.-238 {8.4 compatible formatting of doubles} \ + {expr 1e-238} \ + 9.9999999999999999e-239 +test util-16.1.17.-237 {8.4 compatible formatting of doubles} \ + {expr 1e-237} \ + 9.9999999999999999e-238 +test util-16.1.17.-236 {8.4 compatible formatting of doubles} \ + {expr 1e-236} \ + 1e-236 +test util-16.1.17.-235 {8.4 compatible formatting of doubles} \ + {expr 1e-235} \ + 9.9999999999999996e-236 +test util-16.1.17.-234 {8.4 compatible formatting of doubles} \ + {expr 1e-234} \ + 9.9999999999999996e-235 +test util-16.1.17.-233 {8.4 compatible formatting of doubles} \ + {expr 1e-233} \ + 9.9999999999999996e-234 +test util-16.1.17.-232 {8.4 compatible formatting of doubles} \ + {expr 1e-232} \ + 1e-232 +test util-16.1.17.-231 {8.4 compatible formatting of doubles} \ + {expr 1e-231} \ + 9.9999999999999999e-232 +test util-16.1.17.-230 {8.4 compatible formatting of doubles} \ + {expr 1e-230} \ + 1e-230 +test util-16.1.17.-229 {8.4 compatible formatting of doubles} \ + {expr 1e-229} \ + 1.0000000000000001e-229 +test util-16.1.17.-228 {8.4 compatible formatting of doubles} \ + {expr 1e-228} \ + 1e-228 +test util-16.1.17.-227 {8.4 compatible formatting of doubles} \ + {expr 1e-227} \ + 9.9999999999999994e-228 +test util-16.1.17.-226 {8.4 compatible formatting of doubles} \ + {expr 1e-226} \ + 9.9999999999999992e-227 +test util-16.1.17.-225 {8.4 compatible formatting of doubles} \ + {expr 1e-225} \ + 9.9999999999999996e-226 +test util-16.1.17.-224 {8.4 compatible formatting of doubles} \ + {expr 1e-224} \ + 1e-224 +test util-16.1.17.-223 {8.4 compatible formatting of doubles} \ + {expr 1e-223} \ + 9.9999999999999997e-224 +test util-16.1.17.-222 {8.4 compatible formatting of doubles} \ + {expr 1e-222} \ + 1e-222 +test util-16.1.17.-221 {8.4 compatible formatting of doubles} \ + {expr 1e-221} \ + 1e-221 +test util-16.1.17.-220 {8.4 compatible formatting of doubles} \ + {expr 1e-220} \ + 9.9999999999999999e-221 +test util-16.1.17.-219 {8.4 compatible formatting of doubles} \ + {expr 1e-219} \ + 1e-219 +test util-16.1.17.-218 {8.4 compatible formatting of doubles} \ + {expr 1e-218} \ + 1e-218 +test util-16.1.17.-217 {8.4 compatible formatting of doubles} \ + {expr 1e-217} \ + 1.0000000000000001e-217 +test util-16.1.17.-216 {8.4 compatible formatting of doubles} \ + {expr 1e-216} \ + 1e-216 +test util-16.1.17.-215 {8.4 compatible formatting of doubles} \ + {expr 1e-215} \ + 1e-215 +test util-16.1.17.-214 {8.4 compatible formatting of doubles} \ + {expr 1e-214} \ + 9.9999999999999991e-215 +test util-16.1.17.-213 {8.4 compatible formatting of doubles} \ + {expr 1e-213} \ + 9.9999999999999995e-214 +test util-16.1.17.-212 {8.4 compatible formatting of doubles} \ + {expr 1e-212} \ + 9.9999999999999995e-213 +test util-16.1.17.-211 {8.4 compatible formatting of doubles} \ + {expr 1e-211} \ + 1.0000000000000001e-211 +test util-16.1.17.-210 {8.4 compatible formatting of doubles} \ + {expr 1e-210} \ + 1e-210 +test util-16.1.17.-209 {8.4 compatible formatting of doubles} \ + {expr 1e-209} \ + 1e-209 +test util-16.1.17.-208 {8.4 compatible formatting of doubles} \ + {expr 1e-208} \ + 1.0000000000000001e-208 +test util-16.1.17.-207 {8.4 compatible formatting of doubles} \ + {expr 1e-207} \ + 9.9999999999999993e-208 +test util-16.1.17.-206 {8.4 compatible formatting of doubles} \ + {expr 1e-206} \ + 1e-206 +test util-16.1.17.-205 {8.4 compatible formatting of doubles} \ + {expr 1e-205} \ + 1e-205 +test util-16.1.17.-204 {8.4 compatible formatting of doubles} \ + {expr 1e-204} \ + 1e-204 +test util-16.1.17.-203 {8.4 compatible formatting of doubles} \ + {expr 1e-203} \ + 1e-203 +test util-16.1.17.-202 {8.4 compatible formatting of doubles} \ + {expr 1e-202} \ + 1e-202 +test util-16.1.17.-201 {8.4 compatible formatting of doubles} \ + {expr 1e-201} \ + 9.9999999999999995e-202 +test util-16.1.17.-200 {8.4 compatible formatting of doubles} \ + {expr 1e-200} \ + 9.9999999999999998e-201 +test util-16.1.17.-199 {8.4 compatible formatting of doubles} \ + {expr 1e-199} \ + 9.9999999999999998e-200 +test util-16.1.17.-198 {8.4 compatible formatting of doubles} \ + {expr 1e-198} \ + 9.9999999999999991e-199 +test util-16.1.17.-197 {8.4 compatible formatting of doubles} \ + {expr 1e-197} \ + 9.9999999999999999e-198 +test util-16.1.17.-196 {8.4 compatible formatting of doubles} \ + {expr 1e-196} \ + 1e-196 +test util-16.1.17.-195 {8.4 compatible formatting of doubles} \ + {expr 1e-195} \ + 1.0000000000000001e-195 +test util-16.1.17.-194 {8.4 compatible formatting of doubles} \ + {expr 1e-194} \ + 1e-194 +test util-16.1.17.-193 {8.4 compatible formatting of doubles} \ + {expr 1e-193} \ + 1e-193 +test util-16.1.17.-192 {8.4 compatible formatting of doubles} \ + {expr 1e-192} \ + 1.0000000000000001e-192 +test util-16.1.17.-191 {8.4 compatible formatting of doubles} \ + {expr 1e-191} \ + 1e-191 +test util-16.1.17.-190 {8.4 compatible formatting of doubles} \ + {expr 1e-190} \ + 1e-190 +test util-16.1.17.-189 {8.4 compatible formatting of doubles} \ + {expr 1e-189} \ + 1.0000000000000001e-189 +test util-16.1.17.-188 {8.4 compatible formatting of doubles} \ + {expr 1e-188} \ + 9.9999999999999995e-189 +test util-16.1.17.-187 {8.4 compatible formatting of doubles} \ + {expr 1e-187} \ + 1e-187 +test util-16.1.17.-186 {8.4 compatible formatting of doubles} \ + {expr 1e-186} \ + 9.9999999999999991e-187 +test util-16.1.17.-185 {8.4 compatible formatting of doubles} \ + {expr 1e-185} \ + 9.9999999999999999e-186 +test util-16.1.17.-184 {8.4 compatible formatting of doubles} \ + {expr 1e-184} \ + 1.0000000000000001e-184 +test util-16.1.17.-183 {8.4 compatible formatting of doubles} \ + {expr 1e-183} \ + 1e-183 +test util-16.1.17.-182 {8.4 compatible formatting of doubles} \ + {expr 1e-182} \ + 1e-182 +test util-16.1.17.-181 {8.4 compatible formatting of doubles} \ + {expr 1e-181} \ + 1e-181 +test util-16.1.17.-180 {8.4 compatible formatting of doubles} \ + {expr 1e-180} \ + 1e-180 +test util-16.1.17.-179 {8.4 compatible formatting of doubles} \ + {expr 1e-179} \ + 1e-179 +test util-16.1.17.-178 {8.4 compatible formatting of doubles} \ + {expr 1e-178} \ + 9.9999999999999995e-179 +test util-16.1.17.-177 {8.4 compatible formatting of doubles} \ + {expr 1e-177} \ + 9.9999999999999995e-178 +test util-16.1.17.-176 {8.4 compatible formatting of doubles} \ + {expr 1e-176} \ + 1e-176 +test util-16.1.17.-175 {8.4 compatible formatting of doubles} \ + {expr 1e-175} \ + 1e-175 +test util-16.1.17.-174 {8.4 compatible formatting of doubles} \ + {expr 1e-174} \ + 1e-174 +test util-16.1.17.-173 {8.4 compatible formatting of doubles} \ + {expr 1e-173} \ + 1e-173 +test util-16.1.17.-172 {8.4 compatible formatting of doubles} \ + {expr 1e-172} \ + 1e-172 +test util-16.1.17.-171 {8.4 compatible formatting of doubles} \ + {expr 1e-171} \ + 9.9999999999999998e-172 +test util-16.1.17.-170 {8.4 compatible formatting of doubles} \ + {expr 1e-170} \ + 9.9999999999999998e-171 +test util-16.1.17.-169 {8.4 compatible formatting of doubles} \ + {expr 1e-169} \ + 1e-169 +test util-16.1.17.-168 {8.4 compatible formatting of doubles} \ + {expr 1e-168} \ + 1e-168 +test util-16.1.17.-167 {8.4 compatible formatting of doubles} \ + {expr 1e-167} \ + 1e-167 +test util-16.1.17.-166 {8.4 compatible formatting of doubles} \ + {expr 1e-166} \ + 1e-166 +test util-16.1.17.-165 {8.4 compatible formatting of doubles} \ + {expr 1e-165} \ + 1e-165 +test util-16.1.17.-164 {8.4 compatible formatting of doubles} \ + {expr 1e-164} \ + 9.9999999999999996e-165 +test util-16.1.17.-163 {8.4 compatible formatting of doubles} \ + {expr 1e-163} \ + 9.9999999999999992e-164 +test util-16.1.17.-162 {8.4 compatible formatting of doubles} \ + {expr 1e-162} \ + 9.9999999999999995e-163 +test util-16.1.17.-161 {8.4 compatible formatting of doubles} \ + {expr 1e-161} \ + 1e-161 +test util-16.1.17.-160 {8.4 compatible formatting of doubles} \ + {expr 1e-160} \ + 9.9999999999999999e-161 +test util-16.1.17.-159 {8.4 compatible formatting of doubles} \ + {expr 1e-159} \ + 9.9999999999999999e-160 +test util-16.1.17.-158 {8.4 compatible formatting of doubles} \ + {expr 1e-158} \ + 1.0000000000000001e-158 +test util-16.1.17.-157 {8.4 compatible formatting of doubles} \ + {expr 1e-157} \ + 9.9999999999999994e-158 +test util-16.1.17.-156 {8.4 compatible formatting of doubles} \ + {expr 1e-156} \ + 1e-156 +test util-16.1.17.-155 {8.4 compatible formatting of doubles} \ + {expr 1e-155} \ + 1e-155 +test util-16.1.17.-154 {8.4 compatible formatting of doubles} \ + {expr 1e-154} \ + 9.9999999999999997e-155 +test util-16.1.17.-153 {8.4 compatible formatting of doubles} \ + {expr 1e-153} \ + 1e-153 +test util-16.1.17.-152 {8.4 compatible formatting of doubles} \ + {expr 1e-152} \ + 1.0000000000000001e-152 +test util-16.1.17.-151 {8.4 compatible formatting of doubles} \ + {expr 1e-151} \ + 9.9999999999999994e-152 +test util-16.1.17.-150 {8.4 compatible formatting of doubles} \ + {expr 1e-150} \ + 1e-150 +test util-16.1.17.-149 {8.4 compatible formatting of doubles} \ + {expr 1e-149} \ + 9.9999999999999998e-150 +test util-16.1.17.-148 {8.4 compatible formatting of doubles} \ + {expr 1e-148} \ + 9.9999999999999994e-149 +test util-16.1.17.-147 {8.4 compatible formatting of doubles} \ + {expr 1e-147} \ + 9.9999999999999997e-148 +test util-16.1.17.-146 {8.4 compatible formatting of doubles} \ + {expr 1e-146} \ + 1e-146 +test util-16.1.17.-145 {8.4 compatible formatting of doubles} \ + {expr 1e-145} \ + 9.9999999999999991e-146 +test util-16.1.17.-144 {8.4 compatible formatting of doubles} \ + {expr 1e-144} \ + 9.9999999999999995e-145 +test util-16.1.17.-143 {8.4 compatible formatting of doubles} \ + {expr 1e-143} \ + 9.9999999999999995e-144 +test util-16.1.17.-142 {8.4 compatible formatting of doubles} \ + {expr 1e-142} \ + 1e-142 +test util-16.1.17.-141 {8.4 compatible formatting of doubles} \ + {expr 1e-141} \ + 1e-141 +test util-16.1.17.-140 {8.4 compatible formatting of doubles} \ + {expr 1e-140} \ + 9.9999999999999998e-141 +test util-16.1.17.-139 {8.4 compatible formatting of doubles} \ + {expr 1e-139} \ + 1e-139 +test util-16.1.17.-138 {8.4 compatible formatting of doubles} \ + {expr 1e-138} \ + 1.0000000000000001e-138 +test util-16.1.17.-137 {8.4 compatible formatting of doubles} \ + {expr 1e-137} \ + 9.9999999999999998e-138 +test util-16.1.17.-136 {8.4 compatible formatting of doubles} \ + {expr 1e-136} \ + 1e-136 +test util-16.1.17.-135 {8.4 compatible formatting of doubles} \ + {expr 1e-135} \ + 1e-135 +test util-16.1.17.-134 {8.4 compatible formatting of doubles} \ + {expr 1e-134} \ + 1e-134 +test util-16.1.17.-133 {8.4 compatible formatting of doubles} \ + {expr 1e-133} \ + 1.0000000000000001e-133 +test util-16.1.17.-132 {8.4 compatible formatting of doubles} \ + {expr 1e-132} \ + 9.9999999999999999e-133 +test util-16.1.17.-131 {8.4 compatible formatting of doubles} \ + {expr 1e-131} \ + 9.9999999999999999e-132 +test util-16.1.17.-130 {8.4 compatible formatting of doubles} \ + {expr 1e-130} \ + 1.0000000000000001e-130 +test util-16.1.17.-129 {8.4 compatible formatting of doubles} \ + {expr 1e-129} \ + 9.9999999999999993e-130 +test util-16.1.17.-128 {8.4 compatible formatting of doubles} \ + {expr 1e-128} \ + 1.0000000000000001e-128 +test util-16.1.17.-127 {8.4 compatible formatting of doubles} \ + {expr 1e-127} \ + 1e-127 +test util-16.1.17.-126 {8.4 compatible formatting of doubles} \ + {expr 1e-126} \ + 9.9999999999999995e-127 +test util-16.1.17.-125 {8.4 compatible formatting of doubles} \ + {expr 1e-125} \ + 1e-125 +test util-16.1.17.-124 {8.4 compatible formatting of doubles} \ + {expr 1e-124} \ + 9.9999999999999993e-125 +test util-16.1.17.-123 {8.4 compatible formatting of doubles} \ + {expr 1e-123} \ + 1.0000000000000001e-123 +test util-16.1.17.-122 {8.4 compatible formatting of doubles} \ + {expr 1e-122} \ + 1.0000000000000001e-122 +test util-16.1.17.-121 {8.4 compatible formatting of doubles} \ + {expr 1e-121} \ + 9.9999999999999998e-122 +test util-16.1.17.-120 {8.4 compatible formatting of doubles} \ + {expr 1e-120} \ + 9.9999999999999998e-121 +test util-16.1.17.-119 {8.4 compatible formatting of doubles} \ + {expr 1e-119} \ + 1e-119 +test util-16.1.17.-118 {8.4 compatible formatting of doubles} \ + {expr 1e-118} \ + 9.9999999999999999e-119 +test util-16.1.17.-117 {8.4 compatible formatting of doubles} \ + {expr 1e-117} \ + 1e-117 +test util-16.1.17.-116 {8.4 compatible formatting of doubles} \ + {expr 1e-116} \ + 9.9999999999999999e-117 +test util-16.1.17.-115 {8.4 compatible formatting of doubles} \ + {expr 1e-115} \ + 1.0000000000000001e-115 +test util-16.1.17.-114 {8.4 compatible formatting of doubles} \ + {expr 1e-114} \ + 1.0000000000000001e-114 +test util-16.1.17.-113 {8.4 compatible formatting of doubles} \ + {expr 1e-113} \ + 9.9999999999999998e-114 +test util-16.1.17.-112 {8.4 compatible formatting of doubles} \ + {expr 1e-112} \ + 9.9999999999999995e-113 +test util-16.1.17.-111 {8.4 compatible formatting of doubles} \ + {expr 1e-111} \ + 1.0000000000000001e-111 +test util-16.1.17.-110 {8.4 compatible formatting of doubles} \ + {expr 1e-110} \ + 1.0000000000000001e-110 +test util-16.1.17.-109 {8.4 compatible formatting of doubles} \ + {expr 1e-109} \ + 9.9999999999999999e-110 +test util-16.1.17.-108 {8.4 compatible formatting of doubles} \ + {expr 1e-108} \ + 1e-108 +test util-16.1.17.-107 {8.4 compatible formatting of doubles} \ + {expr 1e-107} \ + 1e-107 +test util-16.1.17.-106 {8.4 compatible formatting of doubles} \ + {expr 1e-106} \ + 9.9999999999999994e-107 +test util-16.1.17.-105 {8.4 compatible formatting of doubles} \ + {expr 1e-105} \ + 9.9999999999999997e-106 +test util-16.1.17.-104 {8.4 compatible formatting of doubles} \ + {expr 1e-104} \ + 9.9999999999999993e-105 +test util-16.1.17.-103 {8.4 compatible formatting of doubles} \ + {expr 1e-103} \ + 9.9999999999999996e-104 +test util-16.1.17.-102 {8.4 compatible formatting of doubles} \ + {expr 1e-102} \ + 9.9999999999999993e-103 +test util-16.1.17.-101 {8.4 compatible formatting of doubles} \ + {expr 1e-101} \ + 1.0000000000000001e-101 +test util-16.1.17.-100 {8.4 compatible formatting of doubles} \ + {expr 1e-100} \ + 1e-100 +test util-16.1.17.-99 {8.4 compatible formatting of doubles} \ + {expr 1e-99} \ + 1e-99 +test util-16.1.17.-98 {8.4 compatible formatting of doubles} \ + {expr 1e-98} \ + 9.9999999999999994e-99 +test util-16.1.17.-97 {8.4 compatible formatting of doubles} \ + {expr 1e-97} \ + 1e-97 +test util-16.1.17.-96 {8.4 compatible formatting of doubles} \ + {expr 1e-96} \ + 9.9999999999999991e-97 +test util-16.1.17.-95 {8.4 compatible formatting of doubles} \ + {expr 1e-95} \ + 9.9999999999999999e-96 +test util-16.1.17.-94 {8.4 compatible formatting of doubles} \ + {expr 1e-94} \ + 9.9999999999999996e-95 +test util-16.1.17.-93 {8.4 compatible formatting of doubles} \ + {expr 1e-93} \ + 9.999999999999999e-94 +test util-16.1.17.-92 {8.4 compatible formatting of doubles} \ + {expr 1e-92} \ + 9.9999999999999999e-93 +test util-16.1.17.-91 {8.4 compatible formatting of doubles} \ + {expr 1e-91} \ + 1e-91 +test util-16.1.17.-90 {8.4 compatible formatting of doubles} \ + {expr 1e-90} \ + 9.9999999999999999e-91 +test util-16.1.17.-89 {8.4 compatible formatting of doubles} \ + {expr 1e-89} \ + 1e-89 +test util-16.1.17.-88 {8.4 compatible formatting of doubles} \ + {expr 1e-88} \ + 9.9999999999999993e-89 +test util-16.1.17.-87 {8.4 compatible formatting of doubles} \ + {expr 1e-87} \ + 1e-87 +test util-16.1.17.-86 {8.4 compatible formatting of doubles} \ + {expr 1e-86} \ + 1.0000000000000001e-86 +test util-16.1.17.-85 {8.4 compatible formatting of doubles} \ + {expr 1e-85} \ + 9.9999999999999998e-86 +test util-16.1.17.-84 {8.4 compatible formatting of doubles} \ + {expr 1e-84} \ + 1e-84 +test util-16.1.17.-83 {8.4 compatible formatting of doubles} \ + {expr 1e-83} \ + 1e-83 +test util-16.1.17.-82 {8.4 compatible formatting of doubles} \ + {expr 1e-82} \ + 9.9999999999999996e-83 +test util-16.1.17.-81 {8.4 compatible formatting of doubles} \ + {expr 1e-81} \ + 9.9999999999999996e-82 +test util-16.1.17.-80 {8.4 compatible formatting of doubles} \ + {expr 1e-80} \ + 9.9999999999999996e-81 +test util-16.1.17.-79 {8.4 compatible formatting of doubles} \ + {expr 1e-79} \ + 1e-79 +test util-16.1.17.-78 {8.4 compatible formatting of doubles} \ + {expr 1e-78} \ + 1e-78 +test util-16.1.17.-77 {8.4 compatible formatting of doubles} \ + {expr 1e-77} \ + 9.9999999999999993e-78 +test util-16.1.17.-76 {8.4 compatible formatting of doubles} \ + {expr 1e-76} \ + 9.9999999999999993e-77 +test util-16.1.17.-75 {8.4 compatible formatting of doubles} \ + {expr 1e-75} \ + 9.9999999999999996e-76 +test util-16.1.17.-74 {8.4 compatible formatting of doubles} \ + {expr 1e-74} \ + 9.9999999999999996e-75 +test util-16.1.17.-73 {8.4 compatible formatting of doubles} \ + {expr 1e-73} \ + 1e-73 +test util-16.1.17.-72 {8.4 compatible formatting of doubles} \ + {expr 1e-72} \ + 9.9999999999999997e-73 +test util-16.1.17.-71 {8.4 compatible formatting of doubles} \ + {expr 1e-71} \ + 9.9999999999999992e-72 +test util-16.1.17.-70 {8.4 compatible formatting of doubles} \ + {expr 1e-70} \ + 1e-70 +test util-16.1.17.-69 {8.4 compatible formatting of doubles} \ + {expr 1e-69} \ + 9.9999999999999996e-70 +test util-16.1.17.-68 {8.4 compatible formatting of doubles} \ + {expr 1e-68} \ + 1.0000000000000001e-68 +test util-16.1.17.-67 {8.4 compatible formatting of doubles} \ + {expr 1e-67} \ + 9.9999999999999994e-68 +test util-16.1.17.-66 {8.4 compatible formatting of doubles} \ + {expr 1e-66} \ + 9.9999999999999998e-67 +test util-16.1.17.-65 {8.4 compatible formatting of doubles} \ + {expr 1e-65} \ + 9.9999999999999992e-66 +test util-16.1.17.-64 {8.4 compatible formatting of doubles} \ + {expr 1e-64} \ + 9.9999999999999997e-65 +test util-16.1.17.-63 {8.4 compatible formatting of doubles} \ + {expr 1e-63} \ + 1.0000000000000001e-63 +test util-16.1.17.-62 {8.4 compatible formatting of doubles} \ + {expr 1e-62} \ + 1e-62 +test util-16.1.17.-61 {8.4 compatible formatting of doubles} \ + {expr 1e-61} \ + 1e-61 +test util-16.1.17.-60 {8.4 compatible formatting of doubles} \ + {expr 1e-60} \ + 9.9999999999999997e-61 +test util-16.1.17.-59 {8.4 compatible formatting of doubles} \ + {expr 1e-59} \ + 1e-59 +test util-16.1.17.-58 {8.4 compatible formatting of doubles} \ + {expr 1e-58} \ + 1e-58 +test util-16.1.17.-57 {8.4 compatible formatting of doubles} \ + {expr 1e-57} \ + 9.9999999999999995e-58 +test util-16.1.17.-56 {8.4 compatible formatting of doubles} \ + {expr 1e-56} \ + 1e-56 +test util-16.1.17.-55 {8.4 compatible formatting of doubles} \ + {expr 1e-55} \ + 9.9999999999999999e-56 +test util-16.1.17.-54 {8.4 compatible formatting of doubles} \ + {expr 1e-54} \ + 1e-54 +test util-16.1.17.-53 {8.4 compatible formatting of doubles} \ + {expr 1e-53} \ + 1e-53 +test util-16.1.17.-52 {8.4 compatible formatting of doubles} \ + {expr 1e-52} \ + 1e-52 +test util-16.1.17.-51 {8.4 compatible formatting of doubles} \ + {expr 1e-51} \ + 1e-51 +test util-16.1.17.-50 {8.4 compatible formatting of doubles} \ + {expr 1e-50} \ + 1e-50 +test util-16.1.17.-49 {8.4 compatible formatting of doubles} \ + {expr 1e-49} \ + 9.9999999999999994e-50 +test util-16.1.17.-48 {8.4 compatible formatting of doubles} \ + {expr 1e-48} \ + 9.9999999999999997e-49 +test util-16.1.17.-47 {8.4 compatible formatting of doubles} \ + {expr 1e-47} \ + 9.9999999999999997e-48 +test util-16.1.17.-46 {8.4 compatible formatting of doubles} \ + {expr 1e-46} \ + 1e-46 +test util-16.1.17.-45 {8.4 compatible formatting of doubles} \ + {expr 1e-45} \ + 9.9999999999999998e-46 +test util-16.1.17.-44 {8.4 compatible formatting of doubles} \ + {expr 1e-44} \ + 9.9999999999999995e-45 +test util-16.1.17.-43 {8.4 compatible formatting of doubles} \ + {expr 1e-43} \ + 1.0000000000000001e-43 +test util-16.1.17.-42 {8.4 compatible formatting of doubles} \ + {expr 1e-42} \ + 1e-42 +test util-16.1.17.-41 {8.4 compatible formatting of doubles} \ + {expr 1e-41} \ + 1e-41 +test util-16.1.17.-40 {8.4 compatible formatting of doubles} \ + {expr 1e-40} \ + 9.9999999999999993e-41 +test util-16.1.17.-39 {8.4 compatible formatting of doubles} \ + {expr 1e-39} \ + 9.9999999999999993e-40 +test util-16.1.17.-38 {8.4 compatible formatting of doubles} \ + {expr 1e-38} \ + 9.9999999999999996e-39 +test util-16.1.17.-37 {8.4 compatible formatting of doubles} \ + {expr 1e-37} \ + 1.0000000000000001e-37 +test util-16.1.17.-36 {8.4 compatible formatting of doubles} \ + {expr 1e-36} \ + 9.9999999999999994e-37 +test util-16.1.17.-35 {8.4 compatible formatting of doubles} \ + {expr 1e-35} \ + 1e-35 +test util-16.1.17.-34 {8.4 compatible formatting of doubles} \ + {expr 1e-34} \ + 9.9999999999999993e-35 +test util-16.1.17.-33 {8.4 compatible formatting of doubles} \ + {expr 1e-33} \ + 1.0000000000000001e-33 +test util-16.1.17.-32 {8.4 compatible formatting of doubles} \ + {expr 1e-32} \ + 1.0000000000000001e-32 +test util-16.1.17.-31 {8.4 compatible formatting of doubles} \ + {expr 1e-31} \ + 1.0000000000000001e-31 +test util-16.1.17.-30 {8.4 compatible formatting of doubles} \ + {expr 1e-30} \ + 1.0000000000000001e-30 +test util-16.1.17.-29 {8.4 compatible formatting of doubles} \ + {expr 1e-29} \ + 9.9999999999999994e-30 +test util-16.1.17.-28 {8.4 compatible formatting of doubles} \ + {expr 1e-28} \ + 9.9999999999999997e-29 +test util-16.1.17.-27 {8.4 compatible formatting of doubles} \ + {expr 1e-27} \ + 1e-27 +test util-16.1.17.-26 {8.4 compatible formatting of doubles} \ + {expr 1e-26} \ + 1e-26 +test util-16.1.17.-25 {8.4 compatible formatting of doubles} \ + {expr 1e-25} \ + 1e-25 +test util-16.1.17.-24 {8.4 compatible formatting of doubles} \ + {expr 1e-24} \ + 9.9999999999999992e-25 +test util-16.1.17.-23 {8.4 compatible formatting of doubles} \ + {expr 1e-23} \ + 9.9999999999999996e-24 +test util-16.1.17.-22 {8.4 compatible formatting of doubles} \ + {expr 1e-22} \ + 1e-22 +test util-16.1.17.-21 {8.4 compatible formatting of doubles} \ + {expr 1e-21} \ + 9.9999999999999991e-22 +test util-16.1.17.-20 {8.4 compatible formatting of doubles} \ + {expr 1e-20} \ + 9.9999999999999995e-21 +test util-16.1.17.-19 {8.4 compatible formatting of doubles} \ + {expr 1e-19} \ + 9.9999999999999998e-20 +test util-16.1.17.-18 {8.4 compatible formatting of doubles} \ + {expr 1e-18} \ + 1.0000000000000001e-18 +test util-16.1.17.-17 {8.4 compatible formatting of doubles} \ + {expr 1e-17} \ + 1.0000000000000001e-17 +test util-16.1.17.-16 {8.4 compatible formatting of doubles} \ + {expr 1e-16} \ + 9.9999999999999998e-17 +test util-16.1.17.-15 {8.4 compatible formatting of doubles} \ + {expr 1e-15} \ + 1.0000000000000001e-15 +test util-16.1.17.-14 {8.4 compatible formatting of doubles} \ + {expr 1e-14} \ + 1e-14 +test util-16.1.17.-13 {8.4 compatible formatting of doubles} \ + {expr 1e-13} \ + 1e-13 +test util-16.1.17.-12 {8.4 compatible formatting of doubles} \ + {expr 1e-12} \ + 9.9999999999999998e-13 +test util-16.1.17.-11 {8.4 compatible formatting of doubles} \ + {expr 1e-11} \ + 9.9999999999999994e-12 +test util-16.1.17.-10 {8.4 compatible formatting of doubles} \ + {expr 1e-10} \ + 1e-10 +test util-16.1.17.-9 {8.4 compatible formatting of doubles} \ + {expr 1e-9} \ + 1.0000000000000001e-09 +test util-16.1.17.-8 {8.4 compatible formatting of doubles} \ + {expr 1e-8} \ + 1e-08 +test util-16.1.17.-7 {8.4 compatible formatting of doubles} \ + {expr 1e-7} \ + 9.9999999999999995e-08 +test util-16.1.17.-6 {8.4 compatible formatting of doubles} \ + {expr 1e-6} \ + 9.9999999999999995e-07 +test util-16.1.17.-5 {8.4 compatible formatting of doubles} \ + {expr 1e-5} \ + 1.0000000000000001e-05 +test util-16.1.17.-4 {8.4 compatible formatting of doubles} \ + {expr 1e-4} \ + 0.0001 +test util-16.1.17.-3 {8.4 compatible formatting of doubles} \ + {expr 1e-3} \ + 0.001 +test util-16.1.17.-2 {8.4 compatible formatting of doubles} \ + {expr 1e-2} \ + 0.01 +test util-16.1.17.-1 {8.4 compatible formatting of doubles} \ + {expr 1e-1} \ + 0.10000000000000001 +test util-16.1.17.0 {8.4 compatible formatting of doubles} \ + {expr 1e0} \ + 1.0 +test util-16.1.17.1 {8.4 compatible formatting of doubles} \ + {expr 1e1} \ + 10.0 +test util-16.1.17.2 {8.4 compatible formatting of doubles} \ + {expr 1e2} \ + 100.0 +test util-16.1.17.3 {8.4 compatible formatting of doubles} \ + {expr 1e3} \ + 1000.0 +test util-16.1.17.4 {8.4 compatible formatting of doubles} \ + {expr 1e4} \ + 10000.0 +test util-16.1.17.5 {8.4 compatible formatting of doubles} \ + {expr 1e5} \ + 100000.0 +test util-16.1.17.6 {8.4 compatible formatting of doubles} \ + {expr 1e6} \ + 1000000.0 +test util-16.1.17.7 {8.4 compatible formatting of doubles} \ + {expr 1e7} \ + 10000000.0 +test util-16.1.17.8 {8.4 compatible formatting of doubles} \ + {expr 1e8} \ + 100000000.0 +test util-16.1.17.9 {8.4 compatible formatting of doubles} \ + {expr 1e9} \ + 1000000000.0 +test util-16.1.17.10 {8.4 compatible formatting of doubles} \ + {expr 1e10} \ + 10000000000.0 +test util-16.1.17.11 {8.4 compatible formatting of doubles} \ + {expr 1e11} \ + 100000000000.0 +test util-16.1.17.12 {8.4 compatible formatting of doubles} \ + {expr 1e12} \ + 1000000000000.0 +test util-16.1.17.13 {8.4 compatible formatting of doubles} \ + {expr 1e13} \ + 10000000000000.0 +test util-16.1.17.14 {8.4 compatible formatting of doubles} \ + {expr 1e14} \ + 100000000000000.0 +test util-16.1.17.15 {8.4 compatible formatting of doubles} \ + {expr 1e15} \ + 1000000000000000.0 +test util-16.1.17.16 {8.4 compatible formatting of doubles} \ + {expr 1e16} \ + 10000000000000000.0 +test util-16.1.17.17 {8.4 compatible formatting of doubles} \ + {expr 1e17} \ + 1e+17 +test util-16.1.17.18 {8.4 compatible formatting of doubles} \ + {expr 1e18} \ + 1e+18 +test util-16.1.17.19 {8.4 compatible formatting of doubles} \ + {expr 1e19} \ + 1e+19 +test util-16.1.17.20 {8.4 compatible formatting of doubles} \ + {expr 1e20} \ + 1e+20 +test util-16.1.17.21 {8.4 compatible formatting of doubles} \ + {expr 1e21} \ + 1e+21 +test util-16.1.17.22 {8.4 compatible formatting of doubles} \ + {expr 1e22} \ + 1e+22 +test util-16.1.17.23 {8.4 compatible formatting of doubles} \ + {expr 1e23} \ + 9.9999999999999992e+22 +test util-16.1.17.24 {8.4 compatible formatting of doubles} \ + {expr 1e24} \ + 9.9999999999999998e+23 +test util-16.1.17.25 {8.4 compatible formatting of doubles} \ + {expr 1e25} \ + 1.0000000000000001e+25 +test util-16.1.17.26 {8.4 compatible formatting of doubles} \ + {expr 1e26} \ + 1e+26 +test util-16.1.17.27 {8.4 compatible formatting of doubles} \ + {expr 1e27} \ + 1e+27 +test util-16.1.17.28 {8.4 compatible formatting of doubles} \ + {expr 1e28} \ + 9.9999999999999996e+27 +test util-16.1.17.29 {8.4 compatible formatting of doubles} \ + {expr 1e29} \ + 9.9999999999999991e+28 +test util-16.1.17.30 {8.4 compatible formatting of doubles} \ + {expr 1e30} \ + 1e+30 +test util-16.1.17.31 {8.4 compatible formatting of doubles} \ + {expr 1e31} \ + 9.9999999999999996e+30 +test util-16.1.17.32 {8.4 compatible formatting of doubles} \ + {expr 1e32} \ + 1.0000000000000001e+32 +test util-16.1.17.33 {8.4 compatible formatting of doubles} \ + {expr 1e33} \ + 9.9999999999999995e+32 +test util-16.1.17.34 {8.4 compatible formatting of doubles} \ + {expr 1e34} \ + 9.9999999999999995e+33 +test util-16.1.17.35 {8.4 compatible formatting of doubles} \ + {expr 1e35} \ + 9.9999999999999997e+34 +test util-16.1.17.36 {8.4 compatible formatting of doubles} \ + {expr 1e36} \ + 1e+36 +test util-16.1.17.37 {8.4 compatible formatting of doubles} \ + {expr 1e37} \ + 9.9999999999999995e+36 +test util-16.1.17.38 {8.4 compatible formatting of doubles} \ + {expr 1e38} \ + 9.9999999999999998e+37 +test util-16.1.17.39 {8.4 compatible formatting of doubles} \ + {expr 1e39} \ + 9.9999999999999994e+38 +test util-16.1.17.40 {8.4 compatible formatting of doubles} \ + {expr 1e40} \ + 1e+40 +test util-16.1.17.41 {8.4 compatible formatting of doubles} \ + {expr 1e41} \ + 1e+41 +test util-16.1.17.42 {8.4 compatible formatting of doubles} \ + {expr 1e42} \ + 1e+42 +test util-16.1.17.43 {8.4 compatible formatting of doubles} \ + {expr 1e43} \ + 1e+43 +test util-16.1.17.44 {8.4 compatible formatting of doubles} \ + {expr 1e44} \ + 1.0000000000000001e+44 +test util-16.1.17.45 {8.4 compatible formatting of doubles} \ + {expr 1e45} \ + 9.9999999999999993e+44 +test util-16.1.17.46 {8.4 compatible formatting of doubles} \ + {expr 1e46} \ + 9.9999999999999999e+45 +test util-16.1.17.47 {8.4 compatible formatting of doubles} \ + {expr 1e47} \ + 1e+47 +test util-16.1.17.48 {8.4 compatible formatting of doubles} \ + {expr 1e48} \ + 1e+48 +test util-16.1.17.49 {8.4 compatible formatting of doubles} \ + {expr 1e49} \ + 9.9999999999999995e+48 +test util-16.1.17.50 {8.4 compatible formatting of doubles} \ + {expr 1e50} \ + 1.0000000000000001e+50 +test util-16.1.17.51 {8.4 compatible formatting of doubles} \ + {expr 1e51} \ + 9.9999999999999999e+50 +test util-16.1.17.52 {8.4 compatible formatting of doubles} \ + {expr 1e52} \ + 9.9999999999999999e+51 +test util-16.1.17.53 {8.4 compatible formatting of doubles} \ + {expr 1e53} \ + 9.9999999999999999e+52 +test util-16.1.17.54 {8.4 compatible formatting of doubles} \ + {expr 1e54} \ + 1.0000000000000001e+54 +test util-16.1.17.55 {8.4 compatible formatting of doubles} \ + {expr 1e55} \ + 1e+55 +test util-16.1.17.56 {8.4 compatible formatting of doubles} \ + {expr 1e56} \ + 1.0000000000000001e+56 +test util-16.1.17.57 {8.4 compatible formatting of doubles} \ + {expr 1e57} \ + 1e+57 +test util-16.1.17.58 {8.4 compatible formatting of doubles} \ + {expr 1e58} \ + 9.9999999999999994e+57 +test util-16.1.17.59 {8.4 compatible formatting of doubles} \ + {expr 1e59} \ + 9.9999999999999997e+58 +test util-16.1.17.60 {8.4 compatible formatting of doubles} \ + {expr 1e60} \ + 9.9999999999999995e+59 +test util-16.1.17.61 {8.4 compatible formatting of doubles} \ + {expr 1e61} \ + 9.9999999999999995e+60 +test util-16.1.17.62 {8.4 compatible formatting of doubles} \ + {expr 1e62} \ + 1e+62 +test util-16.1.17.63 {8.4 compatible formatting of doubles} \ + {expr 1e63} \ + 1.0000000000000001e+63 +test util-16.1.17.64 {8.4 compatible formatting of doubles} \ + {expr 1e64} \ + 1e+64 +test util-16.1.17.65 {8.4 compatible formatting of doubles} \ + {expr 1e65} \ + 9.9999999999999999e+64 +test util-16.1.17.66 {8.4 compatible formatting of doubles} \ + {expr 1e66} \ + 9.9999999999999995e+65 +test util-16.1.17.67 {8.4 compatible formatting of doubles} \ + {expr 1e67} \ + 9.9999999999999998e+66 +test util-16.1.17.68 {8.4 compatible formatting of doubles} \ + {expr 1e68} \ + 9.9999999999999995e+67 +test util-16.1.17.69 {8.4 compatible formatting of doubles} \ + {expr 1e69} \ + 1.0000000000000001e+69 +test util-16.1.17.70 {8.4 compatible formatting of doubles} \ + {expr 1e70} \ + 1.0000000000000001e+70 +test util-16.1.17.71 {8.4 compatible formatting of doubles} \ + {expr 1e71} \ + 1e+71 +test util-16.1.17.72 {8.4 compatible formatting of doubles} \ + {expr 1e72} \ + 9.9999999999999994e+71 +test util-16.1.17.73 {8.4 compatible formatting of doubles} \ + {expr 1e73} \ + 9.9999999999999998e+72 +test util-16.1.17.74 {8.4 compatible formatting of doubles} \ + {expr 1e74} \ + 9.9999999999999995e+73 +test util-16.1.17.75 {8.4 compatible formatting of doubles} \ + {expr 1e75} \ + 9.9999999999999993e+74 +test util-16.1.17.76 {8.4 compatible formatting of doubles} \ + {expr 1e76} \ + 1e+76 +test util-16.1.17.77 {8.4 compatible formatting of doubles} \ + {expr 1e77} \ + 9.9999999999999998e+76 +test util-16.1.17.78 {8.4 compatible formatting of doubles} \ + {expr 1e78} \ + 1e+78 +test util-16.1.17.79 {8.4 compatible formatting of doubles} \ + {expr 1e79} \ + 9.9999999999999997e+78 +test util-16.1.17.80 {8.4 compatible formatting of doubles} \ + {expr 1e80} \ + 1e+80 +test util-16.1.17.81 {8.4 compatible formatting of doubles} \ + {expr 1e81} \ + 9.9999999999999992e+80 +test util-16.1.17.82 {8.4 compatible formatting of doubles} \ + {expr 1e82} \ + 9.9999999999999996e+81 +test util-16.1.17.83 {8.4 compatible formatting of doubles} \ + {expr 1e83} \ + 1e+83 +test util-16.1.17.84 {8.4 compatible formatting of doubles} \ + {expr 1e84} \ + 1.0000000000000001e+84 +test util-16.1.17.85 {8.4 compatible formatting of doubles} \ + {expr 1e85} \ + 1e+85 +test util-16.1.17.86 {8.4 compatible formatting of doubles} \ + {expr 1e86} \ + 1e+86 +test util-16.1.17.87 {8.4 compatible formatting of doubles} \ + {expr 1e87} \ + 9.9999999999999996e+86 +test util-16.1.17.88 {8.4 compatible formatting of doubles} \ + {expr 1e88} \ + 9.9999999999999996e+87 +test util-16.1.17.89 {8.4 compatible formatting of doubles} \ + {expr 1e89} \ + 9.9999999999999999e+88 +test util-16.1.17.90 {8.4 compatible formatting of doubles} \ + {expr 1e90} \ + 9.9999999999999997e+89 +test util-16.1.17.91 {8.4 compatible formatting of doubles} \ + {expr 1e91} \ + 1.0000000000000001e+91 +test util-16.1.17.92 {8.4 compatible formatting of doubles} \ + {expr 1e92} \ + 1e+92 +test util-16.1.17.93 {8.4 compatible formatting of doubles} \ + {expr 1e93} \ + 1e+93 +test util-16.1.17.94 {8.4 compatible formatting of doubles} \ + {expr 1e94} \ + 1e+94 +test util-16.1.17.95 {8.4 compatible formatting of doubles} \ + {expr 1e95} \ + 1e+95 +test util-16.1.17.96 {8.4 compatible formatting of doubles} \ + {expr 1e96} \ + 1e+96 +test util-16.1.17.97 {8.4 compatible formatting of doubles} \ + {expr 1e97} \ + 1.0000000000000001e+97 +test util-16.1.17.98 {8.4 compatible formatting of doubles} \ + {expr 1e98} \ + 1e+98 +test util-16.1.17.99 {8.4 compatible formatting of doubles} \ + {expr 1e99} \ + 9.9999999999999997e+98 +test util-16.1.17.100 {8.4 compatible formatting of doubles} \ + {expr 1e100} \ + 1e+100 +test util-16.1.17.101 {8.4 compatible formatting of doubles} \ + {expr 1e101} \ + 9.9999999999999998e+100 +test util-16.1.17.102 {8.4 compatible formatting of doubles} \ + {expr 1e102} \ + 9.9999999999999998e+101 +test util-16.1.17.103 {8.4 compatible formatting of doubles} \ + {expr 1e103} \ + 1e+103 +test util-16.1.17.104 {8.4 compatible formatting of doubles} \ + {expr 1e104} \ + 1e+104 +test util-16.1.17.105 {8.4 compatible formatting of doubles} \ + {expr 1e105} \ + 9.9999999999999994e+104 +test util-16.1.17.106 {8.4 compatible formatting of doubles} \ + {expr 1e106} \ + 1.0000000000000001e+106 +test util-16.1.17.107 {8.4 compatible formatting of doubles} \ + {expr 1e107} \ + 9.9999999999999997e+106 +test util-16.1.17.108 {8.4 compatible formatting of doubles} \ + {expr 1e108} \ + 1e+108 +test util-16.1.17.109 {8.4 compatible formatting of doubles} \ + {expr 1e109} \ + 9.9999999999999998e+108 +test util-16.1.17.110 {8.4 compatible formatting of doubles} \ + {expr 1e110} \ + 1e+110 +test util-16.1.17.111 {8.4 compatible formatting of doubles} \ + {expr 1e111} \ + 9.9999999999999996e+110 +test util-16.1.17.112 {8.4 compatible formatting of doubles} \ + {expr 1e112} \ + 9.9999999999999993e+111 +test util-16.1.17.113 {8.4 compatible formatting of doubles} \ + {expr 1e113} \ + 1e+113 +test util-16.1.17.114 {8.4 compatible formatting of doubles} \ + {expr 1e114} \ + 1e+114 +test util-16.1.17.115 {8.4 compatible formatting of doubles} \ + {expr 1e115} \ + 1e+115 +test util-16.1.17.116 {8.4 compatible formatting of doubles} \ + {expr 1e116} \ + 1e+116 +test util-16.1.17.117 {8.4 compatible formatting of doubles} \ + {expr 1e117} \ + 1.0000000000000001e+117 +test util-16.1.17.118 {8.4 compatible formatting of doubles} \ + {expr 1e118} \ + 9.9999999999999997e+117 +test util-16.1.17.119 {8.4 compatible formatting of doubles} \ + {expr 1e119} \ + 9.9999999999999994e+118 +test util-16.1.17.120 {8.4 compatible formatting of doubles} \ + {expr 1e120} \ + 9.9999999999999998e+119 +test util-16.1.17.121 {8.4 compatible formatting of doubles} \ + {expr 1e121} \ + 1e+121 +test util-16.1.17.122 {8.4 compatible formatting of doubles} \ + {expr 1e122} \ + 1e+122 +test util-16.1.17.123 {8.4 compatible formatting of doubles} \ + {expr 1e123} \ + 9.9999999999999998e+122 +test util-16.1.17.124 {8.4 compatible formatting of doubles} \ + {expr 1e124} \ + 9.9999999999999995e+123 +test util-16.1.17.125 {8.4 compatible formatting of doubles} \ + {expr 1e125} \ + 9.9999999999999992e+124 +test util-16.1.17.126 {8.4 compatible formatting of doubles} \ + {expr 1e126} \ + 9.9999999999999992e+125 +test util-16.1.17.127 {8.4 compatible formatting of doubles} \ + {expr 1e127} \ + 9.9999999999999995e+126 +test util-16.1.17.128 {8.4 compatible formatting of doubles} \ + {expr 1e128} \ + 1.0000000000000001e+128 +test util-16.1.17.129 {8.4 compatible formatting of doubles} \ + {expr 1e129} \ + 1e+129 +test util-16.1.17.130 {8.4 compatible formatting of doubles} \ + {expr 1e130} \ + 1.0000000000000001e+130 +test util-16.1.17.131 {8.4 compatible formatting of doubles} \ + {expr 1e131} \ + 9.9999999999999991e+130 +test util-16.1.17.132 {8.4 compatible formatting of doubles} \ + {expr 1e132} \ + 9.9999999999999999e+131 +test util-16.1.17.133 {8.4 compatible formatting of doubles} \ + {expr 1e133} \ + 1e+133 +test util-16.1.17.134 {8.4 compatible formatting of doubles} \ + {expr 1e134} \ + 9.9999999999999992e+133 +test util-16.1.17.135 {8.4 compatible formatting of doubles} \ + {expr 1e135} \ + 9.9999999999999996e+134 +test util-16.1.17.136 {8.4 compatible formatting of doubles} \ + {expr 1e136} \ + 1.0000000000000001e+136 +test util-16.1.17.137 {8.4 compatible formatting of doubles} \ + {expr 1e137} \ + 1e+137 +test util-16.1.17.138 {8.4 compatible formatting of doubles} \ + {expr 1e138} \ + 1e+138 +test util-16.1.17.139 {8.4 compatible formatting of doubles} \ + {expr 1e139} \ + 1e+139 +test util-16.1.17.140 {8.4 compatible formatting of doubles} \ + {expr 1e140} \ + 1.0000000000000001e+140 +test util-16.1.17.141 {8.4 compatible formatting of doubles} \ + {expr 1e141} \ + 1e+141 +test util-16.1.17.142 {8.4 compatible formatting of doubles} \ + {expr 1e142} \ + 1.0000000000000001e+142 +test util-16.1.17.143 {8.4 compatible formatting of doubles} \ + {expr 1e143} \ + 1e+143 +test util-16.1.17.144 {8.4 compatible formatting of doubles} \ + {expr 1e144} \ + 1e+144 +test util-16.1.17.145 {8.4 compatible formatting of doubles} \ + {expr 1e145} \ + 9.9999999999999999e+144 +test util-16.1.17.146 {8.4 compatible formatting of doubles} \ + {expr 1e146} \ + 9.9999999999999993e+145 +test util-16.1.17.147 {8.4 compatible formatting of doubles} \ + {expr 1e147} \ + 9.9999999999999998e+146 +test util-16.1.17.148 {8.4 compatible formatting of doubles} \ + {expr 1e148} \ + 1e+148 +test util-16.1.17.149 {8.4 compatible formatting of doubles} \ + {expr 1e149} \ + 1e+149 +test util-16.1.17.150 {8.4 compatible formatting of doubles} \ + {expr 1e150} \ + 9.9999999999999998e+149 +test util-16.1.17.151 {8.4 compatible formatting of doubles} \ + {expr 1e151} \ + 1e+151 +test util-16.1.17.152 {8.4 compatible formatting of doubles} \ + {expr 1e152} \ + 1e+152 +test util-16.1.17.153 {8.4 compatible formatting of doubles} \ + {expr 1e153} \ + 1e+153 +test util-16.1.17.154 {8.4 compatible formatting of doubles} \ + {expr 1e154} \ + 1e+154 +test util-16.1.17.155 {8.4 compatible formatting of doubles} \ + {expr 1e155} \ + 1e+155 +test util-16.1.17.156 {8.4 compatible formatting of doubles} \ + {expr 1e156} \ + 9.9999999999999998e+155 +test util-16.1.17.157 {8.4 compatible formatting of doubles} \ + {expr 1e157} \ + 9.9999999999999998e+156 +test util-16.1.17.158 {8.4 compatible formatting of doubles} \ + {expr 1e158} \ + 9.9999999999999995e+157 +test util-16.1.17.159 {8.4 compatible formatting of doubles} \ + {expr 1e159} \ + 9.9999999999999993e+158 +test util-16.1.17.160 {8.4 compatible formatting of doubles} \ + {expr 1e160} \ + 1e+160 +test util-16.1.17.161 {8.4 compatible formatting of doubles} \ + {expr 1e161} \ + 1e+161 +test util-16.1.17.162 {8.4 compatible formatting of doubles} \ + {expr 1e162} \ + 9.9999999999999994e+161 +test util-16.1.17.163 {8.4 compatible formatting of doubles} \ + {expr 1e163} \ + 9.9999999999999994e+162 +test util-16.1.17.164 {8.4 compatible formatting of doubles} \ + {expr 1e164} \ + 1e+164 +test util-16.1.17.165 {8.4 compatible formatting of doubles} \ + {expr 1e165} \ + 9.999999999999999e+164 +test util-16.1.17.166 {8.4 compatible formatting of doubles} \ + {expr 1e166} \ + 9.9999999999999994e+165 +test util-16.1.17.167 {8.4 compatible formatting of doubles} \ + {expr 1e167} \ + 1e+167 +test util-16.1.17.168 {8.4 compatible formatting of doubles} \ + {expr 1e168} \ + 9.9999999999999993e+167 +test util-16.1.17.169 {8.4 compatible formatting of doubles} \ + {expr 1e169} \ + 9.9999999999999993e+168 +test util-16.1.17.170 {8.4 compatible formatting of doubles} \ + {expr 1e170} \ + 1e+170 +test util-16.1.17.171 {8.4 compatible formatting of doubles} \ + {expr 1e171} \ + 9.9999999999999995e+170 +test util-16.1.17.172 {8.4 compatible formatting of doubles} \ + {expr 1e172} \ + 1.0000000000000001e+172 +test util-16.1.17.173 {8.4 compatible formatting of doubles} \ + {expr 1e173} \ + 1e+173 +test util-16.1.17.174 {8.4 compatible formatting of doubles} \ + {expr 1e174} \ + 1.0000000000000001e+174 +test util-16.1.17.175 {8.4 compatible formatting of doubles} \ + {expr 1e175} \ + 9.9999999999999994e+174 +test util-16.1.17.176 {8.4 compatible formatting of doubles} \ + {expr 1e176} \ + 1e+176 +test util-16.1.17.177 {8.4 compatible formatting of doubles} \ + {expr 1e177} \ + 1e+177 +test util-16.1.17.178 {8.4 compatible formatting of doubles} \ + {expr 1e178} \ + 1.0000000000000001e+178 +test util-16.1.17.179 {8.4 compatible formatting of doubles} \ + {expr 1e179} \ + 9.9999999999999998e+178 +test util-16.1.17.180 {8.4 compatible formatting of doubles} \ + {expr 1e180} \ + 1e+180 +test util-16.1.17.181 {8.4 compatible formatting of doubles} \ + {expr 1e181} \ + 9.9999999999999992e+180 +test util-16.1.17.182 {8.4 compatible formatting of doubles} \ + {expr 1e182} \ + 1.0000000000000001e+182 +test util-16.1.17.183 {8.4 compatible formatting of doubles} \ + {expr 1e183} \ + 9.9999999999999995e+182 +test util-16.1.17.184 {8.4 compatible formatting of doubles} \ + {expr 1e184} \ + 1e+184 +test util-16.1.17.185 {8.4 compatible formatting of doubles} \ + {expr 1e185} \ + 9.9999999999999998e+184 +test util-16.1.17.186 {8.4 compatible formatting of doubles} \ + {expr 1e186} \ + 9.9999999999999998e+185 +test util-16.1.17.187 {8.4 compatible formatting of doubles} \ + {expr 1e187} \ + 9.9999999999999991e+186 +test util-16.1.17.188 {8.4 compatible formatting of doubles} \ + {expr 1e188} \ + 1e+188 +test util-16.1.17.189 {8.4 compatible formatting of doubles} \ + {expr 1e189} \ + 1e+189 +test util-16.1.17.190 {8.4 compatible formatting of doubles} \ + {expr 1e190} \ + 1.0000000000000001e+190 +test util-16.1.17.191 {8.4 compatible formatting of doubles} \ + {expr 1e191} \ + 1.0000000000000001e+191 +test util-16.1.17.192 {8.4 compatible formatting of doubles} \ + {expr 1e192} \ + 1e+192 +test util-16.1.17.193 {8.4 compatible formatting of doubles} \ + {expr 1e193} \ + 1.0000000000000001e+193 +test util-16.1.17.194 {8.4 compatible formatting of doubles} \ + {expr 1e194} \ + 9.9999999999999994e+193 +test util-16.1.17.195 {8.4 compatible formatting of doubles} \ + {expr 1e195} \ + 9.9999999999999998e+194 +test util-16.1.17.196 {8.4 compatible formatting of doubles} \ + {expr 1e196} \ + 9.9999999999999995e+195 +test util-16.1.17.197 {8.4 compatible formatting of doubles} \ + {expr 1e197} \ + 9.9999999999999995e+196 +test util-16.1.17.198 {8.4 compatible formatting of doubles} \ + {expr 1e198} \ + 1e+198 +test util-16.1.17.199 {8.4 compatible formatting of doubles} \ + {expr 1e199} \ + 1.0000000000000001e+199 +test util-16.1.17.200 {8.4 compatible formatting of doubles} \ + {expr 1e200} \ + 9.9999999999999997e+199 +test util-16.1.17.201 {8.4 compatible formatting of doubles} \ + {expr 1e201} \ + 1e+201 +test util-16.1.17.202 {8.4 compatible formatting of doubles} \ + {expr 1e202} \ + 9.999999999999999e+201 +test util-16.1.17.203 {8.4 compatible formatting of doubles} \ + {expr 1e203} \ + 9.9999999999999999e+202 +test util-16.1.17.204 {8.4 compatible formatting of doubles} \ + {expr 1e204} \ + 9.9999999999999999e+203 +test util-16.1.17.205 {8.4 compatible formatting of doubles} \ + {expr 1e205} \ + 1e+205 +test util-16.1.17.206 {8.4 compatible formatting of doubles} \ + {expr 1e206} \ + 1e+206 +test util-16.1.17.207 {8.4 compatible formatting of doubles} \ + {expr 1e207} \ + 1e+207 +test util-16.1.17.208 {8.4 compatible formatting of doubles} \ + {expr 1e208} \ + 9.9999999999999998e+207 +test util-16.1.17.209 {8.4 compatible formatting of doubles} \ + {expr 1e209} \ + 1.0000000000000001e+209 +test util-16.1.17.210 {8.4 compatible formatting of doubles} \ + {expr 1e210} \ + 9.9999999999999993e+209 +test util-16.1.17.211 {8.4 compatible formatting of doubles} \ + {expr 1e211} \ + 9.9999999999999996e+210 +test util-16.1.17.212 {8.4 compatible formatting of doubles} \ + {expr 1e212} \ + 9.9999999999999991e+211 +test util-16.1.17.213 {8.4 compatible formatting of doubles} \ + {expr 1e213} \ + 9.9999999999999998e+212 +test util-16.1.17.214 {8.4 compatible formatting of doubles} \ + {expr 1e214} \ + 9.9999999999999995e+213 +test util-16.1.17.215 {8.4 compatible formatting of doubles} \ + {expr 1e215} \ + 9.9999999999999991e+214 +test util-16.1.17.216 {8.4 compatible formatting of doubles} \ + {expr 1e216} \ + 1e+216 +test util-16.1.17.217 {8.4 compatible formatting of doubles} \ + {expr 1e217} \ + 9.9999999999999996e+216 +test util-16.1.17.218 {8.4 compatible formatting of doubles} \ + {expr 1e218} \ + 1.0000000000000001e+218 +test util-16.1.17.219 {8.4 compatible formatting of doubles} \ + {expr 1e219} \ + 9.9999999999999997e+218 +test util-16.1.17.220 {8.4 compatible formatting of doubles} \ + {expr 1e220} \ + 1e+220 +test util-16.1.17.221 {8.4 compatible formatting of doubles} \ + {expr 1e221} \ + 1e+221 +test util-16.1.17.222 {8.4 compatible formatting of doubles} \ + {expr 1e222} \ + 1e+222 +test util-16.1.17.223 {8.4 compatible formatting of doubles} \ + {expr 1e223} \ + 1e+223 +test util-16.1.17.224 {8.4 compatible formatting of doubles} \ + {expr 1e224} \ + 9.9999999999999997e+223 +test util-16.1.17.225 {8.4 compatible formatting of doubles} \ + {expr 1e225} \ + 9.9999999999999993e+224 +test util-16.1.17.226 {8.4 compatible formatting of doubles} \ + {expr 1e226} \ + 9.9999999999999996e+225 +test util-16.1.17.227 {8.4 compatible formatting of doubles} \ + {expr 1e227} \ + 1.0000000000000001e+227 +test util-16.1.17.228 {8.4 compatible formatting of doubles} \ + {expr 1e228} \ + 9.9999999999999992e+227 +test util-16.1.17.229 {8.4 compatible formatting of doubles} \ + {expr 1e229} \ + 9.9999999999999999e+228 +test util-16.1.17.230 {8.4 compatible formatting of doubles} \ + {expr 1e230} \ + 1.0000000000000001e+230 +test util-16.1.17.231 {8.4 compatible formatting of doubles} \ + {expr 1e231} \ + 1.0000000000000001e+231 +test util-16.1.17.232 {8.4 compatible formatting of doubles} \ + {expr 1e232} \ + 1.0000000000000001e+232 +test util-16.1.17.233 {8.4 compatible formatting of doubles} \ + {expr 1e233} \ + 9.9999999999999997e+232 +test util-16.1.17.234 {8.4 compatible formatting of doubles} \ + {expr 1e234} \ + 1e+234 +test util-16.1.17.235 {8.4 compatible formatting of doubles} \ + {expr 1e235} \ + 1.0000000000000001e+235 +test util-16.1.17.236 {8.4 compatible formatting of doubles} \ + {expr 1e236} \ + 1.0000000000000001e+236 +test util-16.1.17.237 {8.4 compatible formatting of doubles} \ + {expr 1e237} \ + 9.9999999999999994e+236 +test util-16.1.17.238 {8.4 compatible formatting of doubles} \ + {expr 1e238} \ + 1e+238 +test util-16.1.17.239 {8.4 compatible formatting of doubles} \ + {expr 1e239} \ + 9.9999999999999999e+238 +test util-16.1.17.240 {8.4 compatible formatting of doubles} \ + {expr 1e240} \ + 1e+240 +test util-16.1.17.241 {8.4 compatible formatting of doubles} \ + {expr 1e241} \ + 1.0000000000000001e+241 +test util-16.1.17.242 {8.4 compatible formatting of doubles} \ + {expr 1e242} \ + 1.0000000000000001e+242 +test util-16.1.17.243 {8.4 compatible formatting of doubles} \ + {expr 1e243} \ + 1.0000000000000001e+243 +test util-16.1.17.244 {8.4 compatible formatting of doubles} \ + {expr 1e244} \ + 1.0000000000000001e+244 +test util-16.1.17.245 {8.4 compatible formatting of doubles} \ + {expr 1e245} \ + 1e+245 +test util-16.1.17.246 {8.4 compatible formatting of doubles} \ + {expr 1e246} \ + 1.0000000000000001e+246 +test util-16.1.17.247 {8.4 compatible formatting of doubles} \ + {expr 1e247} \ + 9.9999999999999995e+246 +test util-16.1.17.248 {8.4 compatible formatting of doubles} \ + {expr 1e248} \ + 1e+248 +test util-16.1.17.249 {8.4 compatible formatting of doubles} \ + {expr 1e249} \ + 9.9999999999999992e+248 +test util-16.1.17.250 {8.4 compatible formatting of doubles} \ + {expr 1e250} \ + 9.9999999999999992e+249 +test util-16.1.17.251 {8.4 compatible formatting of doubles} \ + {expr 1e251} \ + 1e+251 +test util-16.1.17.252 {8.4 compatible formatting of doubles} \ + {expr 1e252} \ + 1.0000000000000001e+252 +test util-16.1.17.253 {8.4 compatible formatting of doubles} \ + {expr 1e253} \ + 9.9999999999999994e+252 +test util-16.1.17.254 {8.4 compatible formatting of doubles} \ + {expr 1e254} \ + 9.9999999999999994e+253 +test util-16.1.17.255 {8.4 compatible formatting of doubles} \ + {expr 1e255} \ + 9.9999999999999999e+254 +test util-16.1.17.256 {8.4 compatible formatting of doubles} \ + {expr 1e256} \ + 1e+256 +test util-16.1.17.257 {8.4 compatible formatting of doubles} \ + {expr 1e257} \ + 1e+257 +test util-16.1.17.258 {8.4 compatible formatting of doubles} \ + {expr 1e258} \ + 1.0000000000000001e+258 +test util-16.1.17.259 {8.4 compatible formatting of doubles} \ + {expr 1e259} \ + 9.9999999999999993e+258 +test util-16.1.17.260 {8.4 compatible formatting of doubles} \ + {expr 1e260} \ + 1.0000000000000001e+260 +test util-16.1.17.261 {8.4 compatible formatting of doubles} \ + {expr 1e261} \ + 9.9999999999999993e+260 +test util-16.1.17.262 {8.4 compatible formatting of doubles} \ + {expr 1e262} \ + 1e+262 +test util-16.1.17.263 {8.4 compatible formatting of doubles} \ + {expr 1e263} \ + 1e+263 +test util-16.1.17.264 {8.4 compatible formatting of doubles} \ + {expr 1e264} \ + 1e+264 +test util-16.1.17.265 {8.4 compatible formatting of doubles} \ + {expr 1e265} \ + 1.0000000000000001e+265 +test util-16.1.17.266 {8.4 compatible formatting of doubles} \ + {expr 1e266} \ + 1e+266 +test util-16.1.17.267 {8.4 compatible formatting of doubles} \ + {expr 1e267} \ + 9.9999999999999997e+266 +test util-16.1.17.268 {8.4 compatible formatting of doubles} \ + {expr 1e268} \ + 9.9999999999999997e+267 +test util-16.1.17.269 {8.4 compatible formatting of doubles} \ + {expr 1e269} \ + 1e+269 +test util-16.1.17.270 {8.4 compatible formatting of doubles} \ + {expr 1e270} \ + 1e+270 +test util-16.1.17.271 {8.4 compatible formatting of doubles} \ + {expr 1e271} \ + 9.9999999999999995e+270 +test util-16.1.17.272 {8.4 compatible formatting of doubles} \ + {expr 1e272} \ + 1.0000000000000001e+272 +test util-16.1.17.273 {8.4 compatible formatting of doubles} \ + {expr 1e273} \ + 9.9999999999999995e+272 +test util-16.1.17.274 {8.4 compatible formatting of doubles} \ + {expr 1e274} \ + 9.9999999999999992e+273 +test util-16.1.17.275 {8.4 compatible formatting of doubles} \ + {expr 1e275} \ + 9.9999999999999996e+274 +test util-16.1.17.276 {8.4 compatible formatting of doubles} \ + {expr 1e276} \ + 1.0000000000000001e+276 +test util-16.1.17.277 {8.4 compatible formatting of doubles} \ + {expr 1e277} \ + 1e+277 +test util-16.1.17.278 {8.4 compatible formatting of doubles} \ + {expr 1e278} \ + 9.9999999999999996e+277 +test util-16.1.17.279 {8.4 compatible formatting of doubles} \ + {expr 1e279} \ + 1.0000000000000001e+279 +test util-16.1.17.280 {8.4 compatible formatting of doubles} \ + {expr 1e280} \ + 1e+280 +test util-16.1.17.281 {8.4 compatible formatting of doubles} \ + {expr 1e281} \ + 1e+281 +test util-16.1.17.282 {8.4 compatible formatting of doubles} \ + {expr 1e282} \ + 1e+282 +test util-16.1.17.283 {8.4 compatible formatting of doubles} \ + {expr 1e283} \ + 9.9999999999999996e+282 +test util-16.1.17.284 {8.4 compatible formatting of doubles} \ + {expr 1e284} \ + 1.0000000000000001e+284 +test util-16.1.17.285 {8.4 compatible formatting of doubles} \ + {expr 1e285} \ + 9.9999999999999998e+284 +test util-16.1.17.286 {8.4 compatible formatting of doubles} \ + {expr 1e286} \ + 1e+286 +test util-16.1.17.287 {8.4 compatible formatting of doubles} \ + {expr 1e287} \ + 1.0000000000000001e+287 +test util-16.1.17.288 {8.4 compatible formatting of doubles} \ + {expr 1e288} \ + 1e+288 +test util-16.1.17.289 {8.4 compatible formatting of doubles} \ + {expr 1e289} \ + 1.0000000000000001e+289 +test util-16.1.17.290 {8.4 compatible formatting of doubles} \ + {expr 1e290} \ + 1.0000000000000001e+290 +test util-16.1.17.291 {8.4 compatible formatting of doubles} \ + {expr 1e291} \ + 9.9999999999999996e+290 +test util-16.1.17.292 {8.4 compatible formatting of doubles} \ + {expr 1e292} \ + 1e+292 +test util-16.1.17.293 {8.4 compatible formatting of doubles} \ + {expr 1e293} \ + 9.9999999999999992e+292 +test util-16.1.17.294 {8.4 compatible formatting of doubles} \ + {expr 1e294} \ + 1.0000000000000001e+294 +test util-16.1.17.295 {8.4 compatible formatting of doubles} \ + {expr 1e295} \ + 9.9999999999999998e+294 +test util-16.1.17.296 {8.4 compatible formatting of doubles} \ + {expr 1e296} \ + 9.9999999999999998e+295 +test util-16.1.17.297 {8.4 compatible formatting of doubles} \ + {expr 1e297} \ + 1e+297 +test util-16.1.17.298 {8.4 compatible formatting of doubles} \ + {expr 1e298} \ + 9.9999999999999996e+297 +test util-16.1.17.299 {8.4 compatible formatting of doubles} \ + {expr 1e299} \ + 1.0000000000000001e+299 +test util-16.1.17.300 {8.4 compatible formatting of doubles} \ + {expr 1e300} \ + 1.0000000000000001e+300 +test util-16.1.17.301 {8.4 compatible formatting of doubles} \ + {expr 1e301} \ + 1.0000000000000001e+301 +test util-16.1.17.302 {8.4 compatible formatting of doubles} \ + {expr 1e302} \ + 1.0000000000000001e+302 +test util-16.1.17.303 {8.4 compatible formatting of doubles} \ + {expr 1e303} \ + 1e+303 +test util-16.1.17.304 {8.4 compatible formatting of doubles} \ + {expr 1e304} \ + 9.9999999999999994e+303 +test util-16.1.17.305 {8.4 compatible formatting of doubles} \ + {expr 1e305} \ + 9.9999999999999994e+304 +test util-16.1.17.306 {8.4 compatible formatting of doubles} \ + {expr 1e306} \ + 1e+306 +test util-16.1.17.307 {8.4 compatible formatting of doubles} \ + {expr 1e307} \ + 9.9999999999999999e+306 + +set ::tcl_precision $saved_precision + # cleanup ::tcltest::cleanupTests return # Local Variables: # mode: tcl -# End:
\ No newline at end of file +# End: diff --git a/tests/var.test b/tests/var.test index f2a858c..8913204 100644 --- a/tests/var.test +++ b/tests/var.test @@ -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: var.test,v 1.36.2.1 2010/12/11 18:39:30 kennykb Exp $ +# RCS: @(#) $Id: var.test,v 1.38 2011/01/01 15:14:43 dkf Exp $ # if {"::tcltest" ni [namespace children]} { @@ -118,9 +118,9 @@ test var-1.14 {TclLookupVar, namespace code ignores ":"s in middle and end of va set x:y: 789 list [set :] [set v:] [set x:y:] \ ${:} ${v:} ${x:y:} \ - [expr {[lsearch [info vars] :] != -1}] \ - [expr {[lsearch [info vars] v:] != -1}] \ - [expr {[lsearch [info vars] x:y:] != -1}] + [expr {":" in [info vars]}] \ + [expr {"v:" in [info vars]}] \ + [expr {"x:y:" in [info vars]}] } } {123 456 789 123 456 789 1 1 1} test var-1.15 {TclLookupVar, resurrect variable via upvar to deleted namespace: compiled code path} { diff --git a/tests/winDde.test b/tests/winDde.test index f59a7f2..a819f93 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -9,9 +9,9 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: winDde.test,v 1.28 2005/05/10 18:35:25 kennykb Exp $ +# RCS: @(#) $Id: winDde.test,v 1.29 2011/01/01 15:14:43 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 #tcltest::configure -verbose {pass start} namespace import -force ::tcltest::* @@ -49,7 +49,7 @@ proc createChildProcess { ddeServerName {handler {}}} { puts $f { # DDE child server - # - if {[lsearch [namespace children] ::tcltest] == -1} { + if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -267,7 +267,7 @@ test winDde-7.2 {DDE slave cleanup} -constraints {win dde} -setup { dde services TclEval {} set s [dde services TclEval {}] set m [list [list TclEval dde-interp-7.5]] - if {[lsearch -exact $s $m] != -1} { + if {$m in $s} { set s } } -result {} diff --git a/tests/winPipe.test b/tests/winPipe.test index c5fb814..eeb69fa 100644 --- a/tests/winPipe.test +++ b/tests/winPipe.test @@ -9,16 +9,15 @@ # Copyright (c) 1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # -# 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. # -# RCS: @(#) $Id: winPipe.test,v 1.33.10.1 2010/10/09 17:53:17 kennykb Exp $ +# RCS: @(#) $Id: winPipe.test,v 1.35 2011/01/01 15:14:43 dkf Exp $ package require tcltest namespace import -force ::tcltest::* unset -nocomplain path - set bindir [file join [pwd] [file dirname [info nameofexecutable]]] set cat32 [file join $bindir cat32.exe] @@ -185,7 +184,6 @@ test winpipe-4.1 {Tcl_WaitPid} {win nt exec cat32} { set result "$result$line" } } - set f [open "|[list $cat32] < $path(big) 2> $path(stderr)" r] fconfigure $f -buffering none -blocking 0 fileevent $f readable "readResults $f" @@ -237,7 +235,7 @@ test winpipe-5.1 {TclpCreateTempFile: cleanup temp files} {win exec} { set existing [glob -nocomplain c:/tcl*.tmp] exec [interpreter] < $path(nothing) foreach p [glob -nocomplain c:/tcl*.tmp] { - if {[lsearch $existing $p] == -1} { + if {$p ni $existing} { lappend x $p } } @@ -312,7 +310,6 @@ set path(echoArgs.tcl) [makeFile { puts "[list $argv0 $argv]" } echoArgs.tcl] - ### validate the raw output of BuildCommandLine(). ### test winpipe-7.1 {BuildCommandLine: null arguments} {win exec} { @@ -449,3 +446,7 @@ removeFile nothing removeFile echoArgs.tcl ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tools/genStubs.tcl b/tools/genStubs.tcl index 3e896a1..70e06b1 100644 --- a/tools/genStubs.tcl +++ b/tools/genStubs.tcl @@ -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: genStubs.tcl,v 1.44 2010/09/15 07:33:56 nijtmans Exp $ +# RCS: @(#) $Id: genStubs.tcl,v 1.45 2011/01/19 14:04:32 nijtmans Exp $ package require Tcl 8.4 @@ -491,6 +491,9 @@ proc genStubs::makeDecl {name decl index} { set sep ", " } append line ", ...)" + if {[lindex $args end] eq "{const char *} format"} { + append line " TCL_FORMAT_PRINTF(" [expr [llength $args] - 1] ", " [llength $args] ")" + } } default { set sep "(" @@ -588,6 +591,9 @@ proc genStubs::makeSlot {name decl index} { set sep ", " } append text ", ...)" + if {[lindex $args end] eq "{const char *} format"} { + append text " TCL_FORMAT_PRINTF(" [expr [llength $args] - 1] ", " [llength $args] ")" + } } default { set sep "(" diff --git a/tools/uniParse.tcl b/tools/uniParse.tcl index 46ccce4..0ec0848 100644 --- a/tools/uniParse.tcl +++ b/tools/uniParse.tcl @@ -9,7 +9,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: uniParse.tcl,v 1.6.2.1 2010/10/20 01:50:19 kennykb Exp $ +# RCS: @(#) $Id: uniParse.tcl,v 1.9 2010/10/18 21:47:36 nijtmans Exp $ namespace eval uni { diff --git a/unix/Makefile.in b/unix/Makefile.in index 500d872..2283c0b 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.5 2010/12/01 16:42:37 kennykb Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.315 2010/12/17 23:49:37 stwo Exp $ VERSION = @TCL_VERSION@ MAJOR_VERSION = @TCL_MAJOR_VERSION@ @@ -260,7 +260,6 @@ INSTALL_TZDATA = @INSTALL_TZDATA@ #-------------------------------------------------------------------------- GDB = gdb -DDD = ddd TRACE = strace TRACE_OPTS = VALGRIND = valgrind @@ -738,10 +737,6 @@ shell: ${TCL_EXE} gdb: ${TCL_EXE} $(SHELL_ENV) $(GDB) ./${TCL_EXE} -# This target can be used to run tclsh inside ddd -ddd: ${TCL_EXE} - $(SHELL_ENV) $(DDD) ./${TCL_EXE} - valgrind: ${TCL_EXE} ${TCLTEST_EXE} $(SHELL_ENV) $(VALGRIND) $(VALGRINDARGS) ./${TCLTEST_EXE} $(TOP_DIR)/tests/all.tcl -singleproc 1 $(TESTFLAGS) @@ -1877,13 +1872,13 @@ checkexports: $(TCL_LIB_FILE) # system. # -rpm: all /bin/rpm +rpm: all rm -f THIS.TCL.SPEC echo "%define _builddir `pwd`" > THIS.TCL.SPEC echo "%define _rpmdir `pwd`/RPMS" >> THIS.TCL.SPEC cat tcl.spec >> THIS.TCL.SPEC mkdir -p RPMS/i386 - rpm -bb THIS.TCL.SPEC + rpmbuild -bb THIS.TCL.SPEC mv RPMS/i386/*.rpm . rm -rf RPMS THIS.TCL.SPEC @@ -2019,33 +2014,11 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(M tar -C $(DISTDIR)/pkgs -xzf "$$i"; \ done -# -# The following target can only be used for non-patch releases. Use the -# "allpatch" target below for patch releases. -# - alldist: dist rm -f $(DISTROOT)/$(DISTNAME)-src.tar.gz $(DISTROOT)/$(ZIPNAME) cd $(DISTROOT); tar cf $(DISTNAME)-src.tar $(DISTNAME); \ gzip -9 $(DISTNAME)-src.tar; zip -qr8 $(ZIPNAME) $(DISTNAME) -# -# The target below is similar to "alldist" except it works for patch releases. -# It is needed because patch releases are peculiar: the patch designation -# appears in the name of the compressed file (e.g. tcl8.0p1.tar.gz) but the -# extracted source directory doesn't include the patch designation (e.g., -# tcl8.0). -# - -allpatch: dist - rm -f $(DISTROOT)/$(DISTNAME)-src.tar.gz $(DISTROOT)/$(ZIPNAME) - mv $(DISTROOT)/tcl${VERSION} $(DISTROOT)/old - mv $(DISTROOT)/$(DISTNAME) $(DISTROOT)/tcl${VERSION} - cd $(DISTROOT); tar cf $(DISTNAME)-src.tar tcl${VERSION}; \ - gzip -9 $(DISTNAME)-src.tar; zip -r8 $(ZIPNAME) tcl${VERSION} - mv $(DISTROOT)/tcl${VERSION} $(DISTROOT)/$(DISTNAME) - mv $(DISTROOT)/old $(DISTROOT)/tcl${VERSION} - #-------------------------------------------------------------------------- # This target creates the HTML folder for Tcl & Tk and places it in # DISTDIR/html. It uses the tcltk-man2html.tcl tool from the Tcl group's tool @@ -2078,14 +2051,16 @@ BUILD_HTML = \ # 'make' from getting confused when someone makes an error in a rule. #-------------------------------------------------------------------------- -.PHONY: all binaries libraries doc packages tclLibObjs objs tcltest-real test -.PHONY: test-tcl gdb-test runtest ro-test shell gdb ddd valgrind valgrindshell -.PHONY: topDirName gendate gentommath_h install install-strip install-binaries -.PHONY: install-libraries install-tzdata install-msgs install-doc clean dist -.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 install-headers +.PHONY: all binaries libraries objs doc html html-tcl html-tk test runtest +.PHONY: install install-strip install-binaries install-libraries +.PHONY: install-headers install-private-headers install-doc +.PHONY: clean distclean depend genstubs checkstubs checkexports checkuchar +.PHONY: shell gdb valgrind valgrindshell dist alldist rpm +.PHONY: tclLibObjs tcltest-real test-tcl gdb-test ro-test trace-test xttest +.PHONY: topDirName gendate gentommath_h trace-shell checkdoc +.PHONY: install-tzdata install-msgs +.PHONY: packages configure-packages test-packages clean-packages +.PHONY: dist-packages distclean-packages install-packages #-------------------------------------------------------------------------- # DO NOT DELETE THIS LINE -- make depend depends on it. diff --git a/unix/configure.in b/unix/configure.in index acf1b65..91ebcf1 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -3,7 +3,7 @@ dnl This file is an input file used by the GNU "autoconf" program to dnl generate the file "configure", which is run during Tcl installation dnl to configure the system for the local environment. # -# RCS: @(#) $Id: configure.in,v 1.214.2.1 2010/09/28 15:43:01 kennykb Exp $ +# RCS: @(#) $Id: configure.in,v 1.215 2010/09/28 15:13:55 rmax Exp $ AC_INIT([tcl],[8.6]) AC_PREREQ(2.59) diff --git a/unix/dltest/pkga.c b/unix/dltest/pkga.c index 3c12289..ec5d75f 100644 --- a/unix/dltest/pkga.c +++ b/unix/dltest/pkga.c @@ -9,9 +9,10 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: pkga.c,v 1.16 2010/03/28 03:17:50 dgp Exp $ + * RCS: @(#) $Id: pkga.c,v 1.17 2010/12/31 16:35:26 nijtmans Exp $ */ +#undef STATIC_BUILD #include "tcl.h" /* diff --git a/unix/dltest/pkgb.c b/unix/dltest/pkgb.c index df0cde3..9413c73 100644 --- a/unix/dltest/pkgb.c +++ b/unix/dltest/pkgb.c @@ -10,9 +10,10 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: pkgb.c,v 1.13 2010/03/28 03:17:50 dgp Exp $ + * RCS: @(#) $Id: pkgb.c,v 1.14 2010/12/31 16:35:26 nijtmans Exp $ */ +#undef STATIC_BUILD #include "tcl.h" /* diff --git a/unix/dltest/pkgc.c b/unix/dltest/pkgc.c index 3e4c4e6..334644c 100644 --- a/unix/dltest/pkgc.c +++ b/unix/dltest/pkgc.c @@ -10,9 +10,10 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: pkgc.c,v 1.13 2010/03/28 03:17:50 dgp Exp $ + * RCS: @(#) $Id: pkgc.c,v 1.14 2010/12/31 16:35:26 nijtmans Exp $ */ +#undef STATIC_BUILD #include "tcl.h" /* diff --git a/unix/dltest/pkgd.c b/unix/dltest/pkgd.c index d713e2e..9554c4a 100644 --- a/unix/dltest/pkgd.c +++ b/unix/dltest/pkgd.c @@ -10,9 +10,10 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: pkgd.c,v 1.12 2010/03/28 03:17:50 dgp Exp $ + * RCS: @(#) $Id: pkgd.c,v 1.13 2010/12/31 16:35:26 nijtmans Exp $ */ +#undef STATIC_BUILD #include "tcl.h" /* diff --git a/unix/dltest/pkge.c b/unix/dltest/pkge.c index bd0d838..066b485 100644 --- a/unix/dltest/pkge.c +++ b/unix/dltest/pkge.c @@ -10,9 +10,10 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: pkge.c,v 1.14 2010/03/28 03:17:50 dgp Exp $ + * RCS: @(#) $Id: pkge.c,v 1.15 2010/12/31 16:35:26 nijtmans Exp $ */ +#undef STATIC_BUILD #include "tcl.h" /* diff --git a/unix/dltest/pkgua.c b/unix/dltest/pkgua.c index e431deb..8f7e5cd 100644 --- a/unix/dltest/pkgua.c +++ b/unix/dltest/pkgua.c @@ -10,9 +10,10 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: pkgua.c,v 1.11 2010/03/28 03:17:50 dgp Exp $ + * RCS: @(#) $Id: pkgua.c,v 1.12 2010/12/31 16:35:26 nijtmans Exp $ */ +#undef STATIC_BUILD #include "tcl.h" /* diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c index 459f45f..a74fec8 100644 --- a/unix/tclAppInit.c +++ b/unix/tclAppInit.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: tclAppInit.c,v 1.22.4.1 2010/09/25 14:51:13 kennykb Exp $ + * RCS: @(#) $Id: tclAppInit.c,v 1.24 2010/09/23 21:40:46 nijtmans Exp $ */ #include "tcl.h" diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index 36ce4ca..3b0d984 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.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: tclUnixChan.c,v 1.106.2.1 2010/09/28 15:43:01 kennykb Exp $ + * RCS: @(#) $Id: tclUnixChan.c,v 1.107 2010/09/28 15:13:55 rmax Exp $ */ #include "tclInt.h" /* Internal definitions for Tcl. */ diff --git a/unix/tclUnixPort.h b/unix/tclUnixPort.h index 4eefa39..9283d8b 100644 --- a/unix/tclUnixPort.h +++ b/unix/tclUnixPort.h @@ -19,7 +19,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixPort.h,v 1.72.2.1 2010/09/28 15:43:01 kennykb Exp $ + * RCS: @(#) $Id: tclUnixPort.h,v 1.73 2010/09/28 15:13:55 rmax Exp $ */ #ifndef _TCLUNIXPORT diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 21dd034..db86d61 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.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: tclUnixSock.c,v 1.26.2.5 2010/12/16 01:42:19 kennykb Exp $ + * RCS: @(#) $Id: tclUnixSock.c,v 1.33 2010/12/14 17:22:55 rmax Exp $ */ #include "tclInt.h" @@ -523,7 +523,7 @@ TcpCloseProc( * handlers are already deleted in the generic IO channel closing code * that called this function, so we do not have to delete them here. */ - + for (fds = statePtr->fds; fds != NULL; fds = statePtr->fds) { statePtr->fds = fds->next; Tcl_DeleteFileHandler(fds->fd); @@ -660,7 +660,7 @@ TcpGetOptionProc( Tcl_DStringAppendElement(dsPtr, "-peername"); Tcl_DStringStartSublist(dsPtr); } - + getnameinfo(&peername.sa, size, host, sizeof(host), NULL, 0, NI_NUMERICHOST); Tcl_DStringAppendElement(dsPtr, host); @@ -1319,7 +1319,7 @@ TcpAccept( socklen_t len; /* For accept interface */ char channelName[16 + TCL_INTEGER_SPACE]; char host[NI_MAXHOST], port[NI_MAXSERV]; - + fds = (TcpFdList *) data; len = sizeof(addr); diff --git a/win/Makefile.in b/win/Makefile.in index 392bb15..499f06d 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.3 2010/12/11 18:39:31 kennykb Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.187 2010/12/03 09:19:39 nijtmans Exp $ VERSION = @TCL_VERSION@ @@ -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: cat.c,v 1.5.4.1 2010/12/01 16:42:37 kennykb Exp $ + * RCS: @(#) $Id: cat.c,v 1.6 2010/11/16 14:03:34 nijtmans Exp $ */ #ifdef TCL_BROKEN_MAINARGS diff --git a/win/configure b/win/configure index 32d9310..2e69364 100755 --- a/win/configure +++ b/win/configure @@ -3628,6 +3628,78 @@ _ACEOF fi +# See if the compiler supports intrinsics. + +echo "$as_me:$LINENO: checking for intrinsics support in compiler" >&5 +echo $ECHO_N "checking for intrinsics support in compiler... $ECHO_C" >&6 +if test "${tcl_cv_intrinsics+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. */ + +#define WIN32_LEAN_AND_MEAN +#include <windows.h> +#undef WIN32_LEAN_AND_MEAN +#include <intrin.h> + +int +main () +{ + + __cpuidex(0,0,0); + + ; + 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 + tcl_cv_intrinsics=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_intrinsics=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + +fi +echo "$as_me:$LINENO: result: $tcl_cv_intrinsics" >&5 +echo "${ECHO_T}$tcl_cv_intrinsics" >&6 +if test "$tcl_cv_intrinsics" = "yes"; then + +cat >>confdefs.h <<\_ACEOF +#define HAVE_INTRIN_H 1 +_ACEOF + +fi + #-------------------------------------------------------------------- # Determines the correct binary file extension (.o, .obj, .exe etc.) #-------------------------------------------------------------------- @@ -3899,6 +3971,10 @@ fi SHLIB_SUFFIX=".dll" + # MACHINE is IX86 for LINK, but this is used by the manifest, + # which requires x86|amd64|ia64. + MACHINE="X86" + # Check for a bug in gcc's windres that causes the # compile to fail when a Windows native path is # passed into windres. The mingw toolchain requires @@ -4179,11 +4255,18 @@ echo "$as_me: error: ${CC} does not support the -shared option. LDFLAGS_CONSOLE="-mconsole ${extra_ldflags}" LDFLAGS_WINDOW="-mwindows ${extra_ldflags}" - if test "$do64bit" != "no" ; then - MACHINE="AMD64" - else - MACHINE="X86" - fi + case "$do64bit" in + amd64|x64|yes) + MACHINE="AMD64" ; # assume AMD64 as default 64-bit build + echo "$as_me:$LINENO: result: Using 64-bit $MACHINE mode" >&5 +echo "${ECHO_T} Using 64-bit $MACHINE mode" >&6 + ;; + ia64) + MACHINE="IA64" + echo "$as_me:$LINENO: result: Using 64-bit $MACHINE mode" >&5 +echo "${ECHO_T} Using 64-bit $MACHINE mode" >&6 + ;; + esac else if test "${SHARED_BUILD}" = "0" ; then # static @@ -4208,12 +4291,9 @@ echo "${ECHO_T}using shared flags" >&6 LIBSUFFIX="\${DBGX}.lib" LIBFLAGSUFFIX="\${DBGX}" - # This is a 2-stage check to make sure we have the 64-bit SDK - # We have to know where the SDK is installed. + # This is a 2-stage check to make sure we have the 64-bit SDK + # We have to know where the SDK is installed. # This magic is based on MS Platform SDK for Win2003 SP1 - hobbs - # MACHINE is IX86 for LINK, but this is used by the manifest, - # which requires x86|amd64|ia64. - MACHINE="X86" if test "$do64bit" != "no" ; then if test "x${MSSDK}x" = "xx" ; then MSSDK="C:/Progra~1/Microsoft Platform SDK" @@ -4221,14 +4301,14 @@ echo "${ECHO_T}using shared flags" >&6 MSSDK=`echo "$MSSDK" | sed -e 's!\\\!/!g'` PATH64="" case "$do64bit" in - amd64|x64|yes) - MACHINE="AMD64" ; # assume AMD64 as default 64-bit build - PATH64="${MSSDK}/Bin/Win64/x86/AMD64" - ;; - ia64) - MACHINE="IA64" - PATH64="${MSSDK}/Bin/Win64" - ;; + amd64|x64|yes) + MACHINE="AMD64" ; # assume AMD64 as default 64-bit build + PATH64="${MSSDK}/Bin/Win64/x86/AMD64" + ;; + ia64) + MACHINE="IA64" + PATH64="${MSSDK}/Bin/Win64" + ;; esac if test ! -d "${PATH64}" ; then { echo "$as_me:$LINENO: WARNING: Could not find 64-bit $MACHINE SDK to enable 64bit mode" >&5 diff --git a/win/configure.in b/win/configure.in index 256f8c7..bd42c49 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.3 2010/12/11 18:39:31 kennykb Exp $ +# RCS: @(#) $Id: configure.in,v 1.131 2011/01/12 10:40:03 nijtmans Exp $ AC_INIT(../generic/tcl.h) AC_PREREQ(2.59) @@ -272,6 +272,27 @@ if test "$tcl_cv_mwmo_alertable" = "no"; then [Defined when MWMO_ALERTABLE is missing from winuser.h]) fi +# See if the compiler supports intrinsics. + +AC_CACHE_CHECK(for intrinsics support in compiler, + tcl_cv_intrinsics, +AC_TRY_LINK([ +#define WIN32_LEAN_AND_MEAN +#include <windows.h> +#undef WIN32_LEAN_AND_MEAN +#include <intrin.h> +], +[ + __cpuidex(0,0,0); +], + tcl_cv_intrinsics=yes, + tcl_cv_intrinsics=no) +) +if test "$tcl_cv_intrinsics" = "yes"; then + AC_DEFINE(HAVE_INTRIN_H, 1, + [Defined when the compilers supports intrinsics]) +fi + #-------------------------------------------------------------------- # Determines the correct binary file extension (.o, .obj, .exe etc.) #-------------------------------------------------------------------- diff --git a/win/makefile.vc b/win/makefile.vc index cfa8770..dece300 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.3 2010/12/01 16:42:37 kennykb Exp $ +# RCS: @(#) $Id: makefile.vc,v 1.217 2010/11/28 23:20:11 kennykb Exp $ #------------------------------------------------------------------------------ # Check to see we are configured to build with MSVC (MSDEVDIR or MSVCDIR) diff --git a/win/rules.vc b/win/rules.vc index 4ec990e..ec63ba3 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -11,7 +11,7 @@ # Copyright (c) 2003-2007 Patrick Thoyts # #------------------------------------------------------------------------------ -# RCS: @(#) $Id: rules.vc,v 1.44.2.1 2010/10/20 01:50:19 kennykb Exp $ +# RCS: @(#) $Id: rules.vc,v 1.45 2010/10/11 21:33:30 nijtmans Exp $ #------------------------------------------------------------------------------ !ifndef _RULES_VC @@ -407,6 +407,10 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ SHLIB_SUFFIX=".dll" + # MACHINE is IX86 for LINK, but this is used by the manifest, + # which requires x86|amd64|ia64. + MACHINE="X86" + # Check for a bug in gcc's windres that causes the # compile to fail when a Windows native path is # passed into windres. The mingw toolchain requires @@ -575,11 +579,16 @@ file for information about building with Mingw.]) LDFLAGS_CONSOLE="-mconsole ${extra_ldflags}" LDFLAGS_WINDOW="-mwindows ${extra_ldflags}" - if test "$do64bit" != "no" ; then - MACHINE="AMD64" - else - MACHINE="X86" - fi + case "$do64bit" in + amd64|x64|yes) + MACHINE="AMD64" ; # assume AMD64 as default 64-bit build + AC_MSG_RESULT([ Using 64-bit $MACHINE mode]) + ;; + ia64) + MACHINE="IA64" + AC_MSG_RESULT([ Using 64-bit $MACHINE mode]) + ;; + esac else if test "${SHARED_BUILD}" = "0" ; then # static @@ -602,12 +611,9 @@ file for information about building with Mingw.]) LIBSUFFIX="\${DBGX}.lib" LIBFLAGSUFFIX="\${DBGX}" - # This is a 2-stage check to make sure we have the 64-bit SDK - # We have to know where the SDK is installed. + # This is a 2-stage check to make sure we have the 64-bit SDK + # We have to know where the SDK is installed. # This magic is based on MS Platform SDK for Win2003 SP1 - hobbs - # MACHINE is IX86 for LINK, but this is used by the manifest, - # which requires x86|amd64|ia64. - MACHINE="X86" if test "$do64bit" != "no" ; then if test "x${MSSDK}x" = "xx" ; then MSSDK="C:/Progra~1/Microsoft Platform SDK" @@ -615,14 +621,14 @@ file for information about building with Mingw.]) MSSDK=`echo "$MSSDK" | sed -e 's!\\\!/!g'` PATH64="" case "$do64bit" in - amd64|x64|yes) - MACHINE="AMD64" ; # assume AMD64 as default 64-bit build - PATH64="${MSSDK}/Bin/Win64/x86/AMD64" - ;; - ia64) - MACHINE="IA64" - PATH64="${MSSDK}/Bin/Win64" - ;; + amd64|x64|yes) + MACHINE="AMD64" ; # assume AMD64 as default 64-bit build + PATH64="${MSSDK}/Bin/Win64/x86/AMD64" + ;; + ia64) + MACHINE="IA64" + PATH64="${MSSDK}/Bin/Win64" + ;; esac if test ! -d "${PATH64}" ; then AC_MSG_WARN([Could not find 64-bit $MACHINE SDK to enable 64bit mode]) diff --git a/win/tclAppInit.c b/win/tclAppInit.c index eb4347b..c24aae0 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.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: tclAppInit.c,v 1.31.2.2 2010/12/01 16:42:38 kennykb Exp $ + * RCS: @(#) $Id: tclAppInit.c,v 1.37 2010/11/18 15:50:54 nijtmans Exp $ */ #include "tcl.h" diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index eb19cea..47b8b04 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -10,10 +10,13 @@ * 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.2 2010/12/01 16:42:38 kennykb Exp $ + * RCS: @(#) $Id: tclWin32Dll.c,v 1.74 2011/01/12 07:37:41 nijtmans Exp $ */ #include "tclWinInt.h" +#if defined(HAVE_INTRIN_H) +# include <intrin.h> +#endif /* * The following data structures are used when loading the thunking library @@ -718,12 +721,47 @@ TclWinCPUID( unsigned int index, /* Which CPUID value to retrieve. */ unsigned int *regsPtr) /* Registers after the CPUID. */ { -#if defined(__GNUC__) && !defined(_WIN64) - EXCEPTION_REGISTRATION registration; -#endif int status = TCL_ERROR; -#if defined(__GNUC__) && !defined(_WIN64) +#if defined(HAVE_INTRIN_H) && defined(_WIN64) + + __cpuid(regsPtr, index); + status = TCL_OK; + +#elif defined(__GNUC__) +# if defined(_WIN64) + /* + * Execute the CPUID instruction with the given index, and store results + * off 'regPtr'. + */ + + __asm__ __volatile__( + /* + * Do the CPUID instruction, and save the results in the 'regsPtr' + * area. + */ + + "movl %[rptr], %%edi" "\n\t" + "movl %[index], %%eax" "\n\t" + "cpuid" "\n\t" + "movl %%eax, 0x0(%%edi)" "\n\t" + "movl %%ebx, 0x4(%%edi)" "\n\t" + "movl %%ecx, 0x8(%%edi)" "\n\t" + "movl %%edx, 0xc(%%edi)" "\n\t" + + : + /* No outputs */ + : + [index] "m" (index), + [rptr] "m" (regsPtr) + : + "%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "memory"); + status = TCL_OK; + +# else + + EXCEPTION_REGISTRATION registration; + /* * Execute the CPUID instruction with the given index, and store results * off 'regPtr'. @@ -805,7 +843,14 @@ TclWinCPUID( "%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "memory"); status = registration.status; -#elif defined(_MSC_VER) && !defined(_WIN64) +# endif /* !_WIN64 */ +#elif defined(_MSC_VER) +# if defined(_WIN64) + + __cpuid(regsPtr, index); + status = TCL_OK; + +# else /* * Define a structure in the stack frame to hold the registers. */ @@ -852,6 +897,7 @@ TclWinCPUID( /* do nothing */ } +# endif #else /* * Don't know how to do assembly code for this compiler and/or diff --git a/win/tclWinChan.c b/win/tclWinChan.c index caa0c9f..442b5ad 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.2.1 2010/12/01 16:42:38 kennykb Exp $ + * RCS: @(#) $Id: tclWinChan.c,v 1.61 2011/01/25 22:33:56 nijtmans Exp $ */ #include "tclWinInt.h" @@ -1225,7 +1225,7 @@ TclpGetDefaultStdChannel( HANDLE handle; int mode = -1; const char *bufMode = NULL; - DWORD handleId = (DWORD)INVALID_HANDLE_VALUE; + DWORD handleId = (DWORD) -1; /* Standard handle to retrieve. */ switch (type) { @@ -1338,7 +1338,7 @@ TclWinOpenFileChannel( infoPtr->flags = appendMode; infoPtr->handle = handle; infoPtr->dirty = 0; - wsprintfA(channelName, "file%lx", (int) infoPtr); + sprintf(channelName, "file%Ix", (size_t) infoPtr); infoPtr->channel = Tcl_CreateChannel(&fileChannelType, channelName, infoPtr, permissions); diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 6ad92f1..8b2e074 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.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: tclWinConsole.c,v 1.25 2010/09/13 14:20:39 nijtmans Exp $ + * RCS: @(#) $Id: tclWinConsole.c,v 1.26 2011/01/25 22:33:56 nijtmans Exp $ */ #include "tclWinInt.h" @@ -1362,7 +1362,7 @@ TclWinOpenConsoleChannel( * for instance). */ - wsprintfA(channelName, "file%lx", (int) infoPtr); + sprintf(channelName, "file%Ix", (size_t) infoPtr); infoPtr->channel = Tcl_CreateChannel(&consoleChannelType, channelName, infoPtr, permissions); diff --git a/win/tclWinDde.c b/win/tclWinDde.c index c8cd8c6..4a045eb 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.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: tclWinDde.c,v 1.44.2.1 2010/10/20 01:50:19 kennykb Exp $ + * RCS: @(#) $Id: tclWinDde.c,v 1.46 2011/01/25 22:33:56 nijtmans Exp $ */ #undef STATIC_BUILD @@ -220,7 +220,7 @@ Initialize(void) if (ddeInstance == 0) { Tcl_MutexLock(&ddeMutex); if (ddeInstance == 0) { - if (DdeInitializeA(&ddeInstance, DdeServerProc, + if (DdeInitializeA(&ddeInstance, (PFNCALLBACK) DdeServerProc, CBF_SKIP_REGISTRATIONS | CBF_SKIP_UNREGISTRATIONS | CBF_FAIL_POKES, 0) != DMLERR_NO_ERROR) { ddeInstance = 0; @@ -967,7 +967,7 @@ DdeClientWindowProc( (struct DdeEnumServices *) lpcs->lpCreateParams; #ifdef _WIN64 - SetWindowLongPtr(hwnd, GWLP_USERDATA, (long)es); + SetWindowLongPtr(hwnd, GWLP_USERDATA, (LONG_PTR)es); #else SetWindowLongA(hwnd, GWL_USERDATA, (long)es); #endif @@ -1042,7 +1042,7 @@ DdeEnumWindowsCallback( HWND hwndTarget, LPARAM lParam) { - DWORD dwResult = 0; + DWORD_PTR dwResult = 0; struct DdeEnumServices *es = (struct DdeEnumServices *) lParam; SendMessageTimeoutA(hwndTarget, WM_DDE_INITIATE, (WPARAM)es->hwnd, diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index 149e135..a32222c 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.3 2010/12/01 16:42:38 kennykb Exp $ + * RCS: @(#) $Id: tclWinFCmd.c,v 1.71 2010/11/19 20:47:09 nijtmans Exp $ */ #include "tclWinInt.h" diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 0334ea6..bdf2b04 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.4 2010/12/16 01:42:19 kennykb Exp $ + * RCS: @(#) $Id: tclWinFile.c,v 1.121 2011/01/25 22:33:56 nijtmans Exp $ */ #include "tclWinInt.h" @@ -175,6 +175,7 @@ static int WinLink(const TCHAR *LinkSource, const TCHAR *LinkTarget, int linkAction); static int WinSymLinkDirectory(const TCHAR *LinkDirectory, const TCHAR *LinkTarget); +MODULE_SCOPE void tclWinDebugPanic(const char *format, ...); /* *-------------------------------------------------------------------- @@ -786,9 +787,10 @@ NativeWriteReparse( /* *---------------------------------------------------------------------- * - * WishPanic -- + * tclWinDebugPanic -- * - * Display a message. + * Display a message. If a debugger is present, present it directly + * to the debugger, otherwise use a MessageBox. * * Results: * None. @@ -799,8 +801,8 @@ NativeWriteReparse( *---------------------------------------------------------------------- */ -static void -PanicMessageBox( +void +tclWinDebugPanic( const char *format, ...) { #define TCL_MAX_WARN_LEN 1024 @@ -809,7 +811,7 @@ PanicMessageBox( WCHAR msgString[TCL_MAX_WARN_LEN]; va_start(argList, format); - vsnprintf(buf, sizeof(buf), format, argList); + _vsnprintf(buf, sizeof(buf), format, argList); msgString[TCL_MAX_WARN_LEN-1] = L'\0'; MultiByteToWideChar(CP_UTF8, 0, buf, -1, msgString, TCL_MAX_WARN_LEN); @@ -820,19 +822,15 @@ PanicMessageBox( if (msgString[TCL_MAX_WARN_LEN-1] != L'\0') { memcpy(msgString + (TCL_MAX_WARN_LEN - 5), L" ...", 5 * sizeof(WCHAR)); } + if (IsDebuggerPresent()) { + OutputDebugStringW(msgString); + } else { MessageBeep(MB_ICONEXCLAMATION); MessageBoxW(NULL, msgString, L"Fatal Error", MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND); - /* try to trigger the debugger */ -# ifdef __GNUC__ - __builtin_trap(); -# endif -# ifdef _MSC_VER - DebugBreak(); -# endif - ExitProcess(1); + } } - + /* *--------------------------------------------------------------------------- * @@ -862,7 +860,7 @@ TclpFindExecutable( * create this process. Only if it is NULL, install a new panic handler. */ if (argv0 == NULL) { - Tcl_SetPanicProc(PanicMessageBox); + Tcl_SetPanicProc(tclWinDebugPanic); } #ifdef UNICODE diff --git a/win/tclWinInt.h b/win/tclWinInt.h index 0f6b572..f2e40d4 100644 --- a/win/tclWinInt.h +++ b/win/tclWinInt.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: tclWinInt.h,v 1.37.2.1 2010/10/20 01:50:19 kennykb Exp $ + * RCS: @(#) $Id: tclWinInt.h,v 1.38 2010/10/12 10:21:55 nijtmans Exp $ */ #ifndef _TCLWININT diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index d9f56cb..ab00b0f 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.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: tclWinPipe.c,v 1.83.2.2 2010/10/20 01:50:19 kennykb Exp $ + * RCS: @(#) $Id: tclWinPipe.c,v 1.86 2011/01/25 22:33:56 nijtmans Exp $ */ #include "tclWinInt.h" @@ -1574,7 +1574,6 @@ TclpCreateCommandChannel( Tcl_Pid *pidPtr) /* An array of process identifiers. */ { char channelName[16 + TCL_INTEGER_SPACE]; - int channelId; DWORD id; PipeInfo *infoPtr = (PipeInfo *) ckalloc((unsigned) sizeof(PipeInfo)); @@ -1593,20 +1592,6 @@ TclpCreateCommandChannel( infoPtr->writeError = 0; infoPtr->channel = NULL; - /* - * Use one of the fds associated with the channel as the channel id. - */ - - if (readFile) { - channelId = (int) ((WinFile *) readFile)->handle; - } else if (writeFile) { - channelId = (int) ((WinFile *) writeFile)->handle; - } else if (errorFile) { - channelId = (int) ((WinFile *) errorFile)->handle; - } else { - channelId = 0; - } - infoPtr->validMask = 0; infoPtr->threadId = Tcl_GetCurrentThread(); @@ -1647,7 +1632,7 @@ TclpCreateCommandChannel( * unique, in case channels share handles (stdin/stdout). */ - wsprintfA(channelName, "file%lx", infoPtr); + sprintf(channelName, "file%Ix", (size_t) infoPtr); infoPtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName, infoPtr, infoPtr->validMask); diff --git a/win/tclWinPort.h b/win/tclWinPort.h index fdede5b..22d523e 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.2 2010/12/01 16:42:38 kennykb Exp $ + * RCS: @(#) $Id: tclWinPort.h,v 1.63 2010/11/16 14:57:07 nijtmans Exp $ */ #ifndef _TCLWINPORT diff --git a/win/tclWinReg.c b/win/tclWinReg.c index f59ee23..22a8f72 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.2 2010/12/01 16:42:38 kennykb Exp $ + * RCS: @(#) $Id: tclWinReg.c,v 1.57 2011/01/25 22:33:56 nijtmans Exp $ */ #undef STATIC_BUILD @@ -1417,7 +1417,7 @@ BroadcastValue( Tcl_Obj *const objv[]) /* Argument values. */ { LRESULT result; - DWORD sendResult; + DWORD_PTR sendResult; UINT timeout = 3000; int len; const char *str; diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index 2f8cbd9..986025d 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -11,7 +11,7 @@ * * Serial functionality implemented by Rolf.Schroedter@dlr.de * - * RCS: @(#) $Id: tclWinSerial.c,v 1.44 2010/09/13 14:20:38 nijtmans Exp $ + * RCS: @(#) $Id: tclWinSerial.c,v 1.45 2011/01/25 22:33:56 nijtmans Exp $ */ #include "tclWinInt.h" @@ -1503,7 +1503,7 @@ TclWinOpenSerialChannel( * are shared between multiple channels (stdin/stdout). */ - wsprintfA(channelName, "file%lx", (int) infoPtr); + sprintf(channelName, "file%Ix", (size_t) infoPtr); infoPtr->channel = Tcl_CreateChannel(&serialChannelType, channelName, infoPtr, permissions); diff --git a/win/tclWinSock.c b/win/tclWinSock.c index ec2c4eb..2e384ee 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.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: tclWinSock.c,v 1.74.2.6 2010/12/16 01:42:19 kennykb Exp $ + * RCS: @(#) $Id: tclWinSock.c,v 1.82 2011/01/25 22:33:56 nijtmans Exp $ * * ----------------------------------------------------------------------- * @@ -1050,18 +1050,18 @@ CreateSocket( TclWinConvertWSAError((DWORD) WSAGetLastError()); continue; } - + /* * Win-NT has a misfeature that sockets are inherited in child * processes by default. Turn off the inherit bit. */ - + SetHandleInformation((HANDLE) sock, HANDLE_FLAG_INHERIT, 0); - + /* * Set kernel space buffering */ - + TclSockMinimumBuffers((ClientData)sock, TCP_BUFFER_SIZE); /* @@ -1103,34 +1103,34 @@ CreateSocket( chosenport = ntohs(sockname.sa4.sin_port); } } - + /* * Set the maximum number of pending connect requests to the max value * allowed on each platform (Win32 and Win32s may be different, and * there may be differences between TCP/IP stacks). */ - + if (listen(sock, SOMAXCONN) == SOCKET_ERROR) { TclWinConvertWSAError((DWORD) WSAGetLastError()); closesocket(sock); continue; } - + if (infoPtr == NULL) { /* * Add this socket to the global list of sockets. */ - + infoPtr = NewSocketInfo(sock); fds = infoPtr->sockets; - + /* * Set up the select mask for connection request events. */ - + infoPtr->selectEvents = FD_ACCEPT; infoPtr->watchEvents |= FD_ACCEPT; - + } else { newfds = (TcpFdList *) ckalloc((unsigned) sizeof(TcpFdList)); memset(newfds, (int) 0, sizeof(TcpFdList)); @@ -1159,7 +1159,7 @@ CreateSocket( TclWinConvertWSAError((DWORD) WSAGetLastError()); continue; } - + /* * Win-NT has a misfeature that sockets are inherited in child * processes by default. Turn off the inherit bit. @@ -1170,13 +1170,13 @@ CreateSocket( /* * Set kernel space buffering */ - + TclSockMinimumBuffers((ClientData)sock, TCP_BUFFER_SIZE); - + /* * Try to bind to a local port. */ - + if (bind(sock, myaddrPtr->ai_addr, myaddrPtr->ai_addrlen) == SOCKET_ERROR) { TclWinConvertWSAError((DWORD) WSAGetLastError()); @@ -1197,14 +1197,14 @@ CreateSocket( /* * Attempt to connect to the remote socket. */ - + if (connect(sock, addrPtr->ai_addr, addrPtr->ai_addrlen) == SOCKET_ERROR) { TclWinConvertWSAError((DWORD) WSAGetLastError()); if (Tcl_GetErrno() != EWOULDBLOCK) { goto looperror; } - + /* * The connection is progressing in the background. */ @@ -1227,14 +1227,14 @@ CreateSocket( /* * Add this socket to the global list of sockets. */ - + infoPtr = NewSocketInfo(sock); - + /* * Set up the select mask for read/write events. If the * connect attempt has not completed, include connect events. */ - + infoPtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE; if (asyncConnect) { infoPtr->flags |= SOCKET_ASYNC_CONNECT; @@ -1252,11 +1252,11 @@ CreateSocket( * Register for interest in events in the select mask. Note that this * automatically places the socket into non-blocking mode. */ - + if (infoPtr != NULL) { ioctlsocket(sock, (long) FIONBIO, &flag); SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, (LPARAM) infoPtr); - + return infoPtr; } @@ -1455,7 +1455,7 @@ Tcl_OpenTcpClient( return NULL; } - wsprintfA(channelName, "sock%d", infoPtr->sockets->fd); + sprintf(channelName, "sock%Id", (size_t) infoPtr->sockets->fd); infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, infoPtr, (TCL_READABLE | TCL_WRITABLE)); @@ -1520,7 +1520,7 @@ Tcl_MakeTcpClientChannel( SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, (LPARAM) infoPtr); - wsprintfA(channelName, "sock%d", infoPtr->sockets->fd); + sprintf(channelName, "sock%Id", (size_t) infoPtr->sockets->fd); infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, infoPtr, (TCL_READABLE | TCL_WRITABLE)); Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto crlf"); @@ -1573,7 +1573,7 @@ Tcl_OpenTcpServer( infoPtr->acceptProc = acceptProc; infoPtr->acceptProcData = acceptProcData; - wsprintfA(channelName, "sock%d", infoPtr->sockets->fd); + sprintf(channelName, "sock%Id", (size_t) infoPtr->sockets->fd); infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, infoPtr, 0); @@ -1679,7 +1679,7 @@ TcpAccept( SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, (LPARAM) newInfoPtr); - wsprintfA(channelName, "sock%d", newInfoPtr->sockets->fd); + sprintf(channelName, "sock%Id", (size_t) newInfoPtr->sockets->fd); newInfoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, newInfoPtr, (TCL_READABLE | TCL_WRITABLE)); if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-translation", @@ -2171,7 +2171,7 @@ TcpGetOptionProc( address sockname; socklen_t size; int found = 0; - + if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-sockname"); Tcl_DStringStartSublist(dsPtr); @@ -2182,11 +2182,11 @@ TcpGetOptionProc( if (getsockname(sock, &(sockname.sa), &size) >= 0) { int flags = reverseDNS; found = 1; - + getnameinfo(&sockname.sa, size, host, sizeof(host), NULL, 0, NI_NUMERICHOST); Tcl_DStringAppendElement(dsPtr, host); - + /* * We don't want to resolve INADDR_ANY and sin6addr_any; they * can sometimes cause problems (and never have a name). @@ -2228,7 +2228,7 @@ TcpGetOptionProc( return TCL_ERROR; } } - + #ifdef TCL_FEATURE_KEEPALIVE_NAGLE if (len == 0 || !strncmp(optionName, "-keepalive", len)) { int optlen; diff --git a/win/tclWinTest.c b/win/tclWinTest.c index 73aaaae..3e6c6e3 100644 --- a/win/tclWinTest.c +++ b/win/tclWinTest.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: tclWinTest.c,v 1.27.2.1 2010/10/20 01:50:19 kennykb Exp $ + * RCS: @(#) $Id: tclWinTest.c,v 1.29 2010/10/12 10:21:55 nijtmans Exp $ */ #ifndef USE_TCL_STUBS diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c index 7154496..8c1d2f8 100644 --- a/win/tclWinThrd.c +++ b/win/tclWinThrd.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: tclWinThrd.c,v 1.53 2010/06/16 14:49:51 nijtmans Exp $ + * RCS: @(#) $Id: tclWinThrd.c,v 1.54 2011/01/25 22:33:56 nijtmans Exp $ */ #include "tclWinInt.h" @@ -263,7 +263,7 @@ TclpThreadExit( Tcl_ThreadId Tcl_GetCurrentThread(void) { - return (Tcl_ThreadId) GetCurrentThreadId(); + return (Tcl_ThreadId)(size_t)GetCurrentThreadId(); } /* |