diff options
| author | Kevin B Kenny <kennykb@acm.org> | 2010-12-11 18:39:27 (GMT) |
|---|---|---|
| committer | Kevin B Kenny <kennykb@acm.org> | 2010-12-11 18:39:27 (GMT) |
| commit | fbefb585cb3784a6afcfa775c2c0554e4036f907 (patch) | |
| tree | fe86a2d97e77053d9c344bfd81ded64a9bdc7f9f | |
| parent | 921c2612861d68b7b4eee66736379431ac081f30 (diff) | |
| download | tcl-fbefb585cb3784a6afcfa775c2c0554e4036f907.zip tcl-fbefb585cb3784a6afcfa775c2c0554e4036f907.tar.gz tcl-fbefb585cb3784a6afcfa775c2c0554e4036f907.tar.bz2 | |
merge
46 files changed, 4258 insertions, 2797 deletions
@@ -1,37 +1,135 @@ +2010-12-10 Jan Nijtmans <nijtmans@users.sf.net> + + * generic/tcl.h: [Bug 3129448]: Possible over-allocation on + * generic/tclCkalloc.c: 64-bit platforms, part 2 + * generic/tclCompile.c: + * generic/tclHash.c: + * generic/tclInt.h: + * generic/tclIO.h: + * generic/tclProc.c: + +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. + +2010-12-10 Jan Nijtmans <nijtmans@users.sf.net> + + * generic/tclBinary.c: Fix gcc -Wextra warning: missing initializer + * generic/tclCmdAH.c: + * generic/tclCmdIL.c: + * generic/tclCmdMZ.c: + * generic/tclDictObj.c: + * 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/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: + * unix/tclUnixSock.c: + +2010-12-09 Donal K. Fellows <dkf@users.sf.net> + + * tests/fCmd.test: Improve sanity of constraints now that we don't + support anything before Windows 2000. + + * generic/tclCmdAH.c (TclInitFileCmd, TclMakeFileCommandSafe, ...): + Break up [file] into an ensemble. Note that the ensemble is safe in + itself, but the majority of its subcommands are not. + * generic/tclFCmd.c (FileCopyRename,TclFileDeleteCmd,TclFileAttrsCmd) + (TclFileMakeDirsCmd): Adjust these subcommand implementations to work + inside an ensemble. + (TclFileLinkCmd, TclFileReadLinkCmd, TclFileTemporaryCmd): Move these + subcommand implementations from tclCmdAH.c, where they didn't really + belong. + * generic/tclIOCmd.c (TclChannelNamesCmd): Move to more appropriate + source file. + * generic/tclEnsemble.c (TclMakeEnsemble): Start of code to make + partially-safe ensembles. Currently does not function as expected due + to various shortcomings in how safe interpreters are constructed. + * tests/cmdAH.test, tests/fCmd.test, tests/interp.test: Test updates + to take into account systematization of error messages. + + * tests/append.test, tests/appendComp.test: Clean up tests so that + they don't leave things in the global environment (detected when doing + -singleproc testing). + +2010-12-07 Donal K. Fellows <dkf@users.sf.net> + + * tests/fCmd.test, tests/safe.test, tests/uplevel.test, + * tests/upvar.test, tests/var.test: Convert more tests to tcltest2 and + factor them to be easier to understand. + + * generic/tclStrToD.c: Tidy up code so that more #ifdef-fery is + quarantined at the front of the file and function headers follow the + modern Tcl style. + +2010-12-06 Jan Nijtmans <nijtmans@users.sf.net> + + * generic/tclBinary.c: [Bug 3129448]: Possible over-allocation on + * generic/tclCkalloc.c: 64-bit platforms. + * generic/tclTrace.c + +2010-12-05 Jan Nijtmans <nijtmans@users.sf.net> + + * unix/tcl.m4: [Patch 3116490]: Cross-compile support for unix + * unix/configure: (autoconf-2.59) + +2010-12-03 Jeff Hobbs <jeffh@ActiveState.com> + + * generic/tclUtil.c (TclReToGlob): Add extra check for multiple inner + *s that leads to poor recursive glob matching, defer to original RE + instead. tclbench RE var backtrack. + +2010-12-03 Jan Nijtmans <nijtmans@users.sf.net> + + * generic/tclUtil.c: Silence gcc warning when using -Wwrite-strings + * generic/tclStrToD.c: Silence gcc warning for non-IEEE platforms + * win/Makefile.in: [Patch 3116490]: Cross-compile Tcl mingw32 on unix + * win/tcl.m4: This makes it possible to cross-compile Tcl/Tk for + * win/configure.in: Windows (either 32-bit or 64-bit) out-of-the-box + * win/configure: on UNIX, using mingw-w64 build tools (If Itcl, + tdbc and Thread take over the latest tcl.m4, they can do that too). + 2010-12-01 Kevin B. Kenny <kennykb@acm.org> * generic/tclStrToD.c (SetPrecisionLimits, TclDoubleDigits): - Added meaningless initialization of 'i', 'ilim' and 'ilim1' - to silence warnings from the C compiler about possible use of - uninitialized variables, Added a panic to the 'switch' that - assigns them, to assert that the 'default' case is impossible. - [Bug 3124675] + [Bug 3124675]: Added meaningless initialization of 'i', 'ilim' and + 'ilim1' to silence warnings from the C compiler about possible use of + uninitialized variables, Added a panic to the 'switch' that assigns + them, to assert that the 'default' case is impossible. 2010-12-01 Jan Nijtmans <nijtmans@users.sf.net> - * generic/tclBasic.c: fix gcc 64-bit warnings: cast from pointer to + * generic/tclBasic.c: Fix gcc 64-bit warnings: cast from pointer to * generic/tclHash.c: integer of different size. * generic/tclTest.c: * generic/tclThreadTest.c: - * generic/tclStrToD.c: fix gcc(-4.5.2) warning: 'static' is not at + * generic/tclStrToD.c: Fix gcc(-4.5.2) warning: 'static' is not at beginning of declaration. - * generic/tclPanic.c: Allow Tcl_Panic() to enter the debugger on win32 - * generic/tclCkalloc.c: use Tcl_Panic() in stead of duplicating the code. + * generic/tclPanic.c: Allow Tcl_Panic() to enter the debugger on win32 + * generic/tclCkalloc.c: Use Tcl_Panic() in stead of duplicating the + code. 2010-11-30 Jeff Hobbs <jeffh@ActiveState.com> * generic/tclInt.decls, generic/tclInt.h, generic/tclIntDecls.h: * generic/tclStubInit.c: TclFormatInt restored at slot 24 * generic/tclUtil.c (TclFormatInt): restore TclFormatInt func from - 2005-07-05 macro-ization. Benchmarks indicate it is faster, as a - key int->string routine (e.g. int-indexed arrays). + 2005-07-05 macro-ization. Benchmarks indicate it is faster, as a key + int->string routine (e.g. int-indexed arrays). 2010-11-29 Alexandre Ferrieux <ferrieux@users.sourceforge.net> * generic/tclBasic.c: Patch by Miguel, providing a - [::tcl::unsupported::inject coroname command args], which prepends - ("injects") arbitrary code to a suspended coro's future resumption. - Neat for debugging complex coros without heavy instrumentation. + [::tcl::unsupported::inject coroname command args], which prepends + ("injects") arbitrary code to a suspended coro's future resumption. + Neat for debugging complex coros without heavy instrumentation. 2010-11-29 Kevin B. Kenny <kennykb@acm.org> @@ -44,18 +142,18 @@ * tests/util.test: * unix/Makefile.in: * win/Makefile.in: - * win/makefile.vc: Rewrite of Tcl_PrintDouble and TclDoubleDigits - that (a) fixes a severe performance problem with floating point - shimmering reported by Karl Lehenbauer, (b) allows TclDoubleDigits - to generate the digit strings for 'e' and 'f' format, so that it - can be used for tcl_precision != 0 (and possibly later for [format]), - (c) fixes [Bug 3120139] by making TclPrintDouble inherently - locale-independent, (d) adds test cases to util.test for - correct rounding in difficult cases of TclDoubleDigits where fixed- - precision results are requested. (e) adds test cases to util.test for - the controversial aspects of [Bug 3105247]. As a side effect, two - more modules from libtommath (bn_mp_set_int.c and bn_mp_init_set_int.c) - are brought into the build, since the new code uses them. + * win/makefile.vc: Rewrite of Tcl_PrintDouble and TclDoubleDigits that + (a) fixes a severe performance problem with floating point shimmering + reported by Karl Lehenbauer, (b) allows TclDoubleDigits to generate + the digit strings for 'e' and 'f' format, so that it can be used for + tcl_precision != 0 (and possibly later for [format]), (c) fixes [Bug + 3120139] by making TclPrintDouble inherently locale-independent, (d) + adds test cases to util.test for correct rounding in difficult cases + of TclDoubleDigits where fixed- precision results are requested. (e) + adds test cases to util.test for the controversial aspects of [Bug + 3105247]. As a side effect, two more modules from libtommath + (bn_mp_set_int.c and bn_mp_init_set_int.c) are brought into the build, + since the new code uses them. * generic/tclIntDecls.h: * generic/tclStubInit.c: @@ -73,16 +171,16 @@ 2010-11-19 Jan Nijtmans <nijtmans@users.sf.net> - * win/tclWin32Dll.c: fix gcc warnings: unused variable 'registration' + * win/tclWin32Dll.c: Fix gcc warnings: unused variable 'registration' * win/tclWinChan.c: * win/tclWinFCmd.c: 2010-11-18 Jan Nijtmans <nijtmans@users.sf.net> - * win/tclAppInit.c: [FRQ 491789]: "setargv() doesn't support a - unicode cmdline" now implemented for cygwin and mingw32 too. - * tests/main.test: No longer disable tests Tcl_Main-1.4 and 1.6 - on Windows, because those now work on all supported platforms. + * win/tclAppInit.c: [FRQ 491789]: "setargv() doesn't support a unicode + cmdline" now implemented for cygwin and mingw32 too. + * tests/main.test: No longer disable tests Tcl_Main-1.4 and 1.6 on + Windows, because those now work on all supported platforms. * win/configure.in: Set NO_VIZ=1 when zlib is compiled in libtcl, this resolves compiler warnings in 64-bit and static builds. * win/configure (regenerated) diff --git a/generic/tcl.h b/generic/tcl.h index 76e7c86..27ed895 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 2010/08/14 20:58:30 nijtmans Exp $ + * RCS: @(#) $Id: tcl.h,v 1.308.2.1 2010/12/11 18:39:28 kennykb Exp $ */ #ifndef _TCL @@ -1165,7 +1165,7 @@ struct Tcl_HashEntry { int words[1]; /* Multiple integer words for key. The actual * size will be as large as necessary for this * table's keys. */ - char string[4]; /* String for key. The actual size will be as + char string[1]; /* String for key. The actual size will be as * large as needed to hold the key. */ } key; /* MUST BE LAST FIELD IN RECORD!! */ }; diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 90d5460..816f0f6 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.5 2010/12/01 16:42:34 kennykb Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.465.2.6 2010/12/11 18:39:28 kennykb Exp $ */ #include "tclInt.h" @@ -276,7 +276,6 @@ static const CmdInfo builtInCmds[] = { {"fblocked", Tcl_FblockedObjCmd, NULL, NULL, 1}, {"fconfigure", Tcl_FconfigureObjCmd, NULL, NULL, 0}, {"fcopy", Tcl_FcopyObjCmd, NULL, NULL, 1}, - {"file", Tcl_FileObjCmd, NULL, NULL, 0}, {"fileevent", Tcl_FileEventObjCmd, NULL, NULL, 1}, {"flush", Tcl_FlushObjCmd, NULL, NULL, 1}, {"gets", Tcl_GetsObjCmd, NULL, NULL, 1}, @@ -783,15 +782,17 @@ Tcl_CreateInterp(void) } /* - * Create the "array", "binary", "chan", "dict", "info" and "string" - * ensembles. Note that all these commands (and their subcommands that are - * not present in the global namespace) are wholly safe. + * Create the "array", "binary", "chan", "dict", "file", "info" and + * "string" ensembles. Note that all these commands (and their subcommands + * that are not present in the global namespace) are wholly safe *except* + * for "file". */ TclInitArrayCmd(interp); TclInitBinaryCmd(interp); TclInitChanCmd(interp); TclInitDictCmd(interp); + TclInitFileCmd(interp); TclInitInfoCmd(interp); TclInitStringCmd(interp); TclInitPrefixCmd(interp); @@ -1014,6 +1015,7 @@ TclHideUnsafeCommands( Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name); } } + TclMakeFileCommandSafe(interp); /* Ugh! */ return TCL_OK; } diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 5a92f8d..165da34 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.1 2010/12/01 16:42:34 kennykb Exp $ + * RCS: @(#) $Id: tclBinary.c,v 1.66.2.2 2010/12/11 18:39:28 kennykb Exp $ */ #include "tclInt.h" @@ -174,13 +174,13 @@ typedef struct ByteArray { * array. */ int allocated; /* The amount of space actually allocated * minus 1 byte. */ - unsigned char bytes[4]; /* The array of bytes. The actual size of this + unsigned char bytes[1]; /* The array of bytes. The actual size of this * field depends on the 'allocated' field * above. */ } ByteArray; #define BYTEARRAY_SIZE(len) \ - ((unsigned) (sizeof(ByteArray) - 4 + (len))) + ((unsigned) (TclOffset(ByteArray, bytes) + (len))) #define GET_BYTEARRAY(objPtr) \ ((ByteArray *) (objPtr)->internalRep.otherValuePtr) #define SET_BYTEARRAY(objPtr, baPtr) \ @@ -691,29 +691,30 @@ TclAppendBytesToByteArray( *---------------------------------------------------------------------- */ +static const EnsembleImplMap binaryMap[] = { +{ "format", BinaryFormatCmd, NULL, NULL, NULL, 0 }, +{ "scan", BinaryScanCmd, NULL, NULL, NULL, 0 }, +{ "encode", NULL, NULL, NULL, NULL, 0 }, +{ "decode", NULL, NULL, NULL, NULL, 0 }, +{ NULL, NULL, NULL, NULL, NULL, 0 } +}; +static const EnsembleImplMap encodeMap[] = { +{ "hex", BinaryEncodeHex, NULL, NULL, (ClientData)HexDigits, 0 }, +{ "uuencode", BinaryEncode64, NULL, NULL, (ClientData)UueDigits, 0 }, +{ "base64", BinaryEncode64, NULL, NULL, (ClientData)B64Digits, 0 }, +{ NULL, NULL, NULL, NULL, NULL, 0 } +}; +static const EnsembleImplMap decodeMap[] = { +{ "hex", BinaryDecodeHex, NULL, NULL, NULL, 0 }, +{ "uuencode", BinaryDecodeUu, NULL, NULL, NULL, 0 }, +{ "base64", BinaryDecode64, NULL, NULL, NULL, 0 }, +{ NULL, NULL, NULL, NULL, NULL, 0 } +}; + Tcl_Command TclInitBinaryCmd( Tcl_Interp *interp) { - const EnsembleImplMap binaryMap[] = { - { "format", BinaryFormatCmd, NULL, NULL ,NULL }, - { "scan", BinaryScanCmd, NULL,NULL ,NULL }, - { "encode", NULL, NULL, NULL, NULL }, - { "decode", NULL, NULL, NULL, NULL }, - { NULL, NULL, NULL, NULL, NULL } - }; - const EnsembleImplMap encodeMap[] = { - { "hex", BinaryEncodeHex, NULL, NULL, (ClientData)HexDigits }, - { "uuencode", BinaryEncode64, NULL, NULL, (ClientData)UueDigits }, - { "base64", BinaryEncode64, NULL, NULL, (ClientData)B64Digits }, - { NULL, NULL, NULL, NULL, NULL } - }; - const EnsembleImplMap decodeMap[] = { - { "hex", BinaryDecodeHex, NULL, NULL, NULL }, - { "uuencode", BinaryDecodeUu, NULL, NULL, NULL }, - { "base64", BinaryDecode64, NULL, NULL, NULL }, - { NULL, NULL, NULL, NULL, NULL } - }; Tcl_Command binaryEnsemble; binaryEnsemble = TclMakeEnsemble(interp, "binary", binaryMap); diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 1ef646c..4ea1c78 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.2 2010/12/01 16:42:34 kennykb Exp $ + * RCS: @(#) $Id: tclCkalloc.c,v 1.38.4.3 2010/12/11 18:39:28 kennykb Exp $ */ #include "tclInt.h" @@ -32,12 +32,12 @@ typedef struct MemTag { int refCount; /* Number of mem_headers referencing this * tag. */ - char string[4]; /* Actual size of string will be as large as + char string[1]; /* Actual size of string will be as large as * needed for actual tag. This must be the * last field in the structure. */ } MemTag; -#define TAG_SIZE(bytesInString) ((unsigned) sizeof(MemTag) + bytesInString - 3) +#define TAG_SIZE(bytesInString) ((unsigned) ((TclOffset(MemTag, string) + 1) + bytesInString)) static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers (set * by "memory tag" command). */ @@ -185,7 +185,7 @@ TclDumpMemoryInfo(ClientData clientData, int flags) maximum_malloc_packets, maximum_bytes_malloced); if (flags == 0) { - fprintf((FILE *)clientData, buf); + fprintf((FILE *)clientData, "%s", buf); } else { /* Assume objPtr to append to */ Tcl_AppendToObj((Tcl_Obj *) clientData, buf, -1); @@ -814,6 +814,7 @@ MemoryCmd( FILE *fileP; Tcl_DString buffer; int result; + size_t len; if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], @@ -909,9 +910,10 @@ MemoryCmd( if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) { TclpFree((char *) curTagPtr); } - curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(strlen(argv[2]))); + len = strlen(argv[2]); + curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(len)); curTagPtr->refCount = 0; - strcpy(curTagPtr->string, argv[2]); + memcpy(curTagPtr->string, argv[2], len + 1); return TCL_OK; } if (strcmp(argv[1],"trace") == 0) { diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 2f52595..2d4fc83 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -10,12 +10,11 @@ * 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.1 2010/09/25 14:51:12 kennykb Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.126.2.2 2010/12/11 18:39:28 kennykb Exp $ */ #include "tclInt.h" #include <locale.h> -#include "tclFileSystem.h" /* * The state structure used by [foreach]. Note that the actual structure has @@ -46,8 +45,6 @@ static int CheckAccess(Tcl_Interp *interp, Tcl_Obj *pathPtr, static int EncodingDirsObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int FileTempfileCmd(Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); static inline int ForeachAssignments(Tcl_Interp *interp, struct ForeachState *statePtr); static inline void ForeachCleanup(Tcl_Interp *interp, @@ -65,6 +62,32 @@ static Tcl_NRPostProc ForNextCallback; static Tcl_NRPostProc ForPostNextCallback; static Tcl_NRPostProc ForeachLoopStep; static Tcl_NRPostProc EvalCmdErrMsg; + +static Tcl_ObjCmdProc FileAttrAccessTimeCmd; +static Tcl_ObjCmdProc FileAttrIsDirectoryCmd; +static Tcl_ObjCmdProc FileAttrIsExecutableCmd; +static Tcl_ObjCmdProc FileAttrIsExistingCmd; +static Tcl_ObjCmdProc FileAttrIsFileCmd; +static Tcl_ObjCmdProc FileAttrIsOwnedCmd; +static Tcl_ObjCmdProc FileAttrIsReadableCmd; +static Tcl_ObjCmdProc FileAttrIsWritableCmd; +static Tcl_ObjCmdProc FileAttrLinkStatCmd; +static Tcl_ObjCmdProc FileAttrModifyTimeCmd; +static Tcl_ObjCmdProc FileAttrSizeCmd; +static Tcl_ObjCmdProc FileAttrStatCmd; +static Tcl_ObjCmdProc FileAttrTypeCmd; +static Tcl_ObjCmdProc FilesystemSeparatorCmd; +static Tcl_ObjCmdProc FilesystemVolumesCmd; +static Tcl_ObjCmdProc PathDirNameCmd; +static Tcl_ObjCmdProc PathExtensionCmd; +static Tcl_ObjCmdProc PathFilesystemCmd; +static Tcl_ObjCmdProc PathJoinCmd; +static Tcl_ObjCmdProc PathNativeNameCmd; +static Tcl_ObjCmdProc PathNormalizeCmd; +static Tcl_ObjCmdProc PathRootNameCmd; +static Tcl_ObjCmdProc PathSplitCmd; +static Tcl_ObjCmdProc PathTailCmd; +static Tcl_ObjCmdProc PathTypeCmd; /* *---------------------------------------------------------------------- @@ -882,13 +905,14 @@ ExprCallback( /* *---------------------------------------------------------------------- * - * Tcl_FileObjCmd -- + * TclInitFileCmd -- * - * This procedure is invoked to process the "file" Tcl command. See the - * user documentation for details on what it does. PLEASE NOTE THAT THIS - * FAILS WITH FILENAMES AND PATHS WITH EMBEDDED NULLS. With the - * object-based Tcl_FS APIs, the above NOTE may no longer be true. In any - * case this assertion should be tested. + * This function builds the "file" Tcl command ensemble. See the user + * documentation for details on what that ensemble does. + * + * PLEASE NOTE THAT THIS FAILS WITH FILENAMES AND PATHS WITH EMBEDDED + * NULLS. With the object-based Tcl_FS APIs, the above NOTE may no longer + * be true. In any case this assertion should be tested. * * Results: * A standard Tcl result. @@ -899,570 +923,1160 @@ ExprCallback( *---------------------------------------------------------------------- */ - /* ARGSUSED */ -int -Tcl_FileObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +Tcl_Command +TclInitFileCmd( + Tcl_Interp *interp) { - int index, value; - Tcl_StatBuf buf; - struct utimbuf tval; - /* - * This list of constants should match the fileOption string array below. + * Note that most subcommands are unsafe because either they manipulate + * the native filesystem or because they reveal information about the + * native filesystem. */ - static const char *const fileOptions[] = { - "atime", "attributes", "channels", "copy", - "delete", - "dirname", "executable", "exists", "extension", - "isdirectory", "isfile", "join", "link", - "lstat", "mtime", "mkdir", "nativename", - "normalize", "owned", - "pathtype", "readable", "readlink", "rename", - "rootname", "separator", "size", "split", - "stat", "system", "tail", "tempfile", - "type", "volumes", "writable", - NULL + static const EnsembleImplMap initMap[] = { + {"atime", FileAttrAccessTimeCmd, NULL, NULL, NULL, 0}, + {"attributes", TclFileAttrsCmd, NULL, NULL, NULL, 0}, + {"channels", TclChannelNamesCmd, NULL, NULL, NULL, 0}, + {"copy", TclFileCopyCmd, NULL, NULL, NULL, 0}, + {"delete", TclFileDeleteCmd, NULL, NULL, NULL, 0}, + {"dirname", PathDirNameCmd, NULL, NULL, NULL, 0}, + {"executable", FileAttrIsExecutableCmd, NULL, NULL, NULL, 0}, + {"exists", FileAttrIsExistingCmd, NULL, NULL, NULL, 0}, + {"extension", PathExtensionCmd, NULL, NULL, NULL, 0}, + {"isdirectory", FileAttrIsDirectoryCmd, NULL, NULL, NULL, 0}, + {"isfile", FileAttrIsFileCmd, NULL, NULL, NULL, 0}, + {"join", PathJoinCmd, NULL, NULL, NULL, 0}, + {"link", TclFileLinkCmd, NULL, NULL, NULL, 0}, + {"lstat", FileAttrLinkStatCmd, NULL, NULL, NULL, 0}, + {"mtime", FileAttrModifyTimeCmd, NULL, NULL, NULL, 0}, + {"mkdir", TclFileMakeDirsCmd, NULL, NULL, NULL, 0}, + {"nativename", PathNativeNameCmd, NULL, NULL, NULL, 0}, + {"normalize", PathNormalizeCmd, NULL, NULL, NULL, 0}, + {"owned", FileAttrIsOwnedCmd, NULL, NULL, NULL, 0}, + {"pathtype", PathTypeCmd, NULL, NULL, NULL, 0}, + {"readable", FileAttrIsReadableCmd, NULL, NULL, NULL, 0}, + {"readlink", TclFileReadLinkCmd, NULL, NULL, NULL, 0}, + {"rename", TclFileRenameCmd, NULL, NULL, NULL, 0}, + {"rootname", PathRootNameCmd, NULL, NULL, NULL, 0}, + {"separator", FilesystemSeparatorCmd, NULL, NULL, NULL, 0}, + {"size", FileAttrSizeCmd, NULL, NULL, NULL, 0}, + {"split", PathSplitCmd, NULL, NULL, NULL, 0}, + {"stat", FileAttrStatCmd, NULL, NULL, NULL, 0}, + {"system", PathFilesystemCmd, NULL, NULL, NULL, 0}, + {"tail", PathTailCmd, NULL, NULL, NULL, 0}, + {"tempfile", TclFileTemporaryCmd, NULL, NULL, NULL, 0}, + {"type", FileAttrTypeCmd, NULL, NULL, NULL, 0}, + {"volumes", FilesystemVolumesCmd, NULL, NULL, NULL, 0}, + {"writable", FileAttrIsWritableCmd, NULL, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} }; - enum options { - FCMD_ATIME, FCMD_ATTRIBUTES, FCMD_CHANNELS, FCMD_COPY, - FCMD_DELETE, - FCMD_DIRNAME, FCMD_EXECUTABLE, FCMD_EXISTS, FCMD_EXTENSION, - FCMD_ISDIRECTORY, FCMD_ISFILE, FCMD_JOIN, FCMD_LINK, - FCMD_LSTAT, FCMD_MTIME, FCMD_MKDIR, FCMD_NATIVENAME, - FCMD_NORMALIZE, FCMD_OWNED, - FCMD_PATHTYPE, FCMD_READABLE, FCMD_READLINK, FCMD_RENAME, - FCMD_ROOTNAME, FCMD_SEPARATOR, FCMD_SIZE, FCMD_SPLIT, - FCMD_STAT, FCMD_SYSTEM, FCMD_TAIL, FCMD_TEMPFILE, - FCMD_TYPE, FCMD_VOLUMES, FCMD_WRITABLE + return TclMakeEnsemble(interp, "file", initMap); +} + +/* + *---------------------------------------------------------------------- + * + * TclMakeFileCommandSafe -- + * + * This function hides the unsafe subcommands of the "file" Tcl command + * ensemble. It must only be called from TclHideUnsafeCommands. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Adds commands to the table of hidden commands. + * + *---------------------------------------------------------------------- + */ + +int +TclMakeFileCommandSafe( + Tcl_Interp *interp) +{ + static const struct { + const char *cmdName; + int unsafe; + } unsafeInfo[] = { + {"atime", 1}, + {"attributes", 1}, + {"channels", 0}, + {"copy", 1}, + {"delete", 1}, + {"dirname", 1}, + {"executable", 1}, + {"exists", 1}, + {"extension", 1}, + {"isdirectory", 1}, + {"isfile", 1}, + {"join", 0}, + {"link", 1}, + {"lstat", 1}, + {"mtime", 1}, + {"mkdir", 1}, + {"nativename", 1}, + {"normalize", 1}, + {"owned", 1}, + {"pathtype", 0}, + {"readable", 1}, + {"readlink", 1}, + {"rename", 1}, + {"rootname", 1}, + {"separator", 0}, + {"size", 1}, + {"split", 0}, + {"stat", 1}, + {"system", 0}, + {"tail", 1}, + {"tempfile", 1}, + {"type", 1}, + {"volumes", 1}, + {"writable", 1}, + {NULL, 0} }; + int i; + Tcl_DString oldBuf, newBuf; + + Tcl_DStringInit(&oldBuf); + Tcl_DStringAppend(&oldBuf, "::tcl::file::", -1); + Tcl_DStringInit(&newBuf); + Tcl_DStringAppend(&newBuf, "tcl:file:", -1); + for (i=0 ; unsafeInfo[i].cmdName != NULL ; i++) { + if (unsafeInfo[i].unsafe) { + const char *oldName, *newName; + + Tcl_DStringSetLength(&oldBuf, 13); + oldName = Tcl_DStringAppend(&oldBuf, unsafeInfo[i].cmdName, -1); + Tcl_DStringSetLength(&newBuf, 9); + newName = Tcl_DStringAppend(&newBuf, unsafeInfo[i].cmdName, -1); + if (TclRenameCommand(interp, oldName, "___tmp") != TCL_OK + || Tcl_HideCommand(interp, "___tmp", newName) != TCL_OK) { + Tcl_Panic("problem making 'file %s' safe: %s", + unsafeInfo[i].cmdName, + Tcl_GetString(Tcl_GetObjResult(interp))); + } + } + } + Tcl_DStringFree(&oldBuf); + Tcl_DStringFree(&newBuf); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrAccessTimeCmd -- + * + * This function is invoked to process the "file atime" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May update the access time on the file, if requested by the user. + * + *---------------------------------------------------------------------- + */ - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); +static int +FileAttrAccessTimeCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_StatBuf buf; + struct utimbuf tval; + + if (objc < 2 || objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?time?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0, - &index) != TCL_OK) { + if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } + if (objc == 3) { + /* + * Need separate variable for reading longs from an object on 64-bit + * platforms. [Bug 698146] + */ - switch ((enum options) index) { + long newTime; - case FCMD_ATIME: - case FCMD_MTIME: - if ((objc < 3) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 2, objv, "name ?time?"); + if (TclGetLongFromObj(interp, objv[2], &newTime) != TCL_OK) { return TCL_ERROR; } - if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { + + tval.actime = newTime; + tval.modtime = buf.st_mtime; + + if (Tcl_FSUtime(objv[1], &tval) != 0) { + Tcl_AppendResult(interp, "could not set access time for file \"", + TclGetString(objv[1]), "\": ", Tcl_PosixError(interp), + NULL); return TCL_ERROR; } - if (objc == 4) { - /* - * Need separate variable for reading longs from an object on - * 64-bit platforms. [Bug #698146] - */ - long newTime; + /* + * Do another stat to ensure that the we return the new recognized + * atime - hopefully the same as the one we sent in. However, fs's + * like FAT don't even know what atime is. + */ - if (TclGetLongFromObj(interp, objv[3], &newTime) != TCL_OK) { - return TCL_ERROR; - } + if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { + return TCL_ERROR; + } + } - if (index == FCMD_ATIME) { - tval.actime = newTime; - tval.modtime = buf.st_mtime; - } else { /* index == FCMD_MTIME */ - tval.actime = buf.st_atime; - tval.modtime = newTime; - } + Tcl_SetObjResult(interp, Tcl_NewLongObj((long) buf.st_atime)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrModifyTimeCmd -- + * + * This function is invoked to process the "file mtime" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May update the modification time on the file, if requested by the + * user. + * + *---------------------------------------------------------------------- + */ - if (Tcl_FSUtime(objv[2], &tval) != 0) { - Tcl_AppendResult(interp, "could not set ", - (index == FCMD_ATIME ? "access" : "modification"), - " time for file \"", TclGetString(objv[2]), "\": ", - Tcl_PosixError(interp), NULL); - return TCL_ERROR; - } +static int +FileAttrModifyTimeCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_StatBuf buf; + struct utimbuf tval; - /* - * Do another stat to ensure that the we return the new recognized - * atime - hopefully the same as the one we sent in. However, fs's - * like FAT don't even know what atime is. - */ + if (objc < 2 || objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?time?"); + return TCL_ERROR; + } + if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { + return TCL_ERROR; + } + if (objc == 3) { + /* + * Need separate variable for reading longs from an object on 64-bit + * platforms. [Bug 698146] + */ - if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { - return TCL_ERROR; - } - } + long newTime; - Tcl_SetObjResult(interp, Tcl_NewLongObj((long) - (index == FCMD_ATIME ? buf.st_atime : buf.st_mtime))); - return TCL_OK; - case FCMD_ATTRIBUTES: - return TclFileAttrsCmd(interp, objc, objv); - case FCMD_CHANNELS: - if ((objc < 2) || (objc > 3)) { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + if (TclGetLongFromObj(interp, objv[2], &newTime) != TCL_OK) { return TCL_ERROR; } - return Tcl_GetChannelNamesEx(interp, - ((objc == 2) ? NULL : TclGetString(objv[2]))); - case FCMD_COPY: - return TclFileCopyCmd(interp, objc, objv); - case FCMD_DELETE: - return TclFileDeleteCmd(interp, objc, objv); - case FCMD_DIRNAME: { - Tcl_Obj *dirPtr; - - if (objc != 3) { - goto only3Args; - } - dirPtr = TclPathPart(interp, objv[2], TCL_PATH_DIRNAME); - if (dirPtr == NULL) { + + tval.actime = buf.st_atime; + tval.modtime = newTime; + + if (Tcl_FSUtime(objv[1], &tval) != 0) { + Tcl_AppendResult(interp, "could not set modification time for " + "file \"", TclGetString(objv[1]), "\": ", + Tcl_PosixError(interp), NULL); return TCL_ERROR; } - Tcl_SetObjResult(interp, dirPtr); - Tcl_DecrRefCount(dirPtr); - return TCL_OK; - } - case FCMD_EXECUTABLE: - if (objc != 3) { - goto only3Args; - } - return CheckAccess(interp, objv[2], X_OK); - case FCMD_EXISTS: - if (objc != 3) { - goto only3Args; - } - return CheckAccess(interp, objv[2], F_OK); - case FCMD_EXTENSION: { - Tcl_Obj *ext; - if (objc != 3) { - goto only3Args; - } - ext = TclPathPart(interp, objv[2], TCL_PATH_EXTENSION); - if (ext == NULL) { + /* + * Do another stat to ensure that the we return the new recognized + * mtime - hopefully the same as the one we sent in. + */ + + if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } - Tcl_SetObjResult(interp, ext); - Tcl_DecrRefCount(ext); - return TCL_OK; } - case FCMD_ISDIRECTORY: - if (objc != 3) { - goto only3Args; - } - value = 0; - if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { - value = S_ISDIR(buf.st_mode); - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); - return TCL_OK; - case FCMD_ISFILE: - if (objc != 3) { - goto only3Args; - } - value = 0; - if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { - value = S_ISREG(buf.st_mode); - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); - return TCL_OK; - case FCMD_OWNED: - if (objc != 3) { - goto only3Args; - } - value = 0; - if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { - /* - * For Windows, there are no user ids associated with a file, so - * we always return 1. - * - * TODO: use GetSecurityInfo to get the real owner of the file and - * test for equivalence to the current user. - */ -#if defined(__WIN32__) - value = 1; -#else - value = (geteuid() == buf.st_uid); -#endif - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); - return TCL_OK; - case FCMD_JOIN: { - Tcl_Obj *resObj; + Tcl_SetObjResult(interp, Tcl_NewLongObj((long) buf.st_mtime)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrLinkStatCmd -- + * + * This function is invoked to process the "file lstat" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Writes to an array named by the user. + * + *---------------------------------------------------------------------- + */ - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); - return TCL_ERROR; - } - resObj = Tcl_FSJoinToPath(NULL, objc - 2, objv + 2); - Tcl_SetObjResult(interp, resObj); - return TCL_OK; +static int +FileAttrLinkStatCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_StatBuf buf; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "name varName"); + return TCL_ERROR; + } + if (GetStatBuf(interp, objv[1], Tcl_FSLstat, &buf) != TCL_OK) { + return TCL_ERROR; } - case FCMD_LINK: { - Tcl_Obj *contents; + return StoreStatData(interp, objv[2], &buf); +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrStatCmd -- + * + * This function is invoked to process the "file stat" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Writes to an array named by the user. + * + *---------------------------------------------------------------------- + */ - if (objc < 3 || objc > 5) { - Tcl_WrongNumArgs(interp, 2, objv, "?-linktype? linkname ?target?"); - return TCL_ERROR; - } +static int +FileAttrStatCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_StatBuf buf; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "name varName"); + return TCL_ERROR; + } + if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { + return TCL_ERROR; + } + return StoreStatData(interp, objv[2], &buf); +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrTypeCmd -- + * + * This function is invoked to process the "file type" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +static int +FileAttrTypeCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_StatBuf buf; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + if (GetStatBuf(interp, objv[1], Tcl_FSLstat, &buf) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewStringObj( + GetTypeFromMode((unsigned short) buf.st_mode), -1)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrSizeCmd -- + * + * This function is invoked to process the "file size" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +FileAttrSizeCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_StatBuf buf; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) buf.st_size)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrIsDirectoryCmd -- + * + * This function is invoked to process the "file isdirectory" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +FileAttrIsDirectoryCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_StatBuf buf; + int value = 0; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + if (GetStatBuf(NULL, objv[1], Tcl_FSStat, &buf) == TCL_OK) { + value = S_ISDIR(buf.st_mode); + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrIsExecutableCmd -- + * + * This function is invoked to process the "file executable" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +FileAttrIsExecutableCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + return CheckAccess(interp, objv[1], X_OK); +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrIsExistingCmd -- + * + * This function is invoked to process the "file exists" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +FileAttrIsExistingCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + return CheckAccess(interp, objv[1], F_OK); +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrIsFileCmd -- + * + * This function is invoked to process the "file isfile" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +FileAttrIsFileCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_StatBuf buf; + int value = 0; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + if (GetStatBuf(NULL, objv[1], Tcl_FSStat, &buf) == TCL_OK) { + value = S_ISREG(buf.st_mode); + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrIsOwnedCmd -- + * + * This function is invoked to process the "file owned" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +FileAttrIsOwnedCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_StatBuf buf; + int value = 0; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + if (GetStatBuf(NULL, objv[1], Tcl_FSStat, &buf) == TCL_OK) { /* - * Index of the 'source' argument. + * For Windows, there are no user ids associated with a file, so we + * always return 1. + * + * TODO: use GetSecurityInfo to get the real owner of the file and + * test for equivalence to the current user. */ - if (objc == 5) { - index = 3; - } else { - index = 2; - } +#ifdef __WIN32__ + value = 1; +#else + value = (geteuid() == buf.st_uid); +#endif + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrIsReadableCmd -- + * + * This function is invoked to process the "file readable" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - if (objc > 3) { - int linkAction; - if (objc == 5) { - /* - * We have a '-linktype' argument. - */ - - static const char *const linkTypes[] = { - "-symbolic", "-hard", NULL - }; - if (Tcl_GetIndexFromObj(interp, objv[2], linkTypes, "switch", - 0, &linkAction) != TCL_OK) { - return TCL_ERROR; - } - if (linkAction == 0) { - linkAction = TCL_CREATE_SYMBOLIC_LINK; - } else { - linkAction = TCL_CREATE_HARD_LINK; - } - } else { - linkAction = TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK; - } - if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { - return TCL_ERROR; - } +static int +FileAttrIsReadableCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + return CheckAccess(interp, objv[1], R_OK); +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrIsWritableCmd -- + * + * This function is invoked to process the "file writable" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - /* - * Create link from source to target. - */ +static int +FileAttrIsWritableCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + return CheckAccess(interp, objv[1], W_OK); +} + +/* + *---------------------------------------------------------------------- + * + * PathDirNameCmd -- + * + * This function is invoked to process the "file dirname" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - contents = Tcl_FSLink(objv[index], objv[index+1], linkAction); - if (contents == NULL) { - /* - * We handle three common error cases specially, and for all - * other errors, we use the standard posix error message. - */ - - if (errno == EEXIST) { - Tcl_AppendResult(interp, "could not create new link \"", - TclGetString(objv[index]), - "\": that path already exists", NULL); - } else if (errno == ENOENT) { - /* - * There are two cases here: either the target doesn't - * exist, or the directory of the src doesn't exist. - */ - - int access; - Tcl_Obj *dirPtr = TclPathPart(interp, objv[index], - TCL_PATH_DIRNAME); - - if (dirPtr == NULL) { - return TCL_ERROR; - } - access = Tcl_FSAccess(dirPtr, F_OK); - Tcl_DecrRefCount(dirPtr); - if (access != 0) { - Tcl_AppendResult(interp, - "could not create new link \"", - TclGetString(objv[index]), - "\": no such file or directory", NULL); - } else { - Tcl_AppendResult(interp, - "could not create new link \"", - TclGetString(objv[index]), "\": target \"", - TclGetString(objv[index+1]), - "\" doesn't exist", NULL); - } - } else { - Tcl_AppendResult(interp, - "could not create new link \"", - TclGetString(objv[index]), "\" pointing to \"", - TclGetString(objv[index+1]), "\": ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; - } - } else { - if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { - return TCL_ERROR; - } +static int +PathDirNameCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *dirPtr; - /* - * Read link - */ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + dirPtr = TclPathPart(interp, objv[1], TCL_PATH_DIRNAME); + if (dirPtr == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, dirPtr); + Tcl_DecrRefCount(dirPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * PathExtensionCmd -- + * + * This function is invoked to process the "file extension" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - contents = Tcl_FSLink(objv[index], NULL, 0); - if (contents == NULL) { - Tcl_AppendResult(interp, "could not read link \"", - TclGetString(objv[index]), "\": ", - Tcl_PosixError(interp), NULL); - return TCL_ERROR; - } - } - Tcl_SetObjResult(interp, contents); - if (objc == 3) { - /* - * If we are reading a link, we need to free this result refCount. - * If we are creating a link, this will just be objv[index+1], and - * so we don't own it. - */ +static int +PathExtensionCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *dirPtr; - Tcl_DecrRefCount(contents); - } - return TCL_OK; + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; } - case FCMD_LSTAT: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "name varName"); - return TCL_ERROR; - } - if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) { - return TCL_ERROR; - } - return StoreStatData(interp, objv[3], &buf); - case FCMD_STAT: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "name varName"); - return TCL_ERROR; - } - if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { - return TCL_ERROR; - } - return StoreStatData(interp, objv[3], &buf); - case FCMD_SIZE: - if (objc != 3) { - goto only3Args; - } - if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, - Tcl_NewWideIntObj((Tcl_WideInt) buf.st_size)); - return TCL_OK; - case FCMD_TYPE: - if (objc != 3) { - goto only3Args; - } - if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewStringObj( - GetTypeFromMode((unsigned short) buf.st_mode), -1)); - return TCL_OK; - case FCMD_MKDIR: - return TclFileMakeDirsCmd(interp, objc, objv); - case FCMD_NATIVENAME: { - const char *fileName; - Tcl_DString ds; - - if (objc != 3) { - goto only3Args; - } - fileName = TclGetString(objv[2]); - fileName = Tcl_TranslateFileName(interp, fileName, &ds); - if (fileName == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewStringObj(fileName, - Tcl_DStringLength(&ds))); - Tcl_DStringFree(&ds); - return TCL_OK; + dirPtr = TclPathPart(interp, objv[1], TCL_PATH_EXTENSION); + if (dirPtr == NULL) { + return TCL_ERROR; } - case FCMD_NORMALIZE: { - Tcl_Obj *fileName; + Tcl_SetObjResult(interp, dirPtr); + Tcl_DecrRefCount(dirPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * PathRootNameCmd -- + * + * This function is invoked to process the "file root" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "filename"); - return TCL_ERROR; - } +static int +PathRootNameCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *dirPtr; - fileName = Tcl_FSGetNormalizedPath(interp, objv[2]); - if (fileName == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, fileName); - return TCL_OK; + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + dirPtr = TclPathPart(interp, objv[1], TCL_PATH_ROOT); + if (dirPtr == NULL) { + return TCL_ERROR; } - case FCMD_PATHTYPE: { - Tcl_Obj *typeName; + Tcl_SetObjResult(interp, dirPtr); + Tcl_DecrRefCount(dirPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * PathTailCmd -- + * + * This function is invoked to process the "file tail" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - if (objc != 3) { - goto only3Args; - } +static int +PathTailCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *dirPtr; - switch (Tcl_FSGetPathType(objv[2])) { - case TCL_PATH_ABSOLUTE: - TclNewLiteralStringObj(typeName, "absolute"); - break; - case TCL_PATH_RELATIVE: - TclNewLiteralStringObj(typeName, "relative"); - break; - case TCL_PATH_VOLUME_RELATIVE: - TclNewLiteralStringObj(typeName, "volumerelative"); - break; - default: - return TCL_OK; - } - Tcl_SetObjResult(interp, typeName); - return TCL_OK; + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; } - case FCMD_READABLE: - if (objc != 3) { - goto only3Args; - } - return CheckAccess(interp, objv[2], R_OK); - case FCMD_READLINK: { - Tcl_Obj *contents; + dirPtr = TclPathPart(interp, objv[1], TCL_PATH_TAIL); + if (dirPtr == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, dirPtr); + Tcl_DecrRefCount(dirPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * PathFilesystemCmd -- + * + * This function is invoked to process the "file system" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - if (objc != 3) { - goto only3Args; - } +static int +PathFilesystemCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *fsInfo; - if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) { - return TCL_ERROR; - } + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + fsInfo = Tcl_FSFileSystemInfo(objv[1]); + if (fsInfo == NULL) { + Tcl_SetResult(interp, "unrecognised path", TCL_STATIC); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, fsInfo); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * PathJoinCmd -- + * + * This function is invoked to process the "file join" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +PathJoinCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?"); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_FSJoinToPath(NULL, objc - 1, objv + 1)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * PathNativeNameCmd -- + * + * This function is invoked to process the "file nativename" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - contents = Tcl_FSLink(objv[2], NULL, 0); +static int +PathNativeNameCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + const char *fileName; + Tcl_DString ds; - if (contents == NULL) { - Tcl_AppendResult(interp, "could not readlink \"", - TclGetString(objv[2]), "\": ", Tcl_PosixError(interp), - NULL); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, contents); - Tcl_DecrRefCount(contents); - return TCL_OK; + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; } - case FCMD_RENAME: - return TclFileRenameCmd(interp, objc, objv); - case FCMD_ROOTNAME: { - Tcl_Obj *root; + fileName = Tcl_TranslateFileName(interp, TclGetString(objv[1]), &ds); + if (fileName == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(fileName, + Tcl_DStringLength(&ds))); + Tcl_DStringFree(&ds); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * PathNormalizeCmd -- + * + * This function is invoked to process the "file normalize" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - if (objc != 3) { - goto only3Args; - } - root = TclPathPart(interp, objv[2], TCL_PATH_ROOT); - if (root == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, root); - Tcl_DecrRefCount(root); - return TCL_OK; +static int +PathNormalizeCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *fileName; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; } - case FCMD_SEPARATOR: - if ((objc < 2) || (objc > 3)) { - Tcl_WrongNumArgs(interp, 2, objv, "?name?"); - return TCL_ERROR; - } - if (objc == 2) { - const char *separator = NULL; /* lint */ + fileName = Tcl_FSGetNormalizedPath(interp, objv[1]); + if (fileName == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, fileName); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * PathSplitCmd -- + * + * This function is invoked to process the "file split" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - separator = "/"; - break; - case TCL_PLATFORM_WINDOWS: - separator = "\\"; - break; - } - Tcl_SetObjResult(interp, Tcl_NewStringObj(separator, 1)); - } else { - Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[2]); +static int +PathSplitCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *res; - if (separatorObj == NULL) { - Tcl_SetResult(interp, "Unrecognised path", TCL_STATIC); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, separatorObj); - } - return TCL_OK; - case FCMD_SPLIT: { - Tcl_Obj *res; + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + res = Tcl_FSSplitPath(objv[1], NULL); + if (res == NULL) { + Tcl_AppendResult(interp, "could not read \"", TclGetString(objv[1]), + "\": no such file or directory", NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, res); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * PathTypeCmd -- + * + * This function is invoked to process the "file pathtype" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - if (objc != 3) { - goto only3Args; - } - res = Tcl_FSSplitPath(objv[2], NULL); - if (res == NULL) { - /* How can the interp be NULL here?! DKF */ - if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", - TclGetString(objv[2]), - "\": no such file or directory", NULL); - } - return TCL_ERROR; - } - Tcl_SetObjResult(interp, res); +static int +PathTypeCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *typeName; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + switch (Tcl_FSGetPathType(objv[1])) { + case TCL_PATH_ABSOLUTE: + TclNewLiteralStringObj(typeName, "absolute"); + break; + case TCL_PATH_RELATIVE: + TclNewLiteralStringObj(typeName, "relative"); + break; + case TCL_PATH_VOLUME_RELATIVE: + TclNewLiteralStringObj(typeName, "volumerelative"); + break; + default: + /* Should be unreachable */ return TCL_OK; } - case FCMD_SYSTEM: { - Tcl_Obj *fsInfo; + Tcl_SetObjResult(interp, typeName); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FilesystemSeparatorCmd -- + * + * This function is invoked to process the "file separator" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - if (objc != 3) { - goto only3Args; - } - fsInfo = Tcl_FSFileSystemInfo(objv[2]); - if (fsInfo == NULL) { - Tcl_SetResult(interp, "Unrecognised path", TCL_STATIC); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, fsInfo); - return TCL_OK; +static int +FilesystemSeparatorCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc < 1 || objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?name?"); + return TCL_ERROR; } - case FCMD_TAIL: { - Tcl_Obj *dirPtr; + if (objc == 1) { + const char *separator = NULL; /* lint */ - if (objc != 3) { - goto only3Args; - } - dirPtr = TclPathPart(interp, objv[2], TCL_PATH_TAIL); - if (dirPtr == NULL) { - return TCL_ERROR; + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + separator = "/"; + break; + case TCL_PLATFORM_WINDOWS: + separator = "\\"; + break; } - Tcl_SetObjResult(interp, dirPtr); - Tcl_DecrRefCount(dirPtr); - return TCL_OK; - } - case FCMD_TEMPFILE: - return FileTempfileCmd(interp, objc, objv); - case FCMD_VOLUMES: - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj(separator, 1)); + } else { + Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[1]); + + if (separatorObj == NULL) { + Tcl_SetResult(interp, "unrecognised path", TCL_STATIC); return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_FSListVolumes()); - return TCL_OK; - case FCMD_WRITABLE: - if (objc != 3) { - goto only3Args; - } - return CheckAccess(interp, objv[2], W_OK); + Tcl_SetObjResult(interp, separatorObj); } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FilesystemVolumesCmd -- + * + * This function is invoked to process the "file volumes" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - only3Args: - Tcl_WrongNumArgs(interp, 2, objv, "name"); - return TCL_ERROR; +static int +FilesystemVolumesCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_FSListVolumes()); + return TCL_OK; } /* @@ -1590,13 +2204,13 @@ StoreStatData( */ #define STORE_ARY(fieldName, object) \ - TclNewLiteralStringObj(field, fieldName); \ - Tcl_IncrRefCount(field); \ - value = (object); \ + TclNewLiteralStringObj(field, fieldName); \ + Tcl_IncrRefCount(field); \ + value = (object); \ if (Tcl_ObjSetVar2(interp,varName,field,value,TCL_LEAVE_ERR_MSG)==NULL) { \ - TclDecrRefCount(field); \ - return TCL_ERROR; \ - } \ + TclDecrRefCount(field); \ + return TCL_ERROR; \ + } \ TclDecrRefCount(field); /* @@ -1670,165 +2284,6 @@ GetTypeFromMode( } /* - *--------------------------------------------------------------------------- - * - * FileTempfileCmd - * - * This function implements the "tempfile" subcommand of the "file" - * command. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Creates a temporary file. Opens a channel to that file and puts the - * name of that channel in the result. *Might* register suitable exit - * handlers to ensure that the temporary file gets deleted. Might write - * to a variable, so reentrancy is a potential issue. - * - *--------------------------------------------------------------------------- - */ - -static int -FileTempfileCmd( - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_Obj *nameVarObj = NULL; /* Variable to store the name of the temporary - * file in. */ - Tcl_Obj *nameObj = NULL; /* Object that will contain the filename. */ - Tcl_Channel chan; /* The channel opened (RDWR) on the temporary - * file, or NULL if there's an error. */ - Tcl_Obj *tempDirObj = NULL, *tempBaseObj = NULL, *tempExtObj = NULL; - /* Pieces of template. Each piece is NULL if - * it is omitted. The platform temporary file - * engine might ignore some pieces. */ - - if (objc < 2 || objc > 4) { - Tcl_WrongNumArgs(interp, 2, objv, "?nameVar? ?template?"); - return TCL_ERROR; - } - - if (objc > 2) { - nameVarObj = objv[2]; - TclNewObj(nameObj); - } - if (objc > 3) { - int length; - const char *string = TclGetStringFromObj(objv[3], &length); - - /* - * Treat an empty string as if it wasn't there. - */ - - if (length == 0) { - goto makeTemporary; - } - - /* - * The template only gives a directory if there is a directory - * separator in it. - */ - - if (strchr(string, '/') != NULL - || (tclPlatform == TCL_PLATFORM_WINDOWS - && strchr(string, '\\') != NULL)) { - tempDirObj = TclPathPart(interp, objv[3], TCL_PATH_DIRNAME); - - /* - * Only allow creation of temporary files in the native filesystem - * since they are frequently used for integration with external - * tools or system libraries. [Bug 2388866] - */ - - if (tempDirObj != NULL && Tcl_FSGetFileSystemForPath(tempDirObj) - != &tclNativeFilesystem) { - TclDecrRefCount(tempDirObj); - tempDirObj = NULL; - } - } - - /* - * The template only gives the filename if the last character isn't a - * directory separator. - */ - - if (string[length-1] != '/' && (tclPlatform != TCL_PLATFORM_WINDOWS - || string[length-1] != '\\')) { - Tcl_Obj *tailObj = TclPathPart(interp, objv[3], TCL_PATH_TAIL); - - if (tailObj != NULL) { - tempBaseObj = TclPathPart(interp, tailObj, TCL_PATH_ROOT); - tempExtObj = TclPathPart(interp, tailObj, TCL_PATH_EXTENSION); - TclDecrRefCount(tailObj); - } - } - } - - /* - * Convert empty parts of the template into unspecified parts. - */ - - if (tempDirObj && !TclGetString(tempDirObj)[0]) { - TclDecrRefCount(tempDirObj); - tempDirObj = NULL; - } - if (tempBaseObj && !TclGetString(tempBaseObj)[0]) { - TclDecrRefCount(tempBaseObj); - tempBaseObj = NULL; - } - if (tempExtObj && !TclGetString(tempExtObj)[0]) { - TclDecrRefCount(tempExtObj); - tempExtObj = NULL; - } - - /* - * Create and open the temporary file. - */ - - makeTemporary: - chan = TclpOpenTemporaryFile(tempDirObj,tempBaseObj,tempExtObj, nameObj); - - /* - * If we created pieces of template, get rid of them now. - */ - - if (tempDirObj) { - TclDecrRefCount(tempDirObj); - } - if (tempBaseObj) { - TclDecrRefCount(tempBaseObj); - } - if (tempExtObj) { - TclDecrRefCount(tempExtObj); - } - - /* - * Deal with results. - */ - - if (chan == NULL) { - if (nameVarObj) { - TclDecrRefCount(nameObj); - } - Tcl_AppendResult(interp, "can't create temporary file: ", - Tcl_PosixError(interp), NULL); - return TCL_ERROR; - } - Tcl_RegisterChannel(interp, chan); - if (nameVarObj != NULL) { - if (Tcl_ObjSetVar2(interp, nameVarObj, NULL, nameObj, - TCL_LEAVE_ERR_MSG) == NULL) { - Tcl_UnregisterChannel(interp, chan); - return TCL_ERROR; - } - } - Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL); - return TCL_OK; -} - -/* *---------------------------------------------------------------------- * * Tcl_ForObjCmd -- diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 44a3bf3..8900d14 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.1 2010/09/27 20:33:37 kennykb Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.184.2.2 2010/12/11 18:39:28 kennykb Exp $ */ #include "tclInt.h" @@ -160,31 +160,31 @@ static Tcl_Obj * SelectObjFromSublist(Tcl_Obj *firstPtr, */ static const EnsembleImplMap defaultInfoMap[] = { - {"args", InfoArgsCmd, NULL, NULL, NULL}, - {"body", InfoBodyCmd, NULL, NULL, NULL}, - {"cmdcount", InfoCmdCountCmd, NULL, NULL, NULL}, - {"commands", InfoCommandsCmd, NULL, NULL, NULL}, - {"complete", InfoCompleteCmd, NULL, NULL, NULL}, - {"coroutine", TclInfoCoroutineCmd, NULL, NULL, NULL}, - {"default", InfoDefaultCmd, NULL, NULL, NULL}, - {"errorstack", InfoErrorStackCmd, NULL, NULL, NULL}, - {"exists", TclInfoExistsCmd, TclCompileInfoExistsCmd, NULL, NULL}, - {"frame", InfoFrameCmd, NULL, NULL, NULL}, - {"functions", InfoFunctionsCmd, NULL, NULL, NULL}, - {"globals", TclInfoGlobalsCmd, NULL, NULL, NULL}, - {"hostname", InfoHostnameCmd, NULL, NULL, NULL}, - {"level", InfoLevelCmd, NULL, NULL, NULL}, - {"library", InfoLibraryCmd, NULL, NULL, NULL}, - {"loaded", InfoLoadedCmd, NULL, NULL, NULL}, - {"locals", TclInfoLocalsCmd, NULL, NULL, NULL}, - {"nameofexecutable", InfoNameOfExecutableCmd, NULL, NULL, NULL}, - {"patchlevel", InfoPatchLevelCmd, NULL, NULL, NULL}, - {"procs", InfoProcsCmd, NULL, NULL, NULL}, - {"script", InfoScriptCmd, NULL, NULL, NULL}, - {"sharedlibextension", InfoSharedlibCmd, NULL, NULL, NULL}, - {"tclversion", InfoTclVersionCmd, NULL, NULL, NULL}, - {"vars", TclInfoVarsCmd, NULL, NULL, NULL}, - {NULL, NULL, NULL, NULL, NULL} + {"args", InfoArgsCmd, NULL, NULL, NULL, 0}, + {"body", InfoBodyCmd, NULL, NULL, NULL, 0}, + {"cmdcount", InfoCmdCountCmd, NULL, NULL, NULL, 0}, + {"commands", InfoCommandsCmd, NULL, NULL, NULL, 0}, + {"complete", InfoCompleteCmd, NULL, NULL, NULL, 0}, + {"coroutine", TclInfoCoroutineCmd, NULL, NULL, NULL, 0}, + {"default", InfoDefaultCmd, NULL, NULL, NULL, 0}, + {"errorstack", InfoErrorStackCmd, NULL, NULL, NULL, 0}, + {"exists", TclInfoExistsCmd, TclCompileInfoExistsCmd, NULL, NULL, 0}, + {"frame", InfoFrameCmd, NULL, NULL, NULL, 0}, + {"functions", InfoFunctionsCmd, NULL, NULL, NULL, 0}, + {"globals", TclInfoGlobalsCmd, NULL, NULL, NULL, 0}, + {"hostname", InfoHostnameCmd, NULL, NULL, NULL, 0}, + {"level", InfoLevelCmd, NULL, NULL, NULL, 0}, + {"library", InfoLibraryCmd, NULL, NULL, NULL, 0}, + {"loaded", InfoLoadedCmd, NULL, NULL, NULL, 0}, + {"locals", TclInfoLocalsCmd, NULL, NULL, NULL, 0}, + {"nameofexecutable", InfoNameOfExecutableCmd, NULL, NULL, NULL, 0}, + {"patchlevel", InfoPatchLevelCmd, NULL, NULL, NULL, 0}, + {"procs", InfoProcsCmd, NULL, NULL, NULL, 0}, + {"script", InfoScriptCmd, NULL, NULL, NULL, 0}, + {"sharedlibextension", InfoSharedlibCmd, NULL, NULL, NULL, 0}, + {"tclversion", InfoTclVersionCmd, NULL, NULL, NULL, 0}, + {"vars", TclInfoVarsCmd, NULL, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} }; /* diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index ae2688d..7c30685 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.1 2010/12/01 16:42:34 kennykb Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.214.2.2 2010/12/11 18:39:28 kennykb Exp $ */ #include "tclInt.h" @@ -3346,29 +3346,29 @@ TclInitStringCmd( Tcl_Interp *interp) /* Current interpreter. */ { static const EnsembleImplMap stringImplMap[] = { - {"bytelength", StringBytesCmd, NULL, NULL, NULL}, - {"compare", StringCmpCmd, TclCompileStringCmpCmd, NULL, NULL}, - {"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL}, - {"first", StringFirstCmd, NULL, NULL, NULL}, - {"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL}, - {"is", StringIsCmd, NULL, NULL, NULL}, - {"last", StringLastCmd, NULL, NULL, NULL}, - {"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL}, - {"map", StringMapCmd, NULL, NULL, NULL}, - {"match", StringMatchCmd, TclCompileStringMatchCmd, NULL, NULL}, - {"range", StringRangeCmd, NULL, NULL, NULL}, - {"repeat", StringReptCmd, NULL, NULL, NULL}, - {"replace", StringRplcCmd, NULL, NULL, NULL}, - {"reverse", StringRevCmd, NULL, NULL, NULL}, - {"tolower", StringLowerCmd, NULL, NULL, NULL}, - {"toupper", StringUpperCmd, NULL, NULL, NULL}, - {"totitle", StringTitleCmd, NULL, NULL, NULL}, - {"trim", StringTrimCmd, NULL, NULL, NULL}, - {"trimleft", StringTrimLCmd, NULL, NULL, NULL}, - {"trimright", StringTrimRCmd, NULL, NULL, NULL}, - {"wordend", StringEndCmd, NULL, NULL, NULL}, - {"wordstart", StringStartCmd, NULL, NULL, NULL}, - {NULL, NULL, NULL, NULL, NULL} + {"bytelength", StringBytesCmd, NULL, NULL, NULL, 0}, + {"compare", StringCmpCmd, TclCompileStringCmpCmd, NULL, NULL, 0}, + {"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0}, + {"first", StringFirstCmd, NULL, NULL, NULL, 0}, + {"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL, 0}, + {"is", StringIsCmd, NULL, NULL, NULL, 0}, + {"last", StringLastCmd, NULL, NULL, NULL, 0}, + {"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0}, + {"map", StringMapCmd, NULL, NULL, NULL, 0}, + {"match", StringMatchCmd, TclCompileStringMatchCmd, NULL, NULL, 0}, + {"range", StringRangeCmd, NULL, NULL, NULL, 0}, + {"repeat", StringReptCmd, NULL, NULL, NULL, 0}, + {"replace", StringRplcCmd, NULL, NULL, NULL, 0}, + {"reverse", StringRevCmd, NULL, NULL, NULL, 0}, + {"tolower", StringLowerCmd, NULL, NULL, NULL, 0}, + {"toupper", StringUpperCmd, NULL, NULL, NULL, 0}, + {"totitle", StringTitleCmd, NULL, NULL, NULL, 0}, + {"trim", StringTrimCmd, NULL, NULL, NULL, 0}, + {"trimleft", StringTrimLCmd, NULL, NULL, NULL, 0}, + {"trimright", StringTrimRCmd, NULL, NULL, NULL, 0}, + {"wordend", StringEndCmd, NULL, NULL, NULL, 0}, + {"wordstart", StringStartCmd, NULL, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} }; return TclMakeEnsemble(interp, "string", stringImplMap); diff --git a/generic/tclCompile.c b/generic/tclCompile.c index be688e1..833a920 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.4 2010/10/23 15:49:54 kennykb Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.187.2.5 2010/12/11 18:39:28 kennykb Exp $ */ #include "tclInt.h" @@ -2600,8 +2600,7 @@ TclFindCompiledLocal( if (create || (name == NULL)) { localVar = procPtr->numCompiledLocals; localPtr = (CompiledLocal *) ckalloc((unsigned) - (sizeof(CompiledLocal) - sizeof(localPtr->name) - + nameBytes + 1)); + (TclOffset(CompiledLocal, name) + nameBytes + 1)); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { @@ -4404,7 +4403,7 @@ static void UpdateStringOfInstName(Tcl_Obj *objPtr) } len = strlen(s); objPtr->bytes = ckalloc((unsigned) len + 1); - strcpy(objPtr->bytes, s); + memcpy(objPtr->bytes, s, len + 1); objPtr->length = len; } diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 6a17b02..8affede 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 2010/08/22 18:53:26 nijtmans Exp $ + * RCS: @(#) $Id: tclDictObj.c,v 1.84.2.1 2010/12/11 18:39:28 kennykb Exp $ */ #include "tclInt.h" @@ -87,26 +87,26 @@ static int DictForLoopCallback(ClientData data[], */ static const EnsembleImplMap implementationMap[] = { - {"append", DictAppendCmd, TclCompileDictAppendCmd, NULL, NULL }, - {"create", DictCreateCmd, NULL, NULL, NULL }, - {"exists", DictExistsCmd, NULL, NULL, NULL }, - {"filter", DictFilterCmd, NULL, NULL, NULL }, - {"for", NULL, TclCompileDictForCmd, DictForNRCmd, NULL }, - {"get", DictGetCmd, TclCompileDictGetCmd, NULL, NULL }, - {"incr", DictIncrCmd, TclCompileDictIncrCmd, NULL, NULL }, - {"info", DictInfoCmd, NULL, NULL, NULL }, - {"keys", DictKeysCmd, NULL, NULL, NULL }, - {"lappend", DictLappendCmd, TclCompileDictLappendCmd, NULL, NULL }, - {"merge", DictMergeCmd, NULL, NULL, NULL }, - {"remove", DictRemoveCmd, NULL, NULL, NULL }, - {"replace", DictReplaceCmd, NULL, NULL, NULL }, - {"set", DictSetCmd, TclCompileDictSetCmd, NULL, NULL }, - {"size", DictSizeCmd, NULL, NULL, NULL }, - {"unset", DictUnsetCmd, NULL, NULL, NULL }, - {"update", DictUpdateCmd, TclCompileDictUpdateCmd, NULL, NULL }, - {"values", DictValuesCmd, NULL, NULL, NULL }, - {"with", DictWithCmd, NULL, NULL, NULL }, - {NULL, NULL, NULL, NULL, NULL} + {"append", DictAppendCmd, TclCompileDictAppendCmd, NULL, NULL, 0 }, + {"create", DictCreateCmd, NULL, NULL, NULL, 0 }, + {"exists", DictExistsCmd, NULL, NULL, NULL, 0 }, + {"filter", DictFilterCmd, NULL, NULL, NULL, 0 }, + {"for", NULL, TclCompileDictForCmd, DictForNRCmd, NULL, 0 }, + {"get", DictGetCmd, TclCompileDictGetCmd, NULL, NULL, 0 }, + {"incr", DictIncrCmd, TclCompileDictIncrCmd, NULL, NULL, 0 }, + {"info", DictInfoCmd, NULL, NULL, NULL, 0 }, + {"keys", DictKeysCmd, NULL, NULL, NULL, 0 }, + {"lappend", DictLappendCmd, TclCompileDictLappendCmd, NULL, NULL, 0 }, + {"merge", DictMergeCmd, NULL, NULL, NULL, 0 }, + {"remove", DictRemoveCmd, NULL, NULL, NULL, 0 }, + {"replace", DictReplaceCmd, NULL, NULL, NULL, 0 }, + {"set", DictSetCmd, TclCompileDictSetCmd, NULL, NULL, 0 }, + {"size", DictSizeCmd, NULL, NULL, NULL, 0 }, + {"unset", DictUnsetCmd, NULL, NULL, NULL, 0 }, + {"update", DictUpdateCmd, TclCompileDictUpdateCmd, NULL, NULL, 0 }, + {"values", DictValuesCmd, NULL, NULL, NULL, 0 }, + {"with", DictWithCmd, NULL, NULL, NULL, 0 }, + {NULL, NULL, NULL, NULL, NULL, 0} }; /* diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index c4750c5..1bf9be1 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 2010/03/05 14:34:04 dkf Exp $ + * RCS: @(#) $Id: tclEnsemble.c,v 1.5.4.1 2010/12/11 18:39:28 kennykb Exp $ */ #include "tclInt.h" @@ -1417,16 +1417,21 @@ TclMakeEnsemble( { Tcl_Command ensemble; Tcl_Namespace *ns; - Tcl_DString buf; + Tcl_DString buf, hiddenBuf; const char **nameParts = NULL; const char *cmdName = NULL; - int i, nameCount = 0, ensembleFlags = 0; + int i, nameCount = 0, ensembleFlags = 0, hiddenLen; /* * Construct the path for the ensemble namespace and create it. */ Tcl_DStringInit(&buf); + Tcl_DStringInit(&hiddenBuf); + Tcl_DStringAppend(&hiddenBuf, "tcl:", -1); + Tcl_DStringAppend(&hiddenBuf, name, -1); + Tcl_DStringAppend(&hiddenBuf, ":", -1); + hiddenLen = Tcl_DStringLength(&hiddenBuf); if (name[0] == ':' && name[1] == ':') { /* * An absolute name, so use it directly. @@ -1491,10 +1496,35 @@ TclMakeEnsemble( Tcl_DStringLength(&buf)); Tcl_AppendToObj(toObj, map[i].name, -1); Tcl_DictObjPut(NULL, mapDict, fromObj, toObj); + if (map[i].proc || map[i].nreProc) { - cmdPtr = (Command *) - Tcl_NRCreateCommand(interp, TclGetString(toObj), - map[i].proc, map[i].nreProc, map[i].clientData, NULL); + /* + * If the command is unsafe, hide it when we're in a safe + * interpreter. The code to do this is really hokey! It also + * doesn't work properly yet; this function is always + * currently called before the safe-interp flag is set so the + * Tcl_IsSafe check fails. + */ + + if (map[i].unsafe && Tcl_IsSafe(interp)) { + cmdPtr = (Command *) + Tcl_NRCreateCommand(interp, "___tmp", map[i].proc, + map[i].nreProc, map[i].clientData, NULL); + Tcl_DStringSetLength(&hiddenBuf, hiddenLen); + if (Tcl_HideCommand(interp, "___tmp", + Tcl_DStringAppend(&hiddenBuf, map[i].name, -1))) { + Tcl_Panic(Tcl_GetString(Tcl_GetObjResult(interp))); + } + } else { + /* + * Not hidden, so just create it. Yay! + */ + + cmdPtr = (Command *) + Tcl_NRCreateCommand(interp, TclGetString(toObj), + map[i].proc, map[i].nreProc, map[i].clientData, + NULL); + } cmdPtr->compileProc = map[i].compileProc; if (map[i].compileProc != NULL) { ensembleFlags |= ENSEMBLE_COMPILE; @@ -1508,6 +1538,7 @@ TclMakeEnsemble( } Tcl_DStringFree(&buf); + Tcl_DStringFree(&hiddenBuf); if (nameParts != NULL) { Tcl_Free((char *) nameParts); } diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 8ff6e39..277afa6 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -9,10 +9,11 @@ * 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 2010/02/24 10:32:17 dkf Exp $ + * RCS: @(#) $Id: tclFCmd.c,v 1.51.4.1 2010/12/11 18:39:28 kennykb Exp $ */ #include "tclInt.h" +#include "tclFileSystem.h" /* * Declarations for local functions defined in this file: @@ -48,6 +49,7 @@ static int FileForceOption(Tcl_Interp *interp, int TclFileRenameCmd( + ClientData clientData, /* Unused */ Tcl_Interp *interp, /* Interp for error reporting or recursive * calls in the case of a tricky rename. */ int objc, /* Number of arguments. */ @@ -76,6 +78,7 @@ TclFileRenameCmd( int TclFileCopyCmd( + ClientData clientData, /* Unused */ Tcl_Interp *interp, /* Used for error reporting or recursive calls * in the case of a tricky copy. */ int objc, /* Number of arguments. */ @@ -113,22 +116,20 @@ FileCopyRename( Tcl_StatBuf statBuf; Tcl_Obj *target; - i = FileForceOption(interp, objc - 2, objv + 2, &force); + i = FileForceOption(interp, objc - 1, objv + 1, &force); if (i < 0) { return TCL_ERROR; } - i += 2; + i++; if ((objc - i) < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - TclGetString(objv[0]), " ", TclGetString(objv[1]), - " ?-option value ...? source ?source ...? target\"", NULL); + Tcl_WrongNumArgs(interp, 1, objv, + "?-option value ...? source ?source ...? target"); return TCL_ERROR; } /* - * If target doesn't exist or isn't a directory, try the copy/rename. - * More than 2 arguments is only valid if the target is an existing - * directory. + * If target doesn't exist or isn't a directory, try the copy/rename. More + * than 2 arguments is only valid if the target is an existing directory. */ target = objv[objc - 1]; @@ -218,26 +219,25 @@ FileCopyRename( int TclFileMakeDirsCmd( + ClientData clientData, /* Unused */ Tcl_Interp *interp, /* Used for error reporting. */ int objc, /* Number of arguments */ Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */ { - Tcl_Obj *errfile; + Tcl_Obj *errfile = NULL; int result, i, j, pobjc; Tcl_Obj *split = NULL; Tcl_Obj *target = NULL; Tcl_StatBuf statBuf; - errfile = NULL; - result = TCL_OK; - for (i = 2; i < objc; i++) { + for (i = 1; i < objc; i++) { if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) { result = TCL_ERROR; break; } - split = Tcl_FSSplitPath(objv[i],&pobjc); + split = Tcl_FSSplitPath(objv[i], &pobjc); Tcl_IncrRefCount(split); if (pobjc == 0) { errno = ENOENT; @@ -274,19 +274,17 @@ TclFileMakeDirsCmd( * subdirectory. */ - if (errno == EEXIST) { - if ((Tcl_FSStat(target, &statBuf) == 0) - && S_ISDIR(statBuf.st_mode)) { - /* - * It is a directory that wasn't there before, so keep - * going without error. - */ - - Tcl_ResetResult(interp); - } else { - errfile = target; - goto done; - } + if (errno != EEXIST) { + errfile = target; + goto done; + } else if ((Tcl_FSStat(target, &statBuf) == 0) + && S_ISDIR(statBuf.st_mode)) { + /* + * It is a directory that wasn't there before, so keep + * going without error. + */ + + Tcl_ResetResult(interp); } else { errfile = target; goto done; @@ -338,6 +336,7 @@ TclFileMakeDirsCmd( int TclFileDeleteCmd( + ClientData clientData, /* Unused */ Tcl_Interp *interp, /* Used for error reporting */ int objc, /* Number of arguments */ Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */ @@ -346,16 +345,15 @@ TclFileDeleteCmd( Tcl_Obj *errfile; Tcl_Obj *errorBuffer = NULL; - i = FileForceOption(interp, objc - 2, objv + 2, &force); + i = FileForceOption(interp, objc - 1, objv + 1, &force); if (i < 0) { return TCL_ERROR; } - i += 2; errfile = NULL; result = TCL_OK; - for ( ; i < objc; i++) { + for (i++ ; i < objc; i++) { Tcl_StatBuf statBuf; errfile = objv[i]; @@ -821,22 +819,25 @@ FileForceOption( int *forcePtr) /* If the "-force" was specified, *forcePtr is * filled with 1, otherwise with 0. */ { - int force, i; + int force, i, idx; + static const char *const options[] = { + "-force", "--", NULL + }; force = 0; for (i = 0; i < objc; i++) { if (TclGetString(objv[i])[0] != '-') { break; } - if (strcmp(TclGetString(objv[i]), "-force") == 0) { + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", TCL_EXACT, + &idx) != TCL_OK) { + return -1; + } + if (idx == 0 /* -force */) { force = 1; - } else if (strcmp(TclGetString(objv[i]), "--") == 0) { + } else { /* -- */ i++; break; - } else { - Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[i]), - "\": should be -force or --", NULL); - return -1; } } *forcePtr = force; @@ -940,6 +941,7 @@ FileBasename( int TclFileAttrsCmd( + ClientData clientData, /* Unused */ Tcl_Interp *interp, /* The interpreter for error reporting. */ int objc, /* Number of command line arguments. */ Tcl_Obj *const objv[]) /* The command line objects. */ @@ -951,19 +953,18 @@ TclFileAttrsCmd( int numObjStrings = -1; Tcl_Obj *filePtr; - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, - "name ?-option value ...?"); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?-option value ...?"); return TCL_ERROR; } - filePtr = objv[2]; + filePtr = objv[1]; if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) { return TCL_ERROR; } - objc -= 3; - objv += 3; + objc -= 2; + objv += 2; result = TCL_ERROR; Tcl_SetErrno(0); @@ -1125,6 +1126,362 @@ TclFileAttrsCmd( } /* + *---------------------------------------------------------------------- + * + * TclFileLinkCmd -- + * + * This function is invoked to process the "file link" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May create a new link. + * + *---------------------------------------------------------------------- + */ + +int +TclFileLinkCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *contents; + int index; + + if (objc < 2 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "?-linktype? linkname ?target?"); + return TCL_ERROR; + } + + /* + * Index of the 'source' argument. + */ + + if (objc == 4) { + index = 2; + } else { + index = 1; + } + + if (objc > 2) { + int linkAction; + + if (objc == 4) { + /* + * We have a '-linktype' argument. + */ + + static const char *const linkTypes[] = { + "-symbolic", "-hard", NULL + }; + if (Tcl_GetIndexFromObj(interp, objv[1], linkTypes, "switch", 0, + &linkAction) != TCL_OK) { + return TCL_ERROR; + } + if (linkAction == 0) { + linkAction = TCL_CREATE_SYMBOLIC_LINK; + } else { + linkAction = TCL_CREATE_HARD_LINK; + } + } else { + linkAction = TCL_CREATE_SYMBOLIC_LINK | TCL_CREATE_HARD_LINK; + } + if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Create link from source to target. + */ + + contents = Tcl_FSLink(objv[index], objv[index+1], linkAction); + if (contents == NULL) { + /* + * We handle three common error cases specially, and for all other + * errors, we use the standard posix error message. + */ + + if (errno == EEXIST) { + Tcl_AppendResult(interp, "could not create new link \"", + TclGetString(objv[index]), + "\": that path already exists", NULL); + } else if (errno == ENOENT) { + /* + * There are two cases here: either the target doesn't exist, + * or the directory of the src doesn't exist. + */ + + int access; + Tcl_Obj *dirPtr = TclPathPart(interp, objv[index], + TCL_PATH_DIRNAME); + + if (dirPtr == NULL) { + return TCL_ERROR; + } + access = Tcl_FSAccess(dirPtr, F_OK); + Tcl_DecrRefCount(dirPtr); + if (access != 0) { + Tcl_AppendResult(interp, "could not create new link \"", + TclGetString(objv[index]), + "\": no such file or directory", NULL); + } else { + Tcl_AppendResult(interp, "could not create new link \"", + TclGetString(objv[index]), "\": target \"", + TclGetString(objv[index+1]), "\" doesn't exist", + NULL); + } + } else { + Tcl_AppendResult(interp, "could not create new link \"", + TclGetString(objv[index]), "\" pointing to \"", + TclGetString(objv[index+1]), "\": ", + Tcl_PosixError(interp), NULL); + } + return TCL_ERROR; + } + } else { + if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Read link + */ + + contents = Tcl_FSLink(objv[index], NULL, 0); + if (contents == NULL) { + Tcl_AppendResult(interp, "could not read link \"", + TclGetString(objv[index]), "\": ", Tcl_PosixError(interp), + NULL); + return TCL_ERROR; + } + } + Tcl_SetObjResult(interp, contents); + if (objc == 2) { + /* + * If we are reading a link, we need to free this result refCount. If + * we are creating a link, this will just be objv[index+1], and so we + * don't own it. + */ + + Tcl_DecrRefCount(contents); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclFileReadLinkCmd -- + * + * This function is invoked to process the "file readlink" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclFileReadLinkCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *contents; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + + if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { + return TCL_ERROR; + } + + contents = Tcl_FSLink(objv[1], NULL, 0); + + if (contents == NULL) { + Tcl_AppendResult(interp, "could not readlink \"", + TclGetString(objv[1]), "\": ", Tcl_PosixError(interp), NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, contents); + Tcl_DecrRefCount(contents); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * TclFileTemporaryCmd + * + * This function implements the "tempfile" subcommand of the "file" + * command. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Creates a temporary file. Opens a channel to that file and puts the + * name of that channel in the result. *Might* register suitable exit + * handlers to ensure that the temporary file gets deleted. Might write + * to a variable, so reentrancy is a potential issue. + * + *--------------------------------------------------------------------------- + */ + +int +TclFileTemporaryCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *nameVarObj = NULL; /* Variable to store the name of the temporary + * file in. */ + Tcl_Obj *nameObj = NULL; /* Object that will contain the filename. */ + Tcl_Channel chan; /* The channel opened (RDWR) on the temporary + * file, or NULL if there's an error. */ + Tcl_Obj *tempDirObj = NULL, *tempBaseObj = NULL, *tempExtObj = NULL; + /* Pieces of template. Each piece is NULL if + * it is omitted. The platform temporary file + * engine might ignore some pieces. */ + + if (objc < 1 || objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "?nameVar? ?template?"); + return TCL_ERROR; + } + + if (objc > 1) { + nameVarObj = objv[1]; + TclNewObj(nameObj); + } + if (objc > 2) { + int length; + Tcl_Obj *templateObj = objv[2]; + const char *string = TclGetStringFromObj(templateObj, &length); + + /* + * Treat an empty string as if it wasn't there. + */ + + if (length == 0) { + goto makeTemporary; + } + + /* + * The template only gives a directory if there is a directory + * separator in it. + */ + + if (strchr(string, '/') != NULL + || (tclPlatform == TCL_PLATFORM_WINDOWS + && strchr(string, '\\') != NULL)) { + tempDirObj = TclPathPart(interp, templateObj, TCL_PATH_DIRNAME); + + /* + * Only allow creation of temporary files in the native filesystem + * since they are frequently used for integration with external + * tools or system libraries. [Bug 2388866] + */ + + if (tempDirObj != NULL && Tcl_FSGetFileSystemForPath(tempDirObj) + != &tclNativeFilesystem) { + TclDecrRefCount(tempDirObj); + tempDirObj = NULL; + } + } + + /* + * The template only gives the filename if the last character isn't a + * directory separator. + */ + + if (string[length-1] != '/' && (tclPlatform != TCL_PLATFORM_WINDOWS + || string[length-1] != '\\')) { + Tcl_Obj *tailObj = TclPathPart(interp, templateObj, + TCL_PATH_TAIL); + + if (tailObj != NULL) { + tempBaseObj = TclPathPart(interp, tailObj, TCL_PATH_ROOT); + tempExtObj = TclPathPart(interp, tailObj, TCL_PATH_EXTENSION); + TclDecrRefCount(tailObj); + } + } + } + + /* + * Convert empty parts of the template into unspecified parts. + */ + + if (tempDirObj && !TclGetString(tempDirObj)[0]) { + TclDecrRefCount(tempDirObj); + tempDirObj = NULL; + } + if (tempBaseObj && !TclGetString(tempBaseObj)[0]) { + TclDecrRefCount(tempBaseObj); + tempBaseObj = NULL; + } + if (tempExtObj && !TclGetString(tempExtObj)[0]) { + TclDecrRefCount(tempExtObj); + tempExtObj = NULL; + } + + /* + * Create and open the temporary file. + */ + + makeTemporary: + chan = TclpOpenTemporaryFile(tempDirObj,tempBaseObj,tempExtObj, nameObj); + + /* + * If we created pieces of template, get rid of them now. + */ + + if (tempDirObj) { + TclDecrRefCount(tempDirObj); + } + if (tempBaseObj) { + TclDecrRefCount(tempBaseObj); + } + if (tempExtObj) { + TclDecrRefCount(tempExtObj); + } + + /* + * Deal with results. + */ + + if (chan == NULL) { + if (nameVarObj) { + TclDecrRefCount(nameObj); + } + Tcl_AppendResult(interp, "can't create temporary file: ", + Tcl_PosixError(interp), NULL); + return TCL_ERROR; + } + Tcl_RegisterChannel(interp, chan); + if (nameVarObj != NULL) { + if (Tcl_ObjSetVar2(interp, nameVarObj, NULL, nameObj, + TCL_LEAVE_ERR_MSG) == NULL) { + Tcl_UnregisterChannel(interp, chan); + return TCL_ERROR; + } + } + Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL); + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclHash.c b/generic/tclHash.c index f53bbfe..d5ce21f 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.1 2010/12/01 16:42:35 kennykb Exp $ + * RCS: @(#) $Id: tclHash.c,v 1.46.2.2 2010/12/11 18:39:29 kennykb Exp $ */ #include "tclInt.h" @@ -829,14 +829,14 @@ AllocStringEntry( { const char *string = (const char *) keyPtr; Tcl_HashEntry *hPtr; - unsigned int size; + unsigned int size, allocsize; - size = sizeof(Tcl_HashEntry) + strlen(string) + 1 - sizeof(hPtr->key); - if (size < sizeof(Tcl_HashEntry)) { - size = sizeof(Tcl_HashEntry); + allocsize = size = strlen(string) + 1; + if (size < sizeof(hPtr->key)) { + allocsize = sizeof(hPtr->key); } - hPtr = (Tcl_HashEntry *) ckalloc(size); - strcpy(hPtr->key.string, string); + hPtr = (Tcl_HashEntry *) ckalloc(TclOffset(Tcl_HashEntry, key) + allocsize); + memcpy(hPtr->key.string, string, size); hPtr->clientData = 0; return hPtr; } diff --git a/generic/tclIO.c b/generic/tclIO.c index 0ed57d0..0f490b3 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 2010/03/20 17:49:15 dkf Exp $ + * RCS: @(#) $Id: tclIO.c,v 1.175.2.1 2010/12/11 18:39:29 kennykb Exp $ */ #include "tclInt.h" @@ -8915,6 +8915,33 @@ Tcl_FileEventObjCmd( /* *---------------------------------------------------------------------- * + * ZeroTransferTimerProc -- + * + * Timer handler scheduled by TclCopyChannel so that -command is + * called asynchronously even when -size is 0. + * + * Results: + * None. + * + * Side effects: + * Calls CopyData for -command invocation. + * + *---------------------------------------------------------------------- + */ + +static void +ZeroTransferTimerProc( + ClientData clientData) +{ + /* calling CopyData with mask==0 still implies immediate invocation of the + * -command callback, and completion of the fcopy. + */ + CopyData(clientData, 0); +} + +/* + *---------------------------------------------------------------------- + * * TclCopyChannel -- * * This routine copies data from one channel to another, either @@ -9033,6 +9060,16 @@ TclCopyChannel( outStatePtr->csPtrW = csPtr; /* + * Special handling of -size 0 async transfers, so that the -command is + * still called asynchronously. + */ + + if ((nonBlocking == CHANNEL_NONBLOCKING) && (toRead == 0)) { + Tcl_CreateTimerHandler(0, ZeroTransferTimerProc, csPtr); + return 0; + } + + /* * Start copying data between the channels. */ diff --git a/generic/tclIO.h b/generic/tclIO.h index 5ff855f..ad57391 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 2010/03/20 15:39:46 dkf Exp $ + * RCS: @(#) $Id: tclIO.h,v 1.17.2.1 2010/12/11 18:39:29 kennykb Exp $ */ /* @@ -65,13 +65,13 @@ typedef struct ChannelBuffer { int bufLength; /* How big is the buffer? */ struct ChannelBuffer *nextPtr; /* Next buffer in chain. */ - char buf[4]; /* Placeholder for real buffer. The real - * buffer occuppies this space + bufSize-4 + char buf[1]; /* Placeholder for real buffer. The real + * buffer occuppies this space + bufSize-1 * bytes. This must be the last field in the * structure. */ } ChannelBuffer; -#define CHANNELBUFFER_HEADER_SIZE (sizeof(ChannelBuffer) - 4) +#define CHANNELBUFFER_HEADER_SIZE TclOffset(ChannelBuffer, buf) /* * How much extra space to allocate in buffer to hold bytes from previous diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 696b3ac..fe7fc36 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 2010/08/22 18:53:26 nijtmans Exp $ + * RCS: @(#) $Id: tclIOCmd.c,v 1.69.2.1 2010/12/11 18:39:29 kennykb Exp $ */ #include "tclInt.h" @@ -1898,6 +1898,39 @@ ChanPipeObjCmd( /* *---------------------------------------------------------------------- * + * TclChannelNamesCmd -- + * + * This function is invoked to process the "chan names" and "file + * channels" Tcl commands. See the user documentation for details on + * what they do. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclChannelNamesCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc < 1 || objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); + return TCL_ERROR; + } + return Tcl_GetChannelNamesEx(interp, + ((objc == 1) ? NULL : TclGetString(objv[1]))); +} + +/* + *---------------------------------------------------------------------- + * * TclInitChanCmd -- * * This function is invoked to create the "chan" Tcl command. See the @@ -1924,29 +1957,29 @@ TclInitChanCmd( * function at the moment. */ static const EnsembleImplMap initMap[] = { - {"blocked", Tcl_FblockedObjCmd, NULL, NULL, NULL}, - {"close", Tcl_CloseObjCmd, NULL, NULL, NULL}, - {"copy", Tcl_FcopyObjCmd, NULL, NULL, NULL}, - {"create", TclChanCreateObjCmd, NULL, NULL, NULL}, /* TIP #219 */ - {"eof", Tcl_EofObjCmd, NULL, NULL, NULL}, - {"event", Tcl_FileEventObjCmd, NULL, NULL, NULL}, - {"flush", Tcl_FlushObjCmd, NULL, NULL, NULL}, - {"gets", Tcl_GetsObjCmd, NULL, NULL, NULL}, - {"pending", ChanPendingObjCmd, NULL, NULL, NULL}, /* TIP #287 */ - {"pop", TclChanPopObjCmd, NULL, NULL, NULL}, /* TIP #230 */ - {"postevent", TclChanPostEventObjCmd, NULL, NULL, NULL}, /* TIP #219 */ - {"push", TclChanPushObjCmd, NULL, NULL, NULL}, /* TIP #230 */ - {"puts", Tcl_PutsObjCmd, NULL, NULL, NULL}, - {"read", Tcl_ReadObjCmd, NULL, NULL, NULL}, - {"seek", Tcl_SeekObjCmd, NULL, NULL, NULL}, - {"pipe", ChanPipeObjCmd, NULL, NULL, NULL}, /* TIP #304 */ - {"tell", Tcl_TellObjCmd, NULL, NULL, NULL}, - {"truncate", ChanTruncateObjCmd, NULL, NULL, NULL}, /* TIP #208 */ - {NULL, NULL, NULL, NULL, NULL} + {"blocked", Tcl_FblockedObjCmd, NULL, NULL, NULL, 0}, + {"close", Tcl_CloseObjCmd, NULL, NULL, NULL, 0}, + {"copy", Tcl_FcopyObjCmd, NULL, NULL, NULL, 0}, + {"create", TclChanCreateObjCmd, NULL, NULL, NULL, 0}, /* TIP #219 */ + {"eof", Tcl_EofObjCmd, NULL, NULL, NULL, 0}, + {"event", Tcl_FileEventObjCmd, NULL, NULL, NULL, 0}, + {"flush", Tcl_FlushObjCmd, NULL, NULL, NULL, 0}, + {"gets", Tcl_GetsObjCmd, NULL, NULL, NULL, 0}, + {"names", TclChannelNamesCmd, NULL, NULL, NULL, 0}, + {"pending", ChanPendingObjCmd, NULL, NULL, NULL, 0}, /* TIP #287 */ + {"pop", TclChanPopObjCmd, NULL, NULL, NULL, 0}, /* TIP #230 */ + {"postevent", TclChanPostEventObjCmd, NULL, NULL, NULL, 0}, /* TIP #219 */ + {"push", TclChanPushObjCmd, NULL, NULL, NULL, 0}, /* TIP #230 */ + {"puts", Tcl_PutsObjCmd, NULL, NULL, NULL, 0}, + {"read", Tcl_ReadObjCmd, NULL, NULL, NULL, 0}, + {"seek", Tcl_SeekObjCmd, NULL, NULL, NULL, 0}, + {"pipe", ChanPipeObjCmd, NULL, NULL, NULL, 0}, /* TIP #304 */ + {"tell", Tcl_TellObjCmd, NULL, NULL, NULL, 0}, + {"truncate", ChanTruncateObjCmd, NULL, NULL, NULL, 0}, /* TIP #208 */ + {NULL, NULL, NULL, NULL, NULL, 0} }; static const char *const extras[] = { "configure", "::fconfigure", - "names", "::file channels", NULL }; Tcl_Command ensemble; diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index c34a6bf..a8b2674 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.3 2010/10/28 19:42:20 kennykb Exp $ + * RCS: @(#) $Id: tclIOSock.c,v 1.11.10.4 2010/12/11 18:39:29 kennykb Exp $ */ #include "tclInt.h" @@ -89,25 +89,30 @@ TclSockGetPort( *---------------------------------------------------------------------- */ +#ifdef _WIN32 +# define PTR2SOCK(a) (SOCKET)a +#else +# define PTR2SOCK(a) PTR2INT(a) +#endif int TclSockMinimumBuffers( - int sock, /* Socket file descriptor */ + ClientData sock, /* Socket file descriptor */ int size) /* Minimum buffer size */ { int current; socklen_t len; len = sizeof(int); - getsockopt(sock, SOL_SOCKET, SO_SNDBUF, (char *)¤t, &len); + getsockopt(PTR2SOCK(sock), SOL_SOCKET, SO_SNDBUF, (char *)¤t, &len); if (current < size) { len = sizeof(int); - setsockopt(sock, SOL_SOCKET, SO_SNDBUF, (char *)&size, len); + setsockopt(PTR2SOCK(sock), SOL_SOCKET, SO_SNDBUF, (char *)&size, len); } len = sizeof(int); - getsockopt(sock, SOL_SOCKET, SO_RCVBUF, (char *)¤t, &len); + getsockopt(PTR2SOCK(sock), SOL_SOCKET, SO_RCVBUF, (char *)¤t, &len); if (current < size) { len = sizeof(int); - setsockopt(sock, SOL_SOCKET, SO_RCVBUF, (char *)&size, len); + setsockopt(PTR2SOCK(sock), SOL_SOCKET, SO_RCVBUF, (char *)&size, len); } return TCL_OK; } diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 9eef11a..dd66ec6 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 2010/03/30 13:17:18 nijtmans Exp $ + * RCS: @(#) $Id: tclIndexObj.c,v 1.59.2.1 2010/12/11 18:39:29 kennykb Exp $ */ #include "tclInt.h" @@ -529,10 +529,10 @@ TclInitPrefixCmd( Tcl_Interp *interp) /* Current interpreter. */ { static const EnsembleImplMap prefixImplMap[] = { - {"all", PrefixAllObjCmd, NULL, NULL, NULL}, - {"longest", PrefixLongestObjCmd, NULL, NULL, NULL}, - {"match", PrefixMatchObjCmd, NULL, NULL, NULL}, - {NULL, NULL, NULL, NULL, NULL} + {"all", PrefixAllObjCmd, NULL, NULL, NULL, 0}, + {"longest", PrefixLongestObjCmd, NULL, NULL, NULL, 0}, + {"match", PrefixMatchObjCmd, NULL, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} }; Tcl_Command prefixCmd; diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 2b2274d..ac246f0 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.3 2010/12/01 16:42:35 kennykb Exp $ +# RCS: @(#) $Id: tclInt.decls,v 1.148.2.4 2010/12/11 18:39:29 kennykb Exp $ library tcl @@ -423,7 +423,7 @@ declare 103 { int *portPtr) } declare 104 { - int TclSockMinimumBuffers(int sock, int size) + int TclSockMinimumBuffers(ClientData sock, int size) } # Replaced by Tcl_FSStat in 8.4: #declare 105 { @@ -1023,7 +1023,7 @@ declare 2 win { const char *proto) } declare 3 win { - int TclWinGetSockOpt(int s, int level, int optname, + int TclWinGetSockOpt(SOCKET s, int level, int optname, char FAR *optval, int FAR *optlen) } declare 4 win { @@ -1037,7 +1037,7 @@ declare 6 win { u_short TclWinNToHS(u_short ns) } declare 7 win { - int TclWinSetSockOpt(int s, int level, int optname, + int TclWinSetSockOpt(SOCKET s, int level, int optname, const char FAR *optval, int optlen) } declare 8 win { diff --git a/generic/tclInt.h b/generic/tclInt.h index dbabccf..ea8f948 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.5 2010/12/01 16:42:36 kennykb Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.482.2.6 2010/12/11 18:39:29 kennykb Exp $ */ #ifndef _TCLINT @@ -954,7 +954,7 @@ typedef struct CompiledLocal { * is marked by a unique ClientData tag during * compilation, and that same tag is used to * find the variable at runtime. */ - char name[4]; /* Name of the local variable starts here. If + char name[1]; /* Name of the local variable starts here. If * the name is NULL, this will just be '\0'. * The actual size of this field will be large * enough to hold the name. MUST BE THE LAST @@ -1601,6 +1601,8 @@ typedef struct { CompileProc *compileProc; /* The compiler for the subcommand. */ Tcl_ObjCmdProc *nreProc; /* NRE implementation of this command. */ ClientData clientData; /* Any clientData to give the command. */ + int unsafe; /* Whether this command is to be hidden by + * default in a safe interpreter. */ } EnsembleImplMap; /* @@ -2858,6 +2860,7 @@ MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp, const char *value); MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, Tcl_Channel chan); +MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd; MODULE_SCOPE int TclClearRootEnsemble(ClientData data[], Tcl_Interp *interp, int result); MODULE_SCOPE void TclCleanupLiteralTable(Tcl_Interp *interp, @@ -2874,16 +2877,14 @@ MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, int numBytes, int flags, int line, int *clNextOuter, const char *outerScript); -MODULE_SCOPE int TclFileAttrsCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclFileCopyCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclFileDeleteCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclFileMakeDirsCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclFileRenameCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclFileAttrsCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileCopyCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileDeleteCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileLinkCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileMakeDirsCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileReadLinkCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileRenameCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileTemporaryCmd; MODULE_SCOPE void TclCreateLateExitHandler(Tcl_ExitProc *proc, ClientData clientData); MODULE_SCOPE void TclDeleteLateExitHandler(Tcl_ExitProc *proc, @@ -3234,9 +3235,8 @@ MODULE_SCOPE int Tcl_FconfigureObjCmd( MODULE_SCOPE int Tcl_FcopyObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_FileObjCmd(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_Command TclInitFileCmd(Tcl_Interp *interp); +MODULE_SCOPE int TclMakeFileCommandSafe(Tcl_Interp *interp); MODULE_SCOPE int Tcl_FileEventObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index ba82f75..8be8577 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.3 2010/12/01 16:42:36 kennykb Exp $ + * RCS: @(#) $Id: tclIntDecls.h,v 1.142.2.4 2010/12/11 18:39:29 kennykb Exp $ */ #ifndef _TCLINTDECLS @@ -265,7 +265,7 @@ EXTERN void TclSetupEnv(Tcl_Interp *interp); EXTERN int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 104 */ -EXTERN int TclSockMinimumBuffers(int sock, int size); +EXTERN int TclSockMinimumBuffers(ClientData sock, int size); /* Slot 105 is reserved */ /* Slot 106 is reserved */ /* Slot 107 is reserved */ @@ -709,7 +709,7 @@ typedef struct TclIntStubs { CONST86 char * (*tclSetPreInitScript) (const char *string); /* 101 */ void (*tclSetupEnv) (Tcl_Interp *interp); /* 102 */ int (*tclSockGetPort) (Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 103 */ - int (*tclSockMinimumBuffers) (int sock, int size); /* 104 */ + int (*tclSockMinimumBuffers) (ClientData sock, int size); /* 104 */ void (*reserved105)(void); void (*reserved106)(void); void (*reserved107)(void); diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 95a6016..ceda11c 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 2010/08/21 16:30:26 nijtmans Exp $ + * RCS: @(#) $Id: tclIntPlatDecls.h,v 1.44.2.1 2010/12/11 18:39:29 kennykb Exp $ */ #ifndef _TCLINTPLATDECLS @@ -86,7 +86,7 @@ EXTERN void TclWinConvertWSAError(unsigned long errCode); EXTERN struct servent * TclWinGetServByName(const char *nm, const char *proto); /* 3 */ -EXTERN int TclWinGetSockOpt(int s, int level, int optname, +EXTERN int TclWinGetSockOpt(SOCKET s, int level, int optname, char FAR *optval, int FAR *optlen); /* 4 */ EXTERN HINSTANCE TclWinGetTclInstance(void); @@ -94,7 +94,7 @@ EXTERN HINSTANCE TclWinGetTclInstance(void); /* 6 */ EXTERN u_short TclWinNToHS(u_short ns); /* 7 */ -EXTERN int TclWinSetSockOpt(int s, int level, int optname, +EXTERN int TclWinSetSockOpt(SOCKET s, int level, int optname, const char FAR *optval, int optlen); /* 8 */ EXTERN unsigned long TclpGetPid(Tcl_Pid pid); @@ -227,11 +227,11 @@ typedef struct TclIntPlatStubs { void (*tclWinConvertError) (unsigned long errCode); /* 0 */ void (*tclWinConvertWSAError) (unsigned long errCode); /* 1 */ struct servent * (*tclWinGetServByName) (const char *nm, const char *proto); /* 2 */ - int (*tclWinGetSockOpt) (int s, int level, int optname, char FAR *optval, int FAR *optlen); /* 3 */ + int (*tclWinGetSockOpt) (SOCKET s, int level, int optname, char FAR *optval, int FAR *optlen); /* 3 */ HINSTANCE (*tclWinGetTclInstance) (void); /* 4 */ void (*reserved5)(void); u_short (*tclWinNToHS) (u_short ns); /* 6 */ - int (*tclWinSetSockOpt) (int s, int level, int optname, const char FAR *optval, int optlen); /* 7 */ + int (*tclWinSetSockOpt) (SOCKET s, int level, int optname, const char FAR *optval, int optlen); /* 7 */ unsigned long (*tclpGetPid) (Tcl_Pid pid); /* 8 */ int (*tclWinGetPlatformId) (void); /* 9 */ void (*reserved10)(void); diff --git a/generic/tclProc.c b/generic/tclProc.c index d0c1ca3..92e4169 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.1 2010/09/27 20:33:37 kennykb Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.181.2.2 2010/12/11 18:39:29 kennykb Exp $ */ #include "tclInt.h" @@ -622,8 +622,7 @@ TclCreateProc( */ localPtr = (CompiledLocal *) ckalloc((unsigned) - (sizeof(CompiledLocal) - sizeof(localPtr->name) - + nameLength + 1)); + (TclOffset(CompiledLocal, name) + nameLength + 1)); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { @@ -643,7 +642,7 @@ TclCreateProc( } else { localPtr->defValuePtr = NULL; } - strcpy(localPtr->name, fieldValues[0]); + memcpy(localPtr->name, fieldValues[0], nameLength + 1); if ((i == numArgs - 1) && (localPtr->nameLength == 4) && (localPtr->name[0] == 'a') diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 8544351..76895df 100755 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -1,6 +1,4 @@ /* - *---------------------------------------------------------------------- - * * tclStrToD.c -- * * This file contains a collection of procedures for managing conversions @@ -14,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: tclStrToD.c,v 1.46.2.1 2010/12/01 16:42:36 kennykb Exp $ + * RCS: @(#) $Id: tclStrToD.c,v 1.46.2.2 2010/12/11 18:39:29 kennykb Exp $ * *---------------------------------------------------------------------- */ @@ -41,6 +39,11 @@ #endif /* + * Rounding controls. (Thanks a lot, Intel!) + */ + +#ifdef __i386 +/* * gcc on x86 needs access to rounding controls, because of a questionable * feature where it retains intermediate results as IEEE 'long double' values * somewhat unpredictably. It is tempting to include fpu_control.h, but that @@ -48,41 +51,65 @@ * and ix86-isms are factored out here. */ -#if defined(__GNUC__) && defined(__i386) -typedef unsigned int fpu_control_t __attribute__ ((__mode__ (__HI__))); -#define _FPU_GETCW(cw) __asm__ __volatile__ ("fnstcw %0" : "=m" (*&cw)) -#define _FPU_SETCW(cw) __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw)) +#if defined(__GNUC__) +typedef unsigned int fpu_control_t __attribute__ ((__mode__ (__HI__))); + +#define _FPU_GETCW(cw) __asm__ __volatile__ ("fnstcw %0" : "=m" (*&cw)) +#define _FPU_SETCW(cw) __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw)) # define FPU_IEEE_ROUNDING 0x027f # define ADJUST_FPU_CONTROL_WORD -#endif +#define TCL_IEEE_DOUBLE_ROUNDING \ + fpu_control_t roundTo53Bits = FPU_IEEE_ROUNDING; \ + fpu_control_t oldRoundingMode; \ + _FPU_GETCW(oldRoundingMode); \ + _FPU_SETCW(roundTo53Bits) +#define TCL_DEFAULT_DOUBLE_ROUNDING \ + _FPU_SETCW(oldRoundingMode) -/* Sun ProC needs sunmath for rounding control on x86 like gcc above. - * - * +/* + * Sun ProC needs sunmath for rounding control on x86 like gcc above. */ -#if defined(__sun) && defined(__i386) && !defined(__GNUC__) +#elif defined(__sun) #include <sunmath.h> +#define TCL_IEEE_DOUBLE_ROUNDING \ + ieee_flags("set","precision","double",NULL) +#define TCL_DEFAULT_DOUBLE_ROUNDING \ + ieee_flags("clear","precision",NULL,NULL) + +/* + * Other platforms are assumed to always operate in full IEEE mode, so we make + * the macros to go in and out of that mode do nothing. + */ + +#else /* !__GNUC__ && !__sun */ +#define TCL_IEEE_DOUBLE_ROUNDING ((void) 0) +#define TCL_DEFAULT_DOUBLE_ROUNDING ((void) 0) +#endif +#else /* !__i386 */ +#define TCL_IEEE_DOUBLE_ROUNDING ((void) 0) +#define TCL_DEFAULT_DOUBLE_ROUNDING ((void) 0) #endif /* - * MIPS floating-point units need special settings in control registers - * to use gradual underflow as we expect. This fix is for the MIPSpro - * compiler. + * MIPS floating-point units need special settings in control registers to use + * gradual underflow as we expect. This fix is for the MIPSpro compiler. */ + #if defined(__sgi) && defined(_COMPILER_VERSION) #include <sys/fpu.h> #endif + /* * HP's PA_RISC architecture uses 7ff4000000000000 to represent a quiet NaN. * Everyone else uses 7ff8000000000000. (Why, HP, why?) */ #ifdef __hppa -# define NAN_START 0x7ff4 -# define NAN_MASK (((Tcl_WideUInt) 1) << 50) +# define NAN_START 0x7ff4 +# define NAN_MASK (((Tcl_WideUInt) 1) << 50) #else -# define NAN_START 0x7ff8 -# define NAN_MASK (((Tcl_WideUInt) 1) << 51) +# define NAN_START 0x7ff8 +# define NAN_MASK (((Tcl_WideUInt) 1) << 51) #endif /* @@ -96,45 +123,44 @@ typedef unsigned int fpu_control_t __attribute__ ((__mode__ (__HI__))); #define TWO_OVER_3LOG10 0.28952965460216784 #define LOG10_3HALVES_PLUS_FUDGE 0.1760912590558 -/* Definitions of the parts of an IEEE754-format floating point number */ - -#define SIGN_BIT 0x80000000 - /* Mask for the sign bit in the first - * word of a double */ -#define EXP_MASK 0x7ff00000 - /* Mask for the exponent field in the - * first word of a double */ -#define EXP_SHIFT 20 - /* Shift count to make the exponent an - * integer */ -#define HIDDEN_BIT (((Tcl_WideUInt) 0x00100000) << 32) - /* Hidden 1 bit for the significand */ -#define HI_ORDER_SIG_MASK 0x000fffff +/* + * Definitions of the parts of an IEEE754-format floating point number. + */ + +#define SIGN_BIT 0x80000000 + /* Mask for the sign bit in the first word of + * a double. */ +#define EXP_MASK 0x7ff00000 + /* Mask for the exponent field in the first + * word of a double. */ +#define EXP_SHIFT 20 /* Shift count to make the exponent an + * integer. */ +#define HIDDEN_BIT (((Tcl_WideUInt) 0x00100000) << 32) + /* Hidden 1 bit for the significand. */ +#define HI_ORDER_SIG_MASK 0x000fffff /* Mask for the high-order part of the * significand in the first word of a - * double */ -#define SIG_MASK (((Tcl_WideUInt) HI_ORDER_SIG_MASK << 32) \ - | 0xffffffff) + * double. */ +#define SIG_MASK (((Tcl_WideUInt) HI_ORDER_SIG_MASK << 32) \ + | 0xffffffff) /* Mask for the 52-bit significand. */ -#define FP_PRECISION 53 - /* Number of bits of significand plus the - * hidden bit */ -#define EXPONENT_BIAS 0x3ff - /* Bias of the exponent 0 */ - -/* Derived quantities */ - -#define TEN_PMAX 22 - /* floor(FP_PRECISION*log(2)/log(5)) */ -#define QUICK_MAX 14 - /* floor((FP_PRECISION-1)*log(2)/log(10)) - 1 */ -#define BLETCH 0x10 - /* Highest power of two that is greater than - * DBL_MAX_10_EXP, divided by 16 */ -#define DIGIT_GROUP 8 - /* floor(DIGIT_BIT*log(2)/log(10)) */ - -/* Union used to dismantle floating point numbers. */ +#define FP_PRECISION 53 /* Number of bits of significand plus the + * hidden bit. */ +#define EXPONENT_BIAS 0x3ff /* Bias of the exponent 0. */ + +/* + * Derived quantities. + */ + +#define TEN_PMAX 22 /* floor(FP_PRECISION*log(2)/log(5)) */ +#define QUICK_MAX 14 /* floor((FP_PRECISION-1)*log(2)/log(10))-1 */ +#define BLETCH 0x10 /* Highest power of two that is greater than + * DBL_MAX_10_EXP, divided by 16. */ +#define DIGIT_GROUP 8 /* floor(DIGIT_BIT*log(2)/log(10)) */ + +/* + * Union used to dismantle floating point numbers. + */ typedef union Double { struct { @@ -165,7 +191,7 @@ static int log2FLT_RADIX; /* Logarithm of the floating point radix. */ static int mantBits; /* Number of bits in a double's significand */ static mp_int pow5[9]; /* Table of powers of 5**(2**n), up to * 5**256 */ -static double tiny = 0.0; /* The smallest representable double */ +static double tiny = 0.0; /* The smallest representable double. */ static int maxDigits; /* The maximum number of digits to the left of * the decimal point of a double. */ static int minDigits; /* The maximum number of digits to the right @@ -189,10 +215,12 @@ static int n770_fp; /* Flag is 1 on Nokia N770 floating point. * reversed: if big-endian is 7654 3210, * and little-endian is 0123 4567, * then Nokia's FP is 4567 0123; - * little-endian within the 32-bit words - * but big-endian between them. */ + * little-endian within the 32-bit words but + * big-endian between them. */ -/* Table of powers of 5 that are small enough to fit in an mp_digit. */ +/* + * Table of powers of 5 that are small enough to fit in an mp_digit. + */ static const mp_digit dpow5[13] = { 1, 5, 25, 125, @@ -201,7 +229,10 @@ static const mp_digit dpow5[13] = { 244140625 }; -/* Table of powers: pow5_13[n] = 5**(13*2**(n+1)) */ +/* + * Table of powers: pow5_13[n] = 5**(13*2**(n+1)) + */ + static mp_int pow5_13[5]; /* Table of powers: 5**13, 5**26, 5**52, * 5**104, 5**208 */ static const double tens[] = { @@ -229,7 +260,6 @@ static const Tcl_WideUInt wtens[] = { (Tcl_WideUInt) 1000000*100000, (Tcl_WideUInt) 1000000*1000000, (Tcl_WideUInt) 1000000*1000000*10, (Tcl_WideUInt) 1000000*1000000*100, (Tcl_WideUInt) 1000000*1000000*1000,(Tcl_WideUInt) 1000000*1000000*10000 - }; static const double bigtens[] = { @@ -278,75 +308,81 @@ static const Tcl_WideUInt wuipow5[27] = { * Static functions defined in this file. */ -static int AccumulateDecimalDigit(unsigned, int, +static int AccumulateDecimalDigit(unsigned, int, Tcl_WideUInt *, mp_int *, int); static double MakeHighPrecisionDouble(int signum, mp_int *significand, int nSigDigs, int exponent); static double MakeLowPrecisionDouble(int signum, Tcl_WideUInt significand, int nSigDigs, int exponent); +#ifdef IEEE_FLOATING_POINT static double MakeNaN(int signum, Tcl_WideUInt tag); +#endif static double RefineApproximation(double approx, mp_int *exactSignificand, int exponent); -static void MulPow5(mp_int*, unsigned, mp_int*); -static int NormalizeRightward(Tcl_WideUInt*); +static void MulPow5(mp_int *, unsigned, mp_int *); +static int NormalizeRightward(Tcl_WideUInt *); static int RequiredPrecision(Tcl_WideUInt); -static void DoubleToExpAndSig(double, Tcl_WideUInt*, int*, int*); -static void TakeAbsoluteValue(Double*, int*); -static char* FormatInfAndNaN(Double*, int*, char**); -static char* FormatZero(int*, char**); +static void DoubleToExpAndSig(double, Tcl_WideUInt *, int *, + int *); +static void TakeAbsoluteValue(Double *, int *); +static char * FormatInfAndNaN(Double *, int *, char **); +static char * FormatZero(int *, char **); static int ApproximateLog10(Tcl_WideUInt, int, int); -static int BetterLog10(double, int, int*); -static void ComputeScale(int, int, int*, int*, int*, int*); -static void SetPrecisionLimits(int, int, int*, int*, int*, int*); -static char* BumpUp(char*, char*, int*); -static int AdjustRange(double*, int); -static char* ShorteningQuickFormat(double, int, int, double, - char*, int*); -static char* StrictQuickFormat(double, int, int, double, - char*, int*); -static char* QuickConversion(double, int, int, int, int, int, int, - int*, char**); -static void CastOutPowersOf2(int*, int*, int*); -static char* ShorteningInt64Conversion(Double*, int, Tcl_WideUInt, +static int BetterLog10(double, int, int *); +static void ComputeScale(int, int, int *, int *, int *, int *); +static void SetPrecisionLimits(int, int, int *, int *, int *, + int *); +static char * BumpUp(char *, char *, int *); +static int AdjustRange(double *, int); +static char * ShorteningQuickFormat(double, int, int, double, + char *, int *); +static char * StrictQuickFormat(double, int, int, double, + char *, int *); +static char * QuickConversion(double, int, int, int, int, int, int, + int *, char **); +static void CastOutPowersOf2(int *, int *, int *); +static char * ShorteningInt64Conversion(Double *, int, Tcl_WideUInt, int, int, int, int, int, int, int, int, int, - int, int, int*, char**); -static char* StrictInt64Conversion(Double*, int, Tcl_WideUInt, + int, int, int *, char **); +static char * StrictInt64Conversion(Double *, int, Tcl_WideUInt, int, int, int, int, int, int, - int, int, int*, char**); -static int ShouldBankerRoundUpPowD(mp_int*, int, int); -static int ShouldBankerRoundUpToNextPowD(mp_int*, mp_int*, - int, int, int, mp_int*); -static char* ShorteningBignumConversionPowD(Double* dPtr, + int, int, int *, char **); +static int ShouldBankerRoundUpPowD(mp_int *, int, int); +static int ShouldBankerRoundUpToNextPowD(mp_int *, mp_int *, + int, int, int, mp_int *); +static char * ShorteningBignumConversionPowD(Double *dPtr, int convType, Tcl_WideUInt bw, int b2, int b5, int m2plus, int m2minus, int m5, - int sd, int k, int len, - int ilim, int ilim1, int* decpt, - char** endPtr); -static char* StrictBignumConversionPowD(Double* dPtr, int convType, + int sd, int k, int len, + int ilim, int ilim1, int *decpt, + char **endPtr); +static char * StrictBignumConversionPowD(Double *dPtr, int convType, Tcl_WideUInt bw, int b2, int b5, - int sd, int k, int len, - int ilim, int ilim1, int* decpt, - char** endPtr); -static int ShouldBankerRoundUp(mp_int*, mp_int*, int); -static int ShouldBankerRoundUpToNext(mp_int*, mp_int*, mp_int*, - int, int, mp_int*); -static char* ShorteningBignumConversion(Double* dPtr, int convType, + int sd, int k, int len, + int ilim, int ilim1, int *decpt, + char **endPtr); +static int ShouldBankerRoundUp(mp_int *, mp_int *, int); +static int ShouldBankerRoundUpToNext(mp_int *, mp_int *, + mp_int *, int, int, mp_int *); +static char * ShorteningBignumConversion(Double *dPtr, int convType, Tcl_WideUInt bw, int b2, int m2plus, int m2minus, - int s2, int s5, int k, int len, - int ilim, int ilim1, int* decpt, - char** endPtr); -static char* StrictBignumConversion(Double* dPtr, int convType, + int s2, int s5, int k, int len, + int ilim, int ilim1, int *decpt, + char **endPtr); +static char * StrictBignumConversion(Double *dPtr, int convType, Tcl_WideUInt bw, int b2, - int s2, int s5, int k, int len, - int ilim, int ilim1, int* decpt, - char** endPtr); + int s2, int s5, int k, int len, + int ilim, int ilim1, int *decpt, + char **endPtr); static double BignumToBiasedFrExp(const mp_int *big, int *machexp); static double Pow10TimesFrExp(int exponent, double fraction, int *machexp); static double SafeLdExp(double fraction, int exponent); +#ifdef IEEE_FLOATING_POINT static Tcl_WideUInt Nokia770Twiddle(Tcl_WideUInt w); +#endif /* *---------------------------------------------------------------------- @@ -476,38 +512,38 @@ TclParseNumber( } state = INITIAL; enum State acceptState = INITIAL; - int signum = 0; /* Sign of the number being parsed */ + int signum = 0; /* Sign of the number being parsed. */ Tcl_WideUInt significandWide = 0; /* Significand of the number being parsed (if - * no overflow) */ + * no overflow). */ mp_int significandBig; /* Significand of the number being parsed (if - * it overflows significandWide) */ - int significandOverflow = 0;/* Flag==1 iff significandBig is used */ + * it overflows significandWide). */ + int significandOverflow = 0;/* Flag==1 iff significandBig is used. */ Tcl_WideUInt octalSignificandWide = 0; /* Significand of an octal number; needed * because we don't know whether a number with * a leading zero is octal or decimal until - * we've scanned forward to a '.' or 'e' */ + * we've scanned forward to a '.' or 'e'. */ mp_int octalSignificandBig; /* Significand of octal number once - * octalSignificandWide overflows */ + * octalSignificandWide overflows. */ int octalSignificandOverflow = 0; - /* Flag==1 if octalSignificandBig is used */ + /* Flag==1 if octalSignificandBig is used. */ int numSigDigs = 0; /* Number of significant digits in the decimal - * significand */ + * significand. */ int numTrailZeros = 0; /* Number of trailing zeroes at the current * point in the parse. */ int numDigitsAfterDp = 0; /* Number of digits scanned after the decimal - * point */ + * point. */ int exponentSignum = 0; /* Signum of the exponent of a floating point - * number */ - long exponent = 0; /* Exponent of a floating point number */ - const char *p; /* Pointer to next character to scan */ - size_t len; /* Number of characters remaining after p */ + * number. */ + long exponent = 0; /* Exponent of a floating point number. */ + const char *p; /* Pointer to next character to scan. */ + size_t len; /* Number of characters remaining after p. */ const char *acceptPoint; /* Pointer to position after last character in - * an acceptable number */ + * an acceptable number. */ size_t acceptLen; /* Number of characters following that * point. */ - int status = TCL_OK; /* Status to return to caller */ + int status = TCL_OK; /* Status to return to caller. */ char d = 0; /* Last hexadecimal digit scanned; initialized * to avoid a compiler warning. */ int shift = 0; /* Amount to shift when accumulating binary */ @@ -597,9 +633,9 @@ TclParseNumber( case ZERO: /* * Scanned a leading zero (perhaps with a + or -). Acceptable - * inputs are digits, period, X, b, and E. If 8 or 9 is encountered, - * the number can't be octal. This state and the OCTAL state - * differ only in whether they recognize 'X' and 'b'. + * inputs are digits, period, X, b, and E. If 8 or 9 is + * encountered, the number can't be octal. This state and the + * OCTAL state differ only in whether they recognize 'X' and 'b'. */ acceptState = state; @@ -1193,7 +1229,7 @@ TclParseNumber( case OCTAL: /* - * Returning an octal integer. Final scaling step + * Returning an octal integer. Final scaling step. */ shift = 3 * numTrailZeros; @@ -1254,7 +1290,7 @@ TclParseNumber( case DECIMAL: significandOverflow = AccumulateDecimalDigit(0, numTrailZeros-1, &significandWide, &significandBig, significandOverflow); - if (!significandOverflow && (significandWide > MOST_BITS+signum)) { + if (!significandOverflow && (significandWide > MOST_BITS+signum)){ significandOverflow = 1; TclBNInitBignumFromWideUInt(&significandBig, significandWide); } @@ -1310,16 +1346,16 @@ TclParseNumber( objPtr->typePtr = &tclDoubleType; if (exponentSignum) { - exponent = - exponent; + exponent = -exponent; } if (!significandOverflow) { objPtr->internalRep.doubleValue = MakeLowPrecisionDouble( signum, significandWide, numSigDigs, - (numTrailZeros + exponent - numDigitsAfterDp)); + numTrailZeros + exponent - numDigitsAfterDp); } else { objPtr->internalRep.doubleValue = MakeHighPrecisionDouble( signum, &significandBig, numSigDigs, - (numTrailZeros + exponent - numDigitsAfterDp)); + numTrailZeros + exponent - numDigitsAfterDp); } break; @@ -1336,12 +1372,12 @@ TclParseNumber( #ifdef IEEE_FLOATING_POINT case sNAN: case sNANFINISH: - objPtr->internalRep.doubleValue = MakeNaN(signum, significandWide); + objPtr->internalRep.doubleValue = MakeNaN(signum,significandWide); objPtr->typePtr = &tclDoubleType; break; #endif case INITIAL: - /* This case only to silence compiler warning */ + /* This case only to silence compiler warning. */ Tcl_Panic("TclParseNumber: state INITIAL can't happen here"); } } @@ -1413,7 +1449,7 @@ AccumulateDecimalDigit( Tcl_WideUInt w; /* - * Try wide multiplication first + * Try wide multiplication first. */ if (!bignumFlag) { @@ -1426,10 +1462,10 @@ AccumulateDecimalDigit( *wideRepPtr = digit; return 0; } else if (numZeros >= maxpow10_wide - || w > ((~(Tcl_WideUInt)0)-digit)/pow10_wide[numZeros+1]) { + || w > ((~(Tcl_WideUInt)0)-digit)/pow10_wide[numZeros+1]) { /* - * Wide multiplication will overflow. Expand the - * number to a bignum and fall through into the bignum case. + * Wide multiplication will overflow. Expand the number to a + * bignum and fall through into the bignum case. */ TclBNInitBignumFromWideUInt(bignumRepPtr, w); @@ -1437,6 +1473,7 @@ AccumulateDecimalDigit( /* * Wide multiplication. */ + *wideRepPtr = w * pow10_wide[numZeros+1] + digit; return 0; } @@ -1504,12 +1541,12 @@ AccumulateDecimalDigit( static double MakeLowPrecisionDouble( int signum, /* 1 if the number is negative, 0 otherwise */ - Tcl_WideUInt significand, /* Significand of the number */ - int numSigDigs, /* Number of digits in the significand */ - int exponent) /* Power of ten */ + Tcl_WideUInt significand, /* Significand of the number. */ + int numSigDigs, /* Number of digits in the significand. */ + int exponent) /* Power of ten. */ { - double retval; /* Value of the number */ - mp_int significandBig; /* Significand expressed as a bignum */ + double retval; /* Value of the number. */ + mp_int significandBig; /* Significand expressed as a bignum. */ /* * With gcc on x86, the floating point rounding mode is double-extended. @@ -1519,15 +1556,7 @@ MakeLowPrecisionDouble( * ulp, so we need to change rounding mode to 53-bits. */ -#if defined(__GNUC__) && defined(__i386) - fpu_control_t roundTo53Bits = 0x027f; - fpu_control_t oldRoundingMode; - _FPU_GETCW(oldRoundingMode); - _FPU_SETCW(roundTo53Bits); -#endif -#if defined(__sun) && defined(__i386) && !defined(__GNUC__) - ieee_flags("set","precision","double",NULL); -#endif + TCL_IEEE_DOUBLE_ROUNDING; /* * Test for the easy cases. @@ -1542,10 +1571,12 @@ MakeLowPrecisionDouble( * without special handling. */ - retval = (double)(Tcl_WideInt)significand * pow10vals[exponent]; + retval = (double) + ((Tcl_WideInt)significand * pow10vals[exponent]); goto returnValue; } else { int diff = DBL_DIG - numSigDigs; + if (exponent-diff <= mmaxpow) { /* * 10**exponent is not an exact integer, but @@ -1554,8 +1585,8 @@ MakeLowPrecisionDouble( * with only one roundoff. */ - volatile double factor = - (double)(Tcl_WideInt)significand * pow10vals[diff]; + volatile double factor = (double) + ((Tcl_WideInt)significand * pow10vals[diff]); retval = factor * pow10vals[exponent-diff]; goto returnValue; } @@ -1568,7 +1599,8 @@ MakeLowPrecisionDouble( * only one rounding. */ - retval = (double)(Tcl_WideInt)significand / pow10vals[-exponent]; + retval = (double) + ((Tcl_WideInt)significand / pow10vals[-exponent]); goto returnValue; } } @@ -1597,12 +1629,7 @@ MakeLowPrecisionDouble( * On gcc on x86, restore the floating point mode word. */ -#if defined(__GNUC__) && defined(__i386) - _FPU_SETCW(oldRoundingMode); -#endif -#if defined(__sun) && defined(__i386) && !defined(__GNUC__) - ieee_flags("clear","precision",NULL,NULL); -#endif + TCL_DEFAULT_DOUBLE_ROUNDING; return retval; } @@ -1627,13 +1654,13 @@ MakeLowPrecisionDouble( static double MakeHighPrecisionDouble( - int signum, /* 1=negative, 0=nonnegative */ - mp_int *significand, /* Exact significand of the number */ - int numSigDigs, /* Number of significant digits */ - int exponent) /* Power of 10 by which to multiply */ + int signum, /* 1=negative, 0=nonnegative. */ + mp_int *significand, /* Exact significand of the number. */ + int numSigDigs, /* Number of significant digits. */ + int exponent) /* Power of 10 by which to multiply. */ { double retval; - int machexp; /* Machine exponent of a power of 10 */ + int machexp; /* Machine exponent of a power of 10. */ /* * With gcc on x86, the floating point rounding mode is double-extended. @@ -1643,15 +1670,7 @@ MakeHighPrecisionDouble( * ulp, so we need to change rounding mode to 53-bits. */ -#if defined(__GNUC__) && defined(__i386) - fpu_control_t roundTo53Bits = 0x027f; - fpu_control_t oldRoundingMode; - _FPU_GETCW(oldRoundingMode); - _FPU_SETCW(roundTo53Bits); -#endif -#if defined(__sun) && defined(__i386) && !defined(__GNUC__) - ieee_flags("set","precision","double",NULL); -#endif + TCL_IEEE_DOUBLE_ROUNDING; /* * Quick checks for over/underflow. @@ -1710,12 +1729,8 @@ MakeHighPrecisionDouble( * On gcc on x86, restore the floating point mode word. */ -#if defined(__GNUC__) && defined(__i386) - _FPU_SETCW(oldRoundingMode); -#endif -#if defined(__sun) && defined(__i386) && !defined(__GNUC__) - ieee_flags("clear","precision",NULL,NULL); -#endif + TCL_DEFAULT_DOUBLE_ROUNDING; + return retval; } @@ -1734,8 +1749,8 @@ MakeHighPrecisionDouble( #ifdef IEEE_FLOATING_POINT static double MakeNaN( - int signum, /* Sign bit (1=negative, 0=nonnegative */ - Tcl_WideUInt tags) /* Tag bits to put in the NaN */ + int signum, /* Sign bit (1=negative, 0=nonnegative. */ + Tcl_WideUInt tags) /* Tag bits to put in the NaN. */ { union { Tcl_WideUInt iv; @@ -1773,28 +1788,28 @@ MakeNaN( static double RefineApproximation( - double approxResult, /* Approximate result of conversion */ - mp_int *exactSignificand, /* Integer significand */ - int exponent) /* Power of 10 to multiply by significand */ + double approxResult, /* Approximate result of conversion. */ + mp_int *exactSignificand, /* Integer significand. */ + int exponent) /* Power of 10 to multiply by significand. */ { int M2, M5; /* Powers of 2 and of 5 needed to put the * decimal and binary numbers over a common * denominator. */ - double significand; /* Sigificand of the binary number */ - int binExponent; /* Exponent of the binary number */ + double significand; /* Sigificand of the binary number. */ + int binExponent; /* Exponent of the binary number. */ int msb; /* Most significant bit position of an - * intermediate result */ + * intermediate result. */ int nDigits; /* Number of mp_digit's in an intermediate - * result */ + * result. */ mp_int twoMv; /* Approx binary value expressed as an exact - * integer scaled by the multiplier 2M */ + * integer scaled by the multiplier 2M. */ mp_int twoMd; /* Exact decimal value expressed as an exact - * integer scaled by the multiplier 2M */ - int scale; /* Scale factor for M */ - int multiplier; /* Power of two to scale M */ + * integer scaled by the multiplier 2M. */ + int scale; /* Scale factor for M. */ + int multiplier; /* Power of two to scale M. */ double num, den; /* Numerator and denominator of the correction - * term */ - double quot; /* Correction term */ + * term. */ + double quot; /* Correction term. */ double minincr; /* Lower bound on the absolute value of the * correction term. */ int i; @@ -1824,8 +1839,8 @@ RefineApproximation( M5 = 0; } else { M5 = -exponent; - if ((M5-1) > M2) { - M2 = M5-1; + if (M5 - 1 > M2) { + M2 = M5 - 1; } } @@ -1864,7 +1879,7 @@ RefineApproximation( mp_init_copy(&twoMd, exactSignificand); for (i=0; i<=8; ++i) { - if ((M5+exponent) & (1 << i)) { + if ((M5 + exponent) & (1 << i)) { mp_mul(&twoMd, pow5+i, &twoMd); } } @@ -1874,7 +1889,7 @@ RefineApproximation( /* * The result, 2Mv-2Md, needs to be divided by 2M to yield a correction * term. Because 2M may well overflow a double, we need to scale the - * denominator by a factor of 2**binExponent-mantBits + * denominator by a factor of 2**binExponent-mantBits. */ scale = binExponent - mantBits - 1; @@ -1927,26 +1942,28 @@ RefineApproximation( } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * MultPow5 -- * * Multiply a bignum by a power of 5. * * Side effects: - * Stores base*5**n in result + * Stores base*5**n in result. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ inline static void -MulPow5(mp_int* base, /* Number to multiply */ - unsigned n, /* Power of 5 to multiply by */ - mp_int* result) /* Place to store the result */ +MulPow5( + mp_int *base, /* Number to multiply. */ + unsigned n, /* Power of 5 to multiply by. */ + mp_int *result) /* Place to store the result. */ { - mp_int* p = base; + mp_int *p = base; int n13 = n / 13; int r = n % 13; + if (r != 0) { mp_mul_d(p, dpow5[r], result); p = result; @@ -1966,12 +1983,12 @@ MulPow5(mp_int* base, /* Number to multiply */ } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * NormalizeRightward -- * - * Shifts a number rightward until it is odd (that is, until the - * least significant bit is nonzero. + * Shifts a number rightward until it is odd (that is, until the least + * significant bit is nonzero. * * Results: * Returns the number of bit positions by which the number was shifted. @@ -1979,18 +1996,19 @@ MulPow5(mp_int* base, /* Number to multiply */ * Side effects: * Shifts the number in place; *wPtr is replaced by the shifted number. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ inline static int -NormalizeRightward(Tcl_WideUInt* wPtr) - /* INOUT: Number to shift */ +NormalizeRightward( + Tcl_WideUInt *wPtr) /* INOUT: Number to shift. */ { int rv = 0; Tcl_WideUInt w = *wPtr; + if (!(w & (Tcl_WideUInt) 0xffffffff)) { w >>= 32; rv += 32; - } + } if (!(w & (Tcl_WideUInt) 0xffff)) { w >>= 16; rv += 16; } @@ -2011,25 +2029,26 @@ NormalizeRightward(Tcl_WideUInt* wPtr) } /* - *-----------------------------------------------------------------------------0 + *---------------------------------------------------------------------- * * RequiredPrecision -- * * Determines the number of bits needed to hold an intger. * * Results: - * Returns the position of the most significant bit (0 - 63). - * Returns 0 if the number is zero. + * Returns the position of the most significant bit (0 - 63). Returns 0 + * if the number is zero. * - *---------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ static int -RequiredPrecision(Tcl_WideUInt w) - /* Number to interrogate */ +RequiredPrecision( + Tcl_WideUInt w) /* Number to interrogate. */ { int rv; unsigned long wi; + if (w & ((Tcl_WideUInt) 0xffffffff << 32)) { wi = (unsigned long) (w >> 32); rv = 32; } else { @@ -2057,36 +2076,38 @@ RequiredPrecision(Tcl_WideUInt w) } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * DoubleToExpAndSig -- * * Separates a 'double' into exponent and significand. * * Side effects: - * Stores the significand in '*significand' and the exponent in - * '*expon' so that dv == significand * 2.0**expon, and significand - * is odd. Also stores the position of the leftmost 1-bit in 'significand' - * in 'bits'. + * Stores the significand in '*significand' and the exponent in '*expon' + * so that dv == significand * 2.0**expon, and significand is odd. Also + * stores the position of the leftmost 1-bit in 'significand' in 'bits'. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ inline static void -DoubleToExpAndSig(double dv, /* Number to convert */ - Tcl_WideUInt* significand, - /* OUTPUT: Significand of the number */ - int* expon, /* OUTPUT: Exponent to multiply the number by */ - int* bits) /* OUTPUT: Number of significant bits */ +DoubleToExpAndSig( + double dv, /* Number to convert. */ + Tcl_WideUInt *significand, /* OUTPUT: Significand of the number. */ + int *expon, /* OUTPUT: Exponent to multiply the number + * by. */ + int *bits) /* OUTPUT: Number of significant bits. */ { - Double d; /* Number being converted */ - Tcl_WideUInt z; /* Significand under construction */ - int de; /* Exponent of the number */ - int k; /* Bit count */ + Double d; /* Number being converted. */ + Tcl_WideUInt z; /* Significand under construction. */ + int de; /* Exponent of the number. */ + int k; /* Bit count. */ d.d = dv; - /* Extract exponent and significand */ + /* + * Extract exponent and significand. + */ de = (d.w.word0 & EXP_MASK) >> EXP_SHIFT; z = d.q & SIG_MASK; @@ -2104,22 +2125,23 @@ DoubleToExpAndSig(double dv, /* Number to convert */ } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * TakeAbsoluteValue -- * * Takes the absolute value of a 'double' including 0, Inf and NaN * * Side effects: - * The 'double' in *d is replaced with its absolute value. The - * signum is stored in 'sign': 1 for negative, 0 for nonnegative. + * The 'double' in *d is replaced with its absolute value. The signum is + * stored in 'sign': 1 for negative, 0 for nonnegative. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ - + inline static void -TakeAbsoluteValue(Double* d, /* Number to replace with absolute value */ - int* sign) /* Place to put the signum */ +TakeAbsoluteValue( + Double *d, /* Number to replace with absolute value. */ + int *sign) /* Place to put the signum. */ { if (d->w.word0 & SIGN_BIT) { *sign = 1; @@ -2130,30 +2152,31 @@ TakeAbsoluteValue(Double* d, /* Number to replace with absolute value */ } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * FormatInfAndNaN -- * * Bailout for formatting infinities and Not-A-Number. * * Results: - * Returns one of the strings 'Infinity' and 'NaN'. + * Returns one of the strings 'Infinity' and 'NaN'. The string returned + * must be freed by the caller using 'ckfree'. * * Side effects: - * Stores 9999 in *decpt, and sets '*endPtr' to designate the - * terminating NUL byte of the string if 'endPtr' is not NULL. + * Stores 9999 in *decpt, and sets '*endPtr' to designate the terminating + * NUL byte of the string if 'endPtr' is not NULL. * - * The string returned must be freed by the caller using 'ckfree'. - * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static char* -FormatInfAndNaN(Double* d, /* Exceptional number to format */ - int* decpt, /* Decimal point to set to a bogus value */ - char** endPtr) /* Pointer to the end of the formatted data */ +inline static char * +FormatInfAndNaN( + Double *d, /* Exceptional number to format. */ + int *decpt, /* Decimal point to set to a bogus value. */ + char **endPtr) /* Pointer to the end of the formatted data */ { - char* retval; + char *retval; + *decpt = 9999; if (!(d->w.word1) && !(d->w.word0 & HI_ORDER_SIG_MASK)) { retval = ckalloc(9); @@ -2172,7 +2195,7 @@ FormatInfAndNaN(Double* d, /* Exceptional number to format */ } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * FormatZero -- * @@ -2185,14 +2208,16 @@ FormatInfAndNaN(Double* d, /* Exceptional number to format */ * Stores 1 in '*decpt' and puts a pointer to the NUL byte terminating * the string in '*endPtr' if 'endPtr' is not NULL. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static char* -FormatZero(int* decpt, /* Location of the decimal point */ - char** endPtr) /* Pointer to the end of the formatted data */ +inline static char * +FormatZero( + int *decpt, /* Location of the decimal point. */ + char **endPtr) /* Pointer to the end of the formatted data */ { - char* retval = ckalloc(2); + char *retval = ckalloc(2); + strcpy(retval, "0"); if (endPtr) { *endPtr = retval+1; @@ -2202,35 +2227,35 @@ FormatZero(int* decpt, /* Location of the decimal point */ } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * ApproximateLog10 -- * - * Computes a two-term Taylor series approximation to the common - * log of a number, and computes the number's binary log. + * Computes a two-term Taylor series approximation to the common log of a + * number, and computes the number's binary log. * * Results: - * Return an approximation to floor(log10(bw*2**be)) that is either - * exact or 1 too high. + * Return an approximation to floor(log10(bw*2**be)) that is either exact + * or 1 too high. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ inline static int -ApproximateLog10(Tcl_WideUInt bw, - /* Integer significand of the number */ - int be, /* Power of two to scale bw */ - int bbits) /* Number of bits of precision in bw */ +ApproximateLog10( + Tcl_WideUInt bw, /* Integer significand of the number. */ + int be, /* Power of two to scale bw. */ + int bbits) /* Number of bits of precision in bw. */ { - int i; /* Log base 2 of the number */ + int i; /* Log base 2 of the number. */ int k; /* Floor(Log base 10 of the number) */ - double ds; /* Mantissa of the number */ + double ds; /* Mantissa of the number. */ Double d2; /* * Compute i and d2 such that d = d2*2**i, and 1 < d2 < 2. - * Compute an approximation to log10(d), - * log10(d) ~ log10(2) * i + log10(1.5) + * Compute an approximation to log10(d), + * log10(d) ~ log10(2) * i + log10(1.5) * + (significand-1.5)/(1.5 * log(10)) */ @@ -2238,8 +2263,7 @@ ApproximateLog10(Tcl_WideUInt bw, d2.w.word0 |= (EXPONENT_BIAS) << EXP_SHIFT; i = be + bbits - 1; ds = (d2.d - 1.5) * TWO_OVER_3LOG10 - + LOG10_3HALVES_PLUS_FUDGE - + LOG10_2 * i; + + LOG10_3HALVES_PLUS_FUDGE + LOG10_2 * i; k = (int) ds; if (k > ds) { --k; @@ -2248,7 +2272,7 @@ ApproximateLog10(Tcl_WideUInt bw, } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * BetterLog10 -- * @@ -2256,24 +2280,27 @@ ApproximateLog10(Tcl_WideUInt bw, * 1 .. 10**(TEN_PMAX)-1 * * Side effects: - * Sets k_check to 0 if the new result is known to be exact, and to - * 1 if it may still be one too high. + * Sets k_check to 0 if the new result is known to be exact, and to 1 if + * it may still be one too high. * * Results: - * Returns the improved approximation to log10(d) + * Returns the improved approximation to log10(d). * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ inline static int -BetterLog10(double d, /* Original number to format */ - int k, /* Characteristic(Log base 10) of the number */ - int* k_check) /* Flag == 1 if k is inexact */ +BetterLog10( + double d, /* Original number to format. */ + int k, /* Characteristic(Log base 10) of the + * number. */ + int *k_check) /* Flag == 1 if k is inexact. */ { - /* - * Performance hack. If k is in the range 0..TEN_PMAX, then we can - * use a powers-of-ten table to check it. + /* + * Performance hack. If k is in the range 0..TEN_PMAX, then we can use a + * powers-of-ten table to check it. */ + if (k >= 0 && k <= TEN_PMAX) { if (d < tens[k]) { k--; @@ -2285,39 +2312,40 @@ BetterLog10(double d, /* Original number to format */ return k; } -/* - *----------------------------------------------------------------------------- +/* + *---------------------------------------------------------------------- * * ComputeScale -- * * Prepares to format a floating-point number as decimal. * * Parameters: - * floor(log10*x) is k (or possibly k-1). floor(log2(x) is i. - * The significand of x requires bbits bits to represent. + * floor(log10*x) is k (or possibly k-1). floor(log2(x) is i. The + * significand of x requires bbits bits to represent. * * Results: * Determines integers b2, b5, s2, s5 so that sig*2**b2*5**b5/2**s2*2**s5 - * exactly represents the value of the x/10**k. This value will lie - * in the range [1 .. 10), and allows for computing successive digits - * by multiplying sig%10 by 10. + * exactly represents the value of the x/10**k. This value will lie in + * the range [1 .. 10), and allows for computing successive digits by + * multiplying sig%10 by 10. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ inline static void -ComputeScale(int be, /* Exponent part of number: d = bw * 2**be */ - int k, /* Characteristic of log10(number) */ - int* b2, /* OUTPUT: Power of 2 in the numerator */ - int* b5, /* OUTPUT: Power of 5 in the numerator */ - int* s2, /* OUTPUT: Power of 2 in the denominator */ - int* s5) /* OUTPUT: Power of 5 in the denominator */ +ComputeScale( + int be, /* Exponent part of number: d = bw * 2**be. */ + int k, /* Characteristic of log10(number). */ + int *b2, /* OUTPUT: Power of 2 in the numerator. */ + int *b5, /* OUTPUT: Power of 5 in the numerator. */ + int *s2, /* OUTPUT: Power of 2 in the denominator. */ + int *s5) /* OUTPUT: Power of 5 in the denominator. */ { - - /* - * Scale numerator and denominator powers of 2 so that the - * input binary number is the ratio of integers + /* + * Scale numerator and denominator powers of 2 so that the input binary + * number is the ratio of integers. */ + if (be <= 0) { *b2 = 0; *s2 = -be; @@ -2326,10 +2354,11 @@ ComputeScale(int be, /* Exponent part of number: d = bw * 2**be */ *s2 = 0; } - /* - * Scale numerator and denominator so that the output decimal number - * is the ratio of integers + /* + * Scale numerator and denominator so that the output decimal number is + * the ratio of integers. */ + if (k >= 0) { *b5 = 0; *s5 = k; @@ -2342,49 +2371,45 @@ ComputeScale(int be, /* Exponent part of number: d = bw * 2**be */ } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * SetPrecisionLimits -- * - * Determines how many digits of significance should be computed - * (and, hence, how much memory need be allocated) for formatting a - * floating point number. + * Determines how many digits of significance should be computed (and, + * hence, how much memory need be allocated) for formatting a floating + * point number. * * Given that 'k' is floor(log10(x)): - * if 'shortest' format is used, there will be at most 18 digits in the result. + * if 'shortest' format is used, there will be at most 18 digits in the + * result. * if 'F' format is used, there will be at most 'ndigits' + k + 1 digits * if 'E' format is used, there will be exactly 'ndigits' digits. * * Side effects: - * Adjusts '*ndigitsPtr' to have a valid value. - * Stores the maximum memory allocation needed in *iPtr. - * Sets '*iLimPtr' to the limiting number of digits to convert if k - * has been guessed correctly, and '*iLim1Ptr' to the limiting number - * of digits to convert if k has been guessed to be one too high. + * Adjusts '*ndigitsPtr' to have a valid value. Stores the maximum memory + * allocation needed in *iPtr. Sets '*iLimPtr' to the limiting number of + * digits to convert if k has been guessed correctly, and '*iLim1Ptr' to + * the limiting number of digits to convert if k has been guessed to be + * one too high. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ inline static void -SetPrecisionLimits(int convType, - /* Type of conversion: - * TCL_DD_SHORTEST - * TCL_DD_STEELE0 - * TCL_DD_E_FMT - * TCL_DD_F_FMT */ - int k, /* Floor(log10(number to convert)) */ - int* ndigitsPtr, - /* IN/OUT: Number of digits requested - * (Will be adjusted if needed) */ - int* iPtr, /* OUT: Maximum number of digits - * to return */ - int *iLimPtr,/* OUT: Number of digits of significance - * if the bignum method is used.*/ - int *iLim1Ptr) - /* OUT: Number of digits of significance - * if the quick method is used. */ +SetPrecisionLimits( + int convType, /* Type of conversion: TCL_DD_SHORTEST, + * TCL_DD_STEELE0, TCL_DD_E_FMT, + * TCL_DD_F_FMT. */ + int k, /* Floor(log10(number to convert)) */ + int *ndigitsPtr, /* IN/OUT: Number of digits requested (will be + * adjusted if needed). */ + int *iPtr, /* OUT: Maximum number of digits to return. */ + int *iLimPtr, /* OUT: Number of digits of significance if + * the bignum method is used.*/ + int *iLim1Ptr) /* OUT: Number of digits of significance if + * the quick method is used. */ { - switch(convType) { + switch (convType) { case TCL_DD_SHORTEST0: case TCL_DD_STEELE0: *iLimPtr = *iLim1Ptr = -1; @@ -2414,29 +2439,29 @@ SetPrecisionLimits(int convType, } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * BumpUp -- * - * Increases a string of digits ending in a series of nines to - * designate the next higher number. xxxxb9999... -> xxxx(b+1)0000... + * Increases a string of digits ending in a series of nines to designate + * the next higher number. xxxxb9999... -> xxxx(b+1)0000... * * Results: * Returns a pointer to the end of the adjusted string. * * Side effects: - * In the case that the string consists solely of '999999', sets it - * to "1" and moves the decimal point (*kPtr) one place to the right. + * In the case that the string consists solely of '999999', sets it to + * "1" and moves the decimal point (*kPtr) one place to the right. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ - -inline static char* -BumpUp(char* s, /* Cursor pointing one past the end of the - * string */ - char* retval, /* Start of the string of digits */ - int* kPtr) /* Position of the decimal point */ +inline static char * +BumpUp( + char *s, /* Cursor pointing one past the end of the + * string. */ + char *retval, /* Start of the string of digits. */ + int *kPtr) /* Position of the decimal point. */ { while (*--s == '9') { if (s == retval) { @@ -2451,27 +2476,28 @@ BumpUp(char* s, /* Cursor pointing one past the end of the } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * AdjustRange -- * - * Rescales a 'double' in preparation for formatting it using the - * 'quick' double-to-string method. + * Rescales a 'double' in preparation for formatting it using the 'quick' + * double-to-string method. * * Results: - * Returns the precision that has been lost in the prescaling as - * a count of units in the least significant place. + * Returns the precision that has been lost in the prescaling as a count + * of units in the least significant place. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ inline static int -AdjustRange(double* dPtr, /* INOUT: Number to adjust */ - int k) /* IN: floor(log10(d)) */ +AdjustRange( + double *dPtr, /* INOUT: Number to adjust. */ + int k) /* IN: floor(log10(d)) */ { int ieps; /* Number of roundoff errors that have - * accumulated */ - double d = *dPtr; /* Number to adjust */ + * accumulated. */ + double d = *dPtr; /* Number to adjust. */ double ds; int i, j, j1; @@ -2481,6 +2507,7 @@ AdjustRange(double* dPtr, /* INOUT: Number to adjust */ /* * The number must be reduced to bring it into range. */ + ds = tens[k & 0xf]; j = k >> 4; if (j & BLETCH) { @@ -2499,8 +2526,9 @@ AdjustRange(double* dPtr, /* INOUT: Number to adjust */ d /= ds; } else if ((j1 = -k) != 0) { /* - * The number must be increased to bring it into range + * The number must be increased to bring it into range. */ + d *= tens[j1 & 0xf]; i = 0; for (j = j1>>4; j; j>>=1) { @@ -2517,52 +2545,52 @@ AdjustRange(double* dPtr, /* INOUT: Number to adjust */ } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * ShorteningQuickFormat -- * - * Returns a 'quick' format of a double precision number to a string - * of digits, preferring a shorter string of digits if the shorter - * string is still within 1/2 ulp of the number. + * Returns a 'quick' format of a double precision number to a string of + * digits, preferring a shorter string of digits if the shorter string is + * still within 1/2 ulp of the number. * * Results: - * Returns the string of digits. Returns NULL if the 'quick' method - * fails and the bignum method must be used. + * Returns the string of digits. Returns NULL if the 'quick' method fails + * and the bignum method must be used. * * Side effects: * Stores the position of the decimal point at '*kPtr'. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static char* -ShorteningQuickFormat(double d, /* Number to convert */ - int k, /* floor(log10(d)) */ - int ilim, /* Number of significant digits to return */ - double eps, - /* Estimated roundoff error */ - char* retval, - /* Buffer to receive the digit string */ - int* kPtr) - /* Pointer to stash the position of - * the decimal point */ +inline static char * +ShorteningQuickFormat( + double d, /* Number to convert. */ + int k, /* floor(log10(d)) */ + int ilim, /* Number of significant digits to return. */ + double eps, /* Estimated roundoff error. */ + char *retval, /* Buffer to receive the digit string. */ + int *kPtr) /* Pointer to stash the position of the + * decimal point. */ { - char* s = retval; /* Cursor in the return value */ - int digit; /* Current digit */ + char *s = retval; /* Cursor in the return value. */ + int digit; /* Current digit. */ int i; eps = 0.5 / tens[ilim-1] - eps; i = 0; for (;;) { - /* Convert a digit */ + /* + * Convert a digit. + */ digit = (int) d; d -= digit; *s++ = '0' + digit; - /* - * Truncate the conversion if the string of digits is within - * 1/2 ulp of the actual value. + /* + * Truncate the conversion if the string of digits is within 1/2 ulp + * of the actual value. */ if (d < eps) { @@ -2576,7 +2604,7 @@ ShorteningQuickFormat(double d, /* Number to convert */ /* * Bail out if the conversion fails to converge to a sufficiently - * precise value + * precise value. */ if (++i >= ilim) { @@ -2593,40 +2621,44 @@ ShorteningQuickFormat(double d, /* Number to convert */ } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * StrictQuickFormat -- * - * Convert a double precision number of a string of a precise number - * of digits, using the 'quick' double precision method. + * Convert a double precision number of a string of a precise number of + * digits, using the 'quick' double precision method. * * Results: - * Returns the digit string, or NULL if the bignum method must be - * used to do the formatting. + * Returns the digit string, or NULL if the bignum method must be used to + * do the formatting. * * Side effects: * Stores the position of the decimal point in '*kPtr'. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static char* -StrictQuickFormat(double d, /* Number to convert */ - int k, /* floor(log10(d)) */ - int ilim, /* Number of significant digits to return */ - double eps, /* Estimated roundoff error */ - char* retval, /* Start of the digit string */ - int* kPtr) /* Pointer to stash the position of - * the decimal point */ +inline static char * +StrictQuickFormat( + double d, /* Number to convert. */ + int k, /* floor(log10(d)) */ + int ilim, /* Number of significant digits to return. */ + double eps, /* Estimated roundoff error. */ + char *retval, /* Start of the digit string. */ + int *kPtr) /* Pointer to stash the position of the + * decimal point. */ { - char* s = retval; /* Cursor in the return value */ - int digit; /* Current digit of the answer */ + char *s = retval; /* Cursor in the return value. */ + int digit; /* Current digit of the answer. */ int i; eps *= tens[ilim-1]; i = 1; for (;;) { - /* Extract a digit */ + /* + * Extract a digit. + */ + digit = (int) d; d -= digit; if (d == 0.0) { @@ -2634,10 +2666,11 @@ StrictQuickFormat(double d, /* Number to convert */ } *s++ = '0' + digit; - /* - * When the given digit count is reached, handle trailing strings - * of 0 and 9. + /* + * When the given digit count is reached, handle trailing strings of 0 + * and 9. */ + if (i == ilim) { if (d > 0.5 + eps) { *kPtr = k; @@ -2654,14 +2687,17 @@ StrictQuickFormat(double d, /* Number to convert */ } } - /* Advance to the next digit */ + /* + * Advance to the next digit. + */ + ++i; d *= 10.0; } } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * QuickConversion -- * @@ -2670,42 +2706,46 @@ StrictQuickFormat(double d, /* Number to convert */ * therefore be used for the intermediate results. * * Results: - * Returns the converted string, or NULL if the bignum method must - * be used. + * Returns the converted string, or NULL if the bignum method must be + * used. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static char* -QuickConversion(double d, /* Number to format */ - int k, /* floor(log10(d)), approximately */ - int k_check, /* 0 if k is exact, 1 if it may be too high */ - int flags, /* Flags passed to dtoa: +inline static char * +QuickConversion( + double d, /* Number to format. */ + int k, /* floor(log10(d)), approximately. */ + int k_check, /* 0 if k is exact, 1 if it may be too high */ + int flags, /* Flags passed to dtoa: * TCL_DD_SHORTEN_FLAG */ - int len, /* Length of the return value */ - int ilim, /* Number of digits to store */ - int ilim1, /* Number of digits to store if we - * musguessed k */ - int* decpt, /* OUTPUT: Location of the decimal point */ - char** endPtr) /* OUTPUT: Pointer to the terminal null byte */ + int len, /* Length of the return value. */ + int ilim, /* Number of digits to store. */ + int ilim1, /* Number of digits to store if we misguessed + * k. */ + int *decpt, /* OUTPUT: Location of the decimal point. */ + char **endPtr) /* OUTPUT: Pointer to the terminal null + * byte. */ { int ieps; /* Number of 1-ulp roundoff errors that have - * accumulated in the calculation*/ - Double eps; /* Estimated roundoff error */ - char* retval; /* Returned string */ - char* end; /* Pointer to the terminal null byte in the - * returned string */ + * accumulated in the calculation. */ + Double eps; /* Estimated roundoff error. */ + char *retval; /* Returned string. */ + char *end; /* Pointer to the terminal null byte in the + * returned string. */ /* - * Bring d into the range [1 .. 10) + * Bring d into the range [1 .. 10). */ + ieps = AdjustRange(&d, k); /* - * If the guessed value of k didn't get d into range, adjust it - * by one. If that leaves us outside the range in which quick format - * is accurate, bail out. + * If the guessed value of k didn't get d into range, adjust it by one. If + * that leaves us outside the range in which quick format is accurate, + * bail out. */ + if (k_check && d < 1. && ilim > 0) { if (ilim1 < 0) { return NULL; @@ -2717,15 +2757,16 @@ QuickConversion(double d, /* Number to format */ } /* - * Compute estimated roundoff error + * Compute estimated roundoff error. */ + eps.d = ieps * d + 7.; eps.w.word0 -= (FP_PRECISION-1) << EXP_SHIFT; /* - * Handle the peculiar case where the result has no significant - * digits. + * Handle the peculiar case where the result has no significant digits. */ + retval = ckalloc(len + 1); if (ilim == 0) { d -= 5.; @@ -2742,7 +2783,9 @@ QuickConversion(double d, /* Number to format */ } } - /* Format the digit string */ + /* + * Format the digit string. + */ if (flags & TCL_DD_SHORTEN_FLAG) { end = ShorteningQuickFormat(d, k, ilim, eps.d, retval, decpt); @@ -2761,106 +2804,99 @@ QuickConversion(double d, /* Number to format */ } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * CastOutPowersOf2 -- * - * Adjust the factors 'b2', 'm2', and 's2' to cast out common powers - * of 2 from numerator and denominator in preparation for the 'bignum' - * method of floating point conversion. + * Adjust the factors 'b2', 'm2', and 's2' to cast out common powers of 2 + * from numerator and denominator in preparation for the 'bignum' method + * of floating point conversion. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ inline static void -CastOutPowersOf2(int* b2, /* Power of 2 to multiply the significand */ - int* m2, /* Power of 2 to multiply 1/2 ulp */ - int* s2) /* Power of 2 to multiply the common - * denominator */ +CastOutPowersOf2( + int *b2, /* Power of 2 to multiply the significand. */ + int *m2, /* Power of 2 to multiply 1/2 ulp. */ + int *s2) /* Power of 2 to multiply the common + * denominator. */ { int i; + if (*m2 > 0 && *s2 > 0) { /* Find the smallest power of 2 in the - * numerator */ - if (*m2 < *s2) { /* Find the lowest common denominatorr */ + * numerator. */ + if (*m2 < *s2) { /* Find the lowest common denominator. */ i = *m2; } else { i = *s2; } - *b2 -= i; /* Reduce to lowest terms */ + *b2 -= i; /* Reduce to lowest terms. */ *m2 -= i; *s2 -= i; } } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * ShorteningInt64Conversion -- * - * Converts a double-precision number to the shortest string of - * digits that reconverts exactly to the given number, or to - * 'ilim' digits if that will yield a shorter result. The numerator and - * denominator in David Gay's conversion algorithm are known to fit - * in Tcl_WideUInt, giving considerably faster arithmetic than mp_int's. + * Converts a double-precision number to the shortest string of digits + * that reconverts exactly to the given number, or to 'ilim' digits if + * that will yield a shorter result. The numerator and denominator in + * David Gay's conversion algorithm are known to fit in Tcl_WideUInt, + * giving considerably faster arithmetic than mp_int's. * * Results: - * Returns the string of significant decimal digits, in newly - * allocated memory + * Returns the string of significant decimal digits, in newly allocated + * memory * * Side effects: - * Stores the location of the decimal point in '*decpt' and the - * location of the terminal null byte in '*endPtr'. + * Stores the location of the decimal point in '*decpt' and the location + * of the terminal null byte in '*endPtr'. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static char* -ShorteningInt64Conversion(Double* dPtr, - /* Original number to convert */ - int convType, - /* Type of conversion (shortest, Steele, - E format, F format) */ - Tcl_WideUInt bw, - /* Integer significand */ - int b2, int b5, - /* Scale factor for the significand - * in the numerator */ - int m2plus, int m2minus, int m5, - /* Scale factors for 1/2 ulp in - * the numerator (will be different if - * bw == 1 */ - int s2, int s5, - /* Scale factors for the denominator */ - int k, - /* Number of output digits before the decimal - * point */ - int len, - /* Number of digits to allocate */ - int ilim, - /* Number of digits to convert if b >= s */ - int ilim1, - /* Number of digits to convert if b < s */ - int* decpt, - /* OUTPUT: Position of the decimal point */ - char** endPtr) - /* OUTPUT: Position of the terminal '\0' - * at the end of the returned string */ +inline static char * +ShorteningInt64Conversion( + Double *dPtr, /* Original number to convert. */ + int convType, /* Type of conversion (shortest, Steele, + * E format, F format). */ + Tcl_WideUInt bw, /* Integer significand. */ + int b2, int b5, /* Scale factor for the significand in the + * numerator. */ + int m2plus, int m2minus, int m5, + /* Scale factors for 1/2 ulp in the numerator + * (will be different if bw == 1. */ + int s2, int s5, /* Scale factors for the denominator. */ + int k, /* Number of output digits before the decimal + * point. */ + int len, /* Number of digits to allocate. */ + int ilim, /* Number of digits to convert if b >= s */ + int ilim1, /* Number of digits to convert if b < s */ + int *decpt, /* OUTPUT: Position of the decimal point. */ + char **endPtr) /* OUTPUT: Position of the terminal '\0' at + * the end of the returned string. */ { - - char* retval = ckalloc(len + 1); - /* Output buffer */ + char *retval = ckalloc(len + 1); + /* Output buffer. */ Tcl_WideUInt b = (bw * wuipow5[b5]) << b2; - /* Numerator of the fraction being converted */ + /* Numerator of the fraction being + * converted. */ Tcl_WideUInt S = wuipow5[s5] << s2; - /* Denominator of the fraction being - * converted */ - Tcl_WideUInt mplus, mminus; /* Ranges for testing whether the result - * is within roundoff of being exact */ - int digit; /* Current output digit */ - char* s = retval; /* Cursor in the output buffer */ - int i; /* Current position in the output buffer */ + /* Denominator of the fraction being + * converted. */ + Tcl_WideUInt mplus, mminus; /* Ranges for testing whether the result is + * within roundoff of being exact. */ + int digit; /* Current output digit. */ + char *s = retval; /* Cursor in the output buffer. */ + int i; /* Current position in the output buffer. */ - /* Adjust if the logarithm was guessed wrong */ + /* + * Adjust if the logarithm was guessed wrong. + */ if (b < S) { b = 10 * b; @@ -2869,12 +2905,16 @@ ShorteningInt64Conversion(Double* dPtr, --k; } - /* Compute roundoff ranges */ + /* + * Compute roundoff ranges. + */ mplus = wuipow5[m5] << m2plus; mminus = wuipow5[m5] << m2minus; - /* Loop through the digits */ + /* + * Loop through the digits. + */ i = 1; for (;;) { @@ -2884,21 +2924,19 @@ ShorteningInt64Conversion(Double* dPtr, } b = b % S; - /* + /* * Does the current digit put us on the low side of the exact value * but within within roundoff of being exact? */ - if (b < mplus - || (b == mplus - && convType != TCL_DD_STEELE0 - && (dPtr->w.word1 & 1) == 0)) { + + if (b < mplus || (b == mplus + && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) { /* - * Make sure we shouldn't be rounding *up* instead, - * in case the next number above is closer + * Make sure we shouldn't be rounding *up* instead, in case the + * next number above is closer. */ - if (2 * b > S - || (2 * b == S - && (digit & 1) != 0)) { + + if (2 * b > S || (2 * b == S && (digit & 1) != 0)) { ++digit; if (digit == 10) { *s++ = '9'; @@ -2907,7 +2945,9 @@ ShorteningInt64Conversion(Double* dPtr, } } - /* Stash the current digit */ + /* + * Stash the current digit. + */ *s++ = '0' + digit; break; @@ -2917,10 +2957,9 @@ ShorteningInt64Conversion(Double* dPtr, * Does one plus the current digit put us within roundoff of the * number? */ - if (b > S - mminus - || (b == S - mminus - && convType != TCL_DD_STEELE0 - && (dPtr->w.word1 & 1) == 0)) { + + if (b > S - mminus || (b == S - mminus + && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) { if (digit == 9) { *s++ = '9'; s = BumpUp(s, retval, &k); @@ -2934,27 +2973,30 @@ ShorteningInt64Conversion(Double* dPtr, /* * Have we converted all the requested digits? */ + *s++ = '0' + digit; if (i == ilim) { - if (2*b > S - || (2*b == S && (digit & 1) != 0)) { + if (2*b > S || (2*b == S && (digit & 1) != 0)) { s = BumpUp(s, retval, &k); } break; } - - /* Advance to the next digit */ - + + /* + * Advance to the next digit. + */ + b = 10 * b; mplus = 10 * mplus; mminus = 10 * mminus; ++i; } - /* + /* * Endgame - store the location of the decimal point and the end of the * string. */ + *s = '\0'; *decpt = k; if (endPtr) { @@ -2964,69 +3006,61 @@ ShorteningInt64Conversion(Double* dPtr, } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * StrictInt64Conversion -- * - * Converts a double-precision number to a fixed-length string of - * 'ilim' digits that reconverts exactly to the given number. - * ('ilim' should be replaced with 'ilim1' in the case where - * log10(d) has been overestimated). The numerator and - * denominator in David Gay's conversion algorithm are known to fit - * in Tcl_WideUInt, giving considerably faster arithmetic than mp_int's. + * Converts a double-precision number to a fixed-length string of 'ilim' + * digits that reconverts exactly to the given number. ('ilim' should be + * replaced with 'ilim1' in the case where log10(d) has been + * overestimated). The numerator and denominator in David Gay's + * conversion algorithm are known to fit in Tcl_WideUInt, giving + * considerably faster arithmetic than mp_int's. * * Results: - * Returns the string of significant decimal digits, in newly - * allocated memory + * Returns the string of significant decimal digits, in newly allocated + * memory * * Side effects: - * Stores the location of the decimal point in '*decpt' and the - * location of the terminal null byte in '*endPtr'. + * Stores the location of the decimal point in '*decpt' and the location + * of the terminal null byte in '*endPtr'. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static char* -StrictInt64Conversion(Double* dPtr, - /* Original number to convert */ - int convType, - /* Type of conversion (shortest, Steele, - E format, F format) */ - Tcl_WideUInt bw, - /* Integer significand */ - int b2, int b5, - /* Scale factor for the significand - * in the numerator */ - int s2, int s5, - /* Scale factors for the denominator */ - int k, - /* Number of output digits before the decimal - * point */ - int len, - /* Number of digits to allocate */ - int ilim, - /* Number of digits to convert if b >= s */ - int ilim1, - /* Number of digits to convert if b < s */ - int* decpt, - /* OUTPUT: Position of the decimal point */ - char** endPtr) - /* OUTPUT: Position of the terminal '\0' - * at the end of the returned string */ +inline static char * +StrictInt64Conversion( + Double *dPtr, /* Original number to convert. */ + int convType, /* Type of conversion (shortest, Steele, + * E format, F format). */ + Tcl_WideUInt bw, /* Integer significand. */ + int b2, int b5, /* Scale factor for the significand in the + * numerator. */ + int s2, int s5, /* Scale factors for the denominator. */ + int k, /* Number of output digits before the decimal + * point. */ + int len, /* Number of digits to allocate. */ + int ilim, /* Number of digits to convert if b >= s */ + int ilim1, /* Number of digits to convert if b < s */ + int *decpt, /* OUTPUT: Position of the decimal point. */ + char **endPtr) /* OUTPUT: Position of the terminal '\0' at + * the end of the returned string. */ { - - char* retval = ckalloc(len + 1); - /* Output buffer */ + char *retval = ckalloc(len + 1); + /* Output buffer. */ Tcl_WideUInt b = (bw * wuipow5[b5]) << b2; - /* Numerator of the fraction being converted */ + /* Numerator of the fraction being + * converted. */ Tcl_WideUInt S = wuipow5[s5] << s2; - /* Denominator of the fraction being - * converted */ - int digit; /* Current output digit */ - char* s = retval; /* Cursor in the output buffer */ - int i; /* Current position in the output buffer */ + /* Denominator of the fraction being + * converted. */ + int digit; /* Current output digit. */ + char *s = retval; /* Cursor in the output buffer. */ + int i; /* Current position in the output buffer. */ - /* Adjust if the logarithm was guessed wrong */ + /* + * Adjust if the logarithm was guessed wrong. + */ if (b < S) { b = 10 * b; @@ -3034,7 +3068,9 @@ StrictInt64Conversion(Double* dPtr, --k; } - /* Loop through the digits */ + /* + * Loop through the digits. + */ i = 1; for (;;) { @@ -3047,25 +3083,28 @@ StrictInt64Conversion(Double* dPtr, /* * Have we converted all the requested digits? */ + *s++ = '0' + digit; if (i == ilim) { - if (2*b > S - || (2*b == S && (digit & 1) != 0)) { + if (2*b > S || (2*b == S && (digit & 1) != 0)) { s = BumpUp(s, retval, &k); } break; } - - /* Advance to the next digit */ - + + /* + * Advance to the next digit. + */ + b = 10 * b; ++i; } - /* + /* * Endgame - store the location of the decimal point and the end of the * string. */ + *s = '\0'; *decpt = k; if (endPtr) { @@ -3075,30 +3114,30 @@ StrictInt64Conversion(Double* dPtr, } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * ShouldBankerRoundUpPowD -- * - * Test whether bankers' rounding should round a digit up. Assumption - * is made that the denominator of the fraction being tested is - * a power of 2**DIGIT_BIT. + * Test whether bankers' rounding should round a digit up. Assumption is + * made that the denominator of the fraction being tested is a power of + * 2**DIGIT_BIT. * * Results: - * Returns 1 iff the fraction is more than 1/2, or if the fraction - * is exactly 1/2 and the digit is odd. + * Returns 1 iff the fraction is more than 1/2, or if the fraction is + * exactly 1/2 and the digit is odd. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ inline static int -ShouldBankerRoundUpPowD(mp_int* b, - /* Numerator of the fraction */ - int sd, /* Denominator is 2**(sd*DIGIT_BIT) */ - int isodd) - /* 1 if the digit is odd, 0 if even */ +ShouldBankerRoundUpPowD( + mp_int *b, /* Numerator of the fraction. */ + int sd, /* Denominator is 2**(sd*DIGIT_BIT). */ + int isodd) /* 1 if the digit is odd, 0 if even. */ { int i; - static const mp_digit topbit = (1<<(DIGIT_BIT-1)); + static const mp_digit topbit = 1 << (DIGIT_BIT - 1); + if (b->used < sd || (b->dp[sd-1] & topbit) == 0) { return 0; } @@ -3114,45 +3153,41 @@ ShouldBankerRoundUpPowD(mp_int* b, } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * ShouldBankerRoundUpToNextPowD -- * - * Tests whether bankers' rounding will round down in the - * "denominator is a power of 2**MP_DIGIT" case. + * Tests whether bankers' rounding will round down in the "denominator is + * a power of 2**MP_DIGIT" case. * * Results: * Returns 1 if the rounding will be performed - which increases the * digit by one - and 0 otherwise. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ inline static int -ShouldBankerRoundUpToNextPowD(mp_int* b, - /* Numerator of the fraction */ - mp_int* m, - /* Numerator of the rounding tolerance */ - int sd, - /* Common denominator is 2**(sd*DIGIT_BIT) */ - int convType, - /* Conversion type: STEELE defeats - * round-to-even (Not sure why one wants to - * do this; I copied it from Gay) FIXME */ - int isodd, - /* 1 if the integer significand is odd */ - mp_int* temp) - /* Work area for the calculation */ +ShouldBankerRoundUpToNextPowD( + mp_int *b, /* Numerator of the fraction. */ + mp_int *m, /* Numerator of the rounding tolerance. */ + int sd, /* Common denominator is 2**(sd*DIGIT_BIT). */ + int convType, /* Conversion type: STEELE defeats + * round-to-even (not sure why one wants to do + * this; I copied it from Gay). FIXME */ + int isodd, /* 1 if the integer significand is odd. */ + mp_int *temp) /* Work area for the calculation. */ { int i; - /* - * Compare B and S-m -- which is the same as comparing B+m and S -- - * which we do by computing b+m and doing a bitwhack compare against + /* + * Compare B and S-m - which is the same as comparing B+m and S - which we + * do by computing b+m and doing a bitwhack compare against * 2**(DIGIT_BIT*sd) */ + mp_add(b, m, temp); - if (temp->used <= sd) { /* too few digits to be > S */ + if (temp->used <= sd) { /* Too few digits to be > s */ return 0; } if (temp->used > sd+1 || temp->dp[sd] > 1) { @@ -3160,85 +3195,74 @@ ShouldBankerRoundUpToNextPowD(mp_int* b, return 1; } for (i = sd-1; i >= 0; --i) { - /* check for ==s */ + /* Check for ==s */ if (temp->dp[i] != 0) { /* > s */ return 1; } } if (convType == TCL_DD_STEELE0) { - /* biased rounding */ + /* Biased rounding. */ return 0; } return isodd; } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * ShorteningBignumConversionPowD -- * - * Converts a double-precision number to the shortest string of - * digits that reconverts exactly to the given number, or to - * 'ilim' digits if that will yield a shorter result. The denominator - * in David Gay's conversion algorithm is known to be a power of - * 2**DIGIT_BIT, and hence the division in the main loop may be replaced - * by a digit shift and mask. + * Converts a double-precision number to the shortest string of digits + * that reconverts exactly to the given number, or to 'ilim' digits if + * that will yield a shorter result. The denominator in David Gay's + * conversion algorithm is known to be a power of 2**DIGIT_BIT, and hence + * the division in the main loop may be replaced by a digit shift and + * mask. * * Results: - * Returns the string of significant decimal digits, in newly - * allocated memory + * Returns the string of significant decimal digits, in newly allocated + * memory * * Side effects: - * Stores the location of the decimal point in '*decpt' and the - * location of the terminal null byte in '*endPtr'. + * Stores the location of the decimal point in '*decpt' and the location + * of the terminal null byte in '*endPtr'. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static char* -ShorteningBignumConversionPowD(Double* dPtr, - /* Original number to convert */ - int convType, - /* Type of conversion (shortest, Steele, - E format, F format) */ - Tcl_WideUInt bw, - /* Integer significand */ - int b2, int b5, - /* Scale factor for the significand - * in the numerator */ - int m2plus, int m2minus, int m5, - /* Scale factors for 1/2 ulp in - * the numerator (will be different if - * bw == 1 */ - int sd, - /* Scale factor for the denominator */ - int k, - /* Number of output digits before the decimal - * point */ - int len, - /* Number of digits to allocate */ - int ilim, - /* Number of digits to convert if b >= s */ - int ilim1, - /* Number of digits to convert if b < s */ - int* decpt, - /* OUTPUT: Position of the decimal point */ - char** endPtr) - /* OUTPUT: Position of the terminal '\0' - * at the end of the returned string */ +inline static char * +ShorteningBignumConversionPowD( + Double *dPtr, /* Original number to convert. */ + int convType, /* Type of conversion (shortest, Steele, + * E format, F format). */ + Tcl_WideUInt bw, /* Integer significand. */ + int b2, int b5, /* Scale factor for the significand in the + * numerator. */ + int m2plus, int m2minus, int m5, + /* Scale factors for 1/2 ulp in the numerator + * (will be different if bw == 1). */ + int sd, /* Scale factor for the denominator. */ + int k, /* Number of output digits before the decimal + * point. */ + int len, /* Number of digits to allocate. */ + int ilim, /* Number of digits to convert if b >= s */ + int ilim1, /* Number of digits to convert if b < s */ + int *decpt, /* OUTPUT: Position of the decimal point. */ + char **endPtr) /* OUTPUT: Position of the terminal '\0' at + * the end of the returned string. */ { - - char* retval = ckalloc(len + 1); - /* Output buffer */ - mp_int b; /* Numerator of the fraction being converted */ - mp_int mplus, mminus; /* Bounds for roundoff */ - mp_digit digit; /* Current output digit */ - char* s = retval; /* Cursor in the output buffer */ - int i; /* Index in the output buffer */ + char *retval = ckalloc(len + 1); + /* Output buffer. */ + mp_int b; /* Numerator of the fraction being + * converted. */ + mp_int mplus, mminus; /* Bounds for roundoff. */ + mp_digit digit; /* Current output digit. */ + char *s = retval; /* Cursor in the output buffer. */ + int i; /* Index in the output buffer. */ mp_int temp; int r1; - /* + /* * b = bw * 2**b2 * 5**b5 * mminus = 5**m5 */ @@ -3248,7 +3272,9 @@ ShorteningBignumConversionPowD(Double* dPtr, MulPow5(&b, b5, &b); mp_mul_2d(&b, b2, &b); - /* Adjust if the logarithm was guessed wrong */ + /* + * Adjust if the logarithm was guessed wrong. + */ if (b.used <= sd) { mp_mul_d(&b, 10, &b); @@ -3270,8 +3296,10 @@ ShorteningBignumConversionPowD(Double* dPtr, } mp_init(&temp); - /* Loop through the digits. Do division and mod by s == 2**(sd*DIGIT_BIT) - * by mp_digit extraction */ + /* + * Loop through the digits. Do division and mod by s == 2**(sd*DIGIT_BIT) + * by mp_digit extraction. + */ i = 0; for (;;) { @@ -3285,20 +3313,19 @@ ShorteningBignumConversionPowD(Double* dPtr, --b.used; mp_clamp(&b); } - /* + /* * Does the current digit put us on the low side of the exact value * but within within roundoff of being exact? */ - + r1 = mp_cmp_mag(&b, (m2plus > m2minus)? &mplus : &mminus); - if (r1 == MP_LT - || (r1 == MP_EQ - && convType != TCL_DD_STEELE0 - && (dPtr->w.word1 & 1) == 0)) { + if (r1 == MP_LT || (r1 == MP_EQ + && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) { /* - * Make sure we shouldn't be rounding *up* instead, - * in case the next number above is closer + * Make sure we shouldn't be rounding *up* instead, in case the + * next number above is closer. */ + if (ShouldBankerRoundUpPowD(&b, sd, digit&1)) { ++digit; if (digit == 10) { @@ -3308,7 +3335,9 @@ ShorteningBignumConversionPowD(Double* dPtr, } } - /* Stash the last digit */ + /* + * Stash the last digit. + */ *s++ = '0' + digit; break; @@ -3318,10 +3347,9 @@ ShorteningBignumConversionPowD(Double* dPtr, * Does one plus the current digit put us within roundoff of the * number? */ - - if (ShouldBankerRoundUpToNextPowD(&b, &mminus, sd, - convType, dPtr->w.word1 & 1, - &temp)) { + + if (ShouldBankerRoundUpToNextPowD(&b, &mminus, sd, convType, + dPtr->w.word1 & 1, &temp)) { if (digit == 9) { *s++ = '9'; s = BumpUp(s, retval, &k); @@ -3335,6 +3363,7 @@ ShorteningBignumConversionPowD(Double* dPtr, /* * Have we converted all the requested digits? */ + *s++ = '0' + digit; if (i == ilim) { if (ShouldBankerRoundUpPowD(&b, sd, digit&1)) { @@ -3342,9 +3371,11 @@ ShorteningBignumConversionPowD(Double* dPtr, } break; } - - /* Advance to the next digit */ - + + /* + * Advance to the next digit. + */ + mp_mul_d(&b, 10, &b); mp_mul_d(&mminus, 10, &mminus); if (m2plus > m2minus) { @@ -3353,10 +3384,11 @@ ShorteningBignumConversionPowD(Double* dPtr, ++i; } - /* + /* * Endgame - store the location of the decimal point and the end of the * string. */ + if (m2plus > m2minus) { mp_clear(&mplus); } @@ -3370,65 +3402,55 @@ ShorteningBignumConversionPowD(Double* dPtr, } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * StrictBignumConversionPowD -- * - * Converts a double-precision number to a fixed-lengt string of - * 'ilim' digits (or 'ilim1' if log10(d) has been overestimated.) - * The denominator in David Gay's conversion algorithm is known to - * be a power of 2**DIGIT_BIT, and hence the division in the main - * loop may be replaced by a digit shift and mask. + * Converts a double-precision number to a fixed-lengt string of 'ilim' + * digits (or 'ilim1' if log10(d) has been overestimated). The + * denominator in David Gay's conversion algorithm is known to be a power + * of 2**DIGIT_BIT, and hence the division in the main loop may be + * replaced by a digit shift and mask. * * Results: - * Returns the string of significant decimal digits, in newly - * allocated memory. + * Returns the string of significant decimal digits, in newly allocated + * memory. * * Side effects: - * Stores the location of the decimal point in '*decpt' and the - * location of the terminal null byte in '*endPtr'. + * Stores the location of the decimal point in '*decpt' and the location + * of the terminal null byte in '*endPtr'. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static char* -StrictBignumConversionPowD(Double* dPtr, - /* Original number to convert */ - int convType, - /* Type of conversion (shortest, Steele, - E format, F format) */ - Tcl_WideUInt bw, - /* Integer significand */ - int b2, int b5, - /* Scale factor for the significand - * in the numerator */ - int sd, - /* Scale factor for the denominator */ - int k, - /* Number of output digits before the decimal - * point */ - int len, - /* Number of digits to allocate */ - int ilim, - /* Number of digits to convert if b >= s */ - int ilim1, - /* Number of digits to convert if b < s */ - int* decpt, - /* OUTPUT: Position of the decimal point */ - char** endPtr) - /* OUTPUT: Position of the terminal '\0' - * at the end of the returned string */ +inline static char * +StrictBignumConversionPowD( + Double *dPtr, /* Original number to convert. */ + int convType, /* Type of conversion (shortest, Steele, + * E format, F format). */ + Tcl_WideUInt bw, /* Integer significand. */ + int b2, int b5, /* Scale factor for the significand in the + * numerator. */ + int sd, /* Scale factor for the denominator. */ + int k, /* Number of output digits before the decimal + * point. */ + int len, /* Number of digits to allocate. */ + int ilim, /* Number of digits to convert if b >= s */ + int ilim1, /* Number of digits to convert if b < s */ + int *decpt, /* OUTPUT: Position of the decimal point. */ + char **endPtr) /* OUTPUT: Position of the terminal '\0' at + * the end of the returned string. */ { - - char* retval = ckalloc(len + 1); - /* Output buffer */ - mp_int b; /* Numerator of the fraction being converted */ - mp_digit digit; /* Current output digit */ - char* s = retval; /* Cursor in the output buffer */ - int i; /* Index in the output buffer */ + char *retval = ckalloc(len + 1); + /* Output buffer. */ + mp_int b; /* Numerator of the fraction being + * converted. */ + mp_digit digit; /* Current output digit. */ + char *s = retval; /* Cursor in the output buffer. */ + int i; /* Index in the output buffer. */ mp_int temp; - /* + /* * b = bw * 2**b2 * 5**b5 */ @@ -3436,7 +3458,9 @@ StrictBignumConversionPowD(Double* dPtr, MulPow5(&b, b5, &b); mp_mul_2d(&b, b2, &b); - /* Adjust if the logarithm was guessed wrong */ + /* + * Adjust if the logarithm was guessed wrong. + */ if (b.used <= sd) { mp_mul_d(&b, 10, &b); @@ -3445,9 +3469,9 @@ StrictBignumConversionPowD(Double* dPtr, } mp_init(&temp); - /* + /* * Loop through the digits. Do division and mod by s == 2**(sd*DIGIT_BIT) - * by mp_digit extraction + * by mp_digit extraction. */ i = 1; @@ -3459,12 +3483,14 @@ StrictBignumConversionPowD(Double* dPtr, if (b.used > sd+1 || digit >= 10) { Tcl_Panic("wrong digit!"); } - --b.used; mp_clamp(&b); + --b.used; + mp_clamp(&b); } /* * Have we converted all the requested digits? */ + *s++ = '0' + digit; if (i == ilim) { if (ShouldBankerRoundUpPowD(&b, sd, digit&1)) { @@ -3472,17 +3498,20 @@ StrictBignumConversionPowD(Double* dPtr, } break; } - - /* Advance to the next digit */ - + + /* + * Advance to the next digit. + */ + mp_mul_d(&b, 10, &b); ++i; } - /* + /* * Endgame - store the location of the decimal point and the end of the * string. */ + mp_clear_multi(&b, &temp, NULL); *s = '\0'; *decpt = k; @@ -3493,7 +3522,7 @@ StrictBignumConversionPowD(Double* dPtr, } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * ShouldBankerRoundUp -- * @@ -3503,17 +3532,18 @@ StrictBignumConversionPowD(Double* dPtr, * Results: * Returns 1 if the number needs to be rounded up, 0 otherwise. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ inline static int -ShouldBankerRoundUp(mp_int* twor, - /* 2x the remainder from thd division that - * produced the last digit */ - mp_int* S, /* Denominator */ - int isodd) /* Flag == 1 if the last digit is odd */ +ShouldBankerRoundUp( + mp_int *twor, /* 2x the remainder from thd division that + * produced the last digit. */ + mp_int *S, /* Denominator. */ + int isodd) /* Flag == 1 if the last digit is odd. */ { int r = mp_cmp_mag(twor, S); + switch (r) { case MP_LT: return 0; @@ -3527,38 +3557,37 @@ ShouldBankerRoundUp(mp_int* twor, } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * ShouldBankerRoundUpToNext -- * - * Tests whether the remainder is great enough to force rounding - * to the next higher digit. + * Tests whether the remainder is great enough to force rounding to the + * next higher digit. * * Results: * Returns 1 if the number should be rounded up, 0 otherwise. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ inline static int -ShouldBankerRoundUpToNext(mp_int* b, - /* Remainder from the division that produced +ShouldBankerRoundUpToNext( + mp_int *b, /* Remainder from the division that produced * the last digit. */ - mp_int* m, - /* Numerator of the rounding tolerance */ - mp_int* S, - /* Denominator */ - int convType, - /* Conversion type: STEELE0 defeats - * round-to-even. (Not sure why one would - * want this; I coped it from Gay. FIXME */ - int isodd, - /* 1 if the integer significand is odd */ - mp_int* temp) - /* Work area needed for the calculation */ + mp_int *m, /* Numerator of the rounding tolerance. */ + mp_int *S, /* Denominator. */ + int convType, /* Conversion type: STEELE0 defeats + * round-to-even. (Not sure why one would want + * this; I coped it from Gay). FIXME */ + int isodd, /* 1 if the integer significand is odd. */ + mp_int *temp) /* Work area needed for the calculation. */ { int r; - /* Compare b and S-m: this is the same as comparing B+m and S. */ + + /* + * Compare b and S-m: this is the same as comparing B+m and S. + */ + mp_add(b, m, temp); r = mp_cmp_mag(temp, S); switch(r) { @@ -3576,9 +3605,9 @@ ShouldBankerRoundUpToNext(mp_int* b, Tcl_Panic("in ShouldBankerRoundUpToNext, trichotomy fails!"); return 0; } - + /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * ShorteningBignumConversion -- * @@ -3589,49 +3618,38 @@ ShouldBankerRoundUpToNext(mp_int* b, * Returns the string of digits. * * Side effects: - * Stores the position of the decimal point in *decpt. - * Stores a pointer to the end of the number in *endPtr. + * Stores the position of the decimal point in *decpt. Stores a pointer + * to the end of the number in *endPtr. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static char* -ShorteningBignumConversion(Double* dPtr, - /* Original number being converted */ - int convType, - /* Conversion type */ - Tcl_WideUInt bw, - /* Integer significand and exponent */ - int b2, - /* Scale factor for the significand */ - int m2plus, int m2minus, - /* Scale factors for 1/2 ulp in numerator */ - int s2, int s5, - /* Scale factors for denominator */ - int k, - /* Guessed position of the decimal point */ - int len, - /* Size of the digit buffer to allocate */ - int ilim, - /* Number of digits to convert if b >= s */ - int ilim1, - /* Number of digits to convert if b < s */ - int* decpt, - /* OUTPUT: Position of the decimal point */ - char** endPtr) - /* OUTPUT: Pointer to the end of the number */ +inline static char * +ShorteningBignumConversion( + Double *dPtr, /* Original number being converted. */ + int convType, /* Conversion type. */ + Tcl_WideUInt bw, /* Integer significand and exponent. */ + int b2, /* Scale factor for the significand. */ + int m2plus, int m2minus, /* Scale factors for 1/2 ulp in numerator. */ + int s2, int s5, /* Scale factors for denominator. */ + int k, /* Guessed position of the decimal point. */ + int len, /* Size of the digit buffer to allocate. */ + int ilim, /* Number of digits to convert if b >= s */ + int ilim1, /* Number of digits to convert if b < s */ + int *decpt, /* OUTPUT: Position of the decimal point. */ + char **endPtr) /* OUTPUT: Pointer to the end of the number */ { - char* retval = ckalloc(len+1); - /* Buffer of digits to return */ - char* s = retval; /* Cursor in the return value */ - mp_int b; /* Numerator of the result */ - mp_int mminus; /* 1/2 ulp below the result */ - mp_int mplus; /* 1/2 ulp above the result */ - mp_int S; /* Denominator of the result */ - mp_int dig; /* Current digit of the result */ - int digit; /* Current digit of the result */ - mp_int temp; /* Work area */ - int minit = 1; /* Fudge factor for when we misguess k */ + char *retval = ckalloc(len+1); + /* Buffer of digits to return. */ + char *s = retval; /* Cursor in the return value. */ + mp_int b; /* Numerator of the result. */ + mp_int mminus; /* 1/2 ulp below the result. */ + mp_int mplus; /* 1/2 ulp above the result. */ + mp_int S; /* Denominator of the result. */ + mp_int dig; /* Current digit of the result. */ + int digit; /* Current digit of the result. */ + mp_int temp; /* Work area. */ + int minit = 1; /* Fudge factor for when we misguess k. */ int i; int r1; @@ -3646,10 +3664,9 @@ ShorteningBignumConversion(Double* dPtr, MulPow5(&S, s5, &S); mp_mul_2d(&S, s2, &S); /* - * Handle the case where we guess the position of the decimal point - * wrong. + * Handle the case where we guess the position of the decimal point wrong. */ - + if (mp_cmp_mag(&b, &S) == MP_LT) { mp_mul_d(&b, 10, &b); minit = 10; @@ -3657,7 +3674,9 @@ ShorteningBignumConversion(Double* dPtr, --k; } - /* mminus = 2**m2minus * 5**m5 */ + /* + * mminus = 2**m2minus * 5**m5 + */ mp_init_set_int(&mminus, minit); mp_mul_2d(&mminus, m2minus, &mminus); @@ -3667,7 +3686,9 @@ ShorteningBignumConversion(Double* dPtr, } mp_init(&temp); - /* Loop through the digits */ + /* + * Loop through the digits. + */ mp_init(&dig); i = 1; @@ -3678,17 +3699,15 @@ ShorteningBignumConversion(Double* dPtr, } digit = dig.dp[0]; - /* + /* * Does the current digit leave us with a remainder small enough to * round to it? */ r1 = mp_cmp_mag(&b, (m2plus > m2minus)? &mplus : &mminus); - if (r1 == MP_LT - || (r1 == MP_EQ - && convType != TCL_DD_STEELE0 - && (dPtr->w.word1 & 1) == 0)) { - mp_mul_2d(&b, 1, &b); + if (r1 == MP_LT || (r1 == MP_EQ + && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) { + mp_mul_2d(&b, 1, &b); if (ShouldBankerRoundUp(&b, &S, digit&1)) { ++digit; if (digit == 10) { @@ -3702,12 +3721,12 @@ ShorteningBignumConversion(Double* dPtr, } /* - * Does the current digit leave us with a remainder large enough - * to commit to rounding up to the next higher digit? + * Does the current digit leave us with a remainder large enough to + * commit to rounding up to the next higher digit? */ if (ShouldBankerRoundUpToNext(&b, &mminus, &S, convType, - dPtr->w.word1 & 1, &temp)) { + dPtr->w.word1 & 1, &temp)) { ++digit; if (digit == 10) { *s++ = '9'; @@ -3718,22 +3737,28 @@ ShorteningBignumConversion(Double* dPtr, break; } - /* Have we converted all the requested digits? */ + /* + * Have we converted all the requested digits? + */ *s++ = '0' + digit; if (i == ilim) { mp_mul_2d(&b, 1, &b); if (ShouldBankerRoundUp(&b, &S, digit&1)) { - s = BumpUp(s, retval, &k); + s = BumpUp(s, retval, &k); } break; } - /* Advance to the next digit */ + /* + * Advance to the next digit. + */ if (s5 > 0) { + /* + * Can possibly shorten the denominator. + */ - /* Can possibly shorten the denominator */ mp_mul_2d(&b, 1, &b); mp_mul_2d(&mminus, 1, &mminus); if (m2plus > m2minus) { @@ -3741,17 +3766,18 @@ ShorteningBignumConversion(Double* dPtr, } mp_div_d(&S, 5, &S, NULL); --s5; - /* - * TODO: It might possibly be a win to fall back to - * int64 arithmetic here if S < 2**64/10. But it's - * a win only for a fairly narrow range of magnitudes - * so perhaps not worth bothering. We already know that - * we shorten the denominator by at least 1 mp_digit, perhaps - * 2. as we do the conversion for 17 digits of significance. + + /* + * TODO: It might possibly be a win to fall back to int64 + * arithmetic here if S < 2**64/10. But it's a win only for + * a fairly narrow range of magnitudes so perhaps not worth + * bothering. We already know that we shorten the + * denominator by at least 1 mp_digit, perhaps 2, as we do + * the conversion for 17 digits of significance. * Possible savings: * 10**26 1 trip through loop before fallback possible * 10**27 1 trip - * 10**28 2 trips + * 10**28 2 trips * 10**29 3 trips * 10**30 4 trips * 10**31 5 trips @@ -3766,7 +3792,7 @@ ShorteningBignumConversion(Double* dPtr, * 10**40 14 trips * 10**41 15 trips * 10**42 16 trips - * thereafter no gain. + * thereafter no gain. */ } else { mp_mul_d(&b, 10, &b); @@ -3779,11 +3805,11 @@ ShorteningBignumConversion(Double* dPtr, ++i; } - - /* + /* * Endgame - store the location of the decimal point and the end of the * string. */ + if (m2plus > m2minus) { mp_clear(&mplus); } @@ -3794,59 +3820,51 @@ ShorteningBignumConversion(Double* dPtr, *endPtr = s; } return retval; - } - + /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * StrictBignumConversion -- * - * Convert a floating point number to a fixed-length digit string - * using the multiprecision method. + * Convert a floating point number to a fixed-length digit string using + * the multiprecision method. * * Results: * Returns the string of digits. * * Side effects: - * Stores the position of the decimal point in *decpt. - * Stores a pointer to the end of the number in *endPtr. + * Stores the position of the decimal point in *decpt. Stores a pointer + * to the end of the number in *endPtr. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -inline static char* -StrictBignumConversion(Double* dPtr, - /* Original number being converted */ - int convType, - /* Conversion type */ - Tcl_WideUInt bw, - /* Integer significand and exponent */ - int b2, /* Scale factor for the significand */ - int s2, int s5, - /* Scale factors for denominator */ - int k, /* Guessed position of the decimal point */ - int len, /* Size of the digit buffer to allocate */ - int ilim, - /* Number of digits to convert if b >= s */ - int ilim1, - /* Number of digits to convert if b < s */ - int* decpt, - /* OUTPUT: Position of the decimal point */ - char** endPtr) - /* OUTPUT: Pointer to the end of the number */ +inline static char * +StrictBignumConversion( + Double *dPtr, /* Original number being converted. */ + int convType, /* Conversion type. */ + Tcl_WideUInt bw, /* Integer significand and exponent. */ + int b2, /* Scale factor for the significand. */ + int s2, int s5, /* Scale factors for denominator. */ + int k, /* Guessed position of the decimal point. */ + int len, /* Size of the digit buffer to allocate. */ + int ilim, /* Number of digits to convert if b >= s */ + int ilim1, /* Number of digits to convert if b < s */ + int *decpt, /* OUTPUT: Position of the decimal point. */ + char **endPtr) /* OUTPUT: Pointer to the end of the number */ { - char* retval = ckalloc(len+1); - /* Buffer of digits to return */ - char* s = retval; /* Cursor in the return value */ - mp_int b; /* Numerator of the result */ - mp_int S; /* Denominator of the result */ - mp_int dig; /* Current digit of the result */ - int digit; /* Current digit of the result */ - mp_int temp; /* Work area */ - int g; /* Size of the current digit groun */ + char *retval = ckalloc(len+1); + /* Buffer of digits to return. */ + char *s = retval; /* Cursor in the return value. */ + mp_int b; /* Numerator of the result. */ + mp_int S; /* Denominator of the result. */ + mp_int dig; /* Current digit of the result. */ + int digit; /* Current digit of the result. */ + mp_int temp; /* Work area. */ + int g; /* Size of the current digit ground. */ int i, j; - + /* * b = bw * 2**b2 * 5**b5 * S = 2**s2 * 5*s5 @@ -3858,10 +3876,9 @@ StrictBignumConversion(Double* dPtr, MulPow5(&S, s5, &S); mp_mul_2d(&S, s2, &S); /* - * Handle the case where we guess the position of the decimal point - * wrong. + * Handle the case where we guess the position of the decimal point wrong. */ - + if (mp_cmp_mag(&b, &S) == MP_LT) { mp_mul_d(&b, 10, &b); ilim =ilim1; @@ -3869,29 +3886,33 @@ StrictBignumConversion(Double* dPtr, } mp_init(&temp); - /* Convert the leading digit */ + /* + * Convert the leading digit. + */ mp_init(&dig); i = 0; mp_div(&b, &S, &dig, &b); if (dig.used > 1 || dig.dp[0] >= 10) { - Tcl_Panic("wrong digit!"); - } + Tcl_Panic("wrong digit!"); + } digit = dig.dp[0]; - /* Is a single digit all that was requested? */ + /* + * Is a single digit all that was requested? + */ *s++ = '0' + digit; if (++i >= ilim) { mp_mul_2d(&b, 1, &b); if (ShouldBankerRoundUp(&b, &S, digit&1)) { - s = BumpUp(s, retval, &k); + s = BumpUp(s, retval, &k); } } else { - for (;;) { - - /* Shift by a group of digits. */ + /* + * Shift by a group of digits. + */ g = ilim - i; if (g > DIGIT_GROUP) { @@ -3908,20 +3929,19 @@ StrictBignumConversion(Double* dPtr, mp_mul_d(&b, dpow5[g], &b); } mp_mul_2d(&b, g, &b); - + /* - * As with the shortening bignum conversion, it's possible at - * this point that we will have reduced the denominator to - * less than 2**64/10, at which point it would be possible to - * fall back to to int64 arithmetic. But the potential payoff - * is tremendously less - unless we're working in F format - - * because we know that three groups of digits will always - * suffice for %#.17e, the longest format that doesn't introduce - * empty precision. + * As with the shortening bignum conversion, it's possible at this + * point that we will have reduced the denominator to less than + * 2**64/10, at which point it would be possible to fall back to + * to int64 arithmetic. But the potential payoff is tremendously + * less - unless we're working in F format - because we know that + * three groups of digits will always suffice for %#.17e, the + * longest format that doesn't introduce empty precision. + * + * Extract the next group of digits. */ - /* Extract the next group of digits */ - mp_div(&b, &S, &dig, &b); if (dig.used > 1) { Tcl_Panic("wrong digit!"); @@ -3929,26 +3949,31 @@ StrictBignumConversion(Double* dPtr, digit = dig.dp[0]; for (j = g-1; j >= 0; --j) { int t = itens[j]; + *s++ = digit / t + '0'; digit %= t; } i += g; - - /* Have we converted all the requested digits? */ - + + /* + * Have we converted all the requested digits? + */ + if (i == ilim) { mp_mul_2d(&b, 1, &b); if (ShouldBankerRoundUp(&b, &S, digit&1)) { - s = BumpUp(s, retval, &k); + s = BumpUp(s, retval, &k); } break; } } } - /* + + /* * Endgame - store the location of the decimal point and the end of the * string. */ + mp_clear_multi(&b, &temp, NULL); *s = '\0'; *decpt = k; @@ -3956,120 +3981,120 @@ StrictBignumConversion(Double* dPtr, *endPtr = s; } return retval; - } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * TclDoubleDigits -- * - * Core of Tcl's conversion of double-precision floating point numbers - * to decimal. + * Core of Tcl's conversion of double-precision floating point numbers to + * decimal. * * Results: * Returns a newly-allocated string of digits. * * Side effects: * Sets *decpt to the index of the character in the string before the - * place that the decimal point should go. If 'endPtr' is not NULL, - * sets endPtr to point to the terminating '\0' byte of the string. - * Sets *sign to 1 if a minus sign should be printed with the number, - * or 0 if a plus sign (or no sign) should appear. + * place that the decimal point should go. If 'endPtr' is not NULL, sets + * endPtr to point to the terminating '\0' byte of the string. Sets *sign + * to 1 if a minus sign should be printed with the number, or 0 if a plus + * sign (or no sign) should appear. * - * This function is a service routine that produces the string of digits - * for floating-point-to-decimal conversion. It can do a number of things + * This function is a service routine that produces the string of digits for + * floating-point-to-decimal conversion. It can do a number of things * according to the 'flags' argument. Valid values for 'flags' include: - * TCL_DD_SHORTEST - This is the default for floating point conversion - * if ::tcl_precision is 0. It constructs the shortest string - * of digits that will reconvert to the given number when scanned. + * TCL_DD_SHORTEST - This is the default for floating point conversion if + * ::tcl_precision is 0. It constructs the shortest string of + * digits that will reconvert to the given number when scanned. * For floating point numbers that are exactly between two * decimal numbers, it resolves using the 'round to even' rule. * With this value, the 'ndigits' parameter is ignored. - * TCL_DD_STEELE - This value is not recommended and may be removed - * in the future. It follows the conversion algorithm outlined - * in "How to Print Floating-Point Numbers Accurately" by - * Guy L. Steele, Jr. and Jon L. White [Proc. ACM SIGPLAN '90, - * pp. 112-126]. This rule has the effect of rendering 1e23 - * as 9.9999999999999999e22 - which is a 'better' approximation - * in the sense that it will reconvert correctly even if - * a subsequent input conversion is 'round up' or 'round down' + * TCL_DD_STEELE - This value is not recommended and may be removed in + * the future. It follows the conversion algorithm outlined in + * "How to Print Floating-Point Numbers Accurately" by Guy + * L. Steele, Jr. and Jon L. White [Proc. ACM SIGPLAN '90, + * pp. 112-126]. This rule has the effect of rendering 1e23 as + * 9.9999999999999999e22 - which is a 'better' approximation in + * the sense that it will reconvert correctly even if a + * subsequent input conversion is 'round up' or 'round down' * rather than 'round to nearest', but is surprising otherwise. - * TCL_DD_E_FORMAT - This value is used to prepare numbers for %e - * format conversion (or for default floating->string if - * tcl_precision is not 0). It constructs a string of at most - * 'ndigits' digits, choosing the one that is closest to the - * given number (and resolving ties with 'round to even'). - * It is allowed to return fewer than 'ndigits' if the number - * converts exactly; if the TCL_DD_E_FORMAT|TCL_DD_SHORTEN_FLAG - * is supplied instead, it is also allowed to return fewer digits - * if the shorter string will still reconvert to the given - * input number. - * TCL_DD_F_FORMAT - This value is used to prepare numbers for %f - * format conversion. It requests that conversion proceed until + * TCL_DD_E_FORMAT - This value is used to prepare numbers for %e format + * conversion (or for default floating->string if tcl_precision + * is not 0). It constructs a string of at most 'ndigits' digits, + * choosing the one that is closest to the given number (and + * resolving ties with 'round to even'). It is allowed to return + * fewer than 'ndigits' if the number converts exactly; if the + * TCL_DD_E_FORMAT|TCL_DD_SHORTEN_FLAG is supplied instead, it is + * also allowed to return fewer digits if the shorter string will + * still reconvert to the given input number. + * TCL_DD_F_FORMAT - This value is used to prepare numbers for %f format + * conversion. It requests that conversion proceed until * 'ndigits' digits after the decimal point have been converted. - * It is possible for this format to result in a zero-length - * string if the number is sufficiently small. Again, it - * is permissible for TCL_DD_F_FORMAT to return fewer digits - * for a number that converts exactly, and changing the - * argument to TCL_DD_F_FORMAT|TCL_DD_SHORTEN_FLAG will allow - * the routine also to return fewer digits if the shorter string - * will still reconvert without loss to the given input number. - * - * To any of these flags may be OR'ed TCL_DD_NO_QUICK; this flag - * requires all calculations to be done in exact arithmetic. Normally, - * E and F format with fewer than about 14 digits will be done with - * a quick floating point approximation and fall back on the exact - * arithmetic only if the input number is close enough to the - * midpoint between two decimal strings that more precision is needed - * to resolve which string is correct. - * - * The value stored in the 'decpt' argument on return may be negative - * (indicating that the decimal point falls to the left of the string) - * or greater than the length of the string. In addition, the value -9999 - * is used as a sentinel to indicate that the string is one of the special - * values "Infinity" and "NaN", and that no decimal point should be inserted. - * - *----------------------------------------------------------------------------- + * It is possible for this format to result in a zero-length + * string if the number is sufficiently small. Again, it is + * permissible for TCL_DD_F_FORMAT to return fewer digits for a + * number that converts exactly, and changing the argument to + * TCL_DD_F_FORMAT|TCL_DD_SHORTEN_FLAG will allow the routine + * also to return fewer digits if the shorter string will still + * reconvert without loss to the given input number. + * + * To any of these flags may be OR'ed TCL_DD_NO_QUICK; this flag requires + * all calculations to be done in exact arithmetic. Normally, E and F + * format with fewer than about 14 digits will be done with a quick + * floating point approximation and fall back on the exact arithmetic + * only if the input number is close enough to the midpoint between two + * decimal strings that more precision is needed to resolve which string + * is correct. + * + * The value stored in the 'decpt' argument on return may be negative + * (indicating that the decimal point falls to the left of the string) or + * greater than the length of the string. In addition, the value -9999 is used + * as a sentinel to indicate that the string is one of the special values + * "Infinity" and "NaN", and that no decimal point should be inserted. + * + *---------------------------------------------------------------------- */ -char* -TclDoubleDigits(double dv, /* Number to convert */ - int ndigits, /* Number of digits requested */ - int flags, /* Conversion flags */ - int* decpt, /* OUTPUT: Position of the decimal point */ - int* sign, /* OUTPUT: 1 if the result is negative */ - char** endPtr) /* OUTPUT: If not NULL, receives a pointer - * to one character beyond the end - * of the returned string */ + +char * +TclDoubleDigits( + double dv, /* Number to convert. */ + int ndigits, /* Number of digits requested. */ + int flags, /* Conversion flags. */ + int *decpt, /* OUTPUT: Position of the decimal point. */ + int *sign, /* OUTPUT: 1 if the result is negative. */ + char **endPtr) /* OUTPUT: If not NULL, receives a pointer to + * one character beyond the end of the + * returned string. */ { int convType = (flags & TCL_DD_CONVERSION_TYPE_MASK); - /* Type of conversion being performed - * TCL_DD_SHORTEST0 - * TCL_DD_STEELE0 - * TCL_DD_E_FORMAT - * TCL_DD_F_FORMAT */ - Double d; /* Union for deconstructing doubles */ - Tcl_WideUInt bw; /* Integer significand */ + /* Type of conversion being performed: + * TCL_DD_SHORTEST0, TCL_DD_STEELE0, + * TCL_DD_E_FORMAT, or TCL_DD_F_FORMAT. */ + Double d; /* Union for deconstructing doubles. */ + Tcl_WideUInt bw; /* Integer significand. */ int be; /* Power of 2 by which b must be multiplied */ - int bbits; /* Number of bits needed to represent b */ + int bbits; /* Number of bits needed to represent b. */ int denorm; /* Flag == 1 iff the input number was - * denormalized */ - int k; /* Estimate of floor(log10(d)) */ - int k_check; /* Flag == 1 if d is near enough to a - * power of ten that k must be checked */ + * denormalized. */ + int k; /* Estimate of floor(log10(d)). */ + int k_check; /* Flag == 1 if d is near enough to a power of + * ten that k must be checked. */ int b2, b5, s2, s5; /* Powers of 2 and 5 in the numerator and - * denominator of intermediate results */ - int ilim = -1, ilim1 = -1; /* Number of digits to convert, and number - * to convert if log10(d) has been - * overestimated */ - char* retval; /* Return value from this function */ + * denominator of intermediate results. */ + int ilim = -1, ilim1 = -1; /* Number of digits to convert, and number to + * convert if log10(d) has been + * overestimated. */ + char *retval; /* Return value from this function. */ int i = -1; - /* Put the input number into a union for bit-whacking */ + /* + * Put the input number into a union for bit-whacking. + */ d.d = dv; - /* + /* * Handle the cases of negative numbers (by taking the absolute value: * this includes -Inf and -NaN!), infinity, Not a Number, and zero. */ @@ -4082,12 +4107,12 @@ TclDoubleDigits(double dv, /* Number to convert */ return FormatZero(decpt, endPtr); } - /* + /* * Unpack the floating point into a wide integer and an exponent. - * Determine the number of bits that the big integer requires, and - * compute a quick approximation (which may be one too high) of - * ceil(log10(d.d)). + * Determine the number of bits that the big integer requires, and compute + * a quick approximation (which may be one too high) of ceil(log10(d.d)). */ + denorm = ((d.w.word0 & EXP_MASK) == 0); DoubleToExpAndSig(d.d, &bw, &be, &bbits); k = ApproximateLog10(bw, be, bbits); @@ -4095,60 +4120,59 @@ TclDoubleDigits(double dv, /* Number to convert */ /* At this point, we have: * d is the number to convert. - * bw are significand and exponent: d == bw*2**be, + * bw are significand and exponent: d == bw*2**be, * bbits is the length of bw: 2**bbits-1 <= bw < 2**bbits - * k is either ceil(log10(d)) or ceil(log10(d))+1. k_check is 0 - * if we know that k is exactly ceil(log10(d)) and 1 if we need to - * check. - * We want a rational number + * k is either ceil(log10(d)) or ceil(log10(d))+1. k_check is 0 if we + * know that k is exactly ceil(log10(d)) and 1 if we need to check. + * We want a rational number * r = b * 10**(1-k) = bw * 2**b2 * 5**b5 / (2**s2 / 5**s5), * with b2, b5, s2, s5 >= 0. Note that the most significant decimal - * digit is floor(r) and that successive digits can be obtained - * by setting r <- 10*floor(r) (or b <= 10 * (b % S)). - * Find appropriate b2, b5, s2, s5. + * digit is floor(r) and that successive digits can be obtained by + * setting r <- 10*floor(r) (or b <= 10 * (b % S)). Find appropriate + * b2, b5, s2, s5. */ ComputeScale(be, k, &b2, &b5, &s2, &s5); /* - * Correct an incorrect caller-supplied 'ndigits'. - * Also determine: + * Correct an incorrect caller-supplied 'ndigits'. Also determine: * i = The maximum number of decimal digits that will be returned in the * formatted string. This is k + 1 + ndigits for F format, 18 for - * shortest and Steele, and ndigits for E format. - * ilim = The number of significant digits to convert if - * k has been guessed correctly. This is -1 for shortest and Steele - * (which stop when all significance has been lost), 'ndigits' - * for E format, and 'k + 1 + ndigits' for F format. - * ilim1 = The minimum number of significant digits to convert if - * k has been guessed 1 too high. This, too, is -1 for shortest - * and Steele, and 'ndigits' for E format, but it's 'ndigits-1' - * for F format. + * shortest and Steele, and ndigits for E format. + * ilim = The number of significant digits to convert if k has been + * guessed correctly. This is -1 for shortest and Steele (which + * stop when all significance has been lost), 'ndigits' for E + * format, and 'k + 1 + ndigits' for F format. + * ilim1 = The minimum number of significant digits to convert if k has + * been guessed 1 too high. This, too, is -1 for shortest and + * Steele, and 'ndigits' for E format, but it's 'ndigits-1' for F + * format. */ SetPrecisionLimits(convType, k, &ndigits, &i, &ilim, &ilim1); - /* - * Try to do low-precision conversion in floating point rather - * than resorting to expensive multiprecision arithmetic + /* + * Try to do low-precision conversion in floating point rather than + * resorting to expensive multiprecision arithmetic. */ + if (ilim >= 0 && ilim <= QUICK_MAX && !(flags & TCL_DD_NO_QUICK)) { - if ((retval = QuickConversion(d.d, k, k_check, flags, - i, ilim, ilim1, - decpt, endPtr)) != NULL) { + retval = QuickConversion(d.d, k, k_check, flags, i, ilim, ilim1, + decpt, endPtr); + if (retval != NULL) { return retval; } } - /* - * For shortening conversions, determine the upper and lower bounds - * for the remainder at which we can stop. - * m+ = (2**m2plus * 5**m5) / (2**s2 * 5**s5) is the limit on the - * high side, and - * m- = (2**m2minus * 5**m5) / (2**s2 * 5**s5) is the limit on the - * low side. - * We may need to increase s2 to put m2plus, m2minus, b2 over a - * common denominator. + /* + * For shortening conversions, determine the upper and lower bounds for + * the remainder at which we can stop. + * m+ = (2**m2plus * 5**m5) / (2**s2 * 5**s5) is the limit on the high + * side, and + * m- = (2**m2minus * 5**m5) / (2**s2 * 5**s5) is the limit on the low + * side. + * We may need to increase s2 to put m2plus, m2minus, b2 over a common + * denominator. */ if (flags & TCL_DD_SHORTEN_FLAG) { @@ -4157,11 +4181,11 @@ TclDoubleDigits(double dv, /* Number to convert */ int m5 = b5; int len = i; - /* - * Find the quantity i so that (2**i*5**b5)/(2**s2*5**s5) - * is 1/2 unit in the least significant place of the floating - * point number. + /* + * Find the quantity i so that (2**i*5**b5)/(2**s2*5**s5) is 1/2 unit + * in the least significant place of the floating point number. */ + if (denorm) { i = be + EXPONENT_BIAS + (FP_PRECISION-1); } else { @@ -4170,16 +4194,18 @@ TclDoubleDigits(double dv, /* Number to convert */ b2 += i; s2 += i; - /* + /* * Reduce the fractions to lowest terms, since the above calculation - * may have left excess powers of 2 in numerator and denominator + * may have left excess powers of 2 in numerator and denominator. */ + CastOutPowersOf2(&b2, &m2minus, &s2); /* * In the special case where bw==1, the nearest floating point number * to it on the low side is 1/4 ulp below it. Adjust accordingly. */ + m2plus = m2minus; if (!denorm && bw == 1) { ++b2; @@ -4187,60 +4213,56 @@ TclDoubleDigits(double dv, /* Number to convert */ ++m2plus; } - if (s5+1 < N_LOG2POW5 - && s2+1 + log2pow5[s5+1] <= 64) { + if (s5+1 < N_LOG2POW5 && s2+1 + log2pow5[s5+1] <= 64) { /* - * If 10*2**s2*5**s5 == 2**(s2+1)+5**(s5+1) fits in a 64-bit - * word, then all our intermediate calculations can be done - * using exact 64-bit arithmetic with no need for expensive - * multiprecision operations. (This will be true for all numbers - * in the range [1.0e-3 .. 1.0e+24]). + * If 10*2**s2*5**s5 == 2**(s2+1)+5**(s5+1) fits in a 64-bit word, + * then all our intermediate calculations can be done using exact + * 64-bit arithmetic with no need for expensive multiprecision + * operations. (This will be true for all numbers in the range + * [1.0e-3 .. 1.0e+24]). */ - return ShorteningInt64Conversion(&d, convType, bw, b2, b5, - m2plus, m2minus, m5, - s2, s5, k, len, ilim, ilim1, - decpt, endPtr); + return ShorteningInt64Conversion(&d, convType, bw, b2, b5, m2plus, + m2minus, m5, s2, s5, k, len, ilim, ilim1, decpt, endPtr); } else if (s5 == 0) { /* - * The denominator is a power of 2, so we can replace division - * by digit shifts. First we round up s2 to a multiple of - * DIGIT_BIT, and adjust m2 and b2 accordingly. Then we launch - * into a version of the comparison that's specialized for - * the 'power of mp_digit in the denominator' case. + * The denominator is a power of 2, so we can replace division by + * digit shifts. First we round up s2 to a multiple of DIGIT_BIT, + * and adjust m2 and b2 accordingly. Then we launch into a version + * of the comparison that's specialized for the 'power of mp_digit + * in the denominator' case. */ + if (s2 % DIGIT_BIT != 0) { int delta = DIGIT_BIT - (s2 % DIGIT_BIT); + b2 += delta; m2plus += delta; m2minus += delta; s2 += delta; } return ShorteningBignumConversionPowD(&d, convType, bw, b2, b5, - m2plus, m2minus, m5, - s2/DIGIT_BIT, k, len, - ilim, ilim1, decpt, endPtr); + m2plus, m2minus, m5, s2/DIGIT_BIT, k, len, ilim, ilim1, + decpt, endPtr); } else { - - /* - * Alas, there's no helpful special case; use full-up - * bignum arithmetic for the conversion + /* + * Alas, there's no helpful special case; use full-up bignum + * arithmetic for the conversion. */ - return ShorteningBignumConversion(&d, convType, bw, - b2, m2plus, m2minus, - s2, s5, k, len, - ilim, ilim1, decpt, endPtr); - + return ShorteningBignumConversion(&d, convType, bw, b2, m2plus, + m2minus, s2, s5, k, len, ilim, ilim1, decpt, endPtr); } - } else { - - /* Non-shortening conversion */ + /* + * Non-shortening conversion. + */ int len = i; - /* Reduce numerator and denominator to lowest terms */ + /* + * Reduce numerator and denominator to lowest terms. + */ if (b2 >= s2 && s2 > 0) { b2 -= s2; s2 = 0; @@ -4248,48 +4270,46 @@ TclDoubleDigits(double dv, /* Number to convert */ s2 -= b2; b2 = 0; } - if (s5+1 < N_LOG2POW5 - && s2+1 + log2pow5[s5+1] <= 64) { + if (s5+1 < N_LOG2POW5 && s2+1 + log2pow5[s5+1] <= 64) { /* - * If 10*2**s2*5**s5 == 2**(s2+1)+5**(s5+1) fits in a 64-bit - * word, then all our intermediate calculations can be done - * using exact 64-bit arithmetic with no need for expensive - * multiprecision operations. + * If 10*2**s2*5**s5 == 2**(s2+1)+5**(s5+1) fits in a 64-bit word, + * then all our intermediate calculations can be done using exact + * 64-bit arithmetic with no need for expensive multiprecision + * operations. */ - return StrictInt64Conversion(&d, convType, bw, b2, b5, - s2, s5, k, len, ilim, ilim1, - decpt, endPtr); - + return StrictInt64Conversion(&d, convType, bw, b2, b5, s2, s5, k, + len, ilim, ilim1, decpt, endPtr); } else if (s5 == 0) { /* - * The denominator is a power of 2, so we can replace division - * by digit shifts. First we round up s2 to a multiple of - * DIGIT_BIT, and adjust m2 and b2 accordingly. Then we launch - * into a version of the comparison that's specialized for - * the 'power of mp_digit in the denominator' case. + * The denominator is a power of 2, so we can replace division by + * digit shifts. First we round up s2 to a multiple of DIGIT_BIT, + * and adjust m2 and b2 accordingly. Then we launch into a version + * of the comparison that's specialized for the 'power of mp_digit + * in the denominator' case. */ + if (s2 % DIGIT_BIT != 0) { int delta = DIGIT_BIT - (s2 % DIGIT_BIT); + b2 += delta; s2 += delta; } return StrictBignumConversionPowD(&d, convType, bw, b2, b5, - s2/DIGIT_BIT, k, len, - ilim, ilim1, decpt, endPtr); + s2/DIGIT_BIT, k, len, ilim, ilim1, decpt, endPtr); } else { /* - * There are no helpful special cases, but at least we know - * in advance how many digits we will convert. We can run the - * conversion in steps of DIGIT_GROUP digits, so as to - * have many fewer mp_int divisions. + * There are no helpful special cases, but at least we know in + * advance how many digits we will convert. We can run the + * conversion in steps of DIGIT_GROUP digits, so as to have many + * fewer mp_int divisions. */ - return StrictBignumConversion(&d, convType, bw, b2, s2, s5, - k, len, ilim, ilim1, decpt, endPtr); + + return StrictBignumConversion(&d, convType, bw, b2, s2, s5, k, + len, ilim, ilim1, decpt, endPtr); } - } + } } - /* *---------------------------------------------------------------------- @@ -4317,14 +4337,12 @@ TclInitDoubleConversion(void) int x; Tcl_WideUInt u; double d; - #ifdef IEEE_FLOATING_POINT union { double dv; Tcl_WideUInt iv; } bitwhack; #endif - #if defined(__sgi) && defined(_COMPILER_VERSION) union fpc_csr mipsCR; @@ -4349,8 +4367,8 @@ TclInitDoubleConversion(void) pow10_wide[i] = u; /* - * Determine how many bits of precision a double has, and how many - * decimal digits that represents. + * Determine how many bits of precision a double has, and how many decimal + * digits that represents. */ if (frexp((double) FLT_RADIX, &log2FLT_RADIX) != 0.5) { @@ -4361,8 +4379,8 @@ TclInitDoubleConversion(void) d = 1.0; /* - * Initialize a table of powers of ten that can be exactly represented - * in a double. + * Initialize a table of powers of ten that can be exactly represented in + * a double. */ x = (int) (DBL_MANT_DIG * log((double) FLT_RADIX) / log(5.0)); @@ -4474,9 +4492,9 @@ TclFinalizeDoubleConversion(void) int Tcl_InitBignumFromDouble( - Tcl_Interp *interp, /* For error message */ - double d, /* Number to convert */ - mp_int *b) /* Place to store the result */ + Tcl_Interp *interp, /* For error message. */ + double d, /* Number to convert. */ + mp_int *b) /* Place to store the result. */ { double fract; int expt; @@ -4590,7 +4608,7 @@ TclBignumToDouble( } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * TclCeil -- * @@ -4600,7 +4618,7 @@ TclBignumToDouble( * Results: * Returns the floating point number. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ double @@ -4647,17 +4665,17 @@ TclCeil( } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * TclFloor -- * - * Computes the largest floating point number less than or equal to - * the mp_int argument. + * Computes the largest floating point number less than or equal to the + * mp_int argument. * * Results: * Returns the floating point value. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ double @@ -4718,8 +4736,8 @@ TclFloor( static double BignumToBiasedFrExp( - const mp_int *a, /* Integer to convert */ - int *machexp) /* Power of two */ + const mp_int *a, /* Integer to convert. */ + int *machexp) /* Power of two. */ { mp_int b; int bits; @@ -4783,8 +4801,8 @@ BignumToBiasedFrExp( static double Pow10TimesFrExp( - int exponent, /* Power of 10 to multiply by */ - double fraction, /* Significand of multiplicand */ + int exponent, /* Power of 10 to multiply by. */ + double fraction, /* Significand of multiplicand. */ int *machexp) /* On input, exponent of multiplicand. On * output, exponent of result. */ { @@ -4794,7 +4812,7 @@ Pow10TimesFrExp( if (exponent > 0) { /* - * Multiply by 10**exponent + * Multiply by 10**exponent. */ retval = frexp(retval * pow10vals[exponent&0xf], &j); @@ -4807,7 +4825,7 @@ Pow10TimesFrExp( } } else if (exponent < 0) { /* - * Divide by 10**-exponent + * Divide by 10**-exponent. */ retval = frexp(retval / pow10vals[(-exponent) & 0xf], &j); @@ -4916,26 +4934,27 @@ TclFormatNaN( * * Nokia770Twiddle -- * - * Transpose the two words of a number for Nokia 770 floating - * point handling. + * Transpose the two words of a number for Nokia 770 floating point + * handling. * *---------------------------------------------------------------------- */ - +#ifdef IEEE_FLOATING_POINT static Tcl_WideUInt Nokia770Twiddle( - Tcl_WideUInt w) /* Number to transpose */ + Tcl_WideUInt w) /* Number to transpose. */ { return (((w >> 32) & 0xffffffff) | (w << 32)); } +#endif /* *---------------------------------------------------------------------- * * TclNokia770Doubles -- * - * Transpose the two words of a number for Nokia 770 floating - * point handling. + * Transpose the two words of a number for Nokia 770 floating point + * handling. * *---------------------------------------------------------------------- */ diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 2e8759e..755614a 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 2010/08/22 18:53:26 nijtmans Exp $ + * RCS: @(#) $Id: tclTrace.c,v 1.60.2.1 2010/12/11 18:39:29 kennykb Exp $ */ #include "tclInt.h" @@ -24,11 +24,11 @@ typedef struct { int flags; /* Operations for which Tcl command is to be * invoked. */ size_t length; /* Number of non-NUL chars. in command. */ - char command[4]; /* Space for Tcl command to invoke. Actual + char command[1]; /* Space for Tcl command to invoke. Actual * size will be as large as necessary to hold * command. This field must be the last in the - * structure, so that it can be larger than 4 - * bytes. */ + * structure, so that it can be larger than 1 + * byte. */ } TraceVarInfo; typedef struct { @@ -58,11 +58,11 @@ typedef struct { * deleted too early. Keeps track of how many * pieces of code have a pointer to this * structure. */ - char command[4]; /* Space for Tcl command to invoke. Actual + char command[1]; /* Space for Tcl command to invoke. Actual * size will be as large as necessary to hold * command. This field must be the last in the - * structure, so that it can be larger than 4 - * bytes. */ + * structure, so that it can be larger than 1 + * byte. */ } TraceCommandInfo; /* @@ -464,9 +464,8 @@ TraceExecutionObjCmd( length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) - ckalloc((unsigned) (sizeof(TraceCommandInfo) - - sizeof(tcmdPtr->command) + length + 1)); - + ckalloc((unsigned) ((TclOffset(TraceCommandInfo, command) + + 1) + length)); tcmdPtr->flags = flags; tcmdPtr->stepTrace = NULL; tcmdPtr->startLevel = 0; @@ -701,8 +700,8 @@ TraceCommandObjCmd( length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) - ckalloc((unsigned) (sizeof(TraceCommandInfo) - - sizeof(tcmdPtr->command) + length + 1)); + ckalloc((unsigned) ((TclOffset(TraceCommandInfo, command) + + 1) + length)); tcmdPtr->flags = flags; tcmdPtr->stepTrace = NULL; @@ -902,8 +901,8 @@ TraceVariableObjCmd( length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { CombinedTraceVarInfo *ctvarPtr = (CombinedTraceVarInfo *) - ckalloc((unsigned) (sizeof(CombinedTraceVarInfo) - + length + 1 - sizeof(ctvarPtr->traceCmdInfo.command))); + ckalloc((unsigned) ((TclOffset(CombinedTraceVarInfo, + traceCmdInfo.command) + 1) + length)); ctvarPtr->traceCmdInfo.flags = flags; if (objv[0] == NULL) { diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 4e43176..2e435e6 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.2 2010/12/01 16:42:36 kennykb Exp $ + * RCS: @(#) $Id: tclUtil.c,v 1.117.2.3 2010/12/11 18:39:29 kennykb Exp $ */ #include "tclInt.h" @@ -2527,7 +2527,7 @@ TclFormatInt(buffer, n) long intVal; int i; int numFormatted, j; - char *digits = "0123456789"; + const char *digits = "0123456789"; /* * Check first whether "n" is zero. @@ -3328,7 +3328,7 @@ TclReToGlob( Tcl_DString *dsPtr, int *exactPtr) { - int anchorLeft, anchorRight, lastIsStar; + int anchorLeft, anchorRight, lastIsStar, numStars; char *dsStr, *dsStrStart; const char *msg, *p, *strEnd; @@ -3387,6 +3387,7 @@ TclReToGlob( p = reStr; anchorRight = 0; lastIsStar = 0; + numStars = 0; if (*p == '^') { anchorLeft = 1; @@ -3450,6 +3451,7 @@ TclReToGlob( if (!lastIsStar) { *dsStr++ = '*'; lastIsStar = 1; + numStars++; } continue; } else if (p[1] == '+') { @@ -3457,6 +3459,7 @@ TclReToGlob( *dsStr++ = '?'; *dsStr++ = '*'; lastIsStar = 1; + numStars++; continue; } } @@ -3480,6 +3483,15 @@ TclReToGlob( } lastIsStar = 0; } + if (numStars > 1) { + /* + * Heuristic: if >1 non-anchoring *, the risk is large that glob + * matching is slower than the RE engine, so report invalid. + */ + msg = "excessive recursive glob backtrack potential"; + goto invalidGlob; + } + if (!anchorRight && !lastIsStar) { *dsStr++ = '*'; } diff --git a/generic/tclVar.c b/generic/tclVar.c index 75363cf..2d67a7c 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.2 2010/09/27 20:33:37 kennykb Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.203.2.3 2010/12/11 18:39:29 kennykb Exp $ */ #include "tclInt.h" @@ -4226,18 +4226,18 @@ TclInitArrayCmd( Tcl_Interp *interp) /* Current interpreter. */ { static const EnsembleImplMap arrayImplMap[] = { - {"anymore", ArrayAnyMoreCmd, NULL, NULL, NULL}, - {"donesearch", ArrayDoneSearchCmd, NULL, NULL, NULL}, - {"exists", ArrayExistsCmd, NULL, NULL, NULL}, - {"get", ArrayGetCmd, NULL, NULL, NULL}, - {"names", ArrayNamesCmd, NULL, NULL, NULL}, - {"nextelement", ArrayNextElementCmd, NULL, NULL, NULL}, - {"set", ArraySetCmd, NULL, NULL, NULL}, - {"size", ArraySizeCmd, NULL, NULL, NULL}, - {"startsearch", ArrayStartSearchCmd, NULL, NULL, NULL}, - {"statistics", ArrayStatsCmd, NULL, NULL, NULL}, - {"unset", ArrayUnsetCmd, NULL, NULL, NULL}, - {NULL, NULL, NULL, NULL, NULL} + {"anymore", ArrayAnyMoreCmd, NULL, NULL, NULL, 0}, + {"donesearch", ArrayDoneSearchCmd, NULL, NULL, NULL, 0}, + {"exists", ArrayExistsCmd, NULL, NULL, NULL, 0}, + {"get", ArrayGetCmd, NULL, NULL, NULL, 0}, + {"names", ArrayNamesCmd, NULL, NULL, NULL, 0}, + {"nextelement", ArrayNextElementCmd, NULL, NULL, NULL, 0}, + {"set", ArraySetCmd, NULL, NULL, NULL, 0}, + {"size", ArraySizeCmd, NULL, NULL, NULL, 0}, + {"startsearch", ArrayStartSearchCmd, NULL, NULL, NULL, 0}, + {"statistics", ArrayStatsCmd, NULL, NULL, NULL, 0}, + {"unset", ArrayUnsetCmd, NULL, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} }; return TclMakeEnsemble(interp, "array", arrayImplMap); diff --git a/tests/append.test b/tests/append.test index 3c000df..c6120f2 100644 --- a/tests/append.test +++ b/tests/append.test @@ -11,16 +11,16 @@ # 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 2010/09/01 20:35:33 andreas_kupries Exp $ +# RCS: @(#) $Id: append.test,v 1.12.2.1 2010/12/11 18:39:29 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } -catch {unset x} - +unset -nocomplain x + test append-1.1 {append command} { - catch {unset x} + unset -nocomplain x list [append x 1 2 abc "long string"] $x } {{12abclong string} {12abclong string}} test append-1.2 {append command} { @@ -52,12 +52,12 @@ test append-3.2 {append errors} -returnCodes error -body { append x(0) 44 } -result {can't set "x(0)": variable isn't array} test append-3.3 {append errors} -returnCodes error -body { - catch {unset x} + unset -nocomplain x append x } -result {can't read "x": no such variable} test append-4.1 {lappend command} { - catch {unset x} + unset -nocomplain x list [lappend x 1 2 abc "long string"] $x } {{1 2 abc {long string}} {1 2 abc {long string}}} test append-4.2 {lappend command} { @@ -128,19 +128,19 @@ test append-4.16 {lappend command} { lappend x abc } "x abc" test append-4.17 {lappend command} { - catch {unset x} + unset -nocomplain x lappend x } {} test append-4.18 {lappend command} { - catch {unset x} + unset -nocomplain x lappend x {} } {{}} test append-4.19 {lappend command} { - catch {unset x} + unset -nocomplain x lappend x(0) } {} test append-4.20 {lappend command} { - catch {unset x} + unset -nocomplain x lappend x(0) abc } {abc} unset -nocomplain x @@ -154,7 +154,7 @@ test append-4.22 {lappend command} -returnCodes error -body { } -result {unmatched open quote in list} test append-5.1 {long lappends} -setup { - catch {unset x} + unset -nocomplain x proc check {var size} { set l [llength $var] if {$l != $size} { @@ -188,7 +188,7 @@ test append-6.2 {lappend errors} -returnCodes error -body { test append-7.1 {lappend-created var and error in trace on that var} -setup { catch {rename foo ""} - catch {unset x} + unset -nocomplain x } -body { trace variable x w foo proc foo {} {global x; unset x} @@ -200,8 +200,8 @@ test append-7.1 {lappend-created var and error in trace on that var} -setup { list [info exists x] [catch {set x} msg] $msg } -result {0 1 {can't read "x": no such variable}} test append-7.2 {lappend var triggers read trace} -setup { - catch {unset myvar} - catch {unset ::result} + unset -nocomplain myvar + unset -nocomplain ::result } -body { trace variable myvar r foo proc foo {args} {append ::result $args} @@ -209,8 +209,8 @@ test append-7.2 {lappend var triggers read trace} -setup { return $::result } -result {myvar {} r} test append-7.3 {lappend var triggers read trace, array var} -setup { - catch {unset myvar} - catch {unset ::result} + unset -nocomplain myvar + unset -nocomplain ::result } -body { # The behavior of read triggers on lappend changed in 8.0 to not trigger # them, and was changed back in 8.4. @@ -220,8 +220,8 @@ test append-7.3 {lappend var triggers read trace, array var} -setup { return $::result } -result {myvar b r} test append-7.4 {lappend var triggers read trace, array var exists} -setup { - catch {unset myvar} - catch {unset ::result} + unset -nocomplain myvar + unset -nocomplain ::result } -body { set myvar(0) 1 trace variable myvar r foo @@ -230,8 +230,8 @@ test append-7.4 {lappend var triggers read trace, array var exists} -setup { return $::result } -result {myvar b r} test append-7.5 {append var does not trigger read trace} -setup { - catch {unset myvar} - catch {unset ::result} + unset -nocomplain myvar + unset -nocomplain ::result } -body { trace variable myvar r foo proc foo {args} {append ::result $args} @@ -239,15 +239,16 @@ test append-7.5 {append var does not trigger read trace} -setup { info exists ::result } -result {0} +# THERE ARE NO append-8.* TESTS +# New tests for bug 3057639 to show off the more consistent behaviour of +# lappend in both direct-eval and bytecompiled code paths (see appendComp.test +# for the compiled variants). lappend now behaves like append. 9.0/1 lappend - +# 9.2/3 append -# New tests for bug 3057639 to show off the more consistent behaviour -# of lappend in both direct-eval and bytecompiled code paths (see -# appendComp.test for the compiled variants). lappend now behaves like -# append. 9.0/1 lappend - 9.2/3 append - -test append-9.0 {bug 3057639, lappend direct eval, read trace on non-existing array variable element} { - catch {unset myvar} +test append-9.0 {bug 3057639, lappend direct eval, read trace on non-existing array variable element} -setup { + unset -nocomplain myvar +} -body { array set myvar {} proc nonull {var key val} { upvar 1 $var lvar @@ -259,17 +260,19 @@ test append-9.0 {bug 3057639, lappend direct eval, read trace on non-existing ar list [catch { lappend myvar(key) "new value" } msg] $msg -} {0 {{new value}}} - -test append-9.1 {bug 3057639, lappend direct eval, read trace on non-existing env element} { - catch {unset ::env(__DUMMY__)} +} -result {0 {{new value}}} +test append-9.1 {bug 3057639, lappend direct eval, read trace on non-existing env element} -setup { + unset -nocomplain ::env(__DUMMY__) +} -body { list [catch { lappend ::env(__DUMMY__) "new value" } msg] $msg -} {0 {{new value}}} - -test append-9.2 {bug 3057639, append direct eval, read trace on non-existing array variable element} { - catch {unset myvar} +} -cleanup { + unset -nocomplain ::env(__DUMMY__) +} -result {0 {{new value}}} +test append-9.2 {bug 3057639, append direct eval, read trace on non-existing array variable element} -setup { + unset -nocomplain myvar +} -body { array set myvar {} proc nonull {var key val} { upvar 1 $var lvar @@ -281,19 +284,25 @@ test append-9.2 {bug 3057639, append direct eval, read trace on non-existing arr list [catch { append myvar(key) "new value" } msg] $msg -} {0 {new value}} - -test append-9.3 {bug 3057639, append direct eval, read trace on non-existing env element} { - catch {unset ::env(__DUMMY__)} +} -result {0 {new value}} +test append-9.3 {bug 3057639, append direct eval, read trace on non-existing env element} -setup { + unset -nocomplain ::env(__DUMMY__) +} -body { list [catch { append ::env(__DUMMY__) "new value" } msg] $msg -} {0 {new value}} - - -catch {unset i x result y} +} -cleanup { + unset -nocomplain ::env(__DUMMY__) +} -result {0 {new value}} + +unset -nocomplain i x result y catch {rename foo ""} # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/appendComp.test b/tests/appendComp.test index 9523d2d..93323fb 100644 --- a/tests/appendComp.test +++ b/tests/appendComp.test @@ -11,19 +11,20 @@ # 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 2010/09/01 20:35:33 andreas_kupries Exp $ +# RCS: @(#) $Id: appendComp.test,v 1.13.2.1 2010/12/11 18:39:30 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } catch {unset x} - -test appendComp-1.1 {append command} { - catch {unset x} + +test appendComp-1.1 {append command} -setup { + unset -nocomplain x +} -body { proc foo {} {append ::x 1 2 abc "long string"} list [foo] $x -} {{12abclong string} {12abclong string}} +} -result {{12abclong string} {12abclong string}} test appendComp-1.2 {append command} { proc foo {} { set x "" @@ -67,7 +68,7 @@ test appendComp-3.2 {append errors} -returnCodes error -body { } -result {can't set "x(0)": variable isn't array} test appendComp-3.3 {append errors} -returnCodes error -body { proc foo {} { - catch {unset x} + unset -nocomplain x append x } foo @@ -76,7 +77,7 @@ test appendComp-3.3 {append errors} -returnCodes error -body { test appendComp-4.1 {lappend command} { proc foo {} { global x - catch {unset x} + unset -nocomplain x lappend x 1 2 abc "long string" } list [foo] $x @@ -207,27 +208,31 @@ test appendComp-4.20 {lappend command} { foo } {abc} -proc check {var size} { - set l [llength $var] - if {$l != $size} { - return "length mismatch: should have been $size, was $l" - } - for {set i 0} {$i < $size} {set i [expr $i+1]} { - set j [lindex $var $i] - if {$j != "item $i"} { - return "element $i should have been \"item $i\", was \"$j\"" +test appendComp-5.1 {long lappends} -setup { + unset -nocomplain x + proc check {var size} { + set l [llength $var] + if {$l != $size} { + return "length mismatch: should have been $size, was $l" } + for {set i 0} {$i < $size} {incr i} { + set j [lindex $var $i] + if {$j ne "item $i"} { + return "element $i should have been \"item $i\", was \"$j\"" + } + } + return ok } - return ok -} -test appendComp-5.1 {long lappends} { - catch {unset x} +} -body { set x "" for {set i 0} {$i < 300} {set i [expr $i+1]} { lappend x "item $i" } check $x 300 -} ok +} -cleanup { + unset -nocomplain x + catch {rename check ""} +} -result ok test appendComp-6.1 {lappend errors} -returnCodes error -body { proc foo {} {lappend} @@ -243,7 +248,7 @@ test appendComp-6.2 {lappend errors} -returnCodes error -body { test appendComp-7.1 {lappendComp-created var and error in trace on that var} -setup { catch {rename foo ""} - catch {unset x} + unset -nocomplain x } -body { proc bar {} { global x @@ -259,7 +264,7 @@ test appendComp-7.1 {lappendComp-created var and error in trace on that var} -se bar } -result {0 1 {can't read "x": no such variable}} test appendComp-7.2 {lappend var triggers read trace, index var} -setup { - catch {unset ::result} + unset -nocomplain ::result } -body { proc bar {} { trace variable myvar r foo @@ -282,7 +287,7 @@ test appendComp-7.3 {lappend var triggers read trace, stack var} -setup { bar } -result {::myvar {} r} -constraints {bug-3057639} test appendComp-7.4 {lappend var triggers read trace, array var} -setup { - catch {unset ::result} + unset -nocomplain ::result } -body { # The behavior of read triggers on lappend changed in 8.0 to not trigger # them. Maybe not correct, but been there a while. @@ -295,7 +300,7 @@ test appendComp-7.4 {lappend var triggers read trace, array var} -setup { bar } -result {myvar b r} -constraints {bug-3057639} test appendComp-7.5 {lappend var triggers read trace, array var} -setup { - catch {unset ::result} + unset -nocomplain ::result } -body { # The behavior of read triggers on lappend changed in 8.0 to not trigger # them. Maybe not correct, but been there a while. @@ -308,7 +313,7 @@ test appendComp-7.5 {lappend var triggers read trace, array var} -setup { bar } -result {myvar b r} test appendComp-7.6 {lappend var triggers read trace, array var exists} -setup { - catch {unset ::result} + unset -nocomplain ::result } -body { proc bar {} { set myvar(0) 1 @@ -320,8 +325,8 @@ test appendComp-7.6 {lappend var triggers read trace, array var exists} -setup { bar } -result {myvar b r} -constraints {bug-3057639} test appendComp-7.7 {lappend var triggers read trace, array stack var} -setup { - catch {unset ::myvar} - catch {unset ::result} + unset -nocomplain ::myvar + unset -nocomplain ::result } -body { proc bar {} { trace variable ::myvar r foo @@ -332,8 +337,8 @@ test appendComp-7.7 {lappend var triggers read trace, array stack var} -setup { bar } -result {::myvar b r} -constraints {bug-3057639} test appendComp-7.8 {lappend var triggers read trace, array stack var} -setup { - catch {unset ::myvar} - catch {unset ::result} + unset -nocomplain ::myvar + unset -nocomplain ::result } -body { proc bar {} { trace variable ::myvar r foo @@ -344,7 +349,7 @@ test appendComp-7.8 {lappend var triggers read trace, array stack var} -setup { bar } -result {::myvar b r} test appendComp-7.9 {append var does not trigger read trace} -setup { - catch {unset ::result} + unset -nocomplain ::result } -body { proc bar {} { trace variable myvar r foo @@ -369,25 +374,24 @@ test appendComp-8.1 {defer error to runtime} -setup { interp delete slave } -result {} +# New tests for bug 3057639 to show off the more consistent behaviour of +# lappend in both direct-eval and bytecompiled code paths (see append.test for +# the direct-eval variants). lappend now behaves like append. 9.0/1 lappend - +# 9.2/3 append. -# New tests for bug 3057639 to show off the more consistent behaviour -# of lappend in both direct-eval and bytecompiled code paths (see -# append.test for the direct-eval variants). lappend now behaves like -# append. 9.0/1 lappend - 9.2/3 append. - -# Note also the tests above now constrained by bug-3057639, these -# changed behaviour with the triggering of read traces in bc mode -# gone. +# Note also the tests above now constrained by bug-3057639, these changed +# behaviour with the triggering of read traces in bc mode gone. -# Going back to the tests below. The direct-eval tests are ok before -# and after patch (no read traces run for lappend, append). The -# compiled tests are failing for lappend (9.0/1) before the patch, -# showing how it invokes read traces in the compiled path. The append -# tests are good (9.2/3). After the patch the failues are gone. +# Going back to the tests below. The direct-eval tests are ok before and after +# patch (no read traces run for lappend, append). The compiled tests are +# failing for lappend (9.0/1) before the patch, showing how it invokes read +# traces in the compiled path. The append tests are good (9.2/3). After the +# patch the failues are gone. -test appendComp-9.0 {bug 3057639, lappend compiled, read trace on non-existing array variable element} { - catch {unset myvar} +test appendComp-9.0 {bug 3057639, lappend compiled, read trace on non-existing array variable element} -setup { + unset -nocomplain myvar array set myvar {} +} -body { proc nonull {var key val} { upvar 1 $var lvar if {![info exists lvar($key)]} { @@ -399,22 +403,21 @@ test appendComp-9.0 {bug 3057639, lappend compiled, read trace on non-existing a lappend ::myvar(key) "new value" } list [catch { foo } msg] $msg -} {0 {{new value}}} - - -test appendComp-9.1 {bug 3057639, lappend direct eval, read trace on non-existing env element} { - catch {unset ::env(__DUMMY__)} +} -result {0 {{new value}}} +test appendComp-9.1 {bug 3057639, lappend direct eval, read trace on non-existing env element} -setup { + unset -nocomplain ::env(__DUMMY__) +} -body { proc foo {} { lappend ::env(__DUMMY__) "new value" } list [catch { foo } msg] $msg -} {0 {{new value}}} - - - -test appendComp-9.2 {bug 3057639, append compiled, read trace on non-existing array variable element} { - catch {unset myvar} +} -cleanup { + unset -nocomplain ::env(__DUMMY__) +} -result {0 {{new value}}} +test appendComp-9.2 {bug 3057639, append compiled, read trace on non-existing array variable element} -setup { + unset -nocomplain myvar array set myvar {} +} -body { proc nonull {var key val} { upvar 1 $var lvar if {![info exists lvar($key)]} { @@ -426,18 +429,18 @@ test appendComp-9.2 {bug 3057639, append compiled, read trace on non-existing ar append ::myvar(key) "new value" } list [catch { foo } msg] $msg -} {0 {new value}} - - -test appendComp-9.3 {bug 3057639, append direct eval, read trace on non-existing env element} { - catch {unset ::env(__DUMMY__)} +} -result {0 {new value}} +test appendComp-9.3 {bug 3057639, append direct eval, read trace on non-existing env element} -setup { + unset -nocomplain ::env(__DUMMY__) +} -body { proc foo {} { append ::env(__DUMMY__) "new value" } list [catch { foo } msg] $msg -} {0 {new value}} - - +} -cleanup { + unset -nocomplain ::env(__DUMMY__) +} -result {0 {new value}} + catch {unset i x result y} catch {rename foo ""} catch {rename bar ""} @@ -447,3 +450,8 @@ catch {rename bar {}} # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/cmdAH.test b/tests/cmdAH.test index f7ba584..2213c57 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.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: cmdAH.test,v 1.68 2010/02/05 14:33:09 dkf Exp $ +# RCS: @(#) $Id: cmdAH.test,v 1.68.4.1 2010/12/11 18:39:30 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 @@ -218,10 +218,10 @@ test cmdAH-4.13 {Tcl_EncodingObjCmd} -setup { test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body { file -} -result {wrong # args: should be "file option ?arg ...?"} +} -result {wrong # args: should be "file subcommand ?arg ...?"} test cmdAH-5.2 {Tcl_FileObjCmd} -returnCodes error -body { file x -} -result {bad option "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable} +} -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable} test cmdAH-5.3 {Tcl_FileObjCmd} -returnCodes error -body { file exists } -result {wrong # args: should be "file exists name"} @@ -242,7 +242,7 @@ test cmdAH-6.3 {Tcl_FileObjCmd: volumes} {unix} { } {0} test cmdAH-6.4 {Tcl_FileObjCmd: volumes} win { set volumeList [string tolower [file volumes]] - list [catch {lsearch $volumeList "c:/"} element] [expr $element != -1] [catch {list glob -nocomplain [lindex $volumeList $element]*}] + list [catch {lsearch $volumeList "c:/"} element] [expr {$element != -1}] [catch {list glob -nocomplain [lindex $volumeList $element]*}] } {0 1 0} # attributes @@ -1415,25 +1415,25 @@ test cmdAH-29.5 {Tcl_FileObjCmd: type} { # Error conditions test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file gorp x -} -result {bad option "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable} +} -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable} test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file ex x -} -match glob -result {ambiguous option "ex": must be *} +} -match glob -result {unknown or ambiguous subcommand "ex": must be *} test cmdAH-30.3 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file is x -} -match glob -result {ambiguous option "is": must be *} +} -match glob -result {unknown or ambiguous subcommand "is": must be *} test cmdAH-30.4 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file z x -} -match glob -result {bad option "z": must be *} +} -match glob -result {unknown or ambiguous subcommand "z": must be *} test cmdAH-30.5 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file read x -} -match glob -result {ambiguous option "read": must be *} +} -match glob -result {unknown or ambiguous subcommand "read": must be *} test cmdAH-30.6 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file s x -} -match glob -result {ambiguous option "s": must be *} +} -match glob -result {unknown or ambiguous subcommand "s": must be *} test cmdAH-30.7 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file t x -} -match glob -result {ambiguous option "t": must be *} +} -match glob -result {unknown or ambiguous subcommand "t": must be *} test cmdAH-30.8 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file dirname ~woohgy } -result {user "woohgy" doesn't exist} @@ -1445,7 +1445,7 @@ test cmdAH-30.8 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { interp create simpleInterp interp create -safe safeInterp interp create -safeInterp expose file file +catch {safeInterp expose file file} test cmdAH-31.1 {Tcl_FileObjCmd: channels, too many args} -body { file channels a b diff --git a/tests/fCmd.test b/tests/fCmd.test index 1436a28..09e2622 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -10,10 +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: fCmd.test,v 1.70 2009/11/24 00:08:27 patthoyts Exp $ +# RCS: @(#) $Id: fCmd.test,v 1.70.4.1 2010/12/11 18:39:30 kennykb Exp $ # -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -22,16 +22,16 @@ testConstraint testsetplatform [llength [info commands testsetplatform]] testConstraint testchmod [llength [info commands testchmod]] testConstraint winVista 0 testConstraint win2000orXP 0 -testConstraint winOlderThan2000 0 # Don't know how to determine this constraint correctly testConstraint notNetworkFilesystem 0 -testConstraint 95or98 [expr {[testConstraint 95] || [testConstraint 98]}] -testConstraint 2000orNewer [expr {[testConstraint win] && ![testConstraint 95or98]}] testConstraint reg 0 if {[testConstraint win]} { catch { # Is the registry extension already static to this shell? - if [catch {load {} Registry; set ::reglib {}}] { + try { + load {} Registry + set ::reglib {} + } on error {} { # try the location given to use on the commandline to tcltest ::tcltest::loadTestedCommands load $::reglib Registry @@ -52,7 +52,7 @@ if {[testConstraint unix]} { } # Also used in winFCmd... -if {[testConstraint winOnly]} { +if {[testConstraint win]} { set major [string index $tcl_platform(osVersion) 0] if {[testConstraint nt] && $major > 4} { if {$major > 5} { @@ -60,15 +60,14 @@ if {[testConstraint winOnly]} { } elseif {$major == 5} { testConstraint win2000orXP 1 } - } else { - testConstraint winOlderThan2000 1 } } -testConstraint darwin9 [expr {[testConstraint unix] && - $tcl_platform(os) eq "Darwin" && - int([string range $tcl_platform(osVersion) 0 \ - [string first . $tcl_platform(osVersion)]]) >= 9}] +testConstraint darwin9 [expr { + [testConstraint unix] + && $tcl_platform(os) eq "Darwin" + && [package vsatisfies 1.$tcl_platform(osVersion) 1.9] +}] testConstraint notDarwin9 [expr {![testConstraint darwin9]}] testConstraint fileSharing 0 @@ -106,11 +105,11 @@ proc createfile {file {string a}} { # if the file does not exist, or has a different content # proc checkcontent {file matchString} { - if {[catch { + try { set f [open $file] set fileString [read $f] close $f - }]} then { + } on error {} { return 0 } return [string match $matchString $fileString] @@ -163,8 +162,8 @@ testConstraint xdev [expr {[testConstraint unix] && ([dev .] != [dev /tmp])}] set root [lindex [file split [pwd]] 0] -# A really long file name -# length of long is 1216 chars, which should be greater than any static buffer +# A really long file name. +# Length of long is 1216 chars, which should be greater than any static buffer # or allowable filename. set long "abcdefghihjllmnopqrstuvwxyz01234567890" @@ -173,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 { @@ -192,7 +191,7 @@ test fCmd-2.1 {TclFileCopyCmd} -constraints {notRoot} -setup { test fCmd-3.1 {FileCopyRename: FileForceOption fails} -constraints {notRoot} -body { file rename -xyz -} -returnCodes error -result {bad option "-xyz": should be -force or --} +} -returnCodes error -result {bad option "-xyz": must be -force or --} test fCmd-3.2 {FileCopyRename: not enough args} -constraints {notRoot} -body { file rename xyz } -returnCodes error -result {wrong # args: should be "file rename ?-option value ...? source ?source ...? target"} @@ -390,7 +389,7 @@ test fCmd-4.16 {TclFileMakeDirsCmd: TclpCreateDirectory succeeds} -setup { test fCmd-5.1 {TclFileDeleteCmd: FileForceOption fails} -constraints {notRoot} -body { file delete -xyz -} -returnCodes error -result {bad option "-xyz": should be -force or --} +} -returnCodes error -result {bad option "-xyz": must be -force or --} test fCmd-5.2 {TclFileDeleteCmd: accept 0 files (TIP 323)} -body { file delete -force -force } -result {} @@ -737,7 +736,7 @@ test fCmd-7.4 {FileForceOption: bad option} -constraints {notRoot} -setup { file delete -tf1 } -returnCodes error -cleanup { file delete -- -tf1 -} -result {bad option "-tf1": should be -force or --} +} -result {bad option "-tf1": must be -force or --} test fCmd-7.5 {FileForceOption: multiple times through loop} -setup { cleanup } -constraints {notRoot} -returnCodes error -body { @@ -791,9 +790,20 @@ test fCmd-9.3 {file rename: comprehensive: file to new name} -setup { file rename tf2 tf4 list [lsort [glob tf*]] [file writable tf3] [file writable tf4] } -result {{tf3 tf4} 1 0} -test fCmd-9.4 {file rename: comprehensive: dir to new name} -setup { +test fCmd-9.4.a {file rename: comprehensive: dir to new name} -setup { + cleanup +} -constraints {win win2000orXP testchmod} -body { + file mkdir td1 td2 + testchmod 555 td2 + file rename td1 td3 + file rename td2 td4 + list [lsort [glob td*]] [file writable td3] [file writable td4] +} -cleanup { + cleanup +} -result {{td3 td4} 1 0} +test fCmd-9.4.b {file rename: comprehensive: dir to new name} -setup { cleanup -} -constraints {unixOrPc notRoot testchmod notDarwin9 win2000orXP} -body { +} -constraints {unix notRoot testchmod notDarwin9} -body { file mkdir td1 td2 testchmod 555 td2 file rename td1 td3 @@ -812,9 +822,19 @@ test fCmd-9.5 {file rename: comprehensive: file to self} -setup { file rename -force tf2 tf2 list [contents tf1] [contents tf2] [file writable tf1] [file writable tf2] } -result {tf1 tf2 1 0} -test fCmd-9.6 {file rename: comprehensive: dir to self} -setup { +test fCmd-9.6.a {file rename: comprehensive: dir to self} -setup { cleanup -} -constraints {notRoot unixOrPc testchmod win2000orXP} -body { +} -constraints {win win2000orXP testchmod} -body { + file mkdir td1 + file mkdir td2 + testchmod 555 td2 + file rename -force td1 . + file rename -force td2 . + list [lsort [glob td*]] [file writable td1] [file writable td2] +} -result {{td1 td2} 1 0} +test fCmd-9.6.b {file rename: comprehensive: dir to self} -setup { + cleanup +} -constraints {unix notRoot testchmod} -body { file mkdir td1 file mkdir td2 testchmod 555 td2 @@ -1022,7 +1042,7 @@ test fCmd-10.2 {file copy: comprehensive: file to new name} -setup { } -result {{tf1 tf2 tf3 tf4} tf1 tf2 1 0} test fCmd-10.3 {file copy: comprehensive: dir to new name} -setup { cleanup -} -constraints {notRoot unixOrPc 95or98 testchmod} -body { +} -constraints {unix notRoot testchmod} -body { file mkdir [file join td1 tdx] file mkdir [file join td2 tdy] testchmod 555 td2 @@ -1036,7 +1056,7 @@ test fCmd-10.3 {file copy: comprehensive: dir to new name} -setup { } -result [list {td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 0] test fCmd-10.3.1 {file copy: comprehensive: dir to new name} -setup { cleanup -} -constraints {notRoot 2000orNewer testchmod} -body { +} -constraints {win notRoot testchmod} -body { # On Windows with ACLs, copying a directory is defined like this file mkdir [file join td1 tdx] file mkdir [file join td2 tdy] @@ -1123,7 +1143,7 @@ test fCmd-10.7 {file rename: comprehensive: file to new name and dir} -setup { } -result [subst {{tf1 tf2} {[file join td1 tf3] [file join td1 tf4]} 1 0}] test fCmd-10.8 {file rename: comprehensive: dir to new name and dir} -setup { cleanup -} -constraints {notRoot unixOrPc 95or98 testchmod} -body { +} -constraints {unix notRoot testchmod} -body { file mkdir td1 file mkdir td2 file mkdir td3 @@ -1135,7 +1155,7 @@ test fCmd-10.8 {file rename: comprehensive: dir to new name and dir} -setup { } -result [subst {{td1 td2 td3} {[file join td3 td3] [file join td3 td4]} 1 0}] test fCmd-10.8.1 {file rename: comprehensive: dir to new name and dir} -setup { cleanup -} -constraints {notRoot 2000orNewer testchmod} -body { +} -constraints {win notRoot testchmod} -body { # On Windows with ACLs, copying a directory is defined like this file mkdir td1 file mkdir td2 @@ -1529,8 +1549,7 @@ test fCmd-15.1 {TclMakeDirsCmd: target filename translation failing} -setup { set ::env(HOME) $temp } -result {1} # -# Can Tcl_SplitPath return argc == 0? If so them we need a -# test for that code. +# Can Tcl_SplitPath return argc == 0? If so them we need a test for that code. # test fCmd-15.2 {TclMakeDirsCmd - one directory} -setup { catch {file delete -force -- tfa} @@ -1710,7 +1729,6 @@ test fCmd-17.3 {mkdir several levels deep - absolute} -setup { # # Functionality tests for TclFileRenameCmd() # - test fCmd-18.1 {TclFileRenameCmd: rename (first form) in the same directory} \ -setup { catch {file delete -force -- tfad} @@ -1918,7 +1936,6 @@ test fCmd-19.3 {recursive remove} -constraints {notRoot} -setup { # # Coverage tests for TraverseUnixTree(), called from TclDeleteFilesCmd # - test fCmd-20.1 {TraverseUnixTree : failure opening a subdirectory directory} -setup { catch {file delete -force -- tfa} } -constraints {unix notRoot} -body { @@ -2150,7 +2167,6 @@ test fCmd-22.5 {TclMacCopyFile: copy and overwrite in a single dir} -setup { # TclMacRmdir # Error cases are not covered. # - test fCmd-23.1 {TclMacRmdir: trying to remove a nonempty directory} -setup { catch {file delete -force -- tfad} } -constraints {notRoot} -body { @@ -2212,7 +2228,6 @@ test fCmd-25.3 {TclMacCopyDirectory: copying dirs between different dirs} -setup # # Functionality tests for TclDeleteFilesCmd # - test fCmd-26.1 {TclDeleteFilesCmd: delete symlink} -setup { catch {file delete -force -- tfad1 tfad2} } -constraints {unix notRoot} -body { @@ -2405,7 +2420,7 @@ test fCmd-28.12 {file link: cd into a link} -setup { cd .. set up [pwd] cd $orig - # now '$up' should be either $orig or [file dirname abc.dir], depending on + # Now '$up' should be either $orig or [file dirname abc.dir], depending on # whether 'cd' actually moves to the destination of a link, or simply # treats the link as a directory. (On windows the former, on unix the # latter, I believe) @@ -2530,35 +2545,35 @@ test fCmd-28.22 {file link: relative paths} -setup { catch {file delete -force d1} cd [workingDirectory] } -result d2/d3 - -test fCmd-29.1 {weird memory corruption fault} -body { - open [file join ~a_totally_bogus_user_id/foo bar] -} -returnCodes error -match glob -result * - -cd [temporaryDirectory] -file delete -force abc.link -file delete -force d1/d2 -file delete -force d1 -cd [workingDirectory] - +try { + cd [temporaryDirectory] + file delete -force abc.link + file delete -force d1/d2 + file delete -force d1 +} finally { + cd [workingDirectory] +} removeFile abc2.file removeFile abc.file removeDirectory abc2.dir removeDirectory abc.dir +test fCmd-29.1 {weird memory corruption fault} -body { + open [file join ~a_totally_bogus_user_id/foo bar] +} -returnCodes error -match glob -result * + test fCmd-30.1 {file writable on 'My Documents'} -setup { # Get the localized version of the folder name by looking in the registry. set mydocsname [registry get {HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders} Personal] -} -constraints {2000orNewer reg} -body { +} -constraints {win reg} -body { file writable $mydocsname } -result 1 -test fCmd-30.2 {file readable on 'NTUSER.DAT'} -constraints {2000orNewer} -body { +test fCmd-30.2 {file readable on 'NTUSER.DAT'} -constraints {win} -body { expr {[info exists env(USERPROFILE)] && [file exists $env(USERPROFILE)/NTUSER.DAT] && [file readable $env(USERPROFILE)/NTUSER.DAT]} - } -result {1} -test fCmd-30.3 {file readable on 'pagefile.sys'} -constraints {2000orNewer} -body { +test fCmd-30.3 {file readable on 'pagefile.sys'} -constraints {win} -body { set r {} if {[info exists env(SystemDrive)]} { set path $env(SystemDrive)/pagefile.sys @@ -2568,7 +2583,7 @@ test fCmd-30.3 {file readable on 'pagefile.sys'} -constraints {2000orNewer} -bod } return $r } -result {exists 1 readable 0 stat 0 {}} - + # cleanup cleanup ::tcltest::cleanupTests @@ -2576,4 +2591,5 @@ return # Local Variables: # mode: tcl +# fill-column: 78 # End: diff --git a/tests/fileSystem.test b/tests/fileSystem.test index 2fe13d7..1691eb5 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -600,14 +600,14 @@ test filesystem-6.25 {empty file name} -returnCodes error -body { test filesystem-6.26 {empty file name} {file rootname ""} {} test filesystem-6.27 {empty file name} -returnCodes error -body { file separator "" -} -result {Unrecognised path} +} -result {unrecognised path} test filesystem-6.28 {empty file name} -returnCodes error -body { file size "" } -result {could not read "": no such file or directory} test filesystem-6.29 {empty file name} {file split ""} {} test filesystem-6.30 {empty file name} -returnCodes error -body { file system "" -} -result {Unrecognised path} +} -result {unrecognised path} test filesystem-6.31 {empty file name} {file tail ""} {} test filesystem-6.32 {empty file name} -returnCodes error -body { file type "" diff --git a/tests/interp.test b/tests/interp.test index 6c35cfd..b401dcf 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: interp.test,v 1.68.4.1 2010/12/01 16:42:37 kennykb Exp $ +# RCS: @(#) $Id: interp.test,v 1.68.4.2 2010/12/11 18:39:30 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 @@ -19,7 +19,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { testConstraint testinterpdelete [llength [info commands testinterpdelete]] -set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source unload} +set hidden_cmds {cd encoding exec exit fconfigure glob load open pwd socket source tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable unload} foreach i [interp slaves] { interp delete $i @@ -1607,67 +1607,73 @@ test interp-21.1 {interp hidden} { test interp-21.2 {interp hidden} { interp hidden } "" -test interp-21.3 {interp hidden vs interp hide, interp expose} { +test interp-21.3 {interp hidden vs interp hide, interp expose} -setup { set l "" +} -body { lappend l [interp hidden] interp hide {} pwd lappend l [interp hidden] interp expose {} pwd lappend l [interp hidden] - set l -} {{} pwd {}} -test interp-21.4 {interp hidden} { +} -result {{} pwd {}} +test interp-21.4 {interp hidden} -setup { catch {interp delete a} +} -body { interp create a - set l [interp hidden a] + interp hidden a +} -cleanup { interp delete a - set l -} "" -test interp-21.5 {interp hidden} { +} -result "" +test interp-21.5 {interp hidden} -setup { catch {interp delete a} +} -body { interp create -safe a - set l [lsort [interp hidden a]] + lsort [interp hidden a] +} -cleanup { interp delete a - set l -} $hidden_cmds -test interp-21.6 {interp hidden vs interp hide, interp expose} { +} -result $hidden_cmds +test interp-21.6 {interp hidden vs interp hide, interp expose} -setup { catch {interp delete a} - interp create a set l "" +} -body { + interp create a lappend l [interp hidden a] interp hide a pwd lappend l [interp hidden a] interp expose a pwd lappend l [interp hidden a] +} -cleanup { interp delete a - set l -} {{} pwd {}} -test interp-21.7 {interp hidden} { +} -result {{} pwd {}} +test interp-21.7 {interp hidden} -setup { catch {interp delete a} +} -body { interp create a - set l [a hidden] + a hidden +} -cleanup { interp delete a - set l -} "" -test interp-21.8 {interp hidden} { +} -result "" +test interp-21.8 {interp hidden} -setup { catch {interp delete a} +} -body { interp create a -safe - set l [lsort [a hidden]] + lsort [a hidden] +} -cleanup { interp delete a - set l -} $hidden_cmds -test interp-21.9 {interp hidden vs interp hide, interp expose} { +} -result $hidden_cmds +test interp-21.9 {interp hidden vs interp hide, interp expose} -setup { catch {interp delete a} - interp create a set l "" +} -body { + interp create a lappend l [a hidden] a hide pwd lappend l [a hidden] a expose pwd lappend l [a hidden] +} -cleanup { interp delete a - set l -} {{} pwd {}} +} -result {{} pwd {}} test interp-22.1 {testing interp marktrusted} { catch {interp delete a} @@ -1767,183 +1773,161 @@ test interp-22.9 {testing interp marktrusted} { set l } {1 1 1 0 0} -test interp-23.1 {testing hiding vs aliases} { +test interp-23.1 {testing hiding vs aliases: unsafe interp} -setup { catch {interp delete a} - interp create a set l "" +} -body { + interp create a lappend l [interp hidden a] a alias bar bar - lappend l [interp aliases a] - lappend l [interp hidden a] + lappend l [interp aliases a] [interp hidden a] a hide bar - lappend l [interp aliases a] - lappend l [interp hidden a] + lappend l [interp aliases a] [interp hidden a] a alias bar {} - lappend l [interp aliases a] - lappend l [interp hidden a] + lappend l [interp aliases a] [interp hidden a] +} -cleanup { interp delete a - set l -} {{} bar {} bar bar {} {}} -test interp-23.2 {testing hiding vs aliases} {unixOrPc} { +} -result {{} bar {} bar bar {} {}} +test interp-23.2 {testing hiding vs aliases: safe interp} -setup { catch {interp delete a} - interp create a -safe set l "" +} -constraints {unixOrPc} -body { + interp create a -safe lappend l [lsort [interp hidden a]] a alias bar bar - lappend l [lsort [interp aliases a]] - lappend l [lsort [interp hidden a]] + lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] a hide bar - lappend l [lsort [interp aliases a]] - lappend l [lsort [interp hidden a]] + lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] a alias bar {} - lappend l [lsort [interp aliases a]] - lappend l [lsort [interp hidden a]] + lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] +} -cleanup { interp delete a - set l -} {{cd encoding exec exit fconfigure file glob load open pwd socket source unload} {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} {cd encoding exec exit fconfigure file glob load open pwd socket source unload} {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} {bar cd encoding exec exit fconfigure file glob load open pwd socket source unload} {::tcl::mathfunc::max ::tcl::mathfunc::min clock} {cd encoding exec exit fconfigure file glob load open pwd socket source unload}} +} -result [list $hidden_cmds {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} $hidden_cmds {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} [lsort [concat $hidden_cmds bar]] {::tcl::mathfunc::max ::tcl::mathfunc::min clock} $hidden_cmds] -test interp-24.1 {result resetting on error} { +test interp-24.1 {result resetting on error} -setup { catch {interp delete a} +} -body { interp create a - proc foo args {error $args} - interp alias a foo {} foo - set l [interp eval a { - set l {} - lappend l [catch {foo 1 2 3} msg] - lappend l $msg - lappend l [catch {foo 3 4 5} msg] - lappend l $msg - set l - }] + interp alias a foo {} apply {args {error $args}} + interp eval a { + lappend l [catch {foo 1 2 3} msg] $msg + lappend l [catch {foo 3 4 5} msg] $msg + } +} -cleanup { interp delete a - rename foo {} - set l -} {1 {1 2 3} 1 {3 4 5}} -test interp-24.2 {result resetting on error} { +} -result {1 {1 2 3} 1 {3 4 5}} +test interp-24.2 {result resetting on error} -setup { catch {interp delete a} +} -body { interp create a -safe - proc foo args {error $args} - interp alias a foo {} foo - set l [interp eval a { - set l {} - lappend l [catch {foo 1 2 3} msg] - lappend l $msg - lappend l [catch {foo 3 4 5} msg] - lappend l $msg - set l - }] + interp alias a foo {} apply {args {error $args}} + interp eval a { + lappend l [catch {foo 1 2 3} msg] $msg + lappend l [catch {foo 3 4 5} msg] $msg + } +} -cleanup { interp delete a - rename foo {} - set l -} {1 {1 2 3} 1 {3 4 5}} -test interp-24.3 {result resetting on error} { +} -result {1 {1 2 3} 1 {3 4 5}} +test interp-24.3 {result resetting on error} -setup { catch {interp delete a} +} -body { interp create a interp create {a b} interp eval a { proc foo args {error $args} } interp alias {a b} foo a foo - set l [interp eval {a b} { - set l {} - lappend l [catch {foo 1 2 3} msg] - lappend l $msg - lappend l [catch {foo 3 4 5} msg] - lappend l $msg - set l - }] + interp eval {a b} { + lappend l [catch {foo 1 2 3} msg] $msg + lappend l [catch {foo 3 4 5} msg] $msg + } +} -cleanup { interp delete a - set l -} {1 {1 2 3} 1 {3 4 5}} -test interp-24.4 {result resetting on error} { +} -result {1 {1 2 3} 1 {3 4 5}} +test interp-24.4 {result resetting on error} -setup { catch {interp delete a} +} -body { interp create a -safe interp create {a b} interp eval a { proc foo args {error $args} } interp alias {a b} foo a foo - set l [interp eval {a b} { - set l {} + interp eval {a b} { lappend l [catch {foo 1 2 3} msg] lappend l $msg lappend l [catch {foo 3 4 5} msg] lappend l $msg - set l - }] + } +} -cleanup { interp delete a - set l -} {1 {1 2 3} 1 {3 4 5}} -test interp-24.5 {result resetting on error} { +} -result {1 {1 2 3} 1 {3 4 5}} +test interp-24.5 {result resetting on error} -setup { catch {interp delete a} catch {interp delete b} +} -body { interp create a interp create b interp eval a { proc foo args {error $args} } interp alias b foo a foo - set l [interp eval b { - set l {} - lappend l [catch {foo 1 2 3} msg] - lappend l $msg - lappend l [catch {foo 3 4 5} msg] - lappend l $msg - set l - }] + interp eval b { + lappend l [catch {foo 1 2 3} msg] $msg + lappend l [catch {foo 3 4 5} msg] $msg + } +} -cleanup { interp delete a - set l -} {1 {1 2 3} 1 {3 4 5}} -test interp-24.6 {result resetting on error} { + interp delete b +} -result {1 {1 2 3} 1 {3 4 5}} +test interp-24.6 {result resetting on error} -setup { catch {interp delete a} catch {interp delete b} +} -body { interp create a -safe interp create b -safe interp eval a { proc foo args {error $args} } interp alias b foo a foo - set l [interp eval b { - set l {} - lappend l [catch {foo 1 2 3} msg] - lappend l $msg - lappend l [catch {foo 3 4 5} msg] - lappend l $msg - set l - }] + interp eval b { + lappend l [catch {foo 1 2 3} msg] $msg + lappend l [catch {foo 3 4 5} msg] $msg + } +} -cleanup { interp delete a - set l -} {1 {1 2 3} 1 {3 4 5}} -test interp-24.7 {result resetting on error} { + interp delete b +} -result {1 {1 2 3} 1 {3 4 5}} +test interp-24.7 {result resetting on error} -setup { catch {interp delete a} + set l {} +} -body { interp create a interp eval a { proc foo args {error $args} } - set l {} - lappend l [catch {interp eval a foo 1 2 3} msg] - lappend l $msg - lappend l [catch {interp eval a foo 3 4 5} msg] - lappend l $msg + lappend l [catch {interp eval a foo 1 2 3} msg] $msg + lappend l [catch {interp eval a foo 3 4 5} msg] $msg +} -cleanup { interp delete a - set l -} {1 {1 2 3} 1 {3 4 5}} -test interp-24.8 {result resetting on error} { +} -result {1 {1 2 3} 1 {3 4 5}} +test interp-24.8 {result resetting on error} -setup { catch {interp delete a} + set l {} +} -body { interp create a -safe interp eval a { proc foo args {error $args} } - set l {} - lappend l [catch {interp eval a foo 1 2 3} msg] - lappend l $msg - lappend l [catch {interp eval a foo 3 4 5} msg] - lappend l $msg + lappend l [catch {interp eval a foo 1 2 3} msg] $msg + lappend l [catch {interp eval a foo 3 4 5} msg] $msg +} -cleanup { interp delete a - set l -} {1 {1 2 3} 1 {3 4 5}} -test interp-24.9 {result resetting on error} { +} -result {1 {1 2 3} 1 {3 4 5}} +test interp-24.9 {result resetting on error} -setup { catch {interp delete a} + set l {} +} -body { interp create a interp create {a b} interp eval {a b} { @@ -1954,16 +1938,15 @@ test interp-24.9 {result resetting on error} { eval interp eval b foo $args } } - set l {} - lappend l [catch {interp eval a foo 1 2 3} msg] - lappend l $msg - lappend l [catch {interp eval a foo 3 4 5} msg] - lappend l $msg + lappend l [catch {interp eval a foo 1 2 3} msg] $msg + lappend l [catch {interp eval a foo 3 4 5} msg] $msg +} -cleanup { interp delete a - set l -} {1 {1 2 3} 1 {3 4 5}} -test interp-24.10 {result resetting on error} { +} -result {1 {1 2 3} 1 {3 4 5}} +test interp-24.10 {result resetting on error} -setup { catch {interp delete a} + set l {} +} -body { interp create a -safe interp create {a b} interp eval {a b} { @@ -1974,16 +1957,14 @@ test interp-24.10 {result resetting on error} { eval interp eval b foo $args } } - set l {} - lappend l [catch {interp eval a foo 1 2 3} msg] - lappend l $msg - lappend l [catch {interp eval a foo 3 4 5} msg] - lappend l $msg + lappend l [catch {interp eval a foo 1 2 3} msg] $msg + lappend l [catch {interp eval a foo 3 4 5} msg] $msg +} -cleanup { interp delete a - set l -} {1 {1 2 3} 1 {3 4 5}} -test interp-24.11 {result resetting on error} { +} -result {1 {1 2 3} 1 {3 4 5}} +test interp-24.11 {result resetting on error} -setup { catch {interp delete a} +} -body { interp create a interp create {a b} interp eval {a b} { @@ -1991,20 +1972,17 @@ test interp-24.11 {result resetting on error} { } interp eval a { proc foo args { - set l {} - lappend l [catch {eval interp eval b foo $args} msg] - lappend l $msg - lappend l [catch {eval interp eval b foo $args} msg] - lappend l $msg - set l + lappend l [catch {eval interp eval b foo $args} msg] $msg + lappend l [catch {eval interp eval b foo $args} msg] $msg } } - set l [interp eval a foo 1 2 3] + interp eval a foo 1 2 3 +} -cleanup { interp delete a - set l -} {1 {1 2 3} 1 {1 2 3}} -test interp-24.12 {result resetting on error} { +} -result {1 {1 2 3} 1 {1 2 3}} +test interp-24.12 {result resetting on error} -setup { catch {interp delete a} +} -body { interp create a -safe interp create {a b} interp eval {a b} { @@ -2012,27 +1990,22 @@ test interp-24.12 {result resetting on error} { } interp eval a { proc foo args { - set l {} - lappend l [catch {eval interp eval b foo $args} msg] - lappend l $msg - lappend l [catch {eval interp eval b foo $args} msg] - lappend l $msg - set l + lappend l [catch {eval interp eval b foo $args} msg] $msg + lappend l [catch {eval interp eval b foo $args} msg] $msg } } - set l [interp eval a foo 1 2 3] + interp eval a foo 1 2 3 +} -cleanup { interp delete a - set l -} {1 {1 2 3} 1 {1 2 3}} +} -result {1 {1 2 3} 1 {1 2 3}} -unset hidden_cmds - -test interp-25.1 {testing aliasing of string commands} { +test interp-25.1 {testing aliasing of string commands} -setup { catch {interp delete a} +} -body { interp create a a alias exec foo ;# Relies on exec being a string command! interp delete a -} "" +} -result "" # # Interps result transmission @@ -3058,7 +3031,7 @@ test interp-31.1 {alias invocation scope} { myNewSet a $value return $a } - catch {unset a} + unset -nocomplain a set result [testMyNewSet "ok"] rename testMyNewSet {} rename mySet {} @@ -3580,7 +3553,7 @@ test interp-36.7 {SlaveBgerror sets error handler of slave [1999035]} -setup { set result } -cleanup { variable result {} - unset result + unset -nocomplain result interp delete slave } -result foo @@ -3593,7 +3566,7 @@ test interp-37.1 {safe interps and min() and max(): Bug 2895741} -setup { lappend result [interp eval a {expr min(5,2,3)*max(7,13,11)}] lappend result [interp eval {a b} {expr min(5,2,3)*max(7,13,11)}] } -cleanup { - unset result + unset -nocomplain result interp delete a } -result {26 26} @@ -3614,7 +3587,7 @@ test interp-38.2 {interp debug env var} -setup { } -body { interp debug a } -cleanup { - unset ::env(TCL_INTERP_DEBUG_FRAME) + unset -nocomplain ::env(TCL_INTERP_DEBUG_FRAME) interp delete a } -result {-frame 1} test interp-38.3 {interp debug wrong args} -body { @@ -3642,6 +3615,7 @@ test interp-38.8 {interp debug basic setup} -body { # cleanup +unset -nocomplain hidden_cmds foreach i [interp slaves] { interp delete $i } diff --git a/tests/io.test b/tests/io.test index c69bff9..2077e1c 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 2010/02/07 08:03:11 dkf Exp $ +# RCS: @(#) $Id: io.test,v 1.96.4.1 2010/12/11 18:39:30 kennykb Exp $ if {[catch {package require tcltest 2}]} { puts stderr "Skipping tests in [info script]. tcltest 2 required." @@ -7007,6 +7007,44 @@ test io-53.8a {CopyData: async callback and error handling, Bug 1932639, at eof} removeFile foo removeFile bar } -result {1 sync/OK {CMD 0}} +test io-53.8b {CopyData: async callback and -size 0} -setup { + # copy progress callback. errors out intentionally + proc ::cmd args { + lappend ::RES "CMD $args" + set ::forever has-been-reached + return + } + # Files we use for our channels + set foo [makeFile ashgdfashdgfasdhgfasdhgf foo] + set bar [makeFile {} bar] + # Channels to copy between + set f [open $foo r] ; fconfigure $f -translation binary + set g [open $bar w] ; fconfigure $g -translation binary -buffering none +} -constraints {stdio openpipe fcopy} -body { + set ::RES {} + # Run the copy. Should not invoke -command now. + fcopy $f $g -size 0 -command ::cmd + # Check that -command was not called synchronously + lappend ::RES [expr {([llength $::RES] > 1) ? "sync/FAIL" : "sync/OK"}] + # Now let the async part happen. Should capture the eof in cmd + # If not break the event loop via timer. + set token [after 1000 { + lappend ::RES {cmd/FAIL timeout} + set ::forever has-been-reached + }] + vwait ::forever + catch {after cancel $token} + # Report + set ::RES +} -cleanup { + close $f + close $g + catch {unset ::RES} + catch {unset ::forever} + rename ::cmd {} + removeFile foo + removeFile bar +} -result {sync/OK {CMD 0}} test io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup { set out [makeFile {} out] set err [makeFile {} err] diff --git a/tests/safe.test b/tests/safe.test index ee2ecc3..51d2f7e 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.1 2010/11/03 00:18:57 kennykb Exp $ +# RCS: @(#) $Id: safe.test,v 1.34.2.2 2010/12/11 18:39:30 kennykb Exp $ package require Tcl 8.5 @@ -31,6 +31,11 @@ set ::auto_path [info library] catch {safe::interpConfigure} proc equiv {x} {return $x} + +# testing that nested and statics do what is advertised (we use a static +# package - Tcltest - but it might be absent if we're in standard tclsh) + +testConstraint TcltestPackage [expr {![catch {package require Tcltest}]}] test safe-1.1 {safe::interpConfigure syntax} -returnCodes error -body { safe::interpConfigure @@ -166,27 +171,24 @@ test safe-6.2 {test safe interpreters knowledge of the world} { SafeEval {info script} } {} test safe-6.3 {test safe interpreters knowledge of the world} { - set r [lsort [SafeEval {array names tcl_platform}]] + set r [SafeEval {array names tcl_platform}] # If running a windows-debug shell, remove the "debug" element from r. - if {[testConstraint win] && ("debug" in $r)} { - set r [lreplace $r 1 1] - } - set threaded [lsearch $r "threaded"] - if {$threaded != -1} { - set r [lreplace $r $threaded $threaded] + if {[testConstraint win]} { + set r [lsearch -all -inline -not -exact $r "debug"] } - set r + set r [lsearch -all -inline -not -exact $r "threaded"] + lsort $r } {byteOrder pathSeparator platform pointerSize wordSize} -# more test should be added to check that hostname, nameofexecutable, -# aren't leaking infos, but they still do... +# More test should be added to check that hostname, nameofexecutable, aren't +# leaking infos, but they still do... # high level general test test safe-7.1 {tests that everything works at high level} { set i [safe::interpCreate] # no error shall occur: - # (because the default access_path shall include 1st level sub dirs - # so package require in a slave works like in the master) + # (because the default access_path shall include 1st level sub dirs so + # package require in a slave works like in the master) set v [interp eval $i {package require http 1}] # no error shall occur: interp eval $i {http_config} @@ -400,17 +402,7 @@ test safe-9.6 {interpConfigure widget like behaviour} -body { safe::interpConfigure $i] } -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath * -statics 0 -nested 0 -deleteHook toto}} -# testing that nested and statics do what is advertised (we use a static -# package : Tcltest) -try { - package require Tcltest - testConstraint TcltestPackage 1 - # we use the Tcltest package , which has no Safe_Init -} on error {} { - testConstraint TcltestPackage 0 -} - -teststaticpkg Safepkg1 0 0 +catch {teststaticpkg Safepkg1 0 0} test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup { set i [safe::interpCreate] } -body { diff --git a/tests/uplevel.test b/tests/uplevel.test index f676290..2f725bc 100644 --- a/tests/uplevel.test +++ b/tests/uplevel.test @@ -1,17 +1,17 @@ # Commands covered: uplevel # -# 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: uplevel.test,v 1.9 2008/06/08 03:21:33 msofer Exp $ +# RCS: @(#) $Id: uplevel.test,v 1.9.6.1 2010/12/11 18:39:30 kennykb 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 @@ -85,20 +85,24 @@ test uplevel-3.4 {uplevel to same level} { a1 } 55 -test uplevel-4.1 {error: non-existent level} { - list [catch c1 msg] $msg -} {1 {bad level "#2"}} -test uplevel-4.2 {error: non-existent level} { - proc c2 {} {uplevel 3 {set a b}} - list [catch c2 msg] $msg -} {1 {bad level "3"}} -test uplevel-4.3 {error: not enough args} { - list [catch uplevel msg] $msg -} {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}} -test uplevel-4.4 {error: not enough args} { - proc upBug {} {uplevel 1} - list [catch upBug msg] $msg -} {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}} +test uplevel-4.1 {error: non-existent level} -returnCodes error -body { + apply {{} { + uplevel #2 {set y 222} + }} +} -result {bad level "#2"} +test uplevel-4.2 {error: non-existent level} -returnCodes error -body { + apply {{} { + uplevel 3 {set a b} + }} +} -result {bad level "3"} +test uplevel-4.3 {error: not enough args} -returnCodes error -body { + uplevel +} -result {wrong # args: should be "uplevel ?level? command ?arg ...?"} +test uplevel-4.4 {error: not enough args} -returnCodes error -body { + apply {{} { + uplevel 1 + }} +} -result {wrong # args: should be "uplevel ?level? command ?arg ...?"} proc a2 {} { uplevel a3 @@ -193,7 +197,12 @@ test uplevel-7.3 {var access, LVT in upper level} -setup { rename foo {} rename moo {} } -result {3 3 3} - + # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/upvar.test b/tests/upvar.test index dbf6dd5..d181043 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 2010/02/10 23:28:39 dkf Exp $ +# RCS: @(#) $Id: upvar.test,v 1.20.4.1 2010/12/11 18:39:30 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -427,116 +427,103 @@ namespace eval test_ns_0 { } set ::x test_global -test upvar-NS-1.1 {nsupvar links to correct variable} \ - -body { - namespace eval test_ns_1 { +test upvar-NS-1.1 {nsupvar links to correct variable} -body { + namespace eval test_ns_1 { + namespace upvar ::test_ns_0 x w + set w + } +} -result {test_ns_0} -cleanup { + namespace delete test_ns_1 +} +test upvar-NS-1.2 {nsupvar links to correct variable} -body { + namespace eval test_ns_1 { + proc a {} { namespace upvar ::test_ns_0 x w set w } - } \ - -result {test_ns_0} \ - -cleanup {namespace delete test_ns_1} -test upvar-NS-1.2 {nsupvar links to correct variable} \ - -body { - namespace eval test_ns_1 { - proc a {} { - namespace upvar ::test_ns_0 x w - set w - } - return [a] - } - } \ - -result {test_ns_0} \ - -cleanup {namespace delete test_ns_1} -test upvar-NS-1.3 {nsupvar links to correct variable} \ - -body { - namespace eval test_ns_1 { + return [a] + } +} -result {test_ns_0} -cleanup { + namespace delete test_ns_1 +} +test upvar-NS-1.3 {nsupvar links to correct variable} -body { + namespace eval test_ns_1 { + namespace upvar test_ns_0 x w + set w + } +} -returnCodes error -cleanup { + namespace delete test_ns_1 +} -result {namespace "test_ns_0" not found in "::test_ns_1"} +test upvar-NS-1.4 {nsupvar links to correct variable} -body { + namespace eval test_ns_1 { + proc a {} { namespace upvar test_ns_0 x w set w } - } \ - -result {namespace "test_ns_0" not found in "::test_ns_1"} \ - -returnCodes error \ - -cleanup {namespace delete test_ns_1} -test upvar-NS-1.4 {nsupvar links to correct variable} \ - -body { - namespace eval test_ns_1 { - proc a {} { - namespace upvar test_ns_0 x w - set w - } - return [a] - } - } \ - -result {namespace "test_ns_0" not found in "::test_ns_1"} \ - -returnCodes error \ - -cleanup {namespace delete test_ns_1} -test upvar-NS-1.5 {nsupvar links to correct variable} \ - -body { - namespace eval test_ns_1 { - namespace eval test_ns_0 {} + return [a] + } +} -returnCodes error -cleanup { + namespace delete test_ns_1 +} -result {namespace "test_ns_0" not found in "::test_ns_1"} + +test upvar-NS-1.5 {nsupvar links to correct variable} -body { + namespace eval test_ns_1 { + namespace eval test_ns_0 {} + namespace upvar test_ns_0 x w + set w + } +} -cleanup { + namespace delete test_ns_1 +} -result {can't read "w": no such variable} -returnCodes error +test upvar-NS-1.6 {nsupvar links to correct variable} -body { + namespace eval test_ns_1 { + namespace eval test_ns_0 {} + proc a {} { namespace upvar test_ns_0 x w set w } - } \ - -result {can't read "w": no such variable} \ - -returnCodes error \ - -cleanup {namespace delete test_ns_1} -test upvar-NS-1.6 {nsupvar links to correct variable} \ - -body { - namespace eval test_ns_1 { - namespace eval test_ns_0 {} - proc a {} { - namespace upvar test_ns_0 x w - set w - } - return [a] + return [a] + } +} -cleanup { + namespace delete test_ns_1 +} -result {can't read "w": no such variable} -returnCodes error +test upvar-NS-1.7 {nsupvar links to correct variable} -body { + namespace eval test_ns_1 { + namespace eval test_ns_0 { + variable x test_ns_1::test_ns_0 + } + namespace upvar test_ns_0 x w + set w + } +} -cleanup { + namespace delete test_ns_1 +} -result {test_ns_1::test_ns_0} +test upvar-NS-1.8 {nsupvar links to correct variable} -body { + namespace eval test_ns_1 { + namespace eval test_ns_0 { + variable x test_ns_1::test_ns_0 } - } \ - -result {can't read "w": no such variable} \ - -returnCodes error \ - -cleanup {namespace delete test_ns_1} -test upvar-NS-1.7 {nsupvar links to correct variable} \ - -body { - namespace eval test_ns_1 { - namespace eval test_ns_0 { - variable x test_ns_1::test_ns_0 - } + proc a {} { namespace upvar test_ns_0 x w set w } - } \ - -result {test_ns_1::test_ns_0} \ - -cleanup {namespace delete test_ns_1} -test upvar-NS-1.8 {nsupvar links to correct variable} \ - -body { - namespace eval test_ns_1 { - namespace eval test_ns_0 { - variable x test_ns_1::test_ns_0 - } - proc a {} { - namespace upvar test_ns_0 x w - set w - } - return [a] - } - } \ - -result {test_ns_1::test_ns_0} \ - -cleanup {namespace delete test_ns_1} -test upvar-NS-1.9 {nsupvar links to correct variable} \ - -body { - namespace eval test_ns_1 { - variable x test_ns_1 - proc a {} { - namespace upvar test_ns_0 x w - set w - } - return [a] + return [a] + } +} -cleanup { + namespace delete test_ns_1 +} -result {test_ns_1::test_ns_0} +test upvar-NS-1.9 {nsupvar links to correct variable} -body { + namespace eval test_ns_1 { + variable x test_ns_1 + proc a {} { + namespace upvar test_ns_0 x w + set w } - } \ - -result {namespace "test_ns_0" not found in "::test_ns_1"} \ - -returnCodes error \ - -cleanup {namespace delete test_ns_1} + return [a] + } +} -returnCodes error -cleanup { + namespace delete test_ns_1 +} -result {namespace "test_ns_0" not found in "::test_ns_1"} test upvar-NS-2.1 {TIP 323} -returnCodes error -body { namespace upvar diff --git a/tests/var.test b/tests/var.test index dd9483b..f2a858c 100644 --- a/tests/var.test +++ b/tests/var.test @@ -1,23 +1,23 @@ -# This file contains tests for the tclVar.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 variable- -# related tests appear in several other test files including -# namespace.test, set.test, trace.test, and upvar.test. +# This file contains tests for the tclVar.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 variable-related tests appear in +# several other test files including namespace.test, set.test, trace.test, and +# upvar.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: var.test,v 1.36 2010/08/03 17:25:13 andreas_kupries Exp $ +# RCS: @(#) $Id: var.test,v 1.36.2.1 2010/12/11 18:39:30 kennykb Exp $ # -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2.2 namespace import -force ::tcltest::* } @@ -35,13 +35,14 @@ catch {unset i} catch {unset a} catch {unset arr} -test var-1.1 {TclLookupVar, Array handling} { +test var-1.1 {TclLookupVar, Array handling} -setup { catch {unset a} +} -body { set x "incr" ;# force no compilation and runtime call to Tcl_IncrCmd set i 10 set arr(foo) 37 list [$x i] $i [$x arr(foo)] $arr(foo) -} {11 11 38 38} +} -result {11 11 38 38} test var-1.2 {TclLookupVar, TCL_GLOBAL_ONLY implies global namespace var} { set x "global value" namespace eval test_ns_var { @@ -71,34 +72,35 @@ test var-1.5 {TclLookupVar, active call frame pushed for namespace eval implies test var-1.6 {TclLookupVar, name starts with :: implies some namespace var} { namespace eval test_ns_var {set ::x} } {global value} -test var-1.7 {TclLookupVar, error finding namespace var} { - list [catch {set a:::b} msg] $msg -} {1 {can't read "a:::b": no such variable}} -test var-1.8 {TclLookupVar, error finding namespace var} { - list [catch {set ::foobarfoo} msg] $msg -} {1 {can't read "::foobarfoo": no such variable}} +test var-1.7 {TclLookupVar, error finding namespace var} -body { + set a:::b +} -returnCodes error -result {can't read "a:::b": no such variable} +test var-1.8 {TclLookupVar, error finding namespace var} -body { + set ::foobarfoo +} -returnCodes error -result {can't read "::foobarfoo": no such variable} test var-1.9 {TclLookupVar, create new namespace var} { namespace eval test_ns_var { set v hello } } {hello} -test var-1.10 {TclLookupVar, create new namespace var} { +test var-1.10 {TclLookupVar, create new namespace var} -setup { catch {unset y} +} -body { namespace eval test_ns_var { set ::y 789 } set y -} {789} -test var-1.11 {TclLookupVar, error creating new namespace var} { +} -result {789} +test var-1.11 {TclLookupVar, error creating new namespace var} -body { namespace eval test_ns_var { - list [catch {set ::test_ns_var::foo::bar 314159} msg] $msg + set ::test_ns_var::foo::bar 314159 } -} {1 {can't set "::test_ns_var::foo::bar": parent namespace doesn't exist}} -test var-1.12 {TclLookupVar, error creating new namespace var} { +} -returnCodes error -result {can't set "::test_ns_var::foo::bar": parent namespace doesn't exist} +test var-1.12 {TclLookupVar, error creating new namespace var} -body { namespace eval test_ns_var { - list [catch {set ::test_ns_var::foo:: 1997} msg] $msg + set ::test_ns_var::foo:: 1997 } -} {1 {can't set "::test_ns_var::foo::": parent namespace doesn't exist}} +} -returnCodes error -result {can't set "::test_ns_var::foo::": parent namespace doesn't exist} test var-1.13 {TclLookupVar, new namespace var is created in a particular namespace} { catch {unset aNeWnAmEiNnS} namespace eval test_ns_var { @@ -177,24 +179,25 @@ test var-1.18 {TclLookupVar, resurrect array element via upvar to deleted array: set result } } {0 2 1 {can't set "foo": upvar refers to element in deleted array}} -test var-1.19 {TclLookupVar, right error message when parsing variable name} { - list [catch {[format set] thisvar(doesntexist)} msg] $msg -} {1 {can't read "thisvar(doesntexist)": no such variable}} +test var-1.19 {TclLookupVar, right error message when parsing variable name} -body { + [format set] thisvar(doesntexist) +} -returnCodes error -result {can't read "thisvar(doesntexist)": no such variable} test var-2.1 {Tcl_LappendObjCmd, create var if new} { catch {unset x} lappend x 1 2 } {1 2} -test var-3.1 {MakeUpvar, TCL_NAMESPACE_ONLY not specified for other var} { +test var-3.1 {MakeUpvar, TCL_NAMESPACE_ONLY not specified for other var} -setup { catch {unset x} +} -body { set x 1997 proc p {} { global x ;# calls MakeUpvar with TCL_NAMESPACE_ONLY for other var x return $x } p -} {1997} +} -result {1997} test var-3.2 {MakeUpvar, other var has TCL_NAMESPACE_ONLY specified} { namespace eval test_ns_var { catch {unset v} @@ -206,17 +209,19 @@ test var-3.2 {MakeUpvar, other var has TCL_NAMESPACE_ONLY specified} { p } } {1998} -test var-3.3 {MakeUpvar, my var has TCL_GLOBAL_ONLY specified} testupvar { +test var-3.3 {MakeUpvar, my var has TCL_GLOBAL_ONLY specified} -setup { catch {unset a} +} -constraints testupvar -body { set a 123321 proc p {} { # create global xx linked to global a testupvar 1 a {} xx global } list [p] $xx [set xx 789] $a -} {{} 123321 789 789} -test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} testupvar { +} -result {{} 123321 789 789} +test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} -setup { catch {unset a} +} -constraints testupvar -body { set a 456 namespace eval test_ns_var { catch {unset ::test_ns_var::vv} @@ -227,58 +232,64 @@ test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} testupvar { p } list $test_ns_var::vv [set test_ns_var::vv 123] $a -} {456 123 123} -test var-3.5 {MakeUpvar, no call frame so my var will be in global :: ns} { +} -result {456 123 123} +test var-3.5 {MakeUpvar, no call frame so my var will be in global :: ns} -setup { catch {unset aaaaa} catch {unset xxxxx} +} -body { set aaaaa 77777 upvar #0 aaaaa xxxxx list [set xxxxx] [set aaaaa] -} {77777 77777} -test var-3.6 {MakeUpvar, active call frame pushed for namespace eval} { +} -result {77777 77777} +test var-3.6 {MakeUpvar, active call frame pushed for namespace eval} -setup { catch {unset a} +} -body { set a 121212 namespace eval test_ns_var { upvar ::a vvv set vvv } -} {121212} -test var-3.7 {MakeUpvar, my var has ::s} { +} -result {121212} +test var-3.7 {MakeUpvar, my var has ::s} -setup { catch {unset a} +} -body { set a 789789 upvar #0 a test_ns_var::lnk namespace eval test_ns_var { set lnk } -} {789789} -test var-3.8 {MakeUpvar, my var already exists in global ns} { +} -result {789789} +test var-3.8 {MakeUpvar, my var already exists in global ns} -setup { catch {unset aaaaa} catch {unset xxxxx} +} -body { set aaaaa 456654 set xxxxx hello upvar #0 aaaaa xxxxx set xxxxx -} {hello} -test var-3.9 {MakeUpvar, my var has invalid ns name} { +} -result {hello} +test var-3.9 {MakeUpvar, my var has invalid ns name} -setup { catch {unset aaaaa} +} -returnCodes error -body { set aaaaa 789789 - list [catch {upvar #0 aaaaa test_ns_fred::lnk} msg] $msg -} {1 {can't create "test_ns_fred::lnk": parent namespace doesn't exist}} -test var-3.10 {MakeUpvar, } { + upvar #0 aaaaa test_ns_fred::lnk +} -result {can't create "test_ns_fred::lnk": parent namespace doesn't exist} +test var-3.10 {MakeUpvar, between namespaces} -body { namespace eval {} { - set bar 0 + variable bar 0 namespace eval foo upvar bar bar set foo::bar 1 - catch {list $bar $foo::bar} msg - unset ::aaaaa - set msg + list $bar $foo::bar } -} {1 1} -test var-3.11 {MakeUpvar, my var looks like array elem} -body { +} -cleanup { + unset ::aaaaa +} -result {1 1} +test var-3.11 {MakeUpvar, my var looks like array elem} -setup { catch {unset aaaaa} +} -returnCodes error -body { set aaaaa 789789 upvar #0 aaaaa foo(bar) -} -returnCodes 1 -result {bad variable name "foo(bar)": upvar won't create a scalar variable that looks like an array element} +} -result {bad variable name "foo(bar)": upvar won't create a scalar variable that looks like an array element} test var-4.1 {Tcl_GetVariableName, global variable} testgetvarfullname { catch {unset a} @@ -291,17 +302,19 @@ test var-4.2 {Tcl_GetVariableName, namespace variable} testgetvarfullname { testgetvarfullname george namespace } } ::test_ns_var::george -test var-4.3 {Tcl_GetVariableName, variable can't be array element} testgetvarfullname { +test var-4.3 {Tcl_GetVariableName, variable can't be array element} -setup { catch {unset a} +} -constraints testgetvarfullname -body { set a(1) foo - list [catch {testgetvarfullname a(1) global} msg] $msg -} {1 {unknown variable "a(1)"}} + testgetvarfullname a(1) global +} -returnCodes error -result {unknown variable "a(1)"} -test var-5.1 {Tcl_GetVariableFullName, global variable} { +test var-5.1 {Tcl_GetVariableFullName, global variable} -setup { catch {unset a} +} -body { set a bar namespace which -variable a -} {::a} +} -result {::a} test var-5.2 {Tcl_GetVariableFullName, namespace variable} { namespace eval test_ns_var { variable martha @@ -316,11 +329,10 @@ test var-6.1 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} { namespace eval test_ns_var { variable boeing 777 } - proc p {} { + apply {{} { global ::test_ns_var::boeing set boeing - } - p + }} } {777} test var-6.2 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} { namespace eval test_ns_var { @@ -336,11 +348,10 @@ test var-6.2 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} { } {java} test var-6.3 {Tcl_GlobalObjCmd, variable named {} qualified by a namespace name} { set ::test_ns_var::test_ns_nested:: 24 - proc p {} { + apply {{} { global ::test_ns_var::test_ns_nested:: set {} - } - p + }} } {24} test var-6.4 {Tcl_GlobalObjCmd, variable name matching :*} { # Test for Tcl Bug 480176 @@ -362,13 +373,14 @@ test var-6.6 {Tcl_GlobalObjCmd, no-op case (TIP 323)} { p } {} -test var-7.1 {Tcl_VariableObjCmd, create and initialize one new ns variable} { +test var-7.1 {Tcl_VariableObjCmd, create and initialize one new ns variable} -setup { catch {namespace delete test_ns_var} +} -body { namespace eval test_ns_var { variable one 1 } list [info vars test_ns_var::*] [set test_ns_var::one] -} {::test_ns_var::one 1} +} -result {::test_ns_var::one 1} test var-7.2 {Tcl_VariableObjCmd, if new and no value, leave undefined} { set two 2222222 namespace eval test_ns_var { @@ -390,10 +402,11 @@ test var-7.4 {Tcl_VariableObjCmd, list of vars} { list [lsort [info vars test_ns_var::*]] \ [namespace eval test_ns_var {expr $three+$four}] } [list [lsort {::test_ns_var::four ::test_ns_var::three ::test_ns_var::two ::test_ns_var::one}] 7] -test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} { +test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} -setup { catch {unset a} catch {unset five} catch {unset six} +} -body { set a "" set five 555 set six 666 @@ -403,23 +416,25 @@ test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} { } lappend a $test_ns_var::five \ [set test_ns_var::six 6] [set test_ns_var::six] $six +} -cleanup { catch {unset five} catch {unset six} - set a -} {5 5 6 6 666} -catch {unset newvar} -test var-7.6 {Tcl_VariableObjCmd, variable name can be qualified} { +} -result {5 5 6 6 666} +test var-7.6 {Tcl_VariableObjCmd, variable name can be qualified} -setup { + catch {unset newvar} +} -body { namespace eval test_ns_var { variable ::newvar cheers! } - set newvar -} {cheers!} -catch {unset newvar} -test var-7.7 {Tcl_VariableObjCmd, bad var name} { + return $newvar +} -cleanup { + catch {unset newvar} +} -result {cheers!} +test var-7.7 {Tcl_VariableObjCmd, bad var name} -returnCodes error -body { namespace eval test_ns_var { - list [catch {variable sev:::en 7} msg] $msg + variable sev:::en 7 } -} {1 {can't define "sev:::en": parent namespace doesn't exist}} +} -result {can't define "sev:::en": parent namespace doesn't exist} test var-7.8 {Tcl_VariableObjCmd, if var already exists and no value is given, leave value unchanged} { set a "" namespace eval test_ns_var { @@ -430,8 +445,9 @@ test var-7.8 {Tcl_VariableObjCmd, if var already exists and no value is given, l } set a } {8 8} -test var-7.9 {Tcl_VariableObjCmd, mark as namespace var so var persists until namespace is destroyed or var is unset} { +test var-7.9 {Tcl_VariableObjCmd, mark as namespace var so var persists until namespace is destroyed or var is unset} -setup { catch {namespace delete test_ns_var2} +} -body { set a "" namespace eval test_ns_var2 { variable x 123 @@ -451,8 +467,7 @@ test var-7.9 {Tcl_VariableObjCmd, mark as namespace var so var persists until na lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z] lappend a [list [catch {unset test_ns_var2::z} msg] $msg] lappend a [namespace delete test_ns_var2] - set a -} [list [lsort {::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z}] 1 0 0\ +} -result [list [lsort {::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z}] 1 0 0\ {1 {can't read "test_ns_var2::y": no such variable}}\ [lsort {::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z}] 0 0\ hello 1 0\ @@ -496,20 +511,16 @@ test var-7.13 {Tcl_VariableObjCmd, variable named ":"} { p } } {{My name is ":"} :} -test var-7.14 {Tcl_VariableObjCmd, array element parameter} { - catch {namespace eval test_ns_var { variable arrayvar(1) }} res - set res -} "can't define \"arrayvar(1)\": name refers to an element in an array" -test var-7.15 {Tcl_VariableObjCmd, array element parameter} { - catch { - namespace eval test_ns_var { - variable arrayvar - set arrayvar(1) x - variable arrayvar(1) y - } - } res - set res -} "can't define \"arrayvar(1)\": name refers to an element in an array" +test var-7.14 {Tcl_VariableObjCmd, array element parameter} -body { + namespace eval test_ns_var { variable arrayvar(1) } +} -returnCodes error -result "can't define \"arrayvar(1)\": name refers to an element in an array" +test var-7.15 {Tcl_VariableObjCmd, array element parameter} -body { + namespace eval test_ns_var { + variable arrayvar + set arrayvar(1) x + variable arrayvar(1) y + } +} -returnCodes error -result "can't define \"arrayvar(1)\": name refers to an element in an array" test var-7.16 {Tcl_VariableObjCmd, no args (TIP 323)} { variable } {} @@ -519,158 +530,173 @@ test var-7.17 {Tcl_VariableObjCmd, no args (TIP 323)} { } } {} -test var-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var names} { +test var-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var names} -setup { catch {namespace delete test_ns_var} catch {unset a} +} -body { namespace eval test_ns_var { variable v 123 variable info "" - proc traceUnset {name1 name2 op} { variable info set info [concat $info [list $name1 $name2 $op]] } - trace var v u [namespace code traceUnset] } list [unset test_ns_var::v] $test_ns_var::info -} {{} {test_ns_var::v {} u}} - -test var-8.2 {TclDeleteNamespaceVars, "unset" traces on ns delete are called with fully-qualified var names} { +} -result {{} {test_ns_var::v {} u}} +test var-8.2 {TclDeleteNamespaceVars, "unset" traces on ns delete are called with fully-qualified var names} -setup { catch {namespace delete test_ns_var} catch {unset a} +} -body { set info "" namespace eval test_ns_var { variable v 123 1 trace var v u ::traceUnset } - proc traceUnset {name1 name2 op} { set ::info [concat $::info [list $name1 $name2 $op]] } - list [namespace delete test_ns_var] $::info -} {{} {::test_ns_var::v {} u}} +} -result {{} {::test_ns_var::v {} u}} -test var-9.1 {behaviour of TclGet/SetVar simple get/set} testsetnoerr { - catch {unset u}; catch {unset v} +test var-9.1 {behaviour of TclGet/SetVar simple get/set} -setup { + catch {unset u} + catch {unset v} +} -constraints testsetnoerr -body { list \ - [set u a; testsetnoerr u] \ - [testsetnoerr v b] \ - [testseterr u] \ - [unset v; testseterr v b] -} [list {before get a} {before set b} {before get a} {before set b}] -test var-9.2 {behaviour of TclGet/SetVar namespace get/set} testsetnoerr { + [set u a; testsetnoerr u] \ + [testsetnoerr v b] \ + [testseterr u] \ + [unset v; testseterr v b] +} -result [list {before get a} {before set b} {before get a} {before set b}] +test var-9.2 {behaviour of TclGet/SetVar namespace get/set} -setup { catch {namespace delete ns} +} -constraints testsetnoerr -body { namespace eval ns {variable u a; variable v} list \ - [testsetnoerr ns::u] \ - [testsetnoerr ns::v b] \ - [testseterr ns::u] \ - [unset ns::v; testseterr ns::v b] -} [list {before get a} {before set b} {before get a} {before set b}] -test var-9.3 {behaviour of TclGetVar no variable} testsetnoerr { + [testsetnoerr ns::u] \ + [testsetnoerr ns::v b] \ + [testseterr ns::u] \ + [unset ns::v; testseterr ns::v b] +} -result [list {before get a} {before set b} {before get a} {before set b}] +test var-9.3 {behaviour of TclGetVar no variable} -setup { catch {unset u} +} -constraints testsetnoerr -body { list \ - [catch {testsetnoerr u} res] $res \ - [catch {testseterr u} res] $res -} {1 {before get} 1 {can't read "u": no such variable}} -test var-9.4 {behaviour of TclGetVar no namespace variable} testsetnoerr { + [catch {testsetnoerr u} res] $res \ + [catch {testseterr u} res] $res +} -result {1 {before get} 1 {can't read "u": no such variable}} +test var-9.4 {behaviour of TclGetVar no namespace variable} -setup { catch {namespace delete ns} +} -constraints testsetnoerr -body { namespace eval ns {} list \ - [catch {testsetnoerr ns::w} res] $res \ - [catch {testseterr ns::w} res] $res -} {1 {before get} 1 {can't read "ns::w": no such variable}} -test var-9.5 {behaviour of TclGetVar no namespace} testsetnoerr { + [catch {testsetnoerr ns::w} res] $res \ + [catch {testseterr ns::w} res] $res +} -result {1 {before get} 1 {can't read "ns::w": no such variable}} +test var-9.5 {behaviour of TclGetVar no namespace} -setup { catch {namespace delete ns} +} -constraints testsetnoerr -body { list \ - [catch {testsetnoerr ns::u} res] $res \ - [catch {testseterr ns::v} res] $res -} {1 {before get} 1 {can't read "ns::v": no such variable}} -test var-9.6 {behaviour of TclSetVar no namespace} testsetnoerr { + [catch {testsetnoerr ns::u} res] $res \ + [catch {testseterr ns::v} res] $res +} -result {1 {before get} 1 {can't read "ns::v": no such variable}} +test var-9.6 {behaviour of TclSetVar no namespace} -setup { catch {namespace delete ns} +} -constraints testsetnoerr -body { list \ - [catch {testsetnoerr ns::v 1} res] $res \ - [catch {testseterr ns::v 1} res] $res -} {1 {before set} 1 {can't set "ns::v": parent namespace doesn't exist}} -test var-9.7 {behaviour of TclGetVar array variable} testsetnoerr { + [catch {testsetnoerr ns::v 1} res] $res \ + [catch {testseterr ns::v 1} res] $res +} -result {1 {before set} 1 {can't set "ns::v": parent namespace doesn't exist}} +test var-9.7 {behaviour of TclGetVar array variable} -setup { catch {unset arr} - set arr(1) 1; +} -constraints testsetnoerr -body { + set arr(1) 1 list \ - [catch {testsetnoerr arr} res] $res \ - [catch {testseterr arr} res] $res -} {1 {before get} 1 {can't read "arr": variable is array}} -test var-9.8 {behaviour of TclSetVar array variable} testsetnoerr { + [catch {testsetnoerr arr} res] $res \ + [catch {testseterr arr} res] $res +} -result {1 {before get} 1 {can't read "arr": variable is array}} +test var-9.8 {behaviour of TclSetVar array variable} -setup { catch {unset arr} +} -constraints testsetnoerr -body { set arr(1) 1 list \ - [catch {testsetnoerr arr 2} res] $res \ - [catch {testseterr arr 2} res] $res -} {1 {before set} 1 {can't set "arr": variable is array}} -test var-9.9 {behaviour of TclGetVar read trace success} testsetnoerr { + [catch {testsetnoerr arr 2} res] $res \ + [catch {testseterr arr 2} res] $res +} -result {1 {before set} 1 {can't set "arr": variable is array}} +test var-9.9 {behaviour of TclGetVar read trace success} -setup { + catch {unset u} + catch {unset v} +} -constraints testsetnoerr -body { proc resetvar {val name elem op} {upvar 1 $name v; set v $val} - catch {unset u}; catch {unset v} set u 10 trace var u r [list resetvar 1] trace var v r [list resetvar 2] list \ - [testsetnoerr u] \ - [testseterr v] -} {{before get 1} {before get 2}} + [testsetnoerr u] \ + [testseterr v] +} -result {{before get 1} {before get 2}} test var-9.10 {behaviour of TclGetVar read trace error} testsetnoerr { proc writeonly args {error "write-only"} set v 456 trace var v r writeonly list \ - [catch {testsetnoerr v} msg] $msg \ - [catch {testseterr v} msg] $msg + [catch {testsetnoerr v} msg] $msg \ + [catch {testseterr v} msg] $msg } {1 {before get} 1 {can't read "v": write-only}} -test var-9.11 {behaviour of TclSetVar write trace success} testsetnoerr { +test var-9.11 {behaviour of TclSetVar write trace success} -setup { + catch {unset u} + catch {unset v} +} -constraints testsetnoerr -body { proc doubleval {name elem op} {upvar 1 $name v; set v [expr {2 * $v}]} - catch {unset u}; catch {unset v} set v 1 trace var v w doubleval trace var u w doubleval list \ - [testsetnoerr u 2] \ - [testseterr v 3] -} {{before set 4} {before set 6}} + [testsetnoerr u 2] \ + [testseterr v 3] +} -result {{before set 4} {before set 6}} test var-9.12 {behaviour of TclSetVar write trace error} testsetnoerr { proc readonly args {error "read-only"} set v 456 trace var v w readonly list \ - [catch {testsetnoerr v 2} msg] $msg $v \ - [catch {testseterr v 3} msg] $msg $v + [catch {testsetnoerr v 2} msg] $msg $v \ + [catch {testseterr v 3} msg] $msg $v } {1 {before set} 2 1 {can't set "v": read-only} 3} -test var-10.1 {can't nest arrays with array set} { +test var-10.1 {can't nest arrays with array set} -setup { catch {unset arr} - list [catch {array set arr(x) {a 1 b 2}} res] $res -} {1 {can't set "arr(x)": variable isn't array}} -test var-10.2 {can't nest arrays with array set} { +} -returnCodes error -body { + array set arr(x) {a 1 b 2} +} -result {can't set "arr(x)": variable isn't array} +test var-10.2 {can't nest arrays with array set} -setup { catch {unset arr} - list [catch {array set arr(x) {}} res] $res -} {1 {can't set "arr(x)": variable isn't array}} +} -returnCodes error -body { + array set arr(x) {} +} -result {can't set "arr(x)": variable isn't array} -test var-11.1 {array unset} { +test var-11.1 {array unset} -setup { catch {unset a} +} -body { array set a { 1,1 a 1,2 b 2,1 c 2,3 d } array unset a 1,* lsort -dict [array names a] -} {2,1 2,3} -test var-11.2 {array unset} { +} -result {2,1 2,3} +test var-11.2 {array unset} -setup { catch {unset a} +} -body { array set a { 1,1 a 1,2 b } array unset a array exists a -} 0 -test var-11.3 {array unset errors} { +} -result 0 +test var-11.3 {array unset errors} -setup { catch {unset a} +} -returnCodes error -body { array set a { 1,1 a 1,2 b } - list [catch {array unset a pattern too} msg] $msg -} {1 {wrong # args: should be "array unset arrayName ?pattern?"}} + array unset a pattern too +} -result {wrong # args: should be "array unset arrayName ?pattern?"} test var-12.1 {TclFindCompiledLocals, {} array name} { namespace eval n { @@ -687,8 +713,9 @@ test var-12.1 {TclFindCompiledLocals, {} array name} { } } {0 1 2 2,foo} -test var-13.1 {Tcl_UnsetVar2, unset array with trace set on element} { +test var-13.1 {Tcl_UnsetVar2, unset array with trace set on element} -setup { catch {unset t} +} -body { proc foo {var ind op} { global t set foo bar @@ -699,15 +726,14 @@ test var-13.1 {Tcl_UnsetVar2, unset array with trace set on element} { unset t } set x "If you see this, it worked" -} "If you see this, it worked" +} -result "If you see this, it worked" test var-14.1 {array names syntax} -body { array names foo bar baz snafu } -returnCodes 1 -match glob -result * - test var-14.2 {array names -glob} -body { array names tcl_platform -glob os -} -returnCodes 0 -match exact -result os +} -result os test var-15.1 {segfault in [unset], [Bug 735335]} { proc A { name } { @@ -723,7 +749,6 @@ test var-15.1 {segfault in [unset], [Bug 735335]} { namespace eval test unset useSomeUnlikelyNameHere } {} - test var-16.1 {CallVarTraces: save/restore interp error state} { trace add variable ::errorCode write " ;#" catch {error foo bar baz} @@ -763,7 +788,6 @@ test var-18.1 {array unset and unset traces: Bug 2939073} -setup { unset x already } -result 0 - test var-19.1 {crash when freeing locals hashtable: Bug 3037525} { proc foo {} { catch {upvar 0 dummy \$index} } foo ; # This crashes without the fix for the bug diff --git a/unix/configure b/unix/configure index 75d47d7..04f77d4 100755 --- a/unix/configure +++ b/unix/configure @@ -308,7 +308,7 @@ ac_includes_default="\ # include <unistd.h> #endif" -ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS MAN_FLAGS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT CPP EGREP TCL_THREADS TCLSH_PROG ZLIB_DIR ZLIB_OBJS ZLIB_SRCS ZLIB_INCLUDE RANLIB ac_ct_RANLIB AR LIBOBJS TCL_LIBS DL_LIBS DL_OBJS PLAT_OBJS PLAT_SRCS LDAIX_SRC CFLAGS_DEBUG CFLAGS_OPTIMIZE CFLAGS_WARNING LDFLAGS_DEBUG LDFLAGS_OPTIMIZE CC_SEARCH_FLAGS LD_SEARCH_FLAGS STLIB_LD SHLIB_LD TCL_SHLIB_LD_EXTRAS TK_SHLIB_LD_EXTRAS SHLIB_LD_LIBS SHLIB_CFLAGS SHLIB_SUFFIX MAKE_LIB MAKE_STUB_LIB INSTALL_LIB DLL_INSTALL_DIR INSTALL_STUB_LIB CFLAGS_DEFAULT LDFLAGS_DEFAULT DTRACE TCL_VERSION TCL_MAJOR_VERSION TCL_MINOR_VERSION TCL_PATCH_LEVEL TCL_YEAR PKG_CFG_ARGS TCL_LIB_FILE TCL_LIB_FLAG TCL_LIB_SPEC TCL_STUB_LIB_FILE TCL_STUB_LIB_FLAG TCL_STUB_LIB_SPEC TCL_STUB_LIB_PATH TCL_INCLUDE_SPEC TCL_BUILD_STUB_LIB_SPEC TCL_BUILD_STUB_LIB_PATH TCL_SRC_DIR CFG_TCL_SHARED_LIB_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX TCL_SHARED_BUILD LD_LIBRARY_PATH_VAR TCL_BUILD_LIB_SPEC TCL_LIB_VERSIONS_OK TCL_SHARED_LIB_SUFFIX TCL_UNSHARED_LIB_SUFFIX TCL_HAS_LONGLONG INSTALL_TZDATA DTRACE_SRC DTRACE_HDR DTRACE_OBJ MAKEFILE_SHELL BUILD_DLTEST TCL_PACKAGE_PATH TCL_MODULE_PATH TCL_LIBRARY PRIVATE_INCLUDE_DIR HTML_DIR PACKAGE_DIR EXTRA_CC_SWITCHES EXTRA_APP_CC_SWITCHES EXTRA_INSTALL EXTRA_INSTALL_BINARIES EXTRA_BUILD_HTML EXTRA_TCLSH_LIBS DLTEST_LD DLTEST_SUFFIX' +ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS MAN_FLAGS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT CPP EGREP TCL_THREADS TCLSH_PROG ZLIB_DIR ZLIB_OBJS ZLIB_SRCS ZLIB_INCLUDE RANLIB ac_ct_RANLIB AR ac_ct_AR LIBOBJS TCL_LIBS DL_LIBS DL_OBJS PLAT_OBJS PLAT_SRCS LDAIX_SRC CFLAGS_DEBUG CFLAGS_OPTIMIZE CFLAGS_WARNING LDFLAGS_DEBUG LDFLAGS_OPTIMIZE CC_SEARCH_FLAGS LD_SEARCH_FLAGS STLIB_LD SHLIB_LD TCL_SHLIB_LD_EXTRAS TK_SHLIB_LD_EXTRAS SHLIB_LD_LIBS SHLIB_CFLAGS SHLIB_SUFFIX MAKE_LIB MAKE_STUB_LIB INSTALL_LIB DLL_INSTALL_DIR INSTALL_STUB_LIB CFLAGS_DEFAULT LDFLAGS_DEFAULT DTRACE TCL_VERSION TCL_MAJOR_VERSION TCL_MINOR_VERSION TCL_PATCH_LEVEL TCL_YEAR PKG_CFG_ARGS TCL_LIB_FILE TCL_LIB_FLAG TCL_LIB_SPEC TCL_STUB_LIB_FILE TCL_STUB_LIB_FLAG TCL_STUB_LIB_SPEC TCL_STUB_LIB_PATH TCL_INCLUDE_SPEC TCL_BUILD_STUB_LIB_SPEC TCL_BUILD_STUB_LIB_PATH TCL_SRC_DIR CFG_TCL_SHARED_LIB_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX TCL_SHARED_BUILD LD_LIBRARY_PATH_VAR TCL_BUILD_LIB_SPEC TCL_LIB_VERSIONS_OK TCL_SHARED_LIB_SUFFIX TCL_UNSHARED_LIB_SUFFIX TCL_HAS_LONGLONG INSTALL_TZDATA DTRACE_SRC DTRACE_HDR DTRACE_OBJ MAKEFILE_SHELL BUILD_DLTEST TCL_PACKAGE_PATH TCL_MODULE_PATH TCL_LIBRARY PRIVATE_INCLUDE_DIR HTML_DIR PACKAGE_DIR EXTRA_CC_SWITCHES EXTRA_APP_CC_SWITCHES EXTRA_INSTALL EXTRA_INSTALL_BINARIES EXTRA_BUILD_HTML EXTRA_TCLSH_LIBS DLTEST_LD DLTEST_SUFFIX' ac_subst_files='' # Initialize some variables set by options. @@ -6763,8 +6763,9 @@ else fi - # Extract the first word of "ar", so it can be a program name with args. -set dummy ar; ac_word=$2 + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}ar", so it can be a program name with args. +set dummy ${ac_tool_prefix}ar; ac_word=$2 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_prog_AR+set}" = set; then @@ -6780,7 +6781,7 @@ do test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_AR="ar" + ac_cv_prog_AR="${ac_tool_prefix}ar" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi @@ -6798,12 +6799,47 @@ else echo "${ECHO_T}no" >&6 fi - if test "${AR}" = ""; then +fi +if test -z "$ac_cv_prog_AR"; then + ac_ct_AR=$AR + # Extract the first word of "ar", so it can be a program name with args. +set dummy ar; ac_word=$2 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_ac_ct_AR+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if test -n "$ac_ct_AR"; then + ac_cv_prog_ac_ct_AR="$ac_ct_AR" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_AR="ar" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done +done - { { echo "$as_me:$LINENO: error: Required archive tool 'ar' not found on PATH." >&5 -echo "$as_me: error: Required archive tool 'ar' not found on PATH." >&2;} - { (exit 1); exit 1; }; } +fi +fi +ac_ct_AR=$ac_cv_prog_ac_ct_AR +if test -n "$ac_ct_AR"; then + echo "$as_me:$LINENO: result: $ac_ct_AR" >&5 +echo "${ECHO_T}$ac_ct_AR" >&6 +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 +fi + AR=$ac_ct_AR +else + AR="$ac_cv_prog_AR" fi STLIB_LD='${AR} cr' @@ -20052,6 +20088,7 @@ s,@ZLIB_INCLUDE@,$ZLIB_INCLUDE,;t t s,@RANLIB@,$RANLIB,;t t s,@ac_ct_RANLIB@,$ac_ct_RANLIB,;t t s,@AR@,$AR,;t t +s,@ac_ct_AR@,$ac_ct_AR,;t t s,@LIBOBJS@,$LIBOBJS,;t t s,@TCL_LIBS@,$TCL_LIBS,;t t s,@DL_LIBS@,$DL_LIBS,;t t diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 6d21d69..4d7fa71 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1112,12 +1112,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ CFLAGS_OPTIMIZE=-O CFLAGS_WARNING="" ]) -dnl FIXME: Replace AC_CHECK_PROG with AC_CHECK_TOOL once cross compiling is fixed. -dnl AC_CHECK_TOOL(AR, ar) - AC_CHECK_PROG(AR, ar, ar) - AS_IF([test "${AR}" = ""], [ - AC_MSG_ERROR([Required archive tool 'ar' not found on PATH.]) - ]) + AC_CHECK_TOOL(AR, ar) STLIB_LD='${AR} cr' LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH" PLAT_OBJS="" diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index c3b2d35..6af51d1 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.3 2010/10/28 19:42:20 kennykb Exp $ + * RCS: @(#) $Id: tclUnixSock.c,v 1.26.2.4 2010/12/11 18:39:31 kennykb Exp $ */ #include "tclInt.h" @@ -923,7 +923,7 @@ CreateClientSocket( * Set kernel space buffering */ - TclSockMinimumBuffers(sock, SOCKET_BUFSIZE); + TclSockMinimumBuffers(INT2PTR(sock), SOCKET_BUFSIZE); if (async) { status = TclUnixSetBlockingMode(sock, TCL_MODE_NONBLOCKING); @@ -1185,7 +1185,7 @@ Tcl_OpenTcpServer( * Set kernel space buffering */ - TclSockMinimumBuffers(sock, SOCKET_BUFSIZE); + TclSockMinimumBuffers(INT2PTR(sock), SOCKET_BUFSIZE); /* * Set up to reuse server addresses automatically and bind to the diff --git a/win/Makefile.in b/win/Makefile.in index 2d1c4c4..392bb15 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.2 2010/12/01 16:42:37 kennykb Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.184.2.3 2010/12/11 18:39:31 kennykb Exp $ VERSION = @TCL_VERSION@ @@ -141,17 +141,18 @@ ZLIB_DLL_FILE = zlib1.dll SHARED_LIBRARIES = $(TCL_DLL_FILE) @ZLIB_DLL_FILE@ STATIC_LIBRARIES = $(TCL_LIB_FILE) $(REG_LIB_FILE) $(DDE_LIB_FILE) -# TCL_EXE is the name of a tclsh executable that is available *BEFORE* running -# make for the first time. Certain build targets (make genstubs) need it to be -# available on the PATH. This executable should *NOT* be required just to do a -# normal build although it can be required to run make dist. -TCL_EXE = tclsh - TCLSH = tclsh$(VER)${EXESUFFIX} TCLTEST = tcltest${EXEEXT} CAT32 = cat32$(EXEEXT) MAN2TCL = man2tcl$(EXEEXT) +# For cross-compiled builds, TCL_EXE is the name of a tclsh executable that is +# available *BEFORE* running make for the first time. Certain build targets +# (make genstubs, make install) need it to be available on the PATH. This +# executable should *NOT* be required just to do a normal build although +# it can be required to run make dist. +TCL_EXE = @TCL_EXE@ + @SET_MAKE@ # Setting the VPATH variable to a list of paths will cause the Makefile to @@ -686,14 +687,12 @@ install-libraries: libraries install-tzdata install-msgs install-tzdata: @echo "Installing time zone data" - @TCL_LIBRARY="${LIBRARY_DIR}"; export TCL_LIBRARY; \ - ./$(TCLSH) "$(ROOT_DIR)/tools/installData.tcl" \ + @$(TCL_EXE) "$(ROOT_DIR)/tools/installData.tcl" \ "$(ROOT_DIR)/library/tzdata" "$(SCRIPT_INSTALL_DIR)/tzdata" install-msgs: @echo "Installing message catalogs" - @TCL_LIBRARY="${LIBRARY_DIR}"; export TCL_LIBRARY; \ - ./$(TCLSH) "$(ROOT_DIR)/tools/installData.tcl" \ + @$(TCL_EXE) "$(ROOT_DIR)/tools/installData.tcl" \ "$(ROOT_DIR)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs" install-doc: doc diff --git a/win/configure b/win/configure index 472ad1b..32d9310 100755 --- a/win/configure +++ b/win/configure @@ -309,7 +309,7 @@ ac_includes_default="\ # include <unistd.h> #endif" -ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT CPP EGREP AR ac_ct_AR RANLIB ac_ct_RANLIB RC ac_ct_RC SET_MAKE TCL_THREADS CYGPATH CELIB_DIR DL_LIBS CFLAGS_DEBUG CFLAGS_OPTIMIZE CFLAGS_WARNING ZLIB_DLL_FILE ZLIB_LIBS ZLIB_OBJS CFLAGS_DEFAULT LDFLAGS_DEFAULT VC_MANIFEST_EMBED_DLL VC_MANIFEST_EMBED_EXE TCL_VERSION TCL_MAJOR_VERSION TCL_MINOR_VERSION TCL_PATCH_LEVEL PKG_CFG_ARGS TCL_LIB_FILE TCL_LIB_FLAG TCL_STATIC_LIB_FILE TCL_STATIC_LIB_FLAG TCL_IMPORT_LIB_FILE TCL_IMPORT_LIB_FLAG TCL_LIB_SPEC TCL_STUB_LIB_FILE TCL_STUB_LIB_FLAG TCL_STUB_LIB_SPEC TCL_STUB_LIB_PATH TCL_INCLUDE_SPEC TCL_BUILD_STUB_LIB_SPEC TCL_BUILD_STUB_LIB_PATH TCL_DLL_FILE TCL_SRC_DIR TCL_BIN_DIR TCL_DBGX CFG_TCL_SHARED_LIB_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX CFG_TCL_EXPORT_FILE_SUFFIX EXTRA_CFLAGS DEPARG CC_OBJNAME CC_EXENAME LDFLAGS_DEBUG LDFLAGS_OPTIMIZE LDFLAGS_CONSOLE LDFLAGS_WINDOW STLIB_LD SHLIB_LD SHLIB_LD_LIBS SHLIB_CFLAGS SHLIB_SUFFIX TCL_SHARED_BUILD LIBS_GUI DLLSUFFIX LIBPREFIX LIBSUFFIX EXESUFFIX LIBRARIES MAKE_LIB POST_MAKE_LIB MAKE_DLL MAKE_EXE TCL_BUILD_LIB_SPEC TCL_LD_SEARCH_FLAGS TCL_NEEDS_EXP_FILE TCL_BUILD_EXP_FILE TCL_EXP_FILE TCL_LIB_VERSIONS_OK TCL_PACKAGE_PATH TCL_DDE_VERSION TCL_DDE_MAJOR_VERSION TCL_DDE_MINOR_VERSION TCL_DDE_PATCH_LEVEL TCL_REG_VERSION TCL_REG_MAJOR_VERSION TCL_REG_MINOR_VERSION TCL_REG_PATCH_LEVEL RC_OUT RC_TYPE RC_INCLUDE RC_DEFINE RC_DEFINES RES LIBOBJS LTLIBOBJS' +ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT CPP EGREP AR ac_ct_AR RANLIB ac_ct_RANLIB RC ac_ct_RC SET_MAKE TCL_THREADS CYGPATH CELIB_DIR DL_LIBS CFLAGS_DEBUG CFLAGS_OPTIMIZE CFLAGS_WARNING ZLIB_DLL_FILE ZLIB_LIBS ZLIB_OBJS CFLAGS_DEFAULT LDFLAGS_DEFAULT VC_MANIFEST_EMBED_DLL VC_MANIFEST_EMBED_EXE TCL_VERSION TCL_MAJOR_VERSION TCL_MINOR_VERSION TCL_PATCH_LEVEL PKG_CFG_ARGS TCL_EXE TCL_LIB_FILE TCL_LIB_FLAG TCL_STATIC_LIB_FILE TCL_STATIC_LIB_FLAG TCL_IMPORT_LIB_FILE TCL_IMPORT_LIB_FLAG TCL_LIB_SPEC TCL_STUB_LIB_FILE TCL_STUB_LIB_FLAG TCL_STUB_LIB_SPEC TCL_STUB_LIB_PATH TCL_INCLUDE_SPEC TCL_BUILD_STUB_LIB_SPEC TCL_BUILD_STUB_LIB_PATH TCL_DLL_FILE TCL_SRC_DIR TCL_BIN_DIR TCL_DBGX CFG_TCL_SHARED_LIB_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX CFG_TCL_EXPORT_FILE_SUFFIX EXTRA_CFLAGS DEPARG CC_OBJNAME CC_EXENAME LDFLAGS_DEBUG LDFLAGS_OPTIMIZE LDFLAGS_CONSOLE LDFLAGS_WINDOW STLIB_LD SHLIB_LD SHLIB_LD_LIBS SHLIB_CFLAGS SHLIB_SUFFIX TCL_SHARED_BUILD LIBS_GUI DLLSUFFIX LIBPREFIX LIBSUFFIX EXESUFFIX LIBRARIES MAKE_LIB POST_MAKE_LIB MAKE_DLL MAKE_EXE TCL_BUILD_LIB_SPEC TCL_LD_SEARCH_FLAGS TCL_NEEDS_EXP_FILE TCL_BUILD_EXP_FILE TCL_EXP_FILE TCL_LIB_VERSIONS_OK TCL_PACKAGE_PATH TCL_DDE_VERSION TCL_DDE_MAJOR_VERSION TCL_DDE_MINOR_VERSION TCL_DDE_PATCH_LEVEL TCL_REG_VERSION TCL_REG_MAJOR_VERSION TCL_REG_MINOR_VERSION TCL_REG_PATCH_LEVEL RC_OUT RC_TYPE RC_INCLUDE RC_DEFINE RC_DEFINES RES LIBOBJS LTLIBOBJS' ac_subst_files='' # Initialize some variables set by options. @@ -4009,10 +4009,6 @@ file for information about building with Mingw." >&2;} echo "$as_me:$LINENO: checking compiler flags" >&5 echo $ECHO_N "checking compiler flags... $ECHO_C" >&6 if test "${GCC}" = "yes" ; then - if test "$do64bit" != "no" ; then - { echo "$as_me:$LINENO: WARNING: 64bit mode not supported with GCC on Windows" >&5 -echo "$as_me: WARNING: 64bit mode not supported with GCC on Windows" >&2;} - fi SHLIB_LD="" SHLIB_LD_LIBS='${LIBS}' LIBS="-lnetapi32 -lkernel32 -luser32 -ladvapi32 -lws2_32" @@ -4183,8 +4179,11 @@ echo "$as_me: error: ${CC} does not support the -shared option. LDFLAGS_CONSOLE="-mconsole ${extra_ldflags}" LDFLAGS_WINDOW="-mwindows ${extra_ldflags}" - # gcc under Windows supports only 32bit builds - MACHINE="X86" + if test "$do64bit" != "no" ; then + MACHINE="AMD64" + else + MACHINE="X86" + fi else if test "${SHARED_BUILD}" = "0" ; then # static @@ -4491,6 +4490,16 @@ _ACEOF +# Cross-compiling +case ${host_alias} in +*mingw32*) + TCL_EXE="tclsh" + ;; +*) + TCL_EXE="TCL_LIBRARY=\"\${LIBRARY_DIR}\"; export TCL_LIBRARY; ./\${TCLSH}" + ;; +esac + #------------------------------------------------------------------------ # Add stuff for zlib; note that this is mostly done in the makefile now # as we just assume that the platform hasn't got a usable z.lib @@ -4540,6 +4549,277 @@ cat >>confdefs.h <<\_ACEOF _ACEOF +echo "$as_me:$LINENO: checking for intptr_t" >&5 +echo $ECHO_N "checking for intptr_t... $ECHO_C" >&6 +if test "${ac_cv_type_intptr_t+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. */ +$ac_includes_default +int +main () +{ +if ((intptr_t *) 0) + return 0; +if (sizeof (intptr_t)) + return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 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_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_type_intptr_t=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_type_intptr_t=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_type_intptr_t" >&5 +echo "${ECHO_T}$ac_cv_type_intptr_t" >&6 +if test $ac_cv_type_intptr_t = yes; then + + +cat >>confdefs.h <<\_ACEOF +#define HAVE_INTPTR_T 1 +_ACEOF + +else + + echo "$as_me:$LINENO: checking for pointer-size signed integer type" >&5 +echo $ECHO_N "checking for pointer-size signed integer type... $ECHO_C" >&6 +if test "${tcl_cv_intptr_t+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + + for tcl_cv_intptr_t in "int" "long" "long long" none; do + if test "$tcl_cv_intptr_t" != none; then + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +int +main () +{ +static int test_array [1 - 2 * !(sizeof (void *) <= sizeof ($tcl_cv_intptr_t))]; +test_array [0] = 0 + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 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_objext' + { (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_ok=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_ok=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext + test "$tcl_ok" = yes && break; fi + done +fi +echo "$as_me:$LINENO: result: $tcl_cv_intptr_t" >&5 +echo "${ECHO_T}$tcl_cv_intptr_t" >&6 + if test "$tcl_cv_intptr_t" != none; then + +cat >>confdefs.h <<_ACEOF +#define intptr_t $tcl_cv_intptr_t +_ACEOF + + fi + +fi + +echo "$as_me:$LINENO: checking for uintptr_t" >&5 +echo $ECHO_N "checking for uintptr_t... $ECHO_C" >&6 +if test "${ac_cv_type_uintptr_t+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. */ +$ac_includes_default +int +main () +{ +if ((uintptr_t *) 0) + return 0; +if (sizeof (uintptr_t)) + return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 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_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_type_uintptr_t=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_type_uintptr_t=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_type_uintptr_t" >&5 +echo "${ECHO_T}$ac_cv_type_uintptr_t" >&6 +if test $ac_cv_type_uintptr_t = yes; then + + +cat >>confdefs.h <<\_ACEOF +#define HAVE_UINTPTR_T 1 +_ACEOF + +else + + echo "$as_me:$LINENO: checking for pointer-size unsigned integer type" >&5 +echo $ECHO_N "checking for pointer-size unsigned integer type... $ECHO_C" >&6 +if test "${tcl_cv_uintptr_t+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + + for tcl_cv_uintptr_t in "unsigned int" "unsigned long" "unsigned long long" \ + none; do + if test "$tcl_cv_uintptr_t" != none; then + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +int +main () +{ +static int test_array [1 - 2 * !(sizeof (void *) <= sizeof ($tcl_cv_uintptr_t))]; +test_array [0] = 0 + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 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_objext' + { (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_ok=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_ok=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext + test "$tcl_ok" = yes && break; fi + done +fi +echo "$as_me:$LINENO: result: $tcl_cv_uintptr_t" >&5 +echo "${ECHO_T}$tcl_cv_uintptr_t" >&6 + if test "$tcl_cv_uintptr_t" != none; then + +cat >>confdefs.h <<_ACEOF +#define uintptr_t $tcl_cv_uintptr_t +_ACEOF + + fi + +fi + #-------------------------------------------------------------------- # Set the default compiler switches based on the --enable-symbols # option. This macro depends on C flags, and should be called @@ -4760,6 +5040,7 @@ fi + # empty on win @@ -5514,6 +5795,7 @@ s,@TCL_MAJOR_VERSION@,$TCL_MAJOR_VERSION,;t t s,@TCL_MINOR_VERSION@,$TCL_MINOR_VERSION,;t t s,@TCL_PATCH_LEVEL@,$TCL_PATCH_LEVEL,;t t s,@PKG_CFG_ARGS@,$PKG_CFG_ARGS,;t t +s,@TCL_EXE@,$TCL_EXE,;t t s,@TCL_LIB_FILE@,$TCL_LIB_FILE,;t t s,@TCL_LIB_FLAG@,$TCL_LIB_FLAG,;t t s,@TCL_STATIC_LIB_FILE@,$TCL_STATIC_LIB_FILE,;t t diff --git a/win/configure.in b/win/configure.in index e3a175a..256f8c7 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.2 2010/12/01 16:42:37 kennykb Exp $ +# RCS: @(#) $Id: configure.in,v 1.123.2.3 2010/12/11 18:39:31 kennykb Exp $ AC_INIT(../generic/tcl.h) AC_PREREQ(2.59) @@ -306,6 +306,16 @@ SC_ENABLE_SHARED SC_CONFIG_CFLAGS +# Cross-compiling +case ${host_alias} in +*mingw32*) + TCL_EXE="tclsh" + ;; +*) + TCL_EXE="TCL_LIBRARY=\"\${LIBRARY_DIR}\"; export TCL_LIBRARY; ./\${TCLSH}" + ;; +esac + #------------------------------------------------------------------------ # Add stuff for zlib; note that this is mostly done in the makefile now # as we just assume that the platform hasn't got a usable z.lib @@ -330,6 +340,37 @@ AS_IF([test "$tcl_ok" = "yes"], [ ]) AC_DEFINE(HAVE_ZLIB, 1, [Is there an installed zlib?]) +AC_CHECK_TYPE([intptr_t], [ + AC_DEFINE([HAVE_INTPTR_T], 1, [Do we have the intptr_t type?])], [ + AC_CACHE_CHECK([for pointer-size signed integer type], tcl_cv_intptr_t, [ + for tcl_cv_intptr_t in "int" "long" "long long" none; do + if test "$tcl_cv_intptr_t" != none; then + AC_COMPILE_IFELSE([AC_LANG_BOOL_COMPILE_TRY([AC_INCLUDES_DEFAULT], + [[sizeof (void *) <= sizeof ($tcl_cv_intptr_t)]])], + [tcl_ok=yes], [tcl_ok=no]) + test "$tcl_ok" = yes && break; fi + done]) + if test "$tcl_cv_intptr_t" != none; then + AC_DEFINE_UNQUOTED([intptr_t], [$tcl_cv_intptr_t], [Signed integer + type wide enough to hold a pointer.]) + fi +]) +AC_CHECK_TYPE([uintptr_t], [ + AC_DEFINE([HAVE_UINTPTR_T], 1, [Do we have the uintptr_t type?])], [ + AC_CACHE_CHECK([for pointer-size unsigned integer type], tcl_cv_uintptr_t, [ + for tcl_cv_uintptr_t in "unsigned int" "unsigned long" "unsigned long long" \ + none; do + if test "$tcl_cv_uintptr_t" != none; then + AC_COMPILE_IFELSE([AC_LANG_BOOL_COMPILE_TRY([AC_INCLUDES_DEFAULT], + [[sizeof (void *) <= sizeof ($tcl_cv_uintptr_t)]])], + [tcl_ok=yes], [tcl_ok=no]) + test "$tcl_ok" = yes && break; fi + done]) + if test "$tcl_cv_uintptr_t" != none; then + AC_DEFINE_UNQUOTED([uintptr_t], [$tcl_cv_uintptr_t], [Unsigned integer + type wide enough to hold a pointer.]) + fi +]) #-------------------------------------------------------------------- # Set the default compiler switches based on the --enable-symbols # option. This macro depends on C flags, and should be called @@ -425,6 +466,7 @@ AC_SUBST(TCL_MAJOR_VERSION) AC_SUBST(TCL_MINOR_VERSION) AC_SUBST(TCL_PATCH_LEVEL) AC_SUBST(PKG_CFG_ARGS) +AC_SUBST(TCL_EXE) AC_SUBST(TCL_LIB_FILE) AC_SUBST(TCL_LIB_FLAG) @@ -458,9 +458,6 @@ file for information about building with Mingw.]) AC_MSG_CHECKING([compiler flags]) if test "${GCC}" = "yes" ; then - if test "$do64bit" != "no" ; then - AC_MSG_WARN([64bit mode not supported with GCC on Windows]) - fi SHLIB_LD="" SHLIB_LD_LIBS='${LIBS}' LIBS="-lnetapi32 -lkernel32 -luser32 -ladvapi32 -lws2_32" @@ -578,8 +575,11 @@ file for information about building with Mingw.]) LDFLAGS_CONSOLE="-mconsole ${extra_ldflags}" LDFLAGS_WINDOW="-mwindows ${extra_ldflags}" - # gcc under Windows supports only 32bit builds - MACHINE="X86" + if test "$do64bit" != "no" ; then + MACHINE="AMD64" + else + MACHINE="X86" + fi else if test "${SHARED_BUILD}" = "0" ; then # static diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 66c988a..19ebb82 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.4 2010/10/28 19:42:20 kennykb Exp $ + * RCS: @(#) $Id: tclWinSock.c,v 1.74.2.5 2010/12/11 18:39:31 kennykb Exp $ * * ----------------------------------------------------------------------- * @@ -1062,7 +1062,7 @@ CreateSocket( * Set kernel space buffering */ - TclSockMinimumBuffers((int) sock, TCP_BUFFER_SIZE); + TclSockMinimumBuffers((ClientData)sock, TCP_BUFFER_SIZE); /* * Make sure we use the same port when opening two server sockets @@ -1171,7 +1171,7 @@ CreateSocket( * Set kernel space buffering */ - TclSockMinimumBuffers((int) sock, TCP_BUFFER_SIZE); + TclSockMinimumBuffers((ClientData)sock, TCP_BUFFER_SIZE); /* * Try to bind to a local port. @@ -1508,7 +1508,7 @@ Tcl_MakeTcpClientChannel( * Set kernel space buffering and non-blocking. */ - TclSockMinimumBuffers((int) sock, TCP_BUFFER_SIZE); + TclSockMinimumBuffers((ClientData) sock, TCP_BUFFER_SIZE); infoPtr = NewSocketInfo((SOCKET) sock); @@ -2095,7 +2095,7 @@ TcpGetOptionProc( } infoPtr = (SocketInfo *) instanceData; - sock = (int) infoPtr->sockets->fd; + sock = infoPtr->sockets->fd; if (optionName != NULL) { len = strlen(optionName); } @@ -2107,7 +2107,7 @@ TcpGetOptionProc( int ret; optlen = sizeof(int); - ret = TclWinGetSockOpt((int)sock, SOL_SOCKET, SO_ERROR, + ret = TclWinGetSockOpt(sock, SOL_SOCKET, SO_ERROR, (char *)&err, &optlen); if (ret == SOCKET_ERROR) { err = WSAGetLastError(); @@ -2686,7 +2686,7 @@ InitializeHostName( int TclWinGetSockOpt( - int s, + SOCKET s, int level, int optname, char * optval, @@ -2702,12 +2702,12 @@ TclWinGetSockOpt( return SOCKET_ERROR; } - return getsockopt((SOCKET)s, level, optname, optval, optlen); + return getsockopt(s, level, optname, optval, optlen); } int TclWinSetSockOpt( - int s, + SOCKET s, int level, int optname, const char * optval, @@ -2723,7 +2723,7 @@ TclWinSetSockOpt( return SOCKET_ERROR; } - return setsockopt((SOCKET)s, level, optname, optval, optlen); + return setsockopt(s, level, optname, optval, optlen); } u_short |