diff options
Diffstat (limited to 'generic')
112 files changed, 4007 insertions, 2262 deletions
diff --git a/generic/regc_color.c b/generic/regc_color.c index 92e0aad..f7dd284 100644 --- a/generic/regc_color.c +++ b/generic/regc_color.c @@ -2,7 +2,7 @@ * colorings of characters * This file is #included by regcomp.c. * - * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved. + * Copyright © 1998, 1999 Henry Spencer. All rights reserved. * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics diff --git a/generic/regc_cvec.c b/generic/regc_cvec.c index d450d3e..3b4f1e4 100644 --- a/generic/regc_cvec.c +++ b/generic/regc_cvec.c @@ -2,7 +2,7 @@ * Utility functions for handling cvecs * This file is #included by regcomp.c. * - * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved. + * Copyright © 1998, 1999 Henry Spencer. All rights reserved. * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics diff --git a/generic/regc_lex.c b/generic/regc_lex.c index a303ec6..bad91ce 100644 --- a/generic/regc_lex.c +++ b/generic/regc_lex.c @@ -2,7 +2,7 @@ * lexical analyzer * This file is #included by regcomp.c. * - * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved. + * Copyright © 1998, 1999 Henry Spencer. All rights reserved. * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics @@ -427,7 +427,7 @@ next( if (INCON(L_BBND) && NEXT1('}')) { v->now++; INTOCON(L_BRE); - RET('}'); + RETV('}', 1); } else { FAILW(REG_BADBR); } @@ -1005,7 +1005,7 @@ brenext( if (LASTTYPE(EMPTY) || LASTTYPE('(') || LASTTYPE('^')) { RETV(PLAIN, c); } - RET('*'); + RETV('*', 1); break; case CHR('['): if (HAVE(6) && *(v->now+0) == CHR('[') && diff --git a/generic/regc_locale.c b/generic/regc_locale.c index c90dd64..2aea16d 100644 --- a/generic/regc_locale.c +++ b/generic/regc_locale.c @@ -4,7 +4,7 @@ * This file contains the Unicode locale specific regexp routines. * This file is #included by regcomp.c. * - * Copyright (c) 1998 by Scriptics Corporation. + * Copyright © 1998 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c index 7507137..f676a45 100644 --- a/generic/regc_nfa.c +++ b/generic/regc_nfa.c @@ -2,7 +2,7 @@ * NFA utilities. * This file is #included by regcomp.c. * - * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved. + * Copyright © 1998, 1999 Henry Spencer. All rights reserved. * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics diff --git a/generic/regcomp.c b/generic/regcomp.c index 3be5172..471d13b 100644 --- a/generic/regcomp.c +++ b/generic/regcomp.c @@ -2,7 +2,7 @@ * re_*comp and friends - compile REs * This file #includes several others (see the bottom). * - * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved. + * Copyright © 1998, 1999 Henry Spencer. All rights reserved. * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics diff --git a/generic/rege_dfa.c b/generic/rege_dfa.c index e5f22c4..f38c8c9 100644 --- a/generic/rege_dfa.c +++ b/generic/rege_dfa.c @@ -2,7 +2,7 @@ * DFA routines * This file is #included by regexec.c. * - * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved. + * Copyright © 1998, 1999 Henry Spencer. All rights reserved. * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics diff --git a/generic/regerror.c b/generic/regerror.c index 500dfe2..6606d41 100644 --- a/generic/regerror.c +++ b/generic/regerror.c @@ -1,7 +1,7 @@ /* * regerror - error-code expansion * - * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved. + * Copyright © 1998, 1999 Henry Spencer. All rights reserved. * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics diff --git a/generic/regexec.c b/generic/regexec.c index e7260cd..c085ac6 100644 --- a/generic/regexec.c +++ b/generic/regexec.c @@ -1,7 +1,7 @@ /* * re_*exec and friends - match REs * - * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved. + * Copyright © 1998, 1999 Henry Spencer. All rights reserved. * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics diff --git a/generic/regfree.c b/generic/regfree.c index b0aaa70..71263ab 100644 --- a/generic/regfree.c +++ b/generic/regfree.c @@ -1,7 +1,7 @@ /* * regfree - free an RE * - * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved. + * Copyright © 1998, 1999 Henry Spencer. All rights reserved. * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics diff --git a/generic/regfronts.c b/generic/regfronts.c index 088a640..3042558 100644 --- a/generic/regfronts.c +++ b/generic/regfronts.c @@ -4,7 +4,7 @@ * Mostly for implementation of backward-compatibility kludges. Note that * these routines exist ONLY in char versions. * - * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved. + * Copyright © 1998, 1999 Henry Spencer. All rights reserved. * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics diff --git a/generic/tcl.decls b/generic/tcl.decls index c4af7cc..230e57e 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -860,8 +860,8 @@ declare 243 { void Tcl_SplitPath(const char *path, int *argcPtr, const char ***argvPtr) } declare 244 {nostub {Don't use this function in a stub-enabled extension}} { - void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName, - Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) + void Tcl_StaticLibrary(Tcl_Interp *interp, const char *prefix, + Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc) } declare 245 {deprecated {No longer in use, changed to macro}} { int Tcl_StringMatch(const char *str, const char *pattern) @@ -1163,7 +1163,7 @@ declare 325 { const char *Tcl_UtfAtIndex(const char *src, int index) } declare 326 { - int Tcl_UtfCharComplete(const char *src, int length) + int TclUtfCharComplete(const char *src, int length) } declare 327 { int Tcl_UtfBackslash(const char *src, int *readPtr, char *dst) @@ -1175,10 +1175,10 @@ declare 329 { const char *Tcl_UtfFindLast(const char *src, int ch) } declare 330 { - const char *Tcl_UtfNext(const char *src) + const char *TclUtfNext(const char *src) } declare 331 { - const char *Tcl_UtfPrev(const char *src, const char *start) + const char *TclUtfPrev(const char *src, const char *start) } declare 332 { int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding, @@ -1581,8 +1581,8 @@ declare 443 { } declare 444 { int Tcl_FSLoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *sym1, - const char *sym2, Tcl_PackageInitProc **proc1Ptr, - Tcl_PackageInitProc **proc2Ptr, Tcl_LoadHandle *handlePtr, + const char *sym2, Tcl_LibraryInitProc **proc1Ptr, + Tcl_LibraryInitProc **proc2Ptr, Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr) } declare 445 { @@ -1751,10 +1751,10 @@ declare 490 { Tcl_StatBuf *Tcl_AllocStatBuf(void) } declare 491 { - Tcl_WideInt Tcl_Seek(Tcl_Channel chan, Tcl_WideInt offset, int mode) + long long Tcl_Seek(Tcl_Channel chan, long long offset, int mode) } declare 492 { - Tcl_WideInt Tcl_Tell(Tcl_Channel chan) + long long Tcl_Tell(Tcl_Channel chan) } # TIP#91 (back-compat enhancements for channels) dkf @@ -2026,7 +2026,7 @@ declare 559 { # TIP #208 ('chan' command) jeffh declare 560 { - int Tcl_TruncateChannel(Tcl_Channel chan, Tcl_WideInt length) + int Tcl_TruncateChannel(Tcl_Channel chan, long long length) } declare 561 { Tcl_DriverTruncateProc *Tcl_ChannelTruncateProc( @@ -2177,19 +2177,19 @@ declare 595 { int Tcl_GetDeviceTypeFromStat(const Tcl_StatBuf *statPtr) } declare 596 { - Tcl_WideInt Tcl_GetAccessTimeFromStat(const Tcl_StatBuf *statPtr) + long long Tcl_GetAccessTimeFromStat(const Tcl_StatBuf *statPtr) } declare 597 { - Tcl_WideInt Tcl_GetModificationTimeFromStat(const Tcl_StatBuf *statPtr) + long long Tcl_GetModificationTimeFromStat(const Tcl_StatBuf *statPtr) } declare 598 { - Tcl_WideInt Tcl_GetChangeTimeFromStat(const Tcl_StatBuf *statPtr) + long long Tcl_GetChangeTimeFromStat(const Tcl_StatBuf *statPtr) } declare 599 { - Tcl_WideUInt Tcl_GetSizeFromStat(const Tcl_StatBuf *statPtr) + unsigned long long Tcl_GetSizeFromStat(const Tcl_StatBuf *statPtr) } declare 600 { - Tcl_WideUInt Tcl_GetBlocksFromStat(const Tcl_StatBuf *statPtr) + unsigned long long Tcl_GetBlocksFromStat(const Tcl_StatBuf *statPtr) } declare 601 { unsigned Tcl_GetBlockSizeFromStat(const Tcl_StatBuf *statPtr) @@ -2402,6 +2402,28 @@ declare 648 { int length, Tcl_DString *dsPtr) } +# TIP #481 +declare 651 { + char *TclGetStringFromObj(Tcl_Obj *objPtr, size_t *lengthPtr) +} +declare 652 { + Tcl_UniChar *TclGetUnicodeFromObj(Tcl_Obj *objPtr, size_t *lengthPtr) +} +declare 653 { + unsigned char *TclGetByteArrayFromObj(Tcl_Obj *objPtr, size_t *lengthPtr) +} + +# TIP #575 +declare 654 { + int Tcl_UtfCharComplete(const char *src, int length) +} +declare 655 { + const char *Tcl_UtfNext(const char *src) +} +declare 656 { + const char *Tcl_UtfPrev(const char *src, const char *start) +} + # ----- BASELINE -- FOR -- 8.7.0 ----- # ############################################################################## @@ -2426,6 +2448,9 @@ declare 0 win { declare 1 win { char *Tcl_WinTCharToUtf(const TCHAR *str, int len, Tcl_DString *dsPtr) } +declare 3 win { + void Tcl_WinConvertError(unsigned errCode) +} ################################ # Mac OS X specific functions @@ -2440,6 +2465,9 @@ declare 1 macosx { const char *bundleName, const char *bundleVersion, int hasResourceFile, int maxPathLen, char *libraryPath) } +declare 2 macosx { + void Tcl_MacOSXNotifierAddRunLoopMode(const void *runLoopMode) +} ############################################################################## @@ -2453,8 +2481,8 @@ export { Tcl_Interp *interp) } export { - void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName, - Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) + void Tcl_StaticLibrary(Tcl_Interp *interp, const char *prefix, + Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc) } export { void Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc) @@ -2483,6 +2511,9 @@ export { export { void Tcl_InitSubsystems(void) } +export { + int TclZipfs_AppHook(int *argc, char ***argv) +} # Local Variables: # mode: tcl diff --git a/generic/tcl.h b/generic/tcl.h index 72f9bed..507342f 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -137,7 +137,11 @@ extern "C" { # define TCL_VARARGS_START(type, name, list) (va_start(list, name), name) #endif /* !TCL_NO_DEPRECATED */ #if defined(__GNUC__) && (__GNUC__ > 2) -# define TCL_FORMAT_PRINTF(a,b) __attribute__ ((__format__ (__printf__, a, b))) +# if defined(_WIN32) && defined(__USE_MINGW_ANSI_STDIO) && __USE_MINGW_ANSI_STDIO +# define TCL_FORMAT_PRINTF(a,b) __attribute__ ((__format__ (__MINGW_PRINTF_FORMAT, a, b))) +# else +# define TCL_FORMAT_PRINTF(a,b) __attribute__ ((__format__ (__printf__, a, b))) +# endif # define TCL_NORETURN __attribute__ ((noreturn)) # define TCL_NOINLINE __attribute__ ((noinline)) # if defined(BUILD_tcl) || defined(BUILD_tk) @@ -188,8 +192,7 @@ extern "C" { * MSVCRT. */ -#if (defined(_WIN32) && (defined(_MSC_VER) || (defined(__BORLANDC__) && (__BORLANDC__ >= 0x0550)) || defined(__LCC__) || defined(__WATCOMC__) || (defined(__GNUC__) && defined(__declspec)))) -# define HAVE_DECLSPEC 1 +#ifdef _WIN32 # ifdef STATIC_BUILD # define DLLIMPORT # define DLLEXPORT @@ -327,17 +330,22 @@ typedef long LONG; #ifdef __APPLE__ # ifdef __LP64__ -# undef TCL_WIDE_INT_TYPE # define TCL_WIDE_INT_IS_LONG 1 # define TCL_CFG_DO64BIT 1 # else /* !__LP64__ */ -# define TCL_WIDE_INT_TYPE long long # undef TCL_WIDE_INT_IS_LONG # undef TCL_CFG_DO64BIT # endif /* __LP64__ */ # undef HAVE_STRUCT_STAT64 #endif /* __APPLE__ */ +/* Cross-compiling 32-bit on a 64-bit platform? Then our + * configure script does the wrong thing. Correct that here. + */ +#if defined(__GNUC__) && !defined(_WIN32) && !defined(__LP64__) +# undef TCL_WIDE_INT_IS_LONG +#endif + /* * Define Tcl_WideInt to be a type that is (at least) 64-bits wide, and define * Tcl_WideUInt to be the unsigned variant of that type (assuming that where @@ -353,32 +361,18 @@ typedef long LONG; * * The following invariant should hold for any long value 'longVal': * longVal == Tcl_WideAsLong(Tcl_LongAsWide(longVal)) - * - * Note on converting between Tcl_WideInt and strings. This implementation (in - * tclObj.c) depends on the function - * sprintf(...,"%" TCL_LL_MODIFIER "d",...). */ -#if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG) -# if defined(_WIN32) && (!defined(__USE_MINGW_ANSI_STDIO) || !__USE_MINGW_ANSI_STDIO) -# define TCL_WIDE_INT_TYPE __int64 -# define TCL_LL_MODIFIER "I64" -# if defined(_WIN64) -# define TCL_Z_MODIFIER "I" -# endif -# elif defined(__GNUC__) -# define TCL_Z_MODIFIER "z" -# else /* ! _WIN32 && ! __GNUC__ */ +#if !defined(TCL_WIDE_INT_TYPE) && !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__GNUC__) /* * Don't know what platform it is and configure hasn't discovered what is * going on for us. Try to guess... */ -# include <limits.h> -# if defined(LLONG_MAX) && (LLONG_MAX == LONG_MAX) -# define TCL_WIDE_INT_IS_LONG 1 -# endif -# endif /* _WIN32 */ -#endif /* !TCL_WIDE_INT_TYPE & !TCL_WIDE_INT_IS_LONG */ +# include <limits.h> +# if defined(LLONG_MAX) && (LLONG_MAX == LONG_MAX) +# define TCL_WIDE_INT_IS_LONG 1 +# endif +#endif #ifndef TCL_WIDE_INT_TYPE # define TCL_WIDE_INT_TYPE long long @@ -388,11 +382,17 @@ typedef TCL_WIDE_INT_TYPE Tcl_WideInt; typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; #ifndef TCL_LL_MODIFIER -# define TCL_LL_MODIFIER "ll" +# if defined(_WIN32) && (!defined(__USE_MINGW_ANSI_STDIO) || !__USE_MINGW_ANSI_STDIO) +# define TCL_LL_MODIFIER "I64" +# else +# define TCL_LL_MODIFIER "ll" +# endif #endif /* !TCL_LL_MODIFIER */ #ifndef TCL_Z_MODIFIER # if defined(__GNUC__) && !defined(_WIN32) # define TCL_Z_MODIFIER "z" +# elif defined(_WIN64) +# define TCL_Z_MODIFIER TCL_LL_MODIFIER # else # define TCL_Z_MODIFIER "" # endif @@ -402,10 +402,8 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; #define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val))) #define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val))) -#if defined(_WIN32) -# ifdef __BORLANDC__ - typedef struct stati64 Tcl_StatBuf; -# elif defined(_WIN64) || defined(_USE_64BIT_TIME_T) +#ifdef _WIN32 +# if defined(_WIN64) || defined(_USE_64BIT_TIME_T) typedef struct __stat64 Tcl_StatBuf; # elif (defined(_MSC_VER) && (_MSC_VER < 1400)) || defined(_USE_32BIT_TIME_T) typedef struct _stati64 Tcl_StatBuf; @@ -699,8 +697,8 @@ typedef int (Tcl_MathProc) (ClientData clientData, Tcl_Interp *interp, typedef void (Tcl_NamespaceDeleteProc) (ClientData clientData); typedef int (Tcl_ObjCmdProc) (ClientData clientData, Tcl_Interp *interp, int objc, struct Tcl_Obj *const *objv); -typedef int (Tcl_PackageInitProc) (Tcl_Interp *interp); -typedef int (Tcl_PackageUnloadProc) (Tcl_Interp *interp, int flags); +typedef int (Tcl_LibraryInitProc) (Tcl_Interp *interp); +typedef int (Tcl_LibraryUnloadProc) (Tcl_Interp *interp, int flags); typedef void (Tcl_PanicProc) (const char *format, ...); typedef void (Tcl_TcpAcceptProc) (ClientData callbackData, Tcl_Channel chan, char *address, int port); @@ -719,7 +717,12 @@ typedef void (Tcl_ServiceModeHookProc) (int mode); typedef ClientData (Tcl_InitNotifierProc) (void); typedef void (Tcl_FinalizeNotifierProc) (ClientData clientData); typedef void (Tcl_MainLoopProc) (void); - + +#ifndef TCL_NO_DEPRECATED +# define Tcl_PackageInitProc Tcl_LibraryInitProc +# define Tcl_PackageUnloadProc Tcl_LibraryUnloadProc +#endif + /* *---------------------------------------------------------------------------- * The following structure represents a type of object, which is a particular @@ -956,7 +959,7 @@ typedef struct Tcl_DString { * 64-bit integers). */ -#define TCL_INTEGER_SPACE 24 +#define TCL_INTEGER_SPACE (3*(int)sizeof(Tcl_WideInt)) /* * Flag values passed to Tcl_ConvertElement. @@ -1102,7 +1105,7 @@ typedef struct Tcl_DString { #define TCL_LINK_CHARS 15 #define TCL_LINK_BINARY 16 #define TCL_LINK_READ_ONLY 0x80 - + /* *---------------------------------------------------------------------------- * Forward declarations of Tcl_HashTable and related types. @@ -1444,8 +1447,8 @@ typedef int (Tcl_DriverGetHandleProc) (ClientData instanceData, typedef int (Tcl_DriverFlushProc) (ClientData instanceData); typedef int (Tcl_DriverHandlerProc) (ClientData instanceData, int interestMask); -typedef Tcl_WideInt (Tcl_DriverWideSeekProc) (ClientData instanceData, - Tcl_WideInt offset, int mode, int *errorCodePtr); +typedef long long (Tcl_DriverWideSeekProc) (ClientData instanceData, + long long offset, int mode, int *errorCodePtr); /* * TIP #218, Channel Thread Actions */ @@ -1454,8 +1457,8 @@ typedef void (Tcl_DriverThreadActionProc) (ClientData instanceData, /* * TIP #208, File Truncation (etc.) */ -typedef int (Tcl_DriverTruncateProc) (ClientData instanceData, - Tcl_WideInt length); +typedef int (Tcl_DriverTruncateProc) (void *instanceData, + long long length); /* * struct Tcl_ChannelType: @@ -2382,6 +2385,9 @@ EXTERN const char * Tcl_PkgInitStubsCheck(Tcl_Interp *interp, const char *version, int exact); EXTERN void Tcl_InitSubsystems(void); EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); +#ifndef TCL_NO_DEPRECATED +# define Tcl_StaticPackage Tcl_StaticLibrary +#endif #ifdef _WIN32 EXTERN int TclZipfs_AppHook(int *argc, wchar_t ***argv); #else diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index 4a84255..03655b9 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -6,9 +6,9 @@ * that don't exactly fit are passed up to the next larger size. Blocks * over a certain size are directly allocated from the system. * - * Copyright (c) 1983 Regents of the University of California. - * Copyright (c) 1996-1997 Sun Microsystems, Inc. - * Copyright (c) 1998-1999 by Scriptics Corporation. + * Copyright © 1983 Regents of the University of California. + * Copyright © 1996-1997 Sun Microsystems, Inc. + * Copyright © 1998-1999 Scriptics Corporation. * * Portions contributed by Chris Kingsley, Jack Jansen and Ray Johnson. * @@ -31,7 +31,7 @@ * until Tcl uses config.h properly. */ -#if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__) +#if defined(_MSC_VER) || defined(__MSVCRT__) typedef size_t caddr_t; #endif @@ -94,7 +94,7 @@ union overhead { #define MINBLOCK ((sizeof(union overhead) + (TCL_ALLOCALIGN-1)) & ~(TCL_ALLOCALIGN-1)) #define NBUCKETS (13 - (MINBLOCK >> 4)) -#define MAXMALLOC (1<<(NBUCKETS+2)) +#define MAXMALLOC ((size_t)1 << (NBUCKETS+2)) static union overhead *nextf[NBUCKETS]; /* @@ -583,7 +583,7 @@ TclpRealloc( Tcl_MutexUnlock(allocMutexPtr); return (void *)(overPtr+1); } - maxSize = 1 << (i+3); + maxSize = (size_t)1 << (i+3); expensive = 0; if (numBytes+OVERHEAD > maxSize) { expensive = 1; @@ -656,18 +656,18 @@ mstats( for (j=0, overPtr=nextf[i]; overPtr; overPtr=overPtr->next, j++) { fprintf(stderr, " %u", j); } - totalFree += ((size_t)j) * (1 << (i + 3)); + totalFree += ((size_t)j) * ((size_t)1 << (i + 3)); } fprintf(stderr, "\nused:\t"); for (i = 0; i < NBUCKETS; i++) { fprintf(stderr, " %" TCL_Z_MODIFIER "u", numMallocs[i]); - totalUsed += numMallocs[i] * (1 << (i + 3)); + totalUsed += numMallocs[i] * ((size_t)1 << (i + 3)); } fprintf(stderr, "\n\tTotal small in use: %" TCL_Z_MODIFIER "u, total free: %" TCL_Z_MODIFIER "u\n", totalUsed, totalFree); - fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %" TCL_Z_MODIFIER "u\n", + fprintf(stderr, "\n\tNumber of big (>%" TCL_Z_MODIFIER "u) blocks in use: %" TCL_Z_MODIFIER "u\n", MAXMALLOC, numMallocs[NBUCKETS]); Tcl_MutexUnlock(allocMutexPtr); @@ -748,6 +748,8 @@ TclpRealloc( } #endif /* !USE_TCLALLOC */ +#else +TCL_MAC_EMPTY_FILE(generic_tclAlloc_c) #endif /* !TCL_THREADS */ /* diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 605758b..a20cd1a 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -6,8 +6,8 @@ * This file contains the procedures that convert Tcl Assembly Language (TAL) * to a sequence of bytecode instructions for the Tcl execution engine. * - * Copyright (c) 2010 by Ozgur Dogan Ugurlu. - * Copyright (c) 2010 by Kevin B. Kenny. + * Copyright © 2010 Ozgur Dogan Ugurlu. + * Copyright © 2010 Kevin B. Kenny. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclAsync.c b/generic/tclAsync.c index c432e4f..3a09304 100644 --- a/generic/tclAsync.c +++ b/generic/tclAsync.c @@ -5,8 +5,8 @@ * in a safe way. The code here doesn't actually handle signals, though. * This code is based on proposals made by Mark Diekhans and Don Libes. * - * Copyright (c) 1993 The Regents of the University of California. - * Copyright (c) 1994 Sun Microsystems, Inc. + * Copyright © 1993 The Regents of the University of California. + * Copyright © 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 88e51be..5ca70d4 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -5,13 +5,13 @@ * including interpreter creation and deletion, command creation and * deletion, and command/script execution. * - * Copyright (c) 1987-1994 The Regents of the University of California. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. - * Copyright (c) 1998-1999 by Scriptics Corporation. - * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. - * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> - * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. - * Copyright (c) 2008 Miguel Sofer <msofer@users.sourceforge.net> + * Copyright © 1987-1994 The Regents of the University of California. + * Copyright © 1994-1997 Sun Microsystems, Inc. + * Copyright © 1998-1999 Scriptics Corporation. + * Copyright © 2001, 2002 Kevin B. Kenny. All rights reserved. + * Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net> + * Copyright © 2006-2008 Joe Mistachkin. All rights reserved. + * Copyright © 2008 Miguel Sofer <msofer@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -774,6 +774,10 @@ Tcl_CreateInterp(void) Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS); iPtr->packageUnknown = NULL; +#ifdef _WIN32 +# define getenv(x) _wgetenv(L##x) /* On Windows, use _wgetenv below */ +#endif + /* TIP #268 */ #if (TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE) if (getenv("TCL_PKG_PREFER_LATEST") == NULL) { @@ -1175,6 +1179,7 @@ Tcl_CreateInterp(void) */ Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs); + Tcl_PkgProvideEx(interp, "tcl", TCL_PATCH_LEVEL, &tclStubs); if (TclTommath_Init(interp) != TCL_OK) { Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp))); @@ -3508,6 +3513,8 @@ Tcl_DeleteCommandFromToken( if (cmdPtr->tracePtr != NULL) { CommandTrace *tracePtr; + /* Note that CallCommandTraces() never frees cmdPtr, that's + * done just before Tcl_DeleteCommandFromToken() returns */ CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE); /* @@ -3677,7 +3684,6 @@ CallCommandTraces( } } cmdPtr->flags |= CMD_TRACE_ACTIVE; - cmdPtr->refCount++; result = NULL; active.nextPtr = iPtr->activeCmdTracePtr; @@ -3735,7 +3741,6 @@ CallCommandTraces( */ cmdPtr->flags &= ~CMD_TRACE_ACTIVE; - cmdPtr->refCount--; iPtr->activeCmdTracePtr = active.nextPtr; Tcl_Release(iPtr); return result; @@ -7905,7 +7910,16 @@ ExprAbsFunc( } goto unChanged; } else if (l == WIDE_MIN) { - if (mp_init_i64(&big, l) != MP_OKAY) { + if (sizeof(Tcl_WideInt) > sizeof(int64_t)) { + Tcl_WideUInt ul = -(Tcl_WideUInt)WIDE_MIN; + if (mp_init(&big) != MP_OKAY || mp_unpack(&big, 1, 1, + sizeof(Tcl_WideInt), 0, 0, &ul) != MP_OKAY) { + return TCL_ERROR; + } + if (mp_neg(&big, &big) != MP_OKAY) { + return TCL_ERROR; + } + } else if (mp_init_i64(&big, l) != MP_OKAY) { return TCL_ERROR; } goto tooLarge; diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 8a3541b..396beec 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -4,8 +4,8 @@ * This file contains the implementation of the "binary" Tcl built-in * command and the Tcl binary data object. * - * Copyright (c) 1997 by Sun Microsystems, Inc. - * Copyright (c) 1998-1999 by Scriptics Corporation. + * Copyright © 1997 Sun Microsystems, Inc. + * Copyright © 1998-1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -496,7 +496,7 @@ TclGetBytesFromObj( /* *---------------------------------------------------------------------- * - * Tcl_GetByteArrayFromObj -- + * Tcl_GetByteArrayFromObj/TclGetByteArrayFromObj -- * * Attempt to get the array of bytes from the Tcl object. If the object * is not already a ByteArray object, an attempt will be made to convert @@ -511,6 +511,7 @@ TclGetBytesFromObj( *---------------------------------------------------------------------- */ +#undef Tcl_GetByteArrayFromObj unsigned char * Tcl_GetByteArrayFromObj( Tcl_Obj *objPtr, /* The ByteArray object. */ @@ -533,6 +534,35 @@ Tcl_GetByteArrayFromObj( if (lengthPtr != NULL) { *lengthPtr = baPtr->used; } + return (unsigned char *) baPtr->bytes; +} + +unsigned char * +TclGetByteArrayFromObj( + Tcl_Obj *objPtr, /* The ByteArray object. */ + size_t *lengthPtr) /* If non-NULL, filled with length of the + * array of bytes in the ByteArray object. */ +{ + ByteArray *baPtr; + const Tcl_ObjIntRep *irPtr; + unsigned char *result = TclGetBytesFromObj(NULL, objPtr, (int *)NULL); + + if (result) { + return result; + } + + irPtr = TclFetchIntRep(objPtr, &tclByteArrayType); + assert(irPtr != NULL); + + baPtr = GET_BYTEARRAY(irPtr); + + if (lengthPtr != NULL) { +#if TCL_MAJOR_VERSION > 8 + *lengthPtr = baPtr->used; +#else + *lengthPtr = ((size_t)(unsigned)(baPtr->used + 1)) - 1; +#endif + } return baPtr->bytes; } diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index f761521..6cf3c4c 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -5,9 +5,9 @@ * problems involving overwritten, double freeing memory and loss of * memory. * - * Copyright (c) 1991-1994 The Regents of the University of California. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. - * Copyright (c) 1998-1999 by Scriptics Corporation. + * Copyright © 1991-1994 The Regents of the University of California. + * Copyright © 1994-1997 Sun Microsystems, Inc. + * Copyright © 1998-1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclClock.c b/generic/tclClock.c index e5608b9..90a998d 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -5,9 +5,9 @@ * the time and date facilities of TclX, by Mark Diekhans and Karl * Lehenbauer. * - * Copyright (c) 1991-1995 Karl Lehenbauer & Mark Diekhans. - * Copyright (c) 1995 Sun Microsystems, Inc. - * Copyright (c) 2004 by Kevin B. Kenny. All rights reserved. + * Copyright © 1991-1995 Karl Lehenbauer & Mark Diekhans. + * Copyright © 1995 Sun Microsystems, Inc. + * Copyright © 2004 Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -1650,19 +1650,37 @@ ClockGetenvObjCmd( int objc, Tcl_Obj *const objv[]) { +#ifdef _WIN32 + const WCHAR *varName; + const WCHAR *varValue; + Tcl_DString ds; +#else const char *varName; const char *varValue; +#endif if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "name"); return TCL_ERROR; } +#ifdef _WIN32 + Tcl_DStringInit(&ds); + varName = Tcl_UtfToWCharDString(TclGetString(objv[1]), -1, &ds); + varValue = _wgetenv(varName); + if (varValue == NULL) { + Tcl_DStringFree(&ds); + } else { + Tcl_DStringSetLength(&ds, 0); + Tcl_WCharToUtfDString(varValue, -1, &ds); + Tcl_DStringResult(interp, &ds); + } +#else varName = TclGetString(objv[1]); varValue = getenv(varName); - if (varValue == NULL) { - varValue = ""; + if (varValue != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj(varValue, -1)); } - Tcl_SetObjResult(interp, Tcl_NewStringObj(varValue, -1)); +#endif return TCL_OK; } @@ -2021,26 +2039,52 @@ ClockSecondsObjCmd( *---------------------------------------------------------------------- */ +#ifdef _WIN32 +#define getenv(x) _wgetenv(L##x) +#else +#define WCHAR char +#define wcslen strlen +#define wcscmp strcmp +#define wcscpy strcpy +#endif + static void TzsetIfNecessary(void) { - static char* tzWas = (char *)INT2PTR(-1); /* Previous value of TZ, protected by - * clockMutex. */ - const char *tzIsNow; /* Current value of TZ */ + static WCHAR* tzWas = (WCHAR *)INT2PTR(-1); /* Previous value of TZ, protected by + * clockMutex. */ + static long tzLastRefresh = 0; /* Used for latency before next refresh */ + static size_t tzEnvEpoch = 0; /* Last env epoch, for faster signaling, + that TZ changed via TCL */ + const WCHAR *tzIsNow; /* Current value of TZ */ + + /* + * Prevent performance regression on some platforms by resolving of system time zone: + * small latency for check whether environment was changed (once per second) + * no latency if environment was changed with tcl-env (compare both epoch values) + */ + Tcl_Time now; + Tcl_GetTime(&now); + if (now.sec == tzLastRefresh && tzEnvEpoch == TclEnvEpoch) { + return; + } + + tzEnvEpoch = TclEnvEpoch; + tzLastRefresh = now.sec; Tcl_MutexLock(&clockMutex); tzIsNow = getenv("TZ"); - if (tzIsNow != NULL && (tzWas == NULL || tzWas == INT2PTR(-1) - || strcmp(tzIsNow, tzWas) != 0)) { + if (tzIsNow != NULL && (tzWas == NULL || tzWas == (WCHAR *)INT2PTR(-1) + || wcscmp(tzIsNow, tzWas) != 0)) { tzset(); - if (tzWas != NULL && tzWas != INT2PTR(-1)) { + if (tzWas != NULL && tzWas != (WCHAR *)INT2PTR(-1)) { ckfree(tzWas); } - tzWas = (char *)ckalloc(strlen(tzIsNow) + 1); - strcpy(tzWas, tzIsNow); + tzWas = (WCHAR *)ckalloc(sizeof(WCHAR) * (wcslen(tzIsNow) + 1)); + wcscpy(tzWas, tzIsNow); } else if (tzIsNow == NULL && tzWas != NULL) { tzset(); - if (tzWas != INT2PTR(-1)) ckfree(tzWas); + if (tzWas != (WCHAR *)INT2PTR(-1)) ckfree(tzWas); tzWas = NULL; } Tcl_MutexUnlock(&clockMutex); diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 7973154..c09ad95 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -4,8 +4,8 @@ * This file contains the top-level command routines for most of the Tcl * built-in commands whose names begin with the letters A to H. * - * Copyright (c) 1987-1993 The Regents of the University of California. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright © 1987-1993 The Regents of the University of California. + * Copyright © 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index da8dc65..d3588aa 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -6,12 +6,12 @@ * contains only commands in the generic core (i.e., those that don't * depend much upon UNIX facilities). * - * Copyright (c) 1987-1993 The Regents of the University of California. - * Copyright (c) 1993-1997 Lucent Technologies. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. - * Copyright (c) 1998-1999 by Scriptics Corporation. - * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. - * Copyright (c) 2005 Donal K. Fellows. + * Copyright © 1987-1993 The Regents of the University of California. + * Copyright © 1993-1997 Lucent Technologies. + * Copyright © 1994-1997 Sun Microsystems, Inc. + * Copyright © 1998-1999 Scriptics Corporation. + * Copyright © 2001 Kevin B. Kenny. All rights reserved. + * Copyright © 2005 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -1700,7 +1700,7 @@ InfoLoadedCmd( } else { /* Get pkgs just in specified interp. */ packageName = TclGetString(objv[2]); } - return TclGetLoadedPackagesEx(interp, interpName, packageName); + return TclGetLoadedLibraries(interp, interpName, packageName); } /* diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 0764c60..d020a93 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -6,11 +6,11 @@ * contains only commands in the generic core (i.e. those that don't * depend much upon UNIX facilities). * - * Copyright (c) 1987-1993 The Regents of the University of California. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. - * Copyright (c) 1998-2000 Scriptics Corporation. - * Copyright (c) 2002 ActiveState Corporation. - * Copyright (c) 2003-2009 Donal K. Fellows. + * Copyright © 1987-1993 The Regents of the University of California. + * Copyright © 1994-1997 Sun Microsystems, Inc. + * Copyright © 1998-2000 Scriptics Corporation. + * Copyright © 2002 ActiveState Corporation. + * Copyright © 2003-2009 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -36,31 +36,31 @@ static int UniCharIsHexDigit(int character); */ const char tclDefaultTrimSet[] = - "\x09\x0a\x0b\x0c\x0d " /* ASCII */ - "\xc0\x80" /* nul (U+0000) */ - "\xc2\x85" /* next line (U+0085) */ - "\xc2\xa0" /* non-breaking space (U+00a0) */ - "\xe1\x9a\x80" /* ogham space mark (U+1680) */ - "\xe1\xa0\x8e" /* mongolian vowel separator (U+180e) */ - "\xe2\x80\x80" /* en quad (U+2000) */ - "\xe2\x80\x81" /* em quad (U+2001) */ - "\xe2\x80\x82" /* en space (U+2002) */ - "\xe2\x80\x83" /* em space (U+2003) */ - "\xe2\x80\x84" /* three-per-em space (U+2004) */ - "\xe2\x80\x85" /* four-per-em space (U+2005) */ - "\xe2\x80\x86" /* six-per-em space (U+2006) */ - "\xe2\x80\x87" /* figure space (U+2007) */ - "\xe2\x80\x88" /* punctuation space (U+2008) */ - "\xe2\x80\x89" /* thin space (U+2009) */ - "\xe2\x80\x8a" /* hair space (U+200a) */ - "\xe2\x80\x8b" /* zero width space (U+200b) */ - "\xe2\x80\xa8" /* line separator (U+2028) */ - "\xe2\x80\xa9" /* paragraph separator (U+2029) */ - "\xe2\x80\xaf" /* narrow no-break space (U+202f) */ - "\xe2\x81\x9f" /* medium mathematical space (U+205f) */ - "\xe2\x81\xa0" /* word joiner (U+2060) */ - "\xe3\x80\x80" /* ideographic space (U+3000) */ - "\xef\xbb\xbf" /* zero width no-break space (U+feff) */ + "\x09\x0A\x0B\x0C\x0D " /* ASCII */ + "\xC0\x80" /* nul (U+0000) */ + "\xC2\x85" /* next line (U+0085) */ + "\xC2\xA0" /* non-breaking space (U+00a0) */ + "\xE1\x9A\x80" /* ogham space mark (U+1680) */ + "\xE1\xA0\x8E" /* mongolian vowel separator (U+180e) */ + "\xE2\x80\x80" /* en quad (U+2000) */ + "\xE2\x80\x81" /* em quad (U+2001) */ + "\xE2\x80\x82" /* en space (U+2002) */ + "\xE2\x80\x83" /* em space (U+2003) */ + "\xE2\x80\x84" /* three-per-em space (U+2004) */ + "\xE2\x80\x85" /* four-per-em space (U+2005) */ + "\xE2\x80\x86" /* six-per-em space (U+2006) */ + "\xE2\x80\x87" /* figure space (U+2007) */ + "\xE2\x80\x88" /* punctuation space (U+2008) */ + "\xE2\x80\x89" /* thin space (U+2009) */ + "\xE2\x80\x8A" /* hair space (U+200a) */ + "\xE2\x80\x8B" /* zero width space (U+200b) */ + "\xE2\x80\xA8" /* line separator (U+2028) */ + "\xE2\x80\xA9" /* paragraph separator (U+2029) */ + "\xE2\x80\xAF" /* narrow no-break space (U+202f) */ + "\xE2\x81\x9F" /* medium mathematical space (U+205f) */ + "\xE2\x81\xA0" /* word joiner (U+2060) */ + "\xE3\x80\x80" /* ideographic space (U+3000) */ + "\xEF\xBB\xBF" /* zero width no-break space (U+feff) */ ; /* @@ -4148,14 +4148,14 @@ Tcl_TimeRateObjCmd( Tcl_Obj *objPtr; int result, i; Tcl_Obj *calibrate = NULL, *direct = NULL; - TclWideMUInt count = 0; /* Holds repetition count */ + Tcl_WideUInt count = 0; /* Holds repetition count */ Tcl_WideInt maxms = WIDE_MIN; /* Maximal running time (in milliseconds) */ - TclWideMUInt maxcnt = WIDE_MAX; + Tcl_WideUInt maxcnt = WIDE_MAX; /* Maximal count of iterations. */ - TclWideMUInt threshold = 1; /* Current threshold for check time (faster + Tcl_WideUInt threshold = 1; /* Current threshold for check time (faster * repeat count without time check) */ - TclWideMUInt maxIterTm = 1; /* Max time of some iteration as max + Tcl_WideUInt maxIterTm = 1; /* Max time of some iteration as max * threshold, additionally avoiding divide to * zero (i.e., never < 1) */ unsigned short factor = 50; /* Factor (4..50) limiting threshold to avoid @@ -4529,13 +4529,13 @@ Tcl_TimeRateObjCmd( { Tcl_Obj *objarr[8], **objs = objarr; - TclWideMUInt usec, val; + Tcl_WideUInt usec, val; int digits; /* * Absolute execution time in microseconds or in wide clicks. */ - usec = (TclWideMUInt)(middle - start); + usec = (Tcl_WideUInt)(middle - start); #ifdef TCL_WIDE_CLICKS /* @@ -4565,7 +4565,7 @@ Tcl_TimeRateObjCmd( * Estimate the time of overhead (microsecs). */ - TclWideMUInt curOverhead = overhead * count; + Tcl_WideUInt curOverhead = overhead * count; if (usec > curOverhead) { usec -= curOverhead; diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index beee208..13589b2 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -4,10 +4,10 @@ * This file contains compilation procedures that compile various Tcl * commands into a sequence of instructions ("bytecodes"). * - * Copyright (c) 1997-1998 Sun Microsystems, Inc. - * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. - * Copyright (c) 2002 ActiveState Corporation. - * Copyright (c) 2004-2013 by Donal K. Fellows. + * Copyright © 1997-1998 Sun Microsystems, Inc. + * Copyright © 2001 Kevin B. Kenny. All rights reserved. + * Copyright © 2002 ActiveState Corporation. + * Copyright © 2004-2013 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index cebd8f5..da557a4 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -5,10 +5,10 @@ * commands (beginning with the letters 'g' through 'r') into a sequence * of instructions ("bytecodes"). * - * Copyright (c) 1997-1998 Sun Microsystems, Inc. - * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. - * Copyright (c) 2002 ActiveState Corporation. - * Copyright (c) 2004-2013 by Donal K. Fellows. + * Copyright © 1997-1998 Sun Microsystems, Inc. + * Copyright © 2001 Kevin B. Kenny. All rights reserved. + * Copyright © 2002 ActiveState Corporation. + * Copyright © 2004-2013 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 26698a8..0bac52b 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -6,10 +6,10 @@ * [upvar] and [variable]) into a sequence of instructions ("bytecodes"). * Also includes the operator command compilers. * - * Copyright (c) 1997-1998 Sun Microsystems, Inc. - * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. - * Copyright (c) 2002 ActiveState Corporation. - * Copyright (c) 2004-2010 by Donal K. Fellows. + * Copyright © 1997-1998 Sun Microsystems, Inc. + * Copyright © 2001 Kevin B. Kenny. All rights reserved. + * Copyright © 2002 ActiveState Corporation. + * Copyright © 2004-2010 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index fa15fba..03aebe3 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2145,7 +2145,7 @@ ParseLexeme( */ if (!TclIsBareword(*start) || *start == '_') { - if (TclUCS4Complete(start, numBytes)) { + if (Tcl_UtfCharComplete(start, numBytes)) { scanned = TclUtfToUCS4(start, &ch); } else { char utfBytes[8]; diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 2ab92da..6ffb3dd 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -5,8 +5,8 @@ * commands (like quoted strings or nested sub-commands) into a sequence * of instructions ("bytecodes"). * - * Copyright (c) 1996-1998 Sun Microsystems, Inc. - * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. + * Copyright © 1996-1998 Sun Microsystems, Inc. + * Copyright © 2001 Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclConfig.c b/generic/tclConfig.c index 3bdcd38..a145bac 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -4,7 +4,7 @@ * This file provides the facilities which allow Tcl and other packages * to embed configuration information into their binary libraries. * - * Copyright (c) 2002 Andreas Kupries <andreas_kupries@users.sourceforge.net> + * Copyright © 2002 Andreas Kupries <andreas_kupries@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -178,7 +178,7 @@ Tcl_RegisterConfig( * QueryConfigObjCmd -- * * Implementation of "::<package>::pkgconfig", the command to query - * configuration information embedded into a binary library. + * configuration information embedded into a library. * * Results: * A standard tcl result. diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 9ea6838..95824bb 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -749,10 +749,10 @@ EXTERN int Tcl_SplitList(Tcl_Interp *interp, EXTERN void Tcl_SplitPath(const char *path, int *argcPtr, const char ***argvPtr); /* 244 */ -EXTERN void Tcl_StaticPackage(Tcl_Interp *interp, - const char *pkgName, - Tcl_PackageInitProc *initProc, - Tcl_PackageInitProc *safeInitProc); +EXTERN void Tcl_StaticLibrary(Tcl_Interp *interp, + const char *prefix, + Tcl_LibraryInitProc *initProc, + Tcl_LibraryInitProc *safeInitProc); /* 245 */ TCL_DEPRECATED("No longer in use, changed to macro") int Tcl_StringMatch(const char *str, const char *pattern); @@ -999,7 +999,7 @@ EXTERN int Tcl_UniCharToUtf(int ch, char *buf); /* 325 */ EXTERN const char * Tcl_UtfAtIndex(const char *src, int index); /* 326 */ -EXTERN int Tcl_UtfCharComplete(const char *src, int length); +EXTERN int TclUtfCharComplete(const char *src, int length); /* 327 */ EXTERN int Tcl_UtfBackslash(const char *src, int *readPtr, char *dst); @@ -1008,9 +1008,9 @@ EXTERN const char * Tcl_UtfFindFirst(const char *src, int ch); /* 329 */ EXTERN const char * Tcl_UtfFindLast(const char *src, int ch); /* 330 */ -EXTERN const char * Tcl_UtfNext(const char *src); +EXTERN const char * TclUtfNext(const char *src); /* 331 */ -EXTERN const char * Tcl_UtfPrev(const char *src, const char *start); +EXTERN const char * TclUtfPrev(const char *src, const char *start); /* 332 */ EXTERN int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, @@ -1338,8 +1338,8 @@ EXTERN int Tcl_FSDeleteFile(Tcl_Obj *pathPtr); /* 444 */ EXTERN int Tcl_FSLoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *sym1, const char *sym2, - Tcl_PackageInitProc **proc1Ptr, - Tcl_PackageInitProc **proc2Ptr, + Tcl_LibraryInitProc **proc1Ptr, + Tcl_LibraryInitProc **proc2Ptr, Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr); /* 445 */ @@ -1464,10 +1464,10 @@ EXTERN void Tcl_SetWideIntObj(Tcl_Obj *objPtr, /* 490 */ EXTERN Tcl_StatBuf * Tcl_AllocStatBuf(void); /* 491 */ -EXTERN Tcl_WideInt Tcl_Seek(Tcl_Channel chan, Tcl_WideInt offset, +EXTERN long long Tcl_Seek(Tcl_Channel chan, long long offset, int mode); /* 492 */ -EXTERN Tcl_WideInt Tcl_Tell(Tcl_Channel chan); +EXTERN long long Tcl_Tell(Tcl_Channel chan); /* 493 */ EXTERN Tcl_DriverWideSeekProc * Tcl_ChannelWideSeekProc( const Tcl_ChannelType *chanTypePtr); @@ -1665,7 +1665,7 @@ EXTERN int Tcl_TakeBignumFromObj(Tcl_Interp *interp, Tcl_Obj *obj, void *value); /* 560 */ EXTERN int Tcl_TruncateChannel(Tcl_Channel chan, - Tcl_WideInt length); + long long length); /* 561 */ EXTERN Tcl_DriverTruncateProc * Tcl_ChannelTruncateProc( const Tcl_ChannelType *chanTypePtr); @@ -1771,16 +1771,16 @@ EXTERN int Tcl_GetGroupIdFromStat(const Tcl_StatBuf *statPtr); /* 595 */ EXTERN int Tcl_GetDeviceTypeFromStat(const Tcl_StatBuf *statPtr); /* 596 */ -EXTERN Tcl_WideInt Tcl_GetAccessTimeFromStat(const Tcl_StatBuf *statPtr); +EXTERN long long Tcl_GetAccessTimeFromStat(const Tcl_StatBuf *statPtr); /* 597 */ -EXTERN Tcl_WideInt Tcl_GetModificationTimeFromStat( +EXTERN long long Tcl_GetModificationTimeFromStat( const Tcl_StatBuf *statPtr); /* 598 */ -EXTERN Tcl_WideInt Tcl_GetChangeTimeFromStat(const Tcl_StatBuf *statPtr); +EXTERN long long Tcl_GetChangeTimeFromStat(const Tcl_StatBuf *statPtr); /* 599 */ -EXTERN Tcl_WideUInt Tcl_GetSizeFromStat(const Tcl_StatBuf *statPtr); +EXTERN unsigned long long Tcl_GetSizeFromStat(const Tcl_StatBuf *statPtr); /* 600 */ -EXTERN Tcl_WideUInt Tcl_GetBlocksFromStat(const Tcl_StatBuf *statPtr); +EXTERN unsigned long long Tcl_GetBlocksFromStat(const Tcl_StatBuf *statPtr); /* 601 */ EXTERN unsigned Tcl_GetBlockSizeFromStat(const Tcl_StatBuf *statPtr); /* 602 */ @@ -1920,6 +1920,23 @@ EXTERN char * Tcl_UniCharToUtfDString(const int *uniStr, /* 648 */ EXTERN int * Tcl_UtfToUniCharDString(const char *src, int length, Tcl_DString *dsPtr); +/* Slot 649 is reserved */ +/* Slot 650 is reserved */ +/* 651 */ +EXTERN char * TclGetStringFromObj(Tcl_Obj *objPtr, + size_t *lengthPtr); +/* 652 */ +EXTERN Tcl_UniChar * TclGetUnicodeFromObj(Tcl_Obj *objPtr, + size_t *lengthPtr); +/* 653 */ +EXTERN unsigned char * TclGetByteArrayFromObj(Tcl_Obj *objPtr, + size_t *lengthPtr); +/* 654 */ +EXTERN int Tcl_UtfCharComplete(const char *src, int length); +/* 655 */ +EXTERN const char * Tcl_UtfNext(const char *src); +/* 656 */ +EXTERN const char * Tcl_UtfPrev(const char *src, const char *start); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2199,7 +2216,7 @@ typedef struct TclStubs { void (*tcl_SourceRCFile) (Tcl_Interp *interp); /* 241 */ int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, int *argcPtr, const char ***argvPtr); /* 242 */ void (*tcl_SplitPath) (const char *path, int *argcPtr, const char ***argvPtr); /* 243 */ - TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") void (*tcl_StaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 244 */ + TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") void (*tcl_StaticLibrary) (Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc); /* 244 */ TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_StringMatch) (const char *str, const char *pattern); /* 245 */ TCL_DEPRECATED_API("") int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */ TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 247 */ @@ -2281,12 +2298,12 @@ typedef struct TclStubs { int (*tcl_UniCharToUpper) (int ch); /* 323 */ int (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */ const char * (*tcl_UtfAtIndex) (const char *src, int index); /* 325 */ - int (*tcl_UtfCharComplete) (const char *src, int length); /* 326 */ + int (*tclUtfCharComplete) (const char *src, int length); /* 326 */ int (*tcl_UtfBackslash) (const char *src, int *readPtr, char *dst); /* 327 */ const char * (*tcl_UtfFindFirst) (const char *src, int ch); /* 328 */ const char * (*tcl_UtfFindLast) (const char *src, int ch); /* 329 */ - const char * (*tcl_UtfNext) (const char *src); /* 330 */ - const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 331 */ + const char * (*tclUtfNext) (const char *src); /* 330 */ + const char * (*tclUtfPrev) (const char *src, const char *start); /* 331 */ int (*tcl_UtfToExternal) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 332 */ char * (*tcl_UtfToExternalDString) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr); /* 333 */ int (*tcl_UtfToLower) (char *src); /* 334 */ @@ -2399,7 +2416,7 @@ typedef struct TclStubs { int (*tcl_FSCopyDirectory) (Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr); /* 441 */ int (*tcl_FSCreateDirectory) (Tcl_Obj *pathPtr); /* 442 */ int (*tcl_FSDeleteFile) (Tcl_Obj *pathPtr); /* 443 */ - int (*tcl_FSLoadFile) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *sym1, const char *sym2, Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **proc2Ptr, Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr); /* 444 */ + int (*tcl_FSLoadFile) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *sym1, const char *sym2, Tcl_LibraryInitProc **proc1Ptr, Tcl_LibraryInitProc **proc2Ptr, Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr); /* 444 */ int (*tcl_FSMatchInDirectory) (Tcl_Interp *interp, Tcl_Obj *result, Tcl_Obj *pathPtr, const char *pattern, Tcl_GlobTypeData *types); /* 445 */ Tcl_Obj * (*tcl_FSLink) (Tcl_Obj *pathPtr, Tcl_Obj *toPtr, int linkAction); /* 446 */ int (*tcl_FSRemoveDirectory) (Tcl_Obj *pathPtr, int recursive, Tcl_Obj **errorPtr); /* 447 */ @@ -2446,8 +2463,8 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_NewWideIntObj) (Tcl_WideInt wideValue); /* 488 */ void (*tcl_SetWideIntObj) (Tcl_Obj *objPtr, Tcl_WideInt wideValue); /* 489 */ Tcl_StatBuf * (*tcl_AllocStatBuf) (void); /* 490 */ - Tcl_WideInt (*tcl_Seek) (Tcl_Channel chan, Tcl_WideInt offset, int mode); /* 491 */ - Tcl_WideInt (*tcl_Tell) (Tcl_Channel chan); /* 492 */ + long long (*tcl_Seek) (Tcl_Channel chan, long long offset, int mode); /* 491 */ + long long (*tcl_Tell) (Tcl_Channel chan); /* 492 */ Tcl_DriverWideSeekProc * (*tcl_ChannelWideSeekProc) (const Tcl_ChannelType *chanTypePtr); /* 493 */ int (*tcl_DictObjPut) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr, Tcl_Obj *valuePtr); /* 494 */ int (*tcl_DictObjGet) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr, Tcl_Obj **valuePtrPtr); /* 495 */ @@ -2515,7 +2532,7 @@ typedef struct TclStubs { void (*tcl_SetBignumObj) (Tcl_Obj *obj, void *value); /* 557 */ int (*tcl_GetBignumFromObj) (Tcl_Interp *interp, Tcl_Obj *obj, void *value); /* 558 */ int (*tcl_TakeBignumFromObj) (Tcl_Interp *interp, Tcl_Obj *obj, void *value); /* 559 */ - int (*tcl_TruncateChannel) (Tcl_Channel chan, Tcl_WideInt length); /* 560 */ + int (*tcl_TruncateChannel) (Tcl_Channel chan, long long length); /* 560 */ Tcl_DriverTruncateProc * (*tcl_ChannelTruncateProc) (const Tcl_ChannelType *chanTypePtr); /* 561 */ void (*tcl_SetChannelErrorInterp) (Tcl_Interp *interp, Tcl_Obj *msg); /* 562 */ void (*tcl_GetChannelErrorInterp) (Tcl_Interp *interp, Tcl_Obj **msg); /* 563 */ @@ -2551,11 +2568,11 @@ typedef struct TclStubs { int (*tcl_GetUserIdFromStat) (const Tcl_StatBuf *statPtr); /* 593 */ int (*tcl_GetGroupIdFromStat) (const Tcl_StatBuf *statPtr); /* 594 */ int (*tcl_GetDeviceTypeFromStat) (const Tcl_StatBuf *statPtr); /* 595 */ - Tcl_WideInt (*tcl_GetAccessTimeFromStat) (const Tcl_StatBuf *statPtr); /* 596 */ - Tcl_WideInt (*tcl_GetModificationTimeFromStat) (const Tcl_StatBuf *statPtr); /* 597 */ - Tcl_WideInt (*tcl_GetChangeTimeFromStat) (const Tcl_StatBuf *statPtr); /* 598 */ - Tcl_WideUInt (*tcl_GetSizeFromStat) (const Tcl_StatBuf *statPtr); /* 599 */ - Tcl_WideUInt (*tcl_GetBlocksFromStat) (const Tcl_StatBuf *statPtr); /* 600 */ + long long (*tcl_GetAccessTimeFromStat) (const Tcl_StatBuf *statPtr); /* 596 */ + long long (*tcl_GetModificationTimeFromStat) (const Tcl_StatBuf *statPtr); /* 597 */ + long long (*tcl_GetChangeTimeFromStat) (const Tcl_StatBuf *statPtr); /* 598 */ + unsigned long long (*tcl_GetSizeFromStat) (const Tcl_StatBuf *statPtr); /* 599 */ + unsigned long long (*tcl_GetBlocksFromStat) (const Tcl_StatBuf *statPtr); /* 600 */ unsigned (*tcl_GetBlockSizeFromStat) (const Tcl_StatBuf *statPtr); /* 601 */ int (*tcl_SetEnsembleParameterList) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj *paramList); /* 602 */ int (*tcl_GetEnsembleParameterList) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **paramListPtr); /* 603 */ @@ -2604,6 +2621,14 @@ typedef struct TclStubs { int (*tcl_UtfToUniChar) (const char *src, int *chPtr); /* 646 */ char * (*tcl_UniCharToUtfDString) (const int *uniStr, int uniLength, Tcl_DString *dsPtr); /* 647 */ int * (*tcl_UtfToUniCharDString) (const char *src, int length, Tcl_DString *dsPtr); /* 648 */ + void (*reserved649)(void); + void (*reserved650)(void); + char * (*tclGetStringFromObj) (Tcl_Obj *objPtr, size_t *lengthPtr); /* 651 */ + Tcl_UniChar * (*tclGetUnicodeFromObj) (Tcl_Obj *objPtr, size_t *lengthPtr); /* 652 */ + unsigned char * (*tclGetByteArrayFromObj) (Tcl_Obj *objPtr, size_t *lengthPtr); /* 653 */ + int (*tcl_UtfCharComplete) (const char *src, int length); /* 654 */ + const char * (*tcl_UtfNext) (const char *src); /* 655 */ + const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 656 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3123,8 +3148,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_SplitList) /* 242 */ #define Tcl_SplitPath \ (tclStubsPtr->tcl_SplitPath) /* 243 */ -#define Tcl_StaticPackage \ - (tclStubsPtr->tcl_StaticPackage) /* 244 */ +#define Tcl_StaticLibrary \ + (tclStubsPtr->tcl_StaticLibrary) /* 244 */ #define Tcl_StringMatch \ (tclStubsPtr->tcl_StringMatch) /* 245 */ #define Tcl_TellOld \ @@ -3286,18 +3311,18 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UniCharToUtf) /* 324 */ #define Tcl_UtfAtIndex \ (tclStubsPtr->tcl_UtfAtIndex) /* 325 */ -#define Tcl_UtfCharComplete \ - (tclStubsPtr->tcl_UtfCharComplete) /* 326 */ +#define TclUtfCharComplete \ + (tclStubsPtr->tclUtfCharComplete) /* 326 */ #define Tcl_UtfBackslash \ (tclStubsPtr->tcl_UtfBackslash) /* 327 */ #define Tcl_UtfFindFirst \ (tclStubsPtr->tcl_UtfFindFirst) /* 328 */ #define Tcl_UtfFindLast \ (tclStubsPtr->tcl_UtfFindLast) /* 329 */ -#define Tcl_UtfNext \ - (tclStubsPtr->tcl_UtfNext) /* 330 */ -#define Tcl_UtfPrev \ - (tclStubsPtr->tcl_UtfPrev) /* 331 */ +#define TclUtfNext \ + (tclStubsPtr->tclUtfNext) /* 330 */ +#define TclUtfPrev \ + (tclStubsPtr->tclUtfPrev) /* 331 */ #define Tcl_UtfToExternal \ (tclStubsPtr->tcl_UtfToExternal) /* 332 */ #define Tcl_UtfToExternalDString \ @@ -3932,11 +3957,26 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UniCharToUtfDString) /* 647 */ #define Tcl_UtfToUniCharDString \ (tclStubsPtr->tcl_UtfToUniCharDString) /* 648 */ +/* Slot 649 is reserved */ +/* Slot 650 is reserved */ +#define TclGetStringFromObj \ + (tclStubsPtr->tclGetStringFromObj) /* 651 */ +#define TclGetUnicodeFromObj \ + (tclStubsPtr->tclGetUnicodeFromObj) /* 652 */ +#define TclGetByteArrayFromObj \ + (tclStubsPtr->tclGetByteArrayFromObj) /* 653 */ +#define Tcl_UtfCharComplete \ + (tclStubsPtr->tcl_UtfCharComplete) /* 654 */ +#define Tcl_UtfNext \ + (tclStubsPtr->tcl_UtfNext) /* 655 */ +#define Tcl_UtfPrev \ + (tclStubsPtr->tcl_UtfPrev) /* 656 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ +#undef TclUnusedStubEntry #if defined(USE_TCL_STUBS) # undef Tcl_CreateInterp # undef Tcl_FindExecutable @@ -3945,7 +3985,7 @@ extern const TclStubs *tclStubsPtr; # undef Tcl_SetPanicProc # undef Tcl_SetExitProc # undef Tcl_ObjSetVar2 -# undef Tcl_StaticPackage +# undef Tcl_StaticLibrary # define Tcl_CreateInterp() (tclStubsPtr->tcl_CreateInterp()) # define Tcl_GetStringResult(interp) (tclStubsPtr->tcl_GetStringResult(interp)) # define Tcl_Init(interp) (tclStubsPtr->tcl_Init(interp)) @@ -4114,6 +4154,37 @@ extern const TclStubs *tclStubsPtr; # endif #endif +#undef Tcl_GetString +#undef Tcl_GetUnicode +#define Tcl_GetString(objPtr) \ + Tcl_GetStringFromObj(objPtr, (int *)NULL) +#define Tcl_GetUnicode(objPtr) \ + Tcl_GetUnicodeFromObj(objPtr, (int *)NULL) +#ifdef TCL_NO_DEPRECATED +#undef Tcl_GetStringFromObj +#undef Tcl_GetUnicodeFromObj +#undef Tcl_GetByteArrayFromObj +#endif +#if defined(USE_TCL_STUBS) +#ifdef TCL_NO_DEPRECATED +#define Tcl_GetStringFromObj(objPtr, sizePtr) \ + (sizeof(*sizePtr) <= sizeof(int) ? tclStubsPtr->tcl_GetStringFromObj(objPtr, (int *)sizePtr) : tclStubsPtr->tclGetStringFromObj(objPtr, (size_t *)sizePtr)) +#define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ + (sizeof(*sizePtr) <= sizeof(int) ? tclStubsPtr->tcl_GetByteArrayFromObj(objPtr, (int *)sizePtr) : tclStubsPtr->tclGetByteArrayFromObj(objPtr, (size_t *)sizePtr)) +#define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ + (sizeof(*sizePtr) <= sizeof(int) ? tclStubsPtr->tcl_GetUnicodeFromObj(objPtr, (int *)sizePtr) : tclStubsPtr->tclGetUnicodeFromObj(objPtr, (size_t *)sizePtr)) +#endif +#else +#ifdef TCL_NO_DEPRECATED +#define Tcl_GetStringFromObj(objPtr, sizePtr) \ + (sizeof(*sizePtr) <= sizeof(int) ? (Tcl_GetStringFromObj)(objPtr, (int *)sizePtr) : (TclGetStringFromObj)(objPtr, (size_t *)sizePtr)) +#define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ + (sizeof(*sizePtr) <= sizeof(int) ? (Tcl_GetByteArrayFromObj)(objPtr, (int *)sizePtr) : TclGetByteArrayFromObj(objPtr, (size_t *)sizePtr)) +#define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ + (sizeof(*sizePtr) <= sizeof(int) ? (Tcl_GetUnicodeFromObj)(objPtr, (int *)sizePtr) : TclGetUnicodeFromObj(objPtr, (size_t *)sizePtr)) +#endif +#endif + #undef Tcl_NewLongObj #define Tcl_NewLongObj(value) Tcl_NewWideIntObj((long)(value)) #undef Tcl_NewIntObj @@ -4124,8 +4195,6 @@ extern const TclStubs *tclStubsPtr; #define Tcl_SetIntObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (int)(value)) #undef Tcl_SetLongObj #define Tcl_SetLongObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (long)(value)) -#undef Tcl_GetUnicode -#define Tcl_GetUnicode(objPtr) Tcl_GetUnicodeFromObj((objPtr), NULL) #undef Tcl_BackgroundError #define Tcl_BackgroundError(interp) Tcl_BackgroundException((interp), TCL_ERROR) #undef Tcl_StringMatch @@ -4177,10 +4246,16 @@ extern const TclStubs *tclStubsPtr; #define Tcl_Close(interp, chan) Tcl_CloseEx(interp, chan, 0) #endif -#if defined(USE_TCL_STUBS) && (TCL_UTF_MAX > 3) +#undef TclUtfCharComplete +#undef TclUtfNext +#undef TclUtfPrev +#if defined(USE_TCL_STUBS) && (TCL_UTF_MAX < 4) && !defined(TCL_NO_DEPRECATED) # undef Tcl_UtfCharComplete -# define Tcl_UtfCharComplete(src, length) (((unsigned)((unsigned char)*(src) - 0xF0) < 5) \ - ? ((length) >= 4) : tclStubsPtr->tcl_UtfCharComplete((src), (length))) +# undef Tcl_UtfNext +# undef Tcl_UtfPrev +# define Tcl_UtfCharComplete (tclStubsPtr->tclUtfCharComplete) +# define Tcl_UtfNext (tclStubsPtr->tclUtfNext) +# define Tcl_UtfPrev (tclStubsPtr->tclUtfPrev) #endif #define Tcl_CreateSlave Tcl_CreateChild #define Tcl_GetSlave Tcl_GetChild diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 9c11df6..a0ce8a4 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -4,7 +4,7 @@ * This file contains functions that implement the Tcl dict object type * and its accessor command. * - * Copyright (c) 2002-2010 by Donal K. Fellows. + * Copyright © 2002-2010 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 8ccc303..f5cc8b7 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -4,9 +4,9 @@ * This file contains procedures that disassemble bytecode into either * human-readable or Tcl-processable forms. * - * Copyright (c) 1996-1998 Sun Microsystems, Inc. - * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. - * Copyright (c) 2013-2016 Donal K. Fellows. + * Copyright © 1996-1998 Sun Microsystems, Inc. + * Copyright © 2001 Kevin B. Kenny. All rights reserved. + * Copyright © 2013-2016 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index ff3c44c..72b6ee3 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -3,7 +3,7 @@ * * Contains the implementation of the encoding conversion package. * - * Copyright (c) 1996-1998 Sun Microsystems, Inc. + * Copyright © 1996-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -220,14 +220,7 @@ static size_t unilen(const char *src); static Tcl_EncodingConvertProc Utf16ToUtfProc; static Tcl_EncodingConvertProc UtfToUtf16Proc; static Tcl_EncodingConvertProc UtfToUcs2Proc; -static int UtfToUtfProc(ClientData clientData, - const char *src, int srcLen, int flags, - Tcl_EncodingState *statePtr, char *dst, - int dstLen, int *srcReadPtr, - int *dstWrotePtr, int *dstCharsPtr, - int pureNullMode); -static Tcl_EncodingConvertProc UtfIntToUtfExtProc; -static Tcl_EncodingConvertProc UtfExtToUtfIntProc; +static Tcl_EncodingConvertProc UtfToUtfProc; static Tcl_EncodingConvertProc Iso88591FromUtfProc; static Tcl_EncodingConvertProc Iso88591ToUtfProc; @@ -517,6 +510,12 @@ FillEncodingFileMap(void) *--------------------------------------------------------------------------- */ +/* This flags must not conflict with other TCL_ENCODING_* flags in tcl.h */ +#define TCL_ENCODING_MODIFIED 0x20 /* Converting NULL bytes to 0xC0 0x80 */ +/* Since TCL_ENCODING_MODIFIED is only used for utf-8 and + * TCL_ENCODING_LE is only used for utf-16/ucs-2, re-use the same value */ +#define TCL_ENCODING_LE TCL_ENCODING_MODIFIED /* Little-endian encoding */ + void TclInitEncodingSubsystem(void) { @@ -533,7 +532,7 @@ TclInitEncodingSubsystem(void) return; } - isLe.s = 1; + isLe.s = TCL_ENCODING_LE; Tcl_MutexLock(&encodingMutex); Tcl_InitHashTable(&encodingTable, TCL_STRING_KEYS); Tcl_MutexUnlock(&encodingMutex); @@ -553,8 +552,8 @@ TclInitEncodingSubsystem(void) tclIdentityEncoding = Tcl_CreateEncoding(&type); type.encodingName = "utf-8"; - type.toUtfProc = UtfExtToUtfIntProc; - type.fromUtfProc = UtfIntToUtfExtProc; + type.toUtfProc = UtfToUtfProc; + type.fromUtfProc = UtfToUtfProc; type.freeProc = NULL; type.nullSize = 1; type.clientData = NULL; @@ -565,7 +564,7 @@ TclInitEncodingSubsystem(void) type.freeProc = NULL; type.nullSize = 2; type.encodingName = "ucs-2le"; - type.clientData = INT2PTR(1); + type.clientData = INT2PTR(TCL_ENCODING_LE); Tcl_CreateEncoding(&type); type.encodingName = "ucs-2be"; type.clientData = INT2PTR(0); @@ -579,7 +578,7 @@ TclInitEncodingSubsystem(void) type.freeProc = NULL; type.nullSize = 2; type.encodingName = "utf-16le"; - type.clientData = INT2PTR(1); + type.clientData = INT2PTR(TCL_ENCODING_LE); Tcl_CreateEncoding(&type); type.encodingName = "utf-16be"; type.clientData = INT2PTR(0); @@ -1141,19 +1140,21 @@ Tcl_ExternalToUtfDString( } flags = TCL_ENCODING_START | TCL_ENCODING_END; + if (encodingPtr->toUtfProc == UtfToUtfProc) { + flags |= TCL_ENCODING_MODIFIED; + } while (1) { result = encodingPtr->toUtfProc(encodingPtr->clientData, src, srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote, &dstChars); soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); + src += srcRead; if (result != TCL_CONVERT_NOSPACE) { Tcl_DStringSetLength(dstPtr, soFar); return Tcl_DStringValue(dstPtr); } - flags &= ~TCL_ENCODING_START; - src += srcRead; srcLen -= srcRead; if (Tcl_DStringLength(dstPtr) == 0) { Tcl_DStringSetLength(dstPtr, dstLen); @@ -1249,15 +1250,17 @@ Tcl_ExternalToUtf( if (!noTerminate) { /* * If there are any null characters in the middle of the buffer, - * they will converted to the UTF-8 null character (\xC080). To get + * they will converted to the UTF-8 null character (\xC0\x80). To get * the actual \0 at the end of the destination buffer, we need to * append it manually. First make room for it... */ dstLen--; } + if (encodingPtr->toUtfProc == UtfToUtfProc) { + flags |= TCL_ENCODING_MODIFIED; + } do { - int savedFlags = flags; Tcl_EncodingState savedState = *statePtr; result = encodingPtr->toUtfProc(encodingPtr->clientData, src, srcLen, @@ -1267,7 +1270,6 @@ Tcl_ExternalToUtf( break; } dstLen = Tcl_UtfAtIndex(dst, maxChars) - dst + (TCL_UTF_MAX - 1); - flags = savedFlags; *statePtr = savedState; } while (1); if (!noTerminate) { @@ -1331,8 +1333,8 @@ Tcl_UtfToExternalDString( flags = TCL_ENCODING_START | TCL_ENCODING_END; while (1) { result = encodingPtr->fromUtfProc(encodingPtr->clientData, src, - srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote, - &dstChars); + srcLen, flags, &state, dst, dstLen, + &srcRead, &dstWrote, &dstChars); soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); if (result != TCL_CONVERT_NOSPACE) { @@ -1433,8 +1435,8 @@ Tcl_UtfToExternal( dstLen -= encodingPtr->nullSize; result = encodingPtr->fromUtfProc(encodingPtr->clientData, src, srcLen, - flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, - dstCharsPtr); + flags, statePtr, dst, dstLen, srcReadPtr, + dstWrotePtr, dstCharsPtr); if (encodingPtr->nullSize == 2) { dst[*dstWrotePtr + 1] = '\0'; } @@ -2156,104 +2158,6 @@ BinaryProc( /* *------------------------------------------------------------------------- * - * UtfIntToUtfExtProc -- - * - * Convert from UTF-8 to UTF-8. While converting null-bytes from the - * Tcl's internal representation (0xC0, 0x80) to the official - * representation (0x00). See UtfToUtfProc for details. - * - * Results: - * Returns TCL_OK if conversion was successful. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -UtfIntToUtfExtProc( - ClientData clientData, - const char *src, /* Source string in UTF-8. */ - int srcLen, /* Source string length in bytes. */ - int flags, /* Conversion control flags. */ - Tcl_EncodingState *statePtr,/* Place for conversion routine to store state - * information used during a piecewise - * conversion. Contents of statePtr are - * initialized and/or reset by conversion - * routine under control of flags argument. */ - char *dst, /* Output buffer in which converted string - * is stored. */ - int dstLen, /* The maximum length of output buffer in - * bytes. */ - int *srcReadPtr, /* Filled with the number of bytes from the - * source string that were converted. This may - * be less than the original source length if - * there was a problem converting some source - * characters. */ - int *dstWrotePtr, /* Filled with the number of bytes that were - * stored in the output buffer as a result of - * the conversion. */ - int *dstCharsPtr) /* Filled with the number of characters that - * correspond to the bytes stored in the - * output buffer. */ -{ - return UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, - srcReadPtr, dstWrotePtr, dstCharsPtr, 1); -} - -/* - *------------------------------------------------------------------------- - * - * UtfExtToUtfIntProc -- - * - * Convert from UTF-8 to UTF-8 while converting null-bytes from the - * official representation (0x00) to Tcl's internal representation (0xC0, - * 0x80). See UtfToUtfProc for details. - * - * Results: - * Returns TCL_OK if conversion was successful. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -UtfExtToUtfIntProc( - ClientData clientData, - const char *src, /* Source string in UTF-8. */ - int srcLen, /* Source string length in bytes. */ - int flags, /* Conversion control flags. */ - Tcl_EncodingState *statePtr,/* Place for conversion routine to store state - * information used during a piecewise - * conversion. Contents of statePtr are - * initialized and/or reset by conversion - * routine under control of flags argument. */ - char *dst, /* Output buffer in which converted string is - * stored. */ - int dstLen, /* The maximum length of output buffer in - * bytes. */ - int *srcReadPtr, /* Filled with the number of bytes from the - * source string that were converted. This may - * be less than the original source length if - * there was a problem converting some source - * characters. */ - int *dstWrotePtr, /* Filled with the number of bytes that were - * stored in the output buffer as a result of - * the conversion. */ - int *dstCharsPtr) /* Filled with the number of characters that - * correspond to the bytes stored in the - * output buffer. */ -{ - return UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, - srcReadPtr, dstWrotePtr, dstCharsPtr, 0); -} - -/* - *------------------------------------------------------------------------- - * * UtfToUtfProc -- * * Convert from UTF-8 to UTF-8. Note that the UTF-8 to UTF-8 translation @@ -2271,15 +2175,11 @@ UtfExtToUtfIntProc( static int UtfToUtfProc( - TCL_UNUSED(ClientData), + ClientData clientData, /* additional flags, e.g. TCL_ENCODING_MODIFIED */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ - Tcl_EncodingState *statePtr,/* Place for conversion routine to store state - * information used during a piecewise - * conversion. Contents of statePtr are - * initialized and/or reset by conversion - * routine under control of flags argument. */ + TCL_UNUSED(Tcl_EncodingState *), char *dst, /* Output buffer in which converted string is * stored. */ int dstLen, /* The maximum length of output buffer in @@ -2292,21 +2192,15 @@ UtfToUtfProc( int *dstWrotePtr, /* Filled with the number of bytes that were * stored in the output buffer as a result of * the conversion. */ - int *dstCharsPtr, /* Filled with the number of characters that + int *dstCharsPtr) /* Filled with the number of characters that * correspond to the bytes stored in the * output buffer. */ - int pureNullMode) /* Convert embedded nulls from internal - * representation to real null-bytes or vice - * versa. Also combine or separate surrogate pairs */ { const char *srcStart, *srcEnd, *srcClose; const char *dstStart, *dstEnd; int result, numChars, charLimit = INT_MAX; - int *chPtr = (int *) statePtr; + int ch; - if (flags & TCL_ENCODING_START) { - *statePtr = 0; - } result = TCL_OK; srcStart = src; @@ -2320,10 +2214,11 @@ UtfToUtfProc( } dstStart = dst; + flags |= PTR2INT(clientData); dstEnd = dst + dstLen - TCL_UTF_MAX; for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) { - if ((src > srcClose) && (!TclUCS4Complete(src, srcEnd - src))) { + if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { /* * If there is more string to follow, this will ensure that the * last UTF-8 character in the source buffer hasn't been cut off. @@ -2336,50 +2231,69 @@ UtfToUtfProc( result = TCL_CONVERT_NOSPACE; break; } - if (UCHAR(*src) < 0x80 && !(UCHAR(*src) == 0 && pureNullMode == 0)) { + if (UCHAR(*src) < 0x80 && !(UCHAR(*src) == 0 && (flags & TCL_ENCODING_MODIFIED))) { /* * Copy 7bit characters, but skip null-bytes when we are in input * mode, so that they get converted to 0xC080. */ *dst++ = *src++; - *chPtr = 0; /* reset surrogate handling */ - } else if (pureNullMode == 1 && UCHAR(*src) == 0xC0 && - (src + 1 < srcEnd) && UCHAR(*(src+1)) == 0x80) { + } else if (UCHAR(*src) == 0xC0 && (src + 1 < srcEnd) + && UCHAR(src[1]) == 0x80 && !(flags & TCL_ENCODING_MODIFIED)) { /* * Convert 0xC080 to real nulls when we are in output mode. */ *dst++ = 0; - *chPtr = 0; /* reset surrogate handling */ src += 2; - } else if (!TclUCS4Complete(src, srcEnd - src)) { + } else if (!Tcl_UtfCharComplete(src, srcEnd - src)) { /* * Always check before using TclUtfToUCS4. Not doing can so * cause it run beyond the end of the buffer! If we happen such an - * incomplete char its bytes are made to represent themselves. + * incomplete char its bytes are made to represent themselves + * unless the user has explicitly asked to be told. */ - *chPtr = UCHAR(*src); - src += 1; - dst += Tcl_UniCharToUtf(*chPtr, dst); + if (flags & TCL_ENCODING_MODIFIED) { + if (flags & TCL_ENCODING_STOPONERROR) { + result = TCL_CONVERT_MULTIBYTE; + break; + } + ch = UCHAR(*src++); + } else { + char chbuf[2]; + chbuf[0] = UCHAR(*src++); chbuf[1] = 0; + TclUtfToUCS4(chbuf, &ch); + } + dst += Tcl_UniCharToUtf(ch, dst); } else { - src += TclUtfToUCS4(src, chPtr); - if ((*chPtr | 0x7FF) == 0xDFFF) { - /* A surrogate character is detected, handle especially */ - int low = *chPtr; - size_t len = (src <= srcEnd-3) ? TclUtfToUCS4(src, &low) : 0; - if (((low & ~0x3FF) != 0xDC00) || (*chPtr & 0x400)) { - *dst++ = (char) (((*chPtr >> 12) | 0xE0) & 0xEF); - *dst++ = (char) (((*chPtr >> 6) | 0x80) & 0xBF); - *dst++ = (char) ((*chPtr | 0x80) & 0xBF); - continue; + int low; + size_t len = TclUtfToUCS4(src, &ch); + if ((len < 2) && (ch != 0) && (flags & TCL_ENCODING_STOPONERROR) + && (flags & TCL_ENCODING_MODIFIED)) { + result = TCL_CONVERT_SYNTAX; + break; + } + src += len; + if ((ch | 0x7FF) == 0xDFFF) { + /* + * A surrogate character is detected, handle especially. + */ + + low = ch; + len = (src <= srcEnd-3) ? TclUtfToUCS4(src, &low) : 0; + + if (((low & ~0x3FF) != 0xDC00) || (ch & 0x400)) { + *dst++ = (char) (((ch >> 12) | 0xE0) & 0xEF); + *dst++ = (char) (((ch >> 6) | 0x80) & 0xBF); + *dst++ = (char) ((ch | 0x80) & 0xBF); + continue; } src += len; - dst += Tcl_UniCharToUtf(*chPtr, dst); - *chPtr = low; + dst += Tcl_UniCharToUtf(ch, dst); + ch = low; } - dst += Tcl_UniCharToUtf(*chPtr, dst); + dst += Tcl_UniCharToUtf(ch, dst); } } @@ -2407,7 +2321,7 @@ UtfToUtfProc( static int Utf16ToUtfProc( - ClientData clientData, /* != NULL means LE, == NUL means BE */ + ClientData clientData, /* additional flags, e.g. TCL_ENCODING_LE */ const char *src, /* Source string in Unicode. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ @@ -2433,18 +2347,27 @@ Utf16ToUtfProc( int result, numChars, charLimit = INT_MAX; unsigned short ch; + flags |= PTR2INT(clientData); if (flags & TCL_ENCODING_CHAR_LIMIT) { charLimit = *dstCharsPtr; } result = TCL_OK; - /* check alignment with utf-16 (2 == sizeof(UTF-16)) */ + /* + * Check alignment with utf-16 (2 == sizeof(UTF-16)) + */ + if ((srcLen % 2) != 0) { result = TCL_CONVERT_MULTIBYTE; srcLen--; } - /* If last code point is a high surrogate, we cannot handle that yet */ - if ((srcLen >= 2) && ((src[srcLen - (clientData?1:2)] & 0xFC) == 0xD8)) { + + /* + * If last code point is a high surrogate, we cannot handle that yet. + */ + + if ((srcLen >= 2) && + ((src[srcLen - ((flags & TCL_ENCODING_LE)?1:2)] & 0xFC) == 0xD8)) { result = TCL_CONVERT_MULTIBYTE; srcLen-= 2; } @@ -2461,15 +2384,17 @@ Utf16ToUtfProc( break; } - if (clientData) { + if (flags & TCL_ENCODING_LE) { ch = (src[1] & 0xFF) << 8 | (src[0] & 0xFF); } else { ch = (src[0] & 0xFF) << 8 | (src[1] & 0xFF); } + /* * Special case for 1-byte utf chars for speed. Make sure we work with * unsigned short-size data. */ + if (ch && ch < 0x80) { *dst++ = (ch & 0xFF); } else { @@ -2502,15 +2427,11 @@ Utf16ToUtfProc( static int UtfToUtf16Proc( - ClientData clientData, /* != NULL means LE, == NUL means BE */ + ClientData clientData, /* additional flags, e.g. TCL_ENCODING_LE */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ - Tcl_EncodingState *statePtr,/* Place for conversion routine to store state - * information used during a piecewise - * conversion. Contents of statePtr are - * initialized and/or reset by conversion - * routine under control of flags argument. */ + TCL_UNUSED(Tcl_EncodingState *), char *dst, /* Output buffer in which converted string is * stored. */ int dstLen, /* The maximum length of output buffer in @@ -2529,11 +2450,8 @@ UtfToUtf16Proc( { const char *srcStart, *srcEnd, *srcClose, *dstStart, *dstEnd; int result, numChars; - Tcl_UniChar *chPtr = (Tcl_UniChar *) statePtr; + int ch; - if (flags & TCL_ENCODING_START) { - *statePtr = 0; - } srcStart = src; srcEnd = src + srcLen; srcClose = srcEnd; @@ -2543,6 +2461,7 @@ UtfToUtf16Proc( dstStart = dst; dstEnd = dst + dstLen - sizeof(Tcl_UniChar); + flags |= PTR2INT(clientData); result = TCL_OK; for (numChars = 0; src < srcEnd; numChars++) { @@ -2559,38 +2478,27 @@ UtfToUtf16Proc( result = TCL_CONVERT_NOSPACE; break; } - src += TclUtfToUniChar(src, chPtr); - - if (clientData) { -#if TCL_UTF_MAX > 3 - if (*chPtr <= 0xFFFF) { - *dst++ = (*chPtr & 0xFF); - *dst++ = (*chPtr >> 8); + src += TclUtfToUCS4(src, &ch); + if (flags & TCL_ENCODING_LE) { + if (ch <= 0xFFFF) { + *dst++ = (ch & 0xFF); + *dst++ = (ch >> 8); } else { - *dst++ = (((*chPtr - 0x10000) >> 10) & 0xFF); - *dst++ = (((*chPtr - 0x10000) >> 18) & 0x3) | 0xD8; - *dst++ = (*chPtr & 0xFF); - *dst++ = ((*chPtr >> 8) & 0x3) | 0xDC; + *dst++ = (((ch - 0x10000) >> 10) & 0xFF); + *dst++ = (((ch - 0x10000) >> 18) & 0x3) | 0xD8; + *dst++ = (ch & 0xFF); + *dst++ = ((ch >> 8) & 0x3) | 0xDC; } -#else - *dst++ = (*chPtr & 0xFF); - *dst++ = (*chPtr >> 8); -#endif } else { -#if TCL_UTF_MAX > 3 - if (*chPtr <= 0xFFFF) { - *dst++ = (*chPtr >> 8); - *dst++ = (*chPtr & 0xFF); + if (ch <= 0xFFFF) { + *dst++ = (ch >> 8); + *dst++ = (ch & 0xFF); } else { - *dst++ = (((*chPtr - 0x10000) >> 18) & 0x3) | 0xD8; - *dst++ = (((*chPtr - 0x10000) >> 10) & 0xFF); - *dst++ = ((*chPtr >> 8) & 0x3) | 0xDC; - *dst++ = (*chPtr & 0xFF); + *dst++ = (((ch - 0x10000) >> 18) & 0x3) | 0xD8; + *dst++ = (((ch - 0x10000) >> 10) & 0xFF); + *dst++ = ((ch >> 8) & 0x3) | 0xDC; + *dst++ = (ch & 0xFF); } -#else - *dst++ = (*chPtr >> 8); - *dst++ = (*chPtr & 0xFF); -#endif } } *srcReadPtr = src - srcStart; @@ -2617,7 +2525,7 @@ UtfToUtf16Proc( static int UtfToUcs2Proc( - ClientData clientData, /* != NULL means LE, == NUL means BE */ + ClientData clientData, /* additional flags, e.g. TCL_ENCODING_LE */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ @@ -2645,6 +2553,7 @@ UtfToUcs2Proc( #endif Tcl_UniChar ch = 0; + flags |= PTR2INT(clientData); srcStart = src; srcEnd = src + srcLen; srcClose = srcEnd; @@ -2688,7 +2597,7 @@ UtfToUcs2Proc( * casting dst to a Tcl_UniChar. [Bug 1122671] */ - if (clientData) { + if (flags & TCL_ENCODING_LE) { *dst++ = (ch & 0xFF); *dst++ = (ch >> 8); } else { @@ -3096,7 +3005,9 @@ Iso88591FromUtfProc( break; } #if TCL_UTF_MAX <= 3 - if ((ch >= 0xD800) && (len < 3)) len = 4; + if ((ch >= 0xD800) && (len < 3)) { + len = 4; + } #endif /* * Plunge on, using '?' as a fallback character. @@ -3141,7 +3052,7 @@ TableFreeProc( ClientData clientData) /* TableEncodingData that specifies * encoding. */ { - TableEncodingData *dataPtr = (TableEncodingData *)clientData; + TableEncodingData *dataPtr = (TableEncodingData *) clientData; /* * Make sure we aren't freeing twice on shutdown. [Bug 219314] @@ -3199,7 +3110,7 @@ EscapeToUtfProc( * correspond to the bytes stored in the * output buffer. */ { - EscapeEncodingData *dataPtr = (EscapeEncodingData *)clientData; + EscapeEncodingData *dataPtr = (EscapeEncodingData *) clientData; const char *prefixBytes, *tablePrefixBytes, *srcStart, *srcEnd; const unsigned short *const *tableToUnicode; const Encoding *encodingPtr; diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 23516f8..929f3ef 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -4,7 +4,7 @@ * Contains support for ensembles (see TIP#112), which provide simple * mechanism for creating composite commands on top of namespaces. * - * Copyright (c) 2005-2013 Donal K. Fellows. + * Copyright © 2005-2013 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclEnv.c b/generic/tclEnv.c index 96d050d..64d0309 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -6,8 +6,8 @@ * is primarily responsible for keeping the "env" arrays in sync with the * system environment variables. * - * Copyright (c) 1991-1994 The Regents of the University of California. - * Copyright (c) 1994-1998 Sun Microsystems, Inc. + * Copyright © 1991-1994 The Regents of the University of California. + * Copyright © 1994-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -36,6 +36,11 @@ TCL_DECLARE_MUTEX(envMutex) /* To serialize access to environ. */ # define techar char #endif + +/* MODULE_SCOPE */ +size_t TclEnvEpoch = 0; /* Epoch of the tcl environment + * (if changed with tcl-env). */ + static struct { int cacheSize; /* Number of env strings in cache. */ char **cache; /* Array containing all of the environment @@ -417,6 +422,7 @@ Tcl_PutEnv( value[0] = '\0'; TclSetEnv(name, value+1); } + TclEnvEpoch++; Tcl_DStringFree(&nameString); return 0; @@ -624,6 +630,7 @@ EnvTraceProc( if (flags & TCL_TRACE_ARRAY) { TclSetupEnv(interp); + TclEnvEpoch++; return NULL; } @@ -644,6 +651,7 @@ EnvTraceProc( value = Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY); TclSetEnv(name2, value); + TclEnvEpoch++; } /* @@ -667,6 +675,7 @@ EnvTraceProc( if (flags & TCL_TRACE_UNSETS) { TclUnsetEnv(name2); + TclEnvEpoch++; } return NULL; } diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 76a45ae..52cd351 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -5,9 +5,9 @@ * background errors, exit handlers, and the "vwait" and "update" command * functions. * - * Copyright (c) 1990-1994 The Regents of the University of California. - * Copyright (c) 1994-1998 Sun Microsystems, Inc. - * Copyright (c) 2004 by Zoran Vasiljevic. + * Copyright © 1990-1994 The Regents of the University of California. + * Copyright © 1994-1998 Sun Microsystems, Inc. + * Copyright © 2004 Zoran Vasiljevic. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -1513,7 +1513,7 @@ Tcl_UpdateObjCmd( } switch ((enum updateOptionsEnum) optionIndex) { case OPT_IDLETASKS: - flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT; + flags = TCL_IDLE_EVENTS|TCL_DONT_WAIT; break; default: Tcl_Panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions"); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 63dd8e6..55bc314 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -3,13 +3,13 @@ * * This file contains procedures that execute byte-compiled Tcl commands. * - * Copyright (c) 1996-1997 Sun Microsystems, Inc. - * Copyright (c) 1998-2000 by Scriptics Corporation. - * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. - * Copyright (c) 2002-2010 by Miguel Sofer. - * Copyright (c) 2005-2007 by Donal K. Fellows. - * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> - * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. + * Copyright © 1996-1997 Sun Microsystems, Inc. + * Copyright © 1998-2000 Scriptics Corporation. + * Copyright © 2001 Kevin B. Kenny. All rights reserved. + * Copyright © 2002-2010 Miguel Sofer. + * Copyright © 2005-2007 Donal K. Fellows. + * Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net> + * Copyright © 2006-2008 Joe Mistachkin. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -5322,7 +5322,7 @@ TEBCresume( TclNewObj(objResultPtr); } else if (TclIsPureByteArray(valuePtr)) { objResultPtr = Tcl_NewByteArrayObj( - Tcl_GetByteArrayFromObj(valuePtr, NULL)+index, 1); + TclGetByteArrayFromObj(valuePtr, NULL)+index, 1); } else if (valuePtr->bytes && length == valuePtr->length) { objResultPtr = Tcl_NewStringObj((const char *) valuePtr->bytes+index, 1); @@ -9991,7 +9991,7 @@ EvalStatsCmd( break; } } - for (i = 31; i >= 0; i--) { + for (i = 31; i != (size_t)-1; i--) { if (statsPtr->srcCount[i] > 0) { maxSizeDecade = i; break; @@ -10014,7 +10014,7 @@ EvalStatsCmd( break; } } - for (i = 31; i >= 0; i--) { + for (i = 31; i != (size_t)-1; i--) { if (statsPtr->byteCodeCount[i] > 0) { maxSizeDecade = i; break; @@ -10037,7 +10037,7 @@ EvalStatsCmd( break; } } - for (i = 31; i >= 0; i--) { + for (i = 31; i != (size_t)-1; i--) { if (statsPtr->lifetimeCount[i] > 0) { maxSizeDecade = i; break; diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index f9636d8..5e39fc2 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -4,7 +4,7 @@ * This file implements the generic portion of file manipulation * subcommands of the "file" command. * - * Copyright (c) 1996-1998 Sun Microsystems, Inc. + * Copyright © 1996-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclFileName.c b/generic/tclFileName.c index c3f3bf0..4ef9e39 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -4,8 +4,8 @@ * This file contains routines for converting file names betwen native * and network form. * - * Copyright (c) 1995-1998 Sun Microsystems, Inc. - * Copyright (c) 1998-1999 by Scriptics Corporation. + * Copyright © 1995-1998 Sun Microsystems, Inc. + * Copyright © 1998-1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -242,7 +242,7 @@ ExtractWinRoot( if (path[4] == '\0') { abs = 4; - } else if (path [4] == ':' && path[5] == '\0') { + } else if (path[4] == ':' && path[5] == '\0') { abs = 5; } @@ -264,7 +264,7 @@ ExtractWinRoot( if (path[4] == '\0') { abs = 4; - } else if (path [4] == ':' && path[5] == '\0') { + } else if (path[4] == ':' && path[5] == '\0') { abs = 5; } } @@ -2600,44 +2600,44 @@ Tcl_GetDeviceTypeFromStat( return (int) statPtr->st_rdev; } -Tcl_WideInt +long long Tcl_GetAccessTimeFromStat( const Tcl_StatBuf *statPtr) { - return (Tcl_WideInt) statPtr->st_atime; + return (long long) statPtr->st_atime; } -Tcl_WideInt +long long Tcl_GetModificationTimeFromStat( const Tcl_StatBuf *statPtr) { - return (Tcl_WideInt) statPtr->st_mtime; + return (long long) statPtr->st_mtime; } -Tcl_WideInt +long long Tcl_GetChangeTimeFromStat( const Tcl_StatBuf *statPtr) { - return (Tcl_WideInt) statPtr->st_ctime; + return (long long) statPtr->st_ctime; } -Tcl_WideUInt +unsigned long long Tcl_GetSizeFromStat( const Tcl_StatBuf *statPtr) { - return (Tcl_WideUInt) statPtr->st_size; + return (unsigned long long) statPtr->st_size; } -Tcl_WideUInt +unsigned long long Tcl_GetBlocksFromStat( const Tcl_StatBuf *statPtr) { #ifdef HAVE_STRUCT_STAT_ST_BLOCKS - return (Tcl_WideUInt) statPtr->st_blocks; + return (unsigned long long) statPtr->st_blocks; #else unsigned blksize = Tcl_GetBlockSizeFromStat(statPtr); - return ((Tcl_WideUInt) statPtr->st_size + blksize - 1) / blksize; + return ((unsigned long long) statPtr->st_size + blksize - 1) / blksize; #endif } diff --git a/generic/tclGet.c b/generic/tclGet.c index 12e0e79..3dbc545 100644 --- a/generic/tclGet.c +++ b/generic/tclGet.c @@ -5,8 +5,8 @@ * integers or floating-point numbers or booleans, doing syntax checking * along the way. * - * Copyright (c) 1990-1993 The Regents of the University of California. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright © 1990-1993 The Regents of the University of California. + * Copyright © 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclHash.c b/generic/tclHash.c index 584b5e1..df1036b 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -4,8 +4,8 @@ * Implementation of in-memory hash tables for Tcl and Tcl-based * applications. * - * Copyright (c) 1991-1993 The Regents of the University of California. - * Copyright (c) 1994 Sun Microsystems, Inc. + * Copyright © 1991-1993 The Regents of the University of California. + * Copyright © 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclHistory.c b/generic/tclHistory.c index 3a52a20..02e15a0 100644 --- a/generic/tclHistory.c +++ b/generic/tclHistory.c @@ -6,8 +6,8 @@ * commands ("events") before they are executed. Commands defined in * history.tcl may be used to perform history substitutions. * - * Copyright (c) 1990-1993 The Regents of the University of California. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright © 1990-1993 The Regents of the University of California. + * Copyright © 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclIO.c b/generic/tclIO.c index 1547489..3954af2 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4,8 +4,8 @@ * This file provides the generic portions (those that are the same on * all platforms and for all channel types) of Tcl's IO facilities. * - * Copyright (c) 1998-2000 Ajuba Solutions - * Copyright (c) 1995-1997 Sun Microsystems, Inc. + * Copyright © 1998-2000 Ajuba Solutions + * Copyright © 1995-1997 Sun Microsystems, Inc. * Contributions from Don Porter, NIST, 2014. (not subject to US copyright) * * See the file "license.terms" for information on usage and redistribution of @@ -3387,7 +3387,8 @@ int Tcl_Close( Tcl_Interp *interp, /* Interpreter for errors. */ Tcl_Channel chan) /* The channel being closed. Must not be - * referenced in any interpreter. */ + * referenced in any interpreter. May be NULL, + * in which case this is a no-op. */ { CloseCallback *cbPtr; /* Iterate over close callbacks for this * channel. */ @@ -6989,10 +6990,10 @@ GetInput( *---------------------------------------------------------------------- */ -Tcl_WideInt +long long Tcl_Seek( Tcl_Channel chan, /* The channel on which to seek. */ - Tcl_WideInt offset, /* Offset to seek to. */ + long long offset, /* Offset to seek to. */ int mode) /* Relative to which location to seek? */ { Channel *chanPtr = (Channel *) chan; @@ -7002,7 +7003,7 @@ Tcl_Seek( int inputBuffered, outputBuffered; /* # bytes held in buffers. */ int result; /* Of device driver operations. */ - Tcl_WideInt curPos; /* Position on the device. */ + long long curPos; /* Position on the device. */ int wasAsync; /* Was the channel nonblocking before the seek * operation? If so, must restore to * non-blocking mode after the seek. */ @@ -7162,7 +7163,7 @@ Tcl_Seek( *---------------------------------------------------------------------- */ -Tcl_WideInt +long long Tcl_Tell( Tcl_Channel chan) /* The channel to return pos for. */ { @@ -7173,7 +7174,7 @@ Tcl_Tell( int inputBuffered, outputBuffered; /* # bytes held in buffers. */ int result; /* Of calling device driver. */ - Tcl_WideInt curPos; /* Position on device. */ + long long curPos; /* Position on device. */ if (CheckChannelErrors(statePtr, TCL_WRITABLE | TCL_READABLE) != 0) { return -1; @@ -7257,7 +7258,7 @@ Tcl_Tell( int Tcl_TruncateChannel( Tcl_Channel chan, /* Channel to truncate. */ - Tcl_WideInt length) /* Length to truncate it to. */ + long long length) /* Length to truncate it to. */ { Channel *chanPtr = (Channel *) chan; Tcl_DriverTruncateProc *truncateProc = @@ -9159,7 +9160,7 @@ TclCopyChannel( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Channel inChan, /* Channel to read from. */ Tcl_Channel outChan, /* Channel to write to. */ - Tcl_WideInt toRead, /* Amount of data to copy, or -1 for all. */ + long long toRead, /* Amount of data to copy, or -1 for all. */ Tcl_Obj *cmdPtr) /* Pointer to script to execute or NULL. */ { Channel *inPtr = (Channel *) inChan; diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index e28f9de..2ab31e4 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -3,7 +3,7 @@ * * Contains the definitions of most of the Tcl commands relating to IO. * - * Copyright (c) 1995-1997 Sun Microsystems, Inc. + * Copyright © 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index 353998f..f03fcca 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -4,8 +4,8 @@ * Implements a generic transformation exposing the underlying API at the * script level. Contributed by Andreas Kupries. * - * Copyright (c) 2000 Ajuba Solutions - * Copyright (c) 1999-2000 Andreas Kupries (a.kupries@westend.com) + * Copyright © 2000 Ajuba Solutions + * Copyright © 1999-2000 Andreas Kupries (a.kupries@westend.com) * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -41,8 +41,8 @@ static void TransformWatchProc(ClientData instanceData, int mask); static int TransformGetFileHandleProc(ClientData instanceData, int direction, ClientData *handlePtr); static int TransformNotifyProc(ClientData instanceData, int mask); -static Tcl_WideInt TransformWideSeekProc(ClientData instanceData, - Tcl_WideInt offset, int mode, int *errorCodePtr); +static long long TransformWideSeekProc(ClientData instanceData, + long long offset, int mode, int *errorCodePtr); /* * Forward declarations of internal procedures. Secondly the procedures for @@ -907,10 +907,10 @@ TransformSeekProc( *---------------------------------------------------------------------- */ -static Tcl_WideInt +static long long TransformWideSeekProc( ClientData instanceData, /* The channel to manipulate. */ - Tcl_WideInt offset, /* Size of movement. */ + long long offset, /* Size of movement. */ int mode, /* How to move. */ int *errorCodePtr) /* Location of error flag. */ { @@ -922,7 +922,7 @@ TransformWideSeekProc( #endif Tcl_DriverWideSeekProc *parentWideSeekProc = Tcl_ChannelWideSeekProc(parentType); - ClientData parentData = Tcl_GetChannelInstanceData(parent); + void *parentData = Tcl_GetChannelInstanceData(parent); if ((offset == 0) && (mode == SEEK_CUR)) { /* diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index e50c96f..88f6de8 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -10,7 +10,7 @@ * * See TIP #219 for the specification of this functionality. * - * Copyright (c) 2004-2005 ActiveState, a divison of Sophos + * Copyright © 2004-2005 ActiveState, a divison of Sophos * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -44,8 +44,8 @@ static void ReflectThread(ClientData clientData, int action); static int ReflectEventRun(Tcl_Event *ev, int flags); static int ReflectEventDelete(Tcl_Event *ev, ClientData cd); #endif -static Tcl_WideInt ReflectSeekWide(ClientData clientData, - Tcl_WideInt offset, int mode, int *errorCodePtr); +static long long ReflectSeekWide(ClientData clientData, + long long offset, int mode, int *errorCodePtr); #ifndef TCL_NO_DEPRECATED static int ReflectSeek(ClientData clientData, long offset, int mode, int *errorCodePtr); @@ -56,12 +56,13 @@ static int ReflectGetOption(ClientData clientData, static int ReflectSetOption(ClientData clientData, Tcl_Interp *interp, const char *optionName, const char *newValue); +static int ReflectTruncate(ClientData clientData, + long long length); static void TimerRunRead(ClientData clientData); static void TimerRunWrite(ClientData clientData); /* - * The C layer channel type/driver definition used by the reflection. This is - * a version 3 structure. + * The C layer channel type/driver definition used by the reflection. */ static const Tcl_ChannelType tclRChannelType = { @@ -89,7 +90,7 @@ static const Tcl_ChannelType tclRChannelType = { #else NULL, /* thread action */ #endif - NULL /* truncate */ + ReflectTruncate /* Truncate. NULL'able */ }; /* @@ -187,6 +188,7 @@ static const char *const methodNames[] = { "initialize", /* */ "read", /* OPT */ "seek", /* OPT */ + "truncate", /* OPT */ "watch", /* */ "write", /* OPT */ NULL @@ -200,6 +202,7 @@ typedef enum { METH_INIT, METH_READ, METH_SEEK, + METH_TRUNCATE, METH_WATCH, METH_WRITE } MethodName; @@ -209,7 +212,8 @@ typedef enum { (FLAG(METH_INIT) | FLAG(METH_FINAL) | FLAG(METH_WATCH)) #define NULLABLE_METHODS \ (FLAG(METH_BLOCKING) | FLAG(METH_SEEK) | \ - FLAG(METH_CONFIGURE) | FLAG(METH_CGET) | FLAG(METH_CGETALL)) + FLAG(METH_CONFIGURE) | FLAG(METH_CGET) | \ + FLAG(METH_CGETALL) | FLAG(METH_TRUNCATE)) #define RANDW \ (TCL_READABLE | TCL_WRITABLE) @@ -239,7 +243,8 @@ typedef enum { ForwardedBlock, ForwardedSetOpt, ForwardedGetOpt, - ForwardedGetOptAll + ForwardedGetOptAll, + ForwardedTruncate } ForwardedOperation; /* @@ -302,6 +307,10 @@ struct ForwardParamGetOpt { const char *name; /* Name of option to get, maybe NULL */ Tcl_DString *value; /* Result */ }; +struct ForwardParamTruncate { + ForwardParamBase base; /* "Supertype". MUST COME FIRST. */ + Tcl_WideInt length; /* I: Length of file. */ +}; /* * Now join all these together in a single union for convenience. @@ -316,6 +325,7 @@ typedef union ForwardParam { struct ForwardParamBlock block; struct ForwardParamSetOpt setOpt; struct ForwardParamGetOpt getOpt; + struct ForwardParamTruncate truncate; } ForwardParam; /* @@ -706,6 +716,9 @@ TclChanCreateObjCmd( #endif clonePtr->wideSeekProc = NULL; } + if (!(methods & FLAG(METH_TRUNCATE))) { + clonePtr->truncateProc = NULL; + } chanPtr->typePtr = clonePtr; } @@ -1550,10 +1563,10 @@ ReflectOutput( *---------------------------------------------------------------------- */ -static Tcl_WideInt +static long long ReflectSeekWide( ClientData clientData, - Tcl_WideInt offset, + long long offset, int seekMode, int *errorCodePtr) { @@ -2048,6 +2061,73 @@ ReflectGetOption( } /* + *---------------------------------------------------------------------- + * + * ReflectTruncate -- + * + * This function is invoked to truncate a channel's file size. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Arbitrary, as it calls upon a Tcl script. + * + *---------------------------------------------------------------------- + */ + +static int +ReflectTruncate( + ClientData clientData, /* Channel to query */ + long long length) /* Length to truncate to. */ +{ + ReflectedChannel *rcPtr = (ReflectedChannel *)clientData; + Tcl_Obj *lenObj; + int errorNum; /* EINVAL or EOK (success). */ + Tcl_Obj *resObj; /* Result for 'truncate' */ + + /* + * Are we in the correct thread? + */ + +#ifdef TCL_THREADS + if (rcPtr->thread != Tcl_GetCurrentThread()) { + ForwardParam p; + + p.truncate.length = length; + + ForwardOpToHandlerThread(rcPtr, ForwardedTruncate, &p); + + if (p.base.code != TCL_OK) { + PassReceivedError(rcPtr->chan, &p); + return EINVAL; + } + + return EOK; + } +#endif + + /* ASSERT: rcPtr->method & FLAG(METH_TRUNCATE) */ + + Tcl_Preserve(rcPtr); + + lenObj = Tcl_NewIntObj(length); + Tcl_IncrRefCount(lenObj); + + if (InvokeTclMethod(rcPtr,METH_TRUNCATE,lenObj,NULL,&resObj)!=TCL_OK) { + Tcl_SetChannelError(rcPtr->chan, resObj); + errorNum = EINVAL; + } else { + errorNum = EOK; + } + + Tcl_DecrRefCount(lenObj); + Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ + Tcl_Release(rcPtr); + return errorNum; +} + +/* * Helpers. ========================================================= */ @@ -3278,6 +3358,19 @@ ForwardProc( Tcl_Release(rcPtr); break; + case ForwardedTruncate: { + Tcl_Obj *lenObj = Tcl_NewIntObj(paramPtr->truncate.length); + + Tcl_IncrRefCount(lenObj); + Tcl_Preserve(rcPtr); + if (InvokeTclMethod(rcPtr,METH_TRUNCATE,lenObj,NULL,&resObj)!=TCL_OK) { + ForwardSetObjError(paramPtr, resObj); + } + Tcl_Release(rcPtr); + Tcl_DecrRefCount(lenObj); + break; + } + default: /* * Bad operation code. diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index 3c5f133..b06bd45 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -10,7 +10,7 @@ * * See TIP #230 for the specification of this functionality. * - * Copyright (c) 2007-2008 ActiveState. + * Copyright © 2007-2008 ActiveState. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -39,8 +39,8 @@ static int ReflectOutput(ClientData clientData, const char *buf, int toWrite, int *errorCodePtr); static void ReflectWatch(ClientData clientData, int mask); static int ReflectBlock(ClientData clientData, int mode); -static Tcl_WideInt ReflectSeekWide(ClientData clientData, - Tcl_WideInt offset, int mode, int *errorCodePtr); +static long long ReflectSeekWide(ClientData clientData, + long long offset, int mode, int *errorCodePtr); #ifndef TCL_NO_DEPRECATED static int ReflectSeek(ClientData clientData, long offset, int mode, int *errorCodePtr); @@ -1327,10 +1327,10 @@ ReflectOutput( *---------------------------------------------------------------------- */ -static Tcl_WideInt +static long long ReflectSeekWide( ClientData clientData, - Tcl_WideInt offset, + long long offset, int seekMode, int *errorCodePtr) { diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index adf729a..87a79db 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -3,7 +3,7 @@ * * Common routines used by all socket based channel types. * - * Copyright (c) 1995-1997 Sun Microsystems, Inc. + * Copyright © 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index fcce215..698b614 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -7,9 +7,9 @@ * is the primary author. Other signifiant contributors are Karl * Lehenbauer, Mark Diekhans and Peter da Silva. * - * Copyright (c) 1991-1994 The Regents of the University of California. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. - * Copyright (c) 2001-2004 Vincent Darley. + * Copyright © 1991-1994 The Regents of the University of California. + * Copyright © 1994-1997 Sun Microsystems, Inc. + * Copyright © 2001-2004 Vincent Darley. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -1756,7 +1756,7 @@ Tcl_FSEvalFileEx( */ if (Tcl_ReadChars(chan, objPtr, -1, - memcmp(string, "\xef\xbb\xbf", 3)) == TCL_IO_FAILURE) { + memcmp(string, "\xEF\xBB\xBF", 3)) == TCL_IO_FAILURE) { Tcl_Close(interp, chan); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", @@ -1893,7 +1893,7 @@ TclNREvalFile( */ if (Tcl_ReadChars(chan, objPtr, -1, - memcmp(string, "\xef\xbb\xbf", 3)) == TCL_IO_FAILURE) { + memcmp(string, "\xEF\xBB\xBF", 3)) == TCL_IO_FAILURE) { Tcl_Close(interp, chan); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", @@ -3009,7 +3009,7 @@ Tcl_FSLoadFile( const char *sym1, const char *sym2, /* Names of two functions to find in the * dynamic shared object. */ - Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **proc2Ptr, + Tcl_LibraryInitProc **proc1Ptr, Tcl_LibraryInitProc **proc2Ptr, /* Places to store pointers to the functions * named by sym1 and sym2. */ Tcl_LoadHandle *handlePtr, /* A place to store the token for the loaded @@ -3027,8 +3027,8 @@ Tcl_FSLoadFile( res = Tcl_LoadFile(interp, pathPtr, symbols, 0, procPtrs, handlePtr); if (res == TCL_OK) { - *proc1Ptr = (Tcl_PackageInitProc *) procPtrs[0]; - *proc2Ptr = (Tcl_PackageInitProc *) procPtrs[1]; + *proc1Ptr = (Tcl_LibraryInitProc *) procPtrs[0]; + *proc2Ptr = (Tcl_LibraryInitProc *) procPtrs[1]; } else { *proc1Ptr = *proc2Ptr = NULL; } @@ -3077,6 +3077,13 @@ Tcl_FSLoadFile( * */ +#ifdef _WIN32 +#define getenv(x) _wgetenv(L##x) +#define atoi(x) _wtoi(x) +#else +#define WCHAR char +#endif + static int skipUnlink( Tcl_Obj *shlibFile) @@ -3098,7 +3105,7 @@ skipUnlink( (void)shlibFile; return 1; #else - char *skipstr = getenv("TCL_TEMPLOAD_NO_UNLINK"); + WCHAR *skipstr = getenv("TCL_TEMPLOAD_NO_UNLINK"); if (skipstr && (skipstr[0] != '\0')) { return atoi(skipstr); diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 6ae2075..48ebb69 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -5,9 +5,9 @@ * to lookup a keyword in a table of valid values and cache the index of * the matching entry. Also provides table-based argv/argc processing. * - * Copyright (c) 1990-1994 The Regents of the University of California. - * Copyright (c) 1997 Sun Microsystems, Inc. - * Copyright (c) 2006 Sam Bromley. + * Copyright © 1990-1994 The Regents of the University of California. + * Copyright © 1997 Sun Microsystems, Inc. + * Copyright © 2006 Sam Bromley. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -785,7 +785,7 @@ PrefixLongestObjCmd( * Adjust in case we stopped in the middle of a UTF char. */ - resultLength = TclUtfPrev(&resultString[i+1], + resultLength = Tcl_UtfPrev(&resultString[i+1], resultString) - resultString; break; } @@ -1332,7 +1332,6 @@ PrintUsage( int width, numSpaces; #define NUM_SPACES 20 static const char spaces[] = " "; - char tmp[TCL_DOUBLE_SPACE]; Tcl_Obj *msg; /* @@ -1382,7 +1381,6 @@ PrintUsage( case TCL_ARGV_FLOAT: Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: %g", *((double *) infoPtr->dstPtr)); - sprintf(tmp, "%g", *((double *) infoPtr->dstPtr)); break; case TCL_ARGV_STRING: { char *string = *((char **) infoPtr->dstPtr); diff --git a/generic/tclInt.decls b/generic/tclInt.decls index e25443d..c7ead64 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -17,6 +17,7 @@ library tcl # Define the unsupported generic interfaces. interface tclInt +scspec EXTERN # Declare each of the functions in the unsupported internal Tcl # interface. These interfaces are allowed to changed between versions. @@ -239,8 +240,8 @@ declare 55 { # Replaced with TclpLoadFile in 8.1: # declare 56 { # int TclLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, -# char *sym2, Tcl_PackageInitProc **proc1Ptr, -# Tcl_PackageInitProc **proc2Ptr) +# char *sym2, Tcl_LibraryInitProc **proc1Ptr, +# Tcl_LibraryInitProc **proc2Ptr) # } # Signature changed to take a length in 8.1: # declare 57 { @@ -552,8 +553,8 @@ declare 138 { } #declare 139 { # int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, -# char *sym2, Tcl_PackageInitProc **proc1Ptr, -# Tcl_PackageInitProc **proc2Ptr, void **clientDataPtr) +# char *sym2, Tcl_LibraryInitProc **proc1Ptr, +# Tcl_LibraryInitProc **proc2Ptr, void **clientDataPtr) #} #declare 140 { # int TclLooksLikeInt(const char *bytes, int length) @@ -981,7 +982,7 @@ declare 247 { declare 248 { int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan, - Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr) + Tcl_Channel outChan, long long toRead, Tcl_Obj *cmdPtr) } declare 249 { @@ -1025,8 +1026,8 @@ declare 256 { Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags) } declare 257 { - void TclStaticPackage(Tcl_Interp *interp, const char *pkgName, - Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) + void TclStaticLibrary(Tcl_Interp *interp, const char *prefix, + Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc) } # TIP 431: temporary directory creation function diff --git a/generic/tclInt.h b/generic/tclInt.h index 8088d0e..b8ed3c1 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1804,7 +1804,7 @@ typedef struct AllocCache { struct Cache *nextPtr; /* Linked list of cache entries. */ Tcl_ThreadId owner; /* Which thread's cache is this? */ Tcl_Obj *firstObjPtr; /* List of free objects for thread. */ - int numObjects; /* Number of objects for thread. */ + size_t numObjects; /* Number of objects for thread. */ } AllocCache; /* @@ -2739,7 +2739,6 @@ MODULE_SCOPE char *tclNativeExecutableName; MODULE_SCOPE int tclFindExecutableSearchDone; MODULE_SCOPE char *tclMemDumpFileName; MODULE_SCOPE TclPlatformType tclPlatform; -MODULE_SCOPE Tcl_NotifierProcs tclNotifierHooks; MODULE_SCOPE Tcl_Encoding tclIdentityEncoding; @@ -3044,7 +3043,7 @@ MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr, unsigned int *sizePtr); -MODULE_SCOPE int TclGetLoadedPackagesEx(Tcl_Interp *interp, +MODULE_SCOPE int TclGetLoadedLibraries(Tcl_Interp *interp, const char *targetName, const char *packageName); MODULE_SCOPE int TclGetWideBitsFromObj(Tcl_Interp *, Tcl_Obj *, @@ -3133,12 +3132,21 @@ MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp, int code, int level, Tcl_Obj *returnOpts); MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); MODULE_SCOPE Tcl_Obj * TclpTempFileName(void); -MODULE_SCOPE Tcl_Obj * TclpTempFileNameForLibrary(Tcl_Interp *interp, Tcl_Obj* pathPtr); +MODULE_SCOPE Tcl_Obj * TclpTempFileNameForLibrary(Tcl_Interp *interp, + Tcl_Obj* pathPtr); MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep, int len); +MODULE_SCOPE void TclpAlertNotifier(ClientData clientData); +MODULE_SCOPE void TclpServiceModeHook(int mode); +MODULE_SCOPE void TclpSetTimer(const Tcl_Time *timePtr); +MODULE_SCOPE int TclpWaitForEvent(const Tcl_Time *timePtr); +MODULE_SCOPE void TclpCreateFileHandler(int fd, int mask, + Tcl_FileProc *proc, ClientData clientData); MODULE_SCOPE int TclpDeleteFile(const void *path); +MODULE_SCOPE void TclpDeleteFileHandler(int fd); MODULE_SCOPE void TclpFinalizeCondition(Tcl_Condition *condPtr); MODULE_SCOPE void TclpFinalizeMutex(Tcl_Mutex *mutexPtr); +MODULE_SCOPE void TclpFinalizeNotifier(ClientData clientData); MODULE_SCOPE void TclpFinalizePipes(void); MODULE_SCOPE void TclpFinalizeSockets(void); MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp, @@ -3152,6 +3160,7 @@ MODULE_SCOPE int TclpFindVariable(const char *name, int *lengthPtr); MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, unsigned int *lengthPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE void TclpInitLock(void); +MODULE_SCOPE ClientData TclpInitNotifier(void); MODULE_SCOPE void TclpInitPlatform(void); MODULE_SCOPE void TclpInitUnlock(void); MODULE_SCOPE Tcl_Obj * TclpObjListVolumes(void); @@ -3178,8 +3187,9 @@ MODULE_SCOPE int TclpObjChdir(Tcl_Obj *pathPtr); MODULE_SCOPE Tcl_Channel TclpOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); -MODULE_SCOPE void TclPkgFileSeen(Tcl_Interp *interp, const char *fileName); -MODULE_SCOPE void *TclInitPkgFiles(Tcl_Interp *interp); +MODULE_SCOPE void TclPkgFileSeen(Tcl_Interp *interp, + const char *fileName); +MODULE_SCOPE void * TclInitPkgFiles(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_PathPart portion); MODULE_SCOPE char * TclpReadlink(const char *fileName, @@ -3253,16 +3263,10 @@ MODULE_SCOPE int TclUtfCount(int ch); # define TclUtfToUCS4 Tcl_UtfToUniChar # define TclUniCharToUCS4(src, ptr) (*ptr = *(src),1) # define TclUCS4Prev(src, ptr) (((src) > (ptr)) ? ((src) - 1) : (src)) -# define TclUCS4Complete Tcl_UtfCharComplete -# define TclChar16Complete(src, length) (((unsigned)((unsigned char)*(src) - 0xF0) < 5) \ - ? ((length) >= 3) : Tcl_UtfCharComplete((src), (length))) #else MODULE_SCOPE int TclUtfToUCS4(const char *, int *); MODULE_SCOPE int TclUniCharToUCS4(const Tcl_UniChar *, int *); MODULE_SCOPE const Tcl_UniChar *TclUCS4Prev(const Tcl_UniChar *, const Tcl_UniChar *); -# define TclUCS4Complete(src, length) (((unsigned)((unsigned char)*(src) - 0xF0) < 5) \ - ? ((length) >= 4) : Tcl_UtfCharComplete((src), (length))) -# define TclChar16Complete Tcl_UtfCharComplete #endif MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData); MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr); @@ -3280,27 +3284,20 @@ MODULE_SCOPE void TclInitThreadStorage(void); MODULE_SCOPE void TclFinalizeThreadDataThread(void); MODULE_SCOPE void TclFinalizeThreadStorage(void); -/* TclWideMUInt -- wide integer used for measurement calculations: */ -#if (!defined(_WIN32) || !defined(_MSC_VER) || (_MSC_VER >= 1400)) -# define TclWideMUInt Tcl_WideUInt -#else -/* older MSVS may not allow conversions between unsigned __int64 and double) */ -# define TclWideMUInt Tcl_WideInt -#endif #ifdef TCL_WIDE_CLICKS -MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void); -MODULE_SCOPE double TclpWideClicksToNanoseconds(Tcl_WideInt clicks); +MODULE_SCOPE long long TclpGetWideClicks(void); +MODULE_SCOPE double TclpWideClicksToNanoseconds(long long clicks); MODULE_SCOPE double TclpWideClickInMicrosec(void); #else # ifdef _WIN32 # define TCL_WIDE_CLICKS 1 -MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void); +MODULE_SCOPE long long TclpGetWideClicks(void); MODULE_SCOPE double TclpWideClickInMicrosec(void); # define TclpWideClicksToNanoseconds(clicks) \ ((double)(clicks) * TclpWideClickInMicrosec() * 1000) # endif #endif -MODULE_SCOPE Tcl_WideInt TclpGetMicroseconds(void); +MODULE_SCOPE long long TclpGetMicroseconds(void); MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp); MODULE_SCOPE void * TclpThreadCreateKey(void); @@ -4225,6 +4222,37 @@ MODULE_SCOPE int TclIndexDecode(int encoded, int endValue); #define TCL_INDEX_START (0) /* + *---------------------------------------------------------------------- + * + * TclScaleTime -- + * + * TIP #233 (Virtualized Time): Wrapper around the time virutalisation + * rescale function to hide the binding of the clientData. + * + * This is static inline code; it's like a macro, but a function. It's + * used because this is a piece of code that ends up in places that are a + * bit performance sensitive. + * + * Results: + * None + * + * Side effects: + * Updates the time structure (given as an argument) with what the time + * should be after virtualisation. + * + *---------------------------------------------------------------------- + */ + +static inline void +TclScaleTime( + Tcl_Time *timePtr) +{ + if (timePtr != NULL) { + tclScaleTimeProcPtr(timePtr, tclTimeClientData); + } +} + +/* *---------------------------------------------------------------- * Macros used by the Tcl core to create and release Tcl objects. * TclNewObj(objPtr) creates a new object denoting an empty string. @@ -4487,10 +4515,11 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, #define TclGetString(objPtr) \ ((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString(objPtr)) +#undef TclGetStringFromObj #define TclGetStringFromObj(objPtr, lenPtr) \ ((objPtr)->bytes \ ? (*(lenPtr) = (objPtr)->length, (objPtr)->bytes) \ - : Tcl_GetStringFromObj((objPtr), (lenPtr))) + : (Tcl_GetStringFromObj)((objPtr), (lenPtr))) /* *---------------------------------------------------------------- @@ -4702,11 +4731,6 @@ MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; (numChars) = _count; \ } while (0); -#define TclUtfPrev(src, start) \ - (((src) < (start) + 2) ? (start) : \ - ((unsigned char) *((src) - 1)) < 0x80 ? (src) - 1 : \ - Tcl_UtfPrev(src, start)) - /* *---------------------------------------------------------------- * Macro that encapsulates the logic that determines when it is safe to @@ -4743,7 +4767,7 @@ MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr); *---------------------------------------------------------------- */ -#ifdef WORDS_BIGENDIAN +#if defined(WORDS_BIGENDIAN) && (TCL_UTF_MAX > 3) # define TclUniCharNcmp(cs,ct,n) memcmp((cs),(ct),(n)*sizeof(Tcl_UniChar)) #else /* !WORDS_BIGENDIAN */ # define TclUniCharNcmp Tcl_UniCharNcmp @@ -4774,7 +4798,7 @@ MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr); *---------------------------------------------------------------------- */ -MODULE_SCOPE Tcl_PackageInitProc TclTommath_Init; +MODULE_SCOPE Tcl_LibraryInitProc TclTommath_Init; /* *---------------------------------------------------------------------- @@ -4786,11 +4810,11 @@ MODULE_SCOPE Tcl_PackageInitProc TclTommath_Init; *---------------------------------------------------------------------- */ -MODULE_SCOPE Tcl_PackageInitProc TclplatformtestInit; -MODULE_SCOPE Tcl_PackageInitProc TclObjTest_Init; -MODULE_SCOPE Tcl_PackageInitProc TclThread_Init; -MODULE_SCOPE Tcl_PackageInitProc Procbodytest_Init; -MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; +MODULE_SCOPE Tcl_LibraryInitProc TclplatformtestInit; +MODULE_SCOPE Tcl_LibraryInitProc TclObjTest_Init; +MODULE_SCOPE Tcl_LibraryInitProc TclThread_Init; +MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_Init; +MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; /* *---------------------------------------------------------------- @@ -5161,6 +5185,35 @@ typedef struct NRE_callback { #define Tcl_Free(ptr) TclpFree(ptr) #endif +/* + * Special hack for macOS, where the static linker (technically the 'ar' + * command) hates empty object files, and accepts no flags to make it shut up. + * + * These symbols are otherwise completely useless. + * + * They can't be written to or written through. They can't be seen by any + * other code. They use a separate attribute (supported by all macOS + * compilers, which are derivatives of clang or gcc) to stop the compilation + * from moaning. They will be excluded during the final linking stage. + * + * Other platforms get nothing at all. That's good. + */ + +#ifdef MAC_OSX_TCL +#define TCL_MAC_EMPTY_FILE(name) \ + static __attribute__((used)) const void *const TclUnusedFile_ ## name; \ + static const void *const TclUnusedFile_ ## name = NULL; +#else +#define TCL_MAC_EMPTY_FILE(name) +#endif /* MAC_OSX_TCL */ + +/* + * Other externals. + */ + +MODULE_SCOPE size_t TclEnvEpoch; /* Epoch of the tcl environment + * (if changed with tcl-env). */ + #endif /* _TCLINT */ /* diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 71d9f5c..bfd3102 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -618,7 +618,7 @@ EXTERN void TclResetRewriteEnsemble(Tcl_Interp *interp, /* 248 */ EXTERN int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, - Tcl_WideInt toRead, Tcl_Obj *cmdPtr); + long long toRead, Tcl_Obj *cmdPtr); /* 249 */ EXTERN char * TclDoubleDigits(double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); @@ -651,10 +651,10 @@ EXTERN int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 257 */ -EXTERN void TclStaticPackage(Tcl_Interp *interp, - const char *pkgName, - Tcl_PackageInitProc *initProc, - Tcl_PackageInitProc *safeInitProc); +EXTERN void TclStaticLibrary(Tcl_Interp *interp, + const char *prefix, + Tcl_LibraryInitProc *initProc, + Tcl_LibraryInitProc *safeInitProc); /* 258 */ EXTERN Tcl_Obj * TclpCreateTemporaryDirectory(Tcl_Obj *dirObj, Tcl_Obj *basenameObj); @@ -916,7 +916,7 @@ typedef struct TclIntStubs { Tcl_HashTable * (*tclGetNamespaceCommandTable) (Tcl_Namespace *nsPtr); /* 245 */ int (*tclInitRewriteEnsemble) (Tcl_Interp *interp, int numRemoved, int numInserted, Tcl_Obj *const *objv); /* 246 */ void (*tclResetRewriteEnsemble) (Tcl_Interp *interp, int isRootEnsemble); /* 247 */ - int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 248 */ + int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, long long toRead, Tcl_Obj *cmdPtr); /* 248 */ char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */ void (*tclSetChildCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */ int (*tclRegisterLiteral) (void *envPtr, const char *bytes, int length, int flags); /* 251 */ @@ -925,7 +925,7 @@ typedef struct TclIntStubs { Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, const int flags); /* 254 */ int (*tclPtrObjMakeUpvar) (Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, int myFlags); /* 255 */ int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 256 */ - void (*tclStaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 257 */ + void (*tclStaticLibrary) (Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc); /* 257 */ Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */ unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *lengthPtr); /* 259 */ void (*tclUnusedStubEntry) (void); /* 260 */ @@ -1370,8 +1370,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclPtrObjMakeUpvar) /* 255 */ #define TclPtrUnsetVar \ (tclIntStubsPtr->tclPtrUnsetVar) /* 256 */ -#define TclStaticPackage \ - (tclIntStubsPtr->tclStaticPackage) /* 257 */ +#define TclStaticLibrary \ + (tclIntStubsPtr->tclStaticLibrary) /* 257 */ #define TclpCreateTemporaryDirectory \ (tclIntStubsPtr->tclpCreateTemporaryDirectory) /* 258 */ #define TclGetBytesFromObj \ @@ -1409,11 +1409,12 @@ extern const TclIntStubs *tclIntStubsPtr; # undef TclGetCommandFullName # undef TclCopyChannelOld # undef TclSockMinimumBuffersOld -# undef Tcl_StaticPackage -# define Tcl_StaticPackage (tclIntStubsPtr->tclStaticPackage) +# undef Tcl_StaticLibrary +# define Tcl_StaticLibrary (tclIntStubsPtr->tclStaticLibrary) #endif #undef TclGuessPackageName +#undef TclUnusedStubEntry #ifndef TCL_NO_DEPRECATED # define TclGuessPackageName(fileName, pkgName) ((void)fileName,(void)pkgName,0) #endif diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index de308de..bd8d8e5 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -570,6 +570,11 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #undef TclpGmtime_unix #undef TclWinConvertWSAError #define TclWinConvertWSAError TclWinConvertError +#if !defined(TCL_USE_STUBS) && !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +# undef TclWinConvertError +# define TclWinConvertError Tcl_WinConvertError +#endif + #undef TclpInetNtoa #define TclpInetNtoa inet_ntoa diff --git a/generic/tclInterp.c b/generic/tclInterp.c index f724175..d63add2 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -4,8 +4,8 @@ * This file implements the "interp" command which allows creation and * manipulation of Tcl interpreters from within Tcl scripts. * - * Copyright (c) 1995-1997 Sun Microsystems, Inc. - * Copyright (c) 2004 Donal K. Fellows + * Copyright © 1995-1997 Sun Microsystems, Inc. + * Copyright © 2004 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -4785,7 +4785,7 @@ ChildTimeLimitCmd( Tcl_Obj *milliObj = NULL, *secObj = NULL; int gran = 0; Tcl_Time limitMoment; - int tmp; + Tcl_WideInt tmp; Tcl_LimitGetTime(childInterp, &limitMoment); for (i=consumedObjc ; i<objc ; i+=2) { @@ -4817,17 +4817,17 @@ ChildTimeLimitCmd( if (milliLen == 0) { break; } - if (TclGetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) { + if (TclGetWideIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) { return TCL_ERROR; } - if (tmp < 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "milliseconds must be at least 0", -1)); + if (tmp < 0 || tmp > LONG_MAX) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "milliseconds must be between 0 and %ld", LONG_MAX)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADVALUE", NULL); return TCL_ERROR; } - limitMoment.usec = ((long) tmp)*1000; + limitMoment.usec = ((long)tmp)*1000; break; case OPT_SEC: secObj = objv[i+1]; @@ -4835,17 +4835,17 @@ ChildTimeLimitCmd( if (secLen == 0) { break; } - if (TclGetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) { + if (TclGetWideIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) { return TCL_ERROR; } - if (tmp < 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "seconds must be at least 0", -1)); + if (tmp < 0 || tmp > LONG_MAX) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "seconds must be between 0 and %ld", LONG_MAX)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADVALUE", NULL); return TCL_ERROR; } - limitMoment.sec = tmp; + limitMoment.sec = (long)tmp; break; } } diff --git a/generic/tclLink.c b/generic/tclLink.c index 13bf6c4..02b19aa 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -6,10 +6,10 @@ * Andreas Stolcke and this implementation is based heavily on a * prototype implementation provided by him. * - * Copyright (c) 1993 The Regents of the University of California. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. - * Copyright (c) 2008 Rene Zaumseil - * Copyright (c) 2019 Donal K. Fellows + * Copyright © 1993 The Regents of the University of California. + * Copyright © 1994-1997 Sun Microsystems, Inc. + * Copyright © 2008 Rene Zaumseil + * Copyright © 2019 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 332e6aa..0cc1c11 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -3,9 +3,9 @@ * * This file contains functions that implement the Tcl list object type. * - * Copyright (c) 1995-1997 Sun Microsystems, Inc. - * Copyright (c) 1998 by Scriptics Corporation. - * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. + * Copyright © 1995-1997 Sun Microsystems, Inc. + * Copyright © 1998 Scriptics Corporation. + * Copyright © 2001 Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 22eff3c..fe1b00d 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -7,8 +7,8 @@ * general hashtable implementation of Tcl hash tables that appears in * tclHash.c. * - * Copyright (c) 1997-1998 Sun Microsystems, Inc. - * Copyright (c) 2004 by Kevin B. Kenny. All rights reserved. + * Copyright © 1997-1998 Sun Microsystems, Inc. + * Copyright © 2004 Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 0d331c6..c9d1b31 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -4,7 +4,7 @@ * This file provides the generic portion (those that are the same on all * platforms) of Tcl's dynamic loading facilities. * - * Copyright (c) 1995-1997 Sun Microsystems, Inc. + * Copyright © 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -13,81 +13,81 @@ #include "tclInt.h" /* - * The following structure describes a package that has been loaded either + * The following structure describes a library that has been loaded either * dynamically (with the "load" command) or statically (as indicated by a call - * to TclGetLoadedPackages). All such packages are linked together into a - * single list for the process. Packages are never unloaded, until the + * to Tcl_StaticLibrary). All such libraries are linked together into a + * single list for the process. Library are never unloaded, until the * application exits, when TclFinalizeLoad is called, and these structures are * freed. */ -typedef struct LoadedPackage { - char *fileName; /* Name of the file from which the package was - * loaded. An empty string means the package +typedef struct LoadedLibrary { + char *fileName; /* Name of the file from which the library was + * loaded. An empty string means the library * is loaded statically. Malloc-ed. */ - char *packageName; /* Name of package prefix for the package, + char *prefix; /* Prefix for the library, * properly capitalized (first letter UC, - * others LC), no "_", as in "Net". + * others LC), as in "Net". * Malloc-ed. */ Tcl_LoadHandle loadHandle; /* Token for the loaded file which should be * passed to (*unLoadProcPtr)() when the file * is no longer needed. If fileName is NULL, * then this field is irrelevant. */ - Tcl_PackageInitProc *initProc; + Tcl_LibraryInitProc *initProc; /* Initialization function to call to - * incorporate this package into a trusted + * incorporate this library into a trusted * interpreter. */ - Tcl_PackageInitProc *safeInitProc; + Tcl_LibraryInitProc *safeInitProc; /* Initialization function to call to - * incorporate this package into a safe + * incorporate this library into a safe * interpreter (one that will execute - * untrusted scripts). NULL means the package + * untrusted scripts). NULL means the library * can't be used in unsafe interpreters. */ - Tcl_PackageUnloadProc *unloadProc; - /* Finalisation function to unload a package + Tcl_LibraryUnloadProc *unloadProc; + /* Finalization function to unload a library * from a trusted interpreter. NULL means that - * the package cannot be unloaded. */ - Tcl_PackageUnloadProc *safeUnloadProc; - /* Finalisation function to unload a package + * the library cannot be unloaded. */ + Tcl_LibraryUnloadProc *safeUnloadProc; + /* Finalization function to unload a library * from a safe interpreter. NULL means that - * the package cannot be unloaded. */ - int interpRefCount; /* How many times the package has been loaded + * the library cannot be unloaded. */ + int interpRefCount; /* How many times the library has been loaded * in trusted interpreters. */ - int safeInterpRefCount; /* How many times the package has been loaded + int safeInterpRefCount; /* How many times the library has been loaded * in safe interpreters. */ - struct LoadedPackage *nextPtr; - /* Next in list of all packages loaded into + struct LoadedLibrary *nextPtr; + /* Next in list of all libraries loaded into * this application process. NULL means end of * list. */ -} LoadedPackage; +} LoadedLibrary; /* * TCL_THREADS - * There is a global list of packages that is anchored at firstPackagePtr. + * There is a global list of libraries that is anchored at firstLibraryPtr. * Access to this list is governed by a mutex. */ -static LoadedPackage *firstPackagePtr = NULL; - /* First in list of all packages loaded into +static LoadedLibrary *firstLibraryPtr = NULL; + /* First in list of all libraries loaded into * this process. */ -TCL_DECLARE_MUTEX(packageMutex) +TCL_DECLARE_MUTEX(libraryMutex) /* - * The following structure represents a particular package that has been + * The following structure represents a particular library that has been * incorporated into a particular interpreter (by calling its initialization * function). There is a list of these structures for each interpreter, with * an AssocData value (key "load") for the interpreter that points to the - * first package (if any). + * first library (if any). */ -typedef struct InterpPackage { - LoadedPackage *pkgPtr; /* Points to detailed information about - * package. */ - struct InterpPackage *nextPtr; - /* Next package in this interpreter, or NULL +typedef struct InterpLibrary { + LoadedLibrary *libraryPtr; /* Points to detailed information about + * library. */ + struct InterpLibrary *nextPtr; + /* Next library in this interpreter, or NULL * for end of list. */ -} InterpPackage; +} InterpLibrary; /* * Prototypes for functions that are private to this file: @@ -121,14 +121,14 @@ Tcl_LoadObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Interp *target; - LoadedPackage *pkgPtr, *defaultPtr; - Tcl_DString pkgName, tmp, initName, safeInitName; + LoadedLibrary *libraryPtr, *defaultPtr; + Tcl_DString pfx, tmp, initName, safeInitName; Tcl_DString unloadName, safeUnloadName; - InterpPackage *ipFirstPtr, *ipPtr; + InterpLibrary *ipFirstPtr, *ipPtr; int code, namesMatch, filesMatch, offset; const char *symbols[2]; - Tcl_PackageInitProc *initProc; - const char *p, *fullFileName, *packageName; + Tcl_LibraryInitProc *initProc; + const char *p, *fullFileName, *prefix; Tcl_LoadHandle loadHandle; Tcl_UniChar ch = 0; unsigned len; @@ -159,7 +159,7 @@ Tcl_LoadObjCmd( } } if ((objc < 2) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 1, savedobjv, "?-global? ?-lazy? ?--? fileName ?packageName? ?interp?"); + Tcl_WrongNumArgs(interp, 1, savedobjv, "?-global? ?-lazy? ?--? fileName ?prefix? ?interp?"); return TCL_ERROR; } if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { @@ -167,23 +167,23 @@ Tcl_LoadObjCmd( } fullFileName = Tcl_GetString(objv[1]); - Tcl_DStringInit(&pkgName); + Tcl_DStringInit(&pfx); Tcl_DStringInit(&initName); Tcl_DStringInit(&safeInitName); Tcl_DStringInit(&unloadName); Tcl_DStringInit(&safeUnloadName); Tcl_DStringInit(&tmp); - packageName = NULL; + prefix = NULL; if (objc >= 3) { - packageName = Tcl_GetString(objv[2]); - if (packageName[0] == '\0') { - packageName = NULL; + prefix = Tcl_GetString(objv[2]); + if (prefix[0] == '\0') { + prefix = NULL; } } - if ((fullFileName[0] == 0) && (packageName == NULL)) { + if ((fullFileName[0] == 0) && (prefix == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "must specify either file name or package name", -1)); + "must specify either file name or prefix", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOLIBRARY", NULL); code = TCL_ERROR; @@ -191,7 +191,7 @@ Tcl_LoadObjCmd( } /* - * Figure out which interpreter we're going to load the package into. + * Figure out which interpreter we're going to load the library into. */ target = interp; @@ -206,89 +206,89 @@ Tcl_LoadObjCmd( } /* - * Scan through the packages that are currently loaded to see if the - * package we want is already loaded. We'll use a loaded package if it + * Scan through the libraries that are currently loaded to see if the + * library we want is already loaded. We'll use a loaded library if it * meets any of the following conditions: * - Its name and file match the once we're looking for. * - Its file matches, and we weren't given a name. * - Its name matches, the file name was specified as empty, and there is - * only no statically loaded package with the same name. + * only no statically loaded library with the same prefix. */ - Tcl_MutexLock(&packageMutex); + Tcl_MutexLock(&libraryMutex); defaultPtr = NULL; - for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { - if (packageName == NULL) { + for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; libraryPtr = libraryPtr->nextPtr) { + if (prefix == NULL) { namesMatch = 0; } else { - TclDStringClear(&pkgName); - Tcl_DStringAppend(&pkgName, packageName, -1); + TclDStringClear(&pfx); + Tcl_DStringAppend(&pfx, prefix, -1); TclDStringClear(&tmp); - Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1); - Tcl_UtfToLower(Tcl_DStringValue(&pkgName)); + Tcl_DStringAppend(&tmp, libraryPtr->prefix, -1); + Tcl_UtfToLower(Tcl_DStringValue(&pfx)); Tcl_UtfToLower(Tcl_DStringValue(&tmp)); if (strcmp(Tcl_DStringValue(&tmp), - Tcl_DStringValue(&pkgName)) == 0) { + Tcl_DStringValue(&pfx)) == 0) { namesMatch = 1; } else { namesMatch = 0; } } - TclDStringClear(&pkgName); + TclDStringClear(&pfx); - filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0); - if (filesMatch && (namesMatch || (packageName == NULL))) { + filesMatch = (strcmp(libraryPtr->fileName, fullFileName) == 0); + if (filesMatch && (namesMatch || (prefix == NULL))) { break; } if (namesMatch && (fullFileName[0] == 0)) { - defaultPtr = pkgPtr; + defaultPtr = libraryPtr; } if (filesMatch && !namesMatch && (fullFileName[0] != 0)) { /* - * Can't have two different packages loaded from the same file. + * Can't have two different libraries loaded from the same file. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "file \"%s\" is already loaded for package \"%s\"", - fullFileName, pkgPtr->packageName)); + "file \"%s\" is already loaded for prefix \"%s\"", + fullFileName, libraryPtr->prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "SPLITPERSONALITY", NULL); code = TCL_ERROR; - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexUnlock(&libraryMutex); goto done; } } - Tcl_MutexUnlock(&packageMutex); - if (pkgPtr == NULL) { - pkgPtr = defaultPtr; + Tcl_MutexUnlock(&libraryMutex); + if (libraryPtr == NULL) { + libraryPtr = defaultPtr; } /* - * Scan through the list of packages already loaded in the target - * interpreter. If the package we want is already loaded there, then + * Scan through the list of libraries already loaded in the target + * interpreter. If the library we want is already loaded there, then * there's nothing for us to do. */ - if (pkgPtr != NULL) { - ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); + if (libraryPtr != NULL) { + ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL); for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { - if (ipPtr->pkgPtr == pkgPtr) { + if (ipPtr->libraryPtr == libraryPtr) { code = TCL_OK; goto done; } } } - if (pkgPtr == NULL) { + if (libraryPtr == NULL) { /* * The desired file isn't currently loaded, so load it. It's an error - * if the desired package is a static one. + * if the desired library is a static one. */ if (fullFileName[0] == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "package \"%s\" isn't loaded statically", packageName)); + "no library with prefix \"%s\" is loaded statically", prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOTSTATIC", NULL); code = TCL_ERROR; @@ -296,11 +296,11 @@ Tcl_LoadObjCmd( } /* - * Figure out the module name if it wasn't provided explicitly. + * Figure out the prefix if it wasn't provided explicitly. */ - if (packageName != NULL) { - Tcl_DStringAppend(&pkgName, packageName, -1); + if (prefix != NULL) { + Tcl_DStringAppend(&pfx, prefix, -1); } else { Tcl_Obj *splitPtr, *pkgGuessPtr; int pElements; @@ -311,11 +311,11 @@ Tcl_LoadObjCmd( */ /* - * The platform-specific code couldn't figure out the module - * name. Make a guess by taking the last element of the file - * name, stripping off any leading "lib", and then using all - * of the alphabetic and underline characters that follow - * that. + * The platform-specific code couldn't figure out the prefix. + * Make a guess by taking the last element of the file + * name, stripping off any leading "lib" and/or "tcl", and + * then using all of the alphabetic and underline characters + * that follow that. */ splitPtr = Tcl_FSSplitPath(objv[1], &pElements); @@ -331,6 +331,10 @@ Tcl_LoadObjCmd( pkgGuess += 3; } #endif /* __CYGWIN__ */ + if ((pkgGuess[0] == 't') && (pkgGuess[1] == 'c') + && (pkgGuess[2] == 'l')) { + pkgGuess += 3; + } for (p = pkgGuess; *p != 0; p += offset) { offset = TclUtfToUniChar(p, &ch); if ((ch > 0x100) @@ -342,85 +346,85 @@ Tcl_LoadObjCmd( if (p == pkgGuess) { Tcl_DecrRefCount(splitPtr); Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't figure out package name for %s", + "couldn't figure out prefix for %s", fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", - "WHATPACKAGE", NULL); + "WHATLIBRARY", NULL); code = TCL_ERROR; goto done; } - Tcl_DStringAppend(&pkgName, pkgGuess, p - pkgGuess); + Tcl_DStringAppend(&pfx, pkgGuess, p - pkgGuess); Tcl_DecrRefCount(splitPtr); } /* - * Fix the capitalization in the package name so that the first + * Fix the capitalization in the prefix so that the first * character is in caps (or title case) but the others are all * lower-case. */ - Tcl_DStringSetLength(&pkgName, - Tcl_UtfToTitle(Tcl_DStringValue(&pkgName))); + Tcl_DStringSetLength(&pfx, + Tcl_UtfToTitle(Tcl_DStringValue(&pfx))); /* * Compute the names of the two initialization functions, based on the - * package name. + * prefix. */ - TclDStringAppendDString(&initName, &pkgName); + TclDStringAppendDString(&initName, &pfx); TclDStringAppendLiteral(&initName, "_Init"); - TclDStringAppendDString(&safeInitName, &pkgName); + TclDStringAppendDString(&safeInitName, &pfx); TclDStringAppendLiteral(&safeInitName, "_SafeInit"); - TclDStringAppendDString(&unloadName, &pkgName); + TclDStringAppendDString(&unloadName, &pfx); TclDStringAppendLiteral(&unloadName, "_Unload"); - TclDStringAppendDString(&safeUnloadName, &pkgName); + TclDStringAppendDString(&safeUnloadName, &pfx); TclDStringAppendLiteral(&safeUnloadName, "_SafeUnload"); /* - * Call platform-specific code to load the package and find the two + * Call platform-specific code to load the library and find the two * initialization functions. */ symbols[0] = Tcl_DStringValue(&initName); symbols[1] = NULL; - Tcl_MutexLock(&packageMutex); + Tcl_MutexLock(&libraryMutex); code = Tcl_LoadFile(interp, objv[1], symbols, flags, &initProc, &loadHandle); - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexUnlock(&libraryMutex); if (code != TCL_OK) { goto done; } /* - * Create a new record to describe this package. + * Create a new record to describe this library. */ - pkgPtr = (LoadedPackage *)ckalloc(sizeof(LoadedPackage)); + libraryPtr = (LoadedLibrary *)ckalloc(sizeof(LoadedLibrary)); len = strlen(fullFileName) + 1; - pkgPtr->fileName = (char *)ckalloc(len); - memcpy(pkgPtr->fileName, fullFileName, len); - len = Tcl_DStringLength(&pkgName) + 1; - pkgPtr->packageName = (char *)ckalloc(len); - memcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName), len); - pkgPtr->loadHandle = loadHandle; - pkgPtr->initProc = initProc; - pkgPtr->safeInitProc = (Tcl_PackageInitProc *) + libraryPtr->fileName = (char *)ckalloc(len); + memcpy(libraryPtr->fileName, fullFileName, len); + len = Tcl_DStringLength(&pfx) + 1; + libraryPtr->prefix = (char *)ckalloc(len); + memcpy(libraryPtr->prefix, Tcl_DStringValue(&pfx), len); + libraryPtr->loadHandle = loadHandle; + libraryPtr->initProc = initProc; + libraryPtr->safeInitProc = (Tcl_LibraryInitProc *) Tcl_FindSymbol(interp, loadHandle, Tcl_DStringValue(&safeInitName)); - pkgPtr->unloadProc = (Tcl_PackageUnloadProc *) + libraryPtr->unloadProc = (Tcl_LibraryUnloadProc *) Tcl_FindSymbol(interp, loadHandle, Tcl_DStringValue(&unloadName)); - pkgPtr->safeUnloadProc = (Tcl_PackageUnloadProc *) + libraryPtr->safeUnloadProc = (Tcl_LibraryUnloadProc *) Tcl_FindSymbol(interp, loadHandle, Tcl_DStringValue(&safeUnloadName)); - pkgPtr->interpRefCount = 0; - pkgPtr->safeInterpRefCount = 0; + libraryPtr->interpRefCount = 0; + libraryPtr->safeInterpRefCount = 0; - Tcl_MutexLock(&packageMutex); - pkgPtr->nextPtr = firstPackagePtr; - firstPackagePtr = pkgPtr; - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexLock(&libraryMutex); + libraryPtr->nextPtr = firstLibraryPtr; + firstLibraryPtr = libraryPtr; + Tcl_MutexUnlock(&libraryMutex); /* * The Tcl_FindSymbol calls may have left a spurious error message in @@ -431,32 +435,32 @@ Tcl_LoadObjCmd( } /* - * Invoke the package's initialization function (either the normal one or + * Invoke the library's initialization function (either the normal one or * the safe one, depending on whether or not the interpreter is safe). */ if (Tcl_IsSafe(target)) { - if (pkgPtr->safeInitProc == NULL) { + if (libraryPtr->safeInitProc == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't use package in a safe interpreter: no" - " %s_SafeInit procedure", pkgPtr->packageName)); + "can't use library in a safe interpreter: no" + " %s_SafeInit procedure", libraryPtr->prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "UNSAFE", NULL); code = TCL_ERROR; goto done; } - code = pkgPtr->safeInitProc(target); + code = libraryPtr->safeInitProc(target); } else { - if (pkgPtr->initProc == NULL) { + if (libraryPtr->initProc == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't attach package to interpreter: no %s_Init procedure", - pkgPtr->packageName)); + "can't attach library to interpreter: no %s_Init procedure", + libraryPtr->prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "ENTRYPOINT", NULL); code = TCL_ERROR; goto done; } - code = pkgPtr->initProc(target); + code = libraryPtr->initProc(target); } /* @@ -483,33 +487,33 @@ Tcl_LoadObjCmd( } /* - * Record the fact that the package has been loaded in the target + * Record the fact that the library has been loaded in the target * interpreter. * * Update the proper reference count. */ - Tcl_MutexLock(&packageMutex); + Tcl_MutexLock(&libraryMutex); if (Tcl_IsSafe(target)) { - pkgPtr->safeInterpRefCount++; + libraryPtr->safeInterpRefCount++; } else { - pkgPtr->interpRefCount++; + libraryPtr->interpRefCount++; } - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexUnlock(&libraryMutex); /* - * Refetch ipFirstPtr: loading the package may have introduced additional - * static packages at the head of the linked list! + * Refetch ipFirstPtr: loading the library may have introduced additional + * static libraries at the head of the linked list! */ - ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); - ipPtr = (InterpPackage *)ckalloc(sizeof(InterpPackage)); - ipPtr->pkgPtr = pkgPtr; + ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL); + ipPtr = (InterpLibrary *)ckalloc(sizeof(InterpLibrary)); + ipPtr->libraryPtr = libraryPtr; ipPtr->nextPtr = ipFirstPtr; Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipPtr); done: - Tcl_DStringFree(&pkgName); + Tcl_DStringFree(&pfx); Tcl_DStringFree(&initName); Tcl_DStringFree(&safeInitName); Tcl_DStringFree(&unloadName); @@ -543,14 +547,14 @@ Tcl_UnloadObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Interp *target; /* Which interpreter to unload from. */ - LoadedPackage *pkgPtr, *defaultPtr; - Tcl_DString pkgName, tmp; - Tcl_PackageUnloadProc *unloadProc; - InterpPackage *ipFirstPtr, *ipPtr; + LoadedLibrary *libraryPtr, *defaultPtr; + Tcl_DString pfx, tmp; + Tcl_LibraryUnloadProc *unloadProc; + InterpLibrary *ipFirstPtr, *ipPtr; int i, index, code, complain = 1, keepLibrary = 0; int trustedRefCount = -1, safeRefCount = -1; const char *fullFileName = ""; - const char *packageName; + const char *prefix; static const char *const options[] = { "-nocomplain", "-keeplibrary", "--", NULL }; @@ -594,7 +598,7 @@ Tcl_UnloadObjCmd( endOfForLoop: if ((objc-i < 1) || (objc-i > 3)) { Tcl_WrongNumArgs(interp, 1, objv, - "?-switch ...? fileName ?packageName? ?interp?"); + "?-switch ...? fileName ?prefix? ?interp?"); return TCL_ERROR; } if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) { @@ -602,19 +606,19 @@ Tcl_UnloadObjCmd( } fullFileName = Tcl_GetString(objv[i]); - Tcl_DStringInit(&pkgName); + Tcl_DStringInit(&pfx); Tcl_DStringInit(&tmp); - packageName = NULL; + prefix = NULL; if (objc - i >= 2) { - packageName = Tcl_GetString(objv[i+1]); - if (packageName[0] == '\0') { - packageName = NULL; + prefix = Tcl_GetString(objv[i+1]); + if (prefix[0] == '\0') { + prefix = NULL; } } - if ((fullFileName[0] == 0) && (packageName == NULL)) { + if ((fullFileName[0] == 0) && (prefix == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "must specify either file name or package name", -1)); + "must specify either file name or prefix", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NOLIBRARY", NULL); code = TCL_ERROR; @@ -622,7 +626,7 @@ Tcl_UnloadObjCmd( } /* - * Figure out which interpreter we're going to load the package into. + * Figure out which interpreter we're going to load the library into. */ target = interp; @@ -636,65 +640,65 @@ Tcl_UnloadObjCmd( } /* - * Scan through the packages that are currently loaded to see if the - * package we want is already loaded. We'll use a loaded package if it + * Scan through the libraries that are currently loaded to see if the + * library we want is already loaded. We'll use a loaded library if it * meets any of the following conditions: - * - Its name and file match the once we're looking for. - * - Its file matches, and we weren't given a name. - * - Its name matches, the file name was specified as empty, and there is - * only no statically loaded package with the same name. + * - Its prefix and file match the once we're looking for. + * - Its file matches, and we weren't given a prefix. + * - Its prefix matches, the file name was specified as empty, and there is + * only no statically loaded library with the same prefix. */ - Tcl_MutexLock(&packageMutex); + Tcl_MutexLock(&libraryMutex); defaultPtr = NULL; - for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { + for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; libraryPtr = libraryPtr->nextPtr) { int namesMatch, filesMatch; - if (packageName == NULL) { + if (prefix == NULL) { namesMatch = 0; } else { - TclDStringClear(&pkgName); - Tcl_DStringAppend(&pkgName, packageName, -1); + TclDStringClear(&pfx); + Tcl_DStringAppend(&pfx, prefix, -1); TclDStringClear(&tmp); - Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1); - Tcl_UtfToLower(Tcl_DStringValue(&pkgName)); + Tcl_DStringAppend(&tmp, libraryPtr->prefix, -1); + Tcl_UtfToLower(Tcl_DStringValue(&pfx)); Tcl_UtfToLower(Tcl_DStringValue(&tmp)); if (strcmp(Tcl_DStringValue(&tmp), - Tcl_DStringValue(&pkgName)) == 0) { + Tcl_DStringValue(&pfx)) == 0) { namesMatch = 1; } else { namesMatch = 0; } } - TclDStringClear(&pkgName); + TclDStringClear(&pfx); - filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0); - if (filesMatch && (namesMatch || (packageName == NULL))) { + filesMatch = (strcmp(libraryPtr->fileName, fullFileName) == 0); + if (filesMatch && (namesMatch || (prefix == NULL))) { break; } if (namesMatch && (fullFileName[0] == 0)) { - defaultPtr = pkgPtr; + defaultPtr = libraryPtr; } if (filesMatch && !namesMatch && (fullFileName[0] != 0)) { break; } } - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexUnlock(&libraryMutex); if (fullFileName[0] == 0) { /* - * It's an error to try unload a static package. + * It's an error to try unload a static library. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "package \"%s\" is loaded statically and cannot be unloaded", - packageName)); + "library with prefix \"%s\" is loaded statically and cannot be unloaded", + prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "STATIC", NULL); code = TCL_ERROR; goto done; } - if (pkgPtr == NULL) { + if (libraryPtr == NULL) { /* * The DLL pointed by the provided filename has never been loaded. */ @@ -708,16 +712,16 @@ Tcl_UnloadObjCmd( } /* - * Scan through the list of packages already loaded in the target - * interpreter. If the package we want is already loaded there, then we + * Scan through the list of libraries already loaded in the target + * interpreter. If the library we want is already loaded there, then we * should proceed with unloading. */ code = TCL_ERROR; - if (pkgPtr != NULL) { - ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); + if (libraryPtr != NULL) { + ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL); for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { - if (ipPtr->pkgPtr == pkgPtr) { + if (ipPtr->libraryPtr == libraryPtr) { code = TCL_OK; break; } @@ -725,7 +729,7 @@ Tcl_UnloadObjCmd( } if (code != TCL_OK) { /* - * The package has not been loaded in this interpreter. + * The library has not been loaded in this interpreter. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -739,12 +743,12 @@ Tcl_UnloadObjCmd( /* * Ensure that the DLL can be unloaded. If it is a trusted interpreter, - * pkgPtr->unloadProc must not be NULL for the DLL to be unloadable. If - * the interpreter is a safe one, pkgPtr->safeUnloadProc must be non-NULL. + * libraryPtr->unloadProc must not be NULL for the DLL to be unloadable. If + * the interpreter is a safe one, libraryPtr->safeUnloadProc must be non-NULL. */ if (Tcl_IsSafe(target)) { - if (pkgPtr->safeUnloadProc == NULL) { + if (libraryPtr->safeUnloadProc == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "file \"%s\" cannot be unloaded under a safe interpreter", fullFileName)); @@ -753,9 +757,9 @@ Tcl_UnloadObjCmd( code = TCL_ERROR; goto done; } - unloadProc = pkgPtr->safeUnloadProc; + unloadProc = libraryPtr->safeUnloadProc; } else { - if (pkgPtr->unloadProc == NULL) { + if (libraryPtr->unloadProc == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "file \"%s\" cannot be unloaded under a trusted interpreter", fullFileName)); @@ -764,11 +768,11 @@ Tcl_UnloadObjCmd( code = TCL_ERROR; goto done; } - unloadProc = pkgPtr->unloadProc; + unloadProc = libraryPtr->unloadProc; } /* - * We are ready to unload the package. First, evaluate the unload + * We are ready to unload the library. First, evaluate the unload * function. If this fails, we cannot proceed with unload. Also, we must * specify the proper flag to pass to the unload callback. * TCL_UNLOAD_DETACH_FROM_INTERPRETER is defined when the callback should @@ -779,10 +783,10 @@ Tcl_UnloadObjCmd( code = TCL_UNLOAD_DETACH_FROM_INTERPRETER; if (!keepLibrary) { - Tcl_MutexLock(&packageMutex); - trustedRefCount = pkgPtr->interpRefCount; - safeRefCount = pkgPtr->safeInterpRefCount; - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexLock(&libraryMutex); + trustedRefCount = libraryPtr->interpRefCount; + safeRefCount = libraryPtr->safeInterpRefCount; + Tcl_MutexUnlock(&libraryMutex); if (Tcl_IsSafe(target)) { safeRefCount--; @@ -805,34 +809,34 @@ Tcl_UnloadObjCmd( * if we unload the DLL. */ - Tcl_MutexLock(&packageMutex); + Tcl_MutexLock(&libraryMutex); if (Tcl_IsSafe(target)) { - pkgPtr->safeInterpRefCount--; + libraryPtr->safeInterpRefCount--; /* * Do not let counter get negative. */ - if (pkgPtr->safeInterpRefCount < 0) { - pkgPtr->safeInterpRefCount = 0; + if (libraryPtr->safeInterpRefCount < 0) { + libraryPtr->safeInterpRefCount = 0; } } else { - pkgPtr->interpRefCount--; + libraryPtr->interpRefCount--; /* * Do not let counter get negative. */ - if (pkgPtr->interpRefCount < 0) { - pkgPtr->interpRefCount = 0; + if (libraryPtr->interpRefCount < 0) { + libraryPtr->interpRefCount = 0; } } - trustedRefCount = pkgPtr->interpRefCount; - safeRefCount = pkgPtr->safeInterpRefCount; - Tcl_MutexUnlock(&packageMutex); + trustedRefCount = libraryPtr->interpRefCount; + safeRefCount = libraryPtr->safeInterpRefCount; + Tcl_MutexUnlock(&libraryMutex); code = TCL_OK; - if (pkgPtr->safeInterpRefCount <= 0 && pkgPtr->interpRefCount <= 0 + if (libraryPtr->safeInterpRefCount <= 0 && libraryPtr->interpRefCount <= 0 && !keepLibrary) { /* * Unload the shared library from the application memory... @@ -846,21 +850,21 @@ Tcl_UnloadObjCmd( * it's been unloaded. */ - if (pkgPtr->fileName[0] != '\0') { - Tcl_MutexLock(&packageMutex); - if (Tcl_FSUnloadFile(interp, pkgPtr->loadHandle) == TCL_OK) { + if (libraryPtr->fileName[0] != '\0') { + Tcl_MutexLock(&libraryMutex); + if (Tcl_FSUnloadFile(interp, libraryPtr->loadHandle) == TCL_OK) { /* * Remove this library from the loaded library cache. */ - defaultPtr = pkgPtr; - if (defaultPtr == firstPackagePtr) { - firstPackagePtr = pkgPtr->nextPtr; + defaultPtr = libraryPtr; + if (defaultPtr == firstLibraryPtr) { + firstLibraryPtr = libraryPtr->nextPtr; } else { - for (pkgPtr = firstPackagePtr; pkgPtr != NULL; - pkgPtr = pkgPtr->nextPtr) { - if (pkgPtr->nextPtr == defaultPtr) { - pkgPtr->nextPtr = defaultPtr->nextPtr; + for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; + libraryPtr = libraryPtr->nextPtr) { + if (libraryPtr->nextPtr == defaultPtr) { + libraryPtr->nextPtr = defaultPtr->nextPtr; break; } } @@ -870,16 +874,16 @@ Tcl_UnloadObjCmd( * Remove this library from the interpreter's library cache. */ - ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); + ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL); ipPtr = ipFirstPtr; - if (ipPtr->pkgPtr == defaultPtr) { + if (ipPtr->libraryPtr == defaultPtr) { ipFirstPtr = ipFirstPtr->nextPtr; } else { - InterpPackage *ipPrevPtr; + InterpLibrary *ipPrevPtr; for (ipPrevPtr = ipPtr; ipPtr != NULL; ipPrevPtr = ipPtr, ipPtr = ipPtr->nextPtr) { - if (ipPtr->pkgPtr == defaultPtr) { + if (ipPtr->libraryPtr == defaultPtr) { ipPrevPtr->nextPtr = ipPtr->nextPtr; break; } @@ -888,10 +892,10 @@ Tcl_UnloadObjCmd( Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipFirstPtr); ckfree(defaultPtr->fileName); - ckfree(defaultPtr->packageName); + ckfree(defaultPtr->prefix); ckfree(defaultPtr); ckfree(ipPtr); - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexUnlock(&libraryMutex); } else { code = TCL_ERROR; } @@ -907,7 +911,7 @@ Tcl_UnloadObjCmd( } done: - Tcl_DStringFree(&pkgName); + Tcl_DStringFree(&pfx); Tcl_DStringFree(&tmp); if (!complain && (code != TCL_OK)) { code = TCL_OK; @@ -919,99 +923,99 @@ Tcl_UnloadObjCmd( /* *---------------------------------------------------------------------- * - * Tcl_StaticPackage -- + * Tcl_StaticLibrary -- * - * This function is invoked to indicate that a particular package has + * This function is invoked to indicate that a particular library has * been linked statically with an application. * * Results: * None. * * Side effects: - * Once this function completes, the package becomes loadable via the + * Once this function completes, the library becomes loadable via the * "load" command with an empty file name. * *---------------------------------------------------------------------- */ void -Tcl_StaticPackage( - Tcl_Interp *interp, /* If not NULL, it means that the package has +Tcl_StaticLibrary( + Tcl_Interp *interp, /* If not NULL, it means that the library has * already been loaded into the given * interpreter by calling the appropriate init * proc. */ - const char *pkgName, /* Name of package (must be properly + const char *prefix, /* Prefix (must be properly * capitalized: first letter upper case, * others lower case). */ - Tcl_PackageInitProc *initProc, + Tcl_LibraryInitProc *initProc, /* Function to call to incorporate this - * package into a trusted interpreter. */ - Tcl_PackageInitProc *safeInitProc) + * library into a trusted interpreter. */ + Tcl_LibraryInitProc *safeInitProc) /* Function to call to incorporate this - * package into a safe interpreter (one that + * library into a safe interpreter (one that * will execute untrusted scripts). NULL means - * the package can't be used in safe + * the library can't be used in safe * interpreters. */ { - LoadedPackage *pkgPtr; - InterpPackage *ipPtr, *ipFirstPtr; + LoadedLibrary *libraryPtr; + InterpLibrary *ipPtr, *ipFirstPtr; /* - * Check to see if someone else has already reported this package as + * Check to see if someone else has already reported this library as * statically loaded in the process. */ - Tcl_MutexLock(&packageMutex); - for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { - if ((pkgPtr->initProc == initProc) - && (pkgPtr->safeInitProc == safeInitProc) - && (strcmp(pkgPtr->packageName, pkgName) == 0)) { + Tcl_MutexLock(&libraryMutex); + for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; libraryPtr = libraryPtr->nextPtr) { + if ((libraryPtr->initProc == initProc) + && (libraryPtr->safeInitProc == safeInitProc) + && (strcmp(libraryPtr->prefix, prefix) == 0)) { break; } } - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexUnlock(&libraryMutex); /* - * If the package is not yet recorded as being loaded statically, add it + * If the library is not yet recorded as being loaded statically, add it * to the list now. */ - if (pkgPtr == NULL) { - pkgPtr = (LoadedPackage *)ckalloc(sizeof(LoadedPackage)); - pkgPtr->fileName = (char *)ckalloc(1); - pkgPtr->fileName[0] = 0; - pkgPtr->packageName = (char *)ckalloc(strlen(pkgName) + 1); - strcpy(pkgPtr->packageName, pkgName); - pkgPtr->loadHandle = NULL; - pkgPtr->initProc = initProc; - pkgPtr->safeInitProc = safeInitProc; - Tcl_MutexLock(&packageMutex); - pkgPtr->nextPtr = firstPackagePtr; - firstPackagePtr = pkgPtr; - Tcl_MutexUnlock(&packageMutex); + if (libraryPtr == NULL) { + libraryPtr = (LoadedLibrary *)ckalloc(sizeof(LoadedLibrary)); + libraryPtr->fileName = (char *)ckalloc(1); + libraryPtr->fileName[0] = 0; + libraryPtr->prefix = (char *)ckalloc(strlen(prefix) + 1); + strcpy(libraryPtr->prefix, prefix); + libraryPtr->loadHandle = NULL; + libraryPtr->initProc = initProc; + libraryPtr->safeInitProc = safeInitProc; + Tcl_MutexLock(&libraryMutex); + libraryPtr->nextPtr = firstLibraryPtr; + firstLibraryPtr = libraryPtr; + Tcl_MutexUnlock(&libraryMutex); } if (interp != NULL) { /* - * If we're loading the package into an interpreter, determine whether + * If we're loading the library into an interpreter, determine whether * it's already loaded. */ - ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(interp, "tclLoad", NULL); + ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(interp, "tclLoad", NULL); for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { - if (ipPtr->pkgPtr == pkgPtr) { + if (ipPtr->libraryPtr == libraryPtr) { return; } } /* - * Package isn't loaded in the current interp yet. Mark it as now being + * Library isn't loaded in the current interp yet. Mark it as now being * loaded. */ - ipPtr = (InterpPackage *)ckalloc(sizeof(InterpPackage)); - ipPtr->pkgPtr = pkgPtr; + ipPtr = (InterpLibrary *)ckalloc(sizeof(InterpLibrary)); + ipPtr->libraryPtr = libraryPtr; ipPtr->nextPtr = ipFirstPtr; Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, ipPtr); } @@ -1020,7 +1024,7 @@ Tcl_StaticPackage( /* *---------------------------------------------------------------------- * - * TclGetLoadedPackagesEx -- + * TclGetLoadedLibraries -- * * This function returns information about all of the files that are * loaded (either in a particular interpreter, or for all interpreters). @@ -1030,7 +1034,7 @@ Tcl_StaticPackage( * list of lists is placed in the interp's result. Each sublist * corresponds to one loaded file; its first element is the name of the * file (or an empty string for something that's statically loaded) and - * the second element is the name of the package in that file. + * the second element is the prefix of the library in that file. * * Side effects: * None. @@ -1039,33 +1043,33 @@ Tcl_StaticPackage( */ int -TclGetLoadedPackagesEx( +TclGetLoadedLibraries( Tcl_Interp *interp, /* Interpreter in which to return information * or error message. */ const char *targetName, /* Name of target interpreter or NULL. If * NULL, return info about all interps; * otherwise, just return info about this * interpreter. */ - const char *packageName) /* Package name or NULL. If NULL, return info - * for all packages. + const char *prefix) /* Prefix or NULL. If NULL, return info + * for all prefixes. */ { Tcl_Interp *target; - LoadedPackage *pkgPtr; - InterpPackage *ipPtr; + LoadedLibrary *libraryPtr; + InterpLibrary *ipPtr; Tcl_Obj *resultObj, *pkgDesc[2]; if (targetName == NULL) { TclNewObj(resultObj); - Tcl_MutexLock(&packageMutex); - for (pkgPtr = firstPackagePtr; pkgPtr != NULL; - pkgPtr = pkgPtr->nextPtr) { - pkgDesc[0] = Tcl_NewStringObj(pkgPtr->fileName, -1); - pkgDesc[1] = Tcl_NewStringObj(pkgPtr->packageName, -1); + Tcl_MutexLock(&libraryMutex); + for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; + libraryPtr = libraryPtr->nextPtr) { + pkgDesc[0] = Tcl_NewStringObj(libraryPtr->fileName, -1); + pkgDesc[1] = Tcl_NewStringObj(libraryPtr->prefix, -1); Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewListObj(2, pkgDesc)); } - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexUnlock(&libraryMutex); Tcl_SetObjResult(interp, resultObj); return TCL_OK; } @@ -1074,19 +1078,19 @@ TclGetLoadedPackagesEx( if (target == NULL) { return TCL_ERROR; } - ipPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); + ipPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL); /* - * Return information about all of the available packages. + * Return information about all of the available libraries. */ - if (packageName) { + if (prefix) { resultObj = NULL; for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { - pkgPtr = ipPtr->pkgPtr; + libraryPtr = ipPtr->libraryPtr; - if (!strcmp(packageName, pkgPtr->packageName)) { - resultObj = Tcl_NewStringObj(pkgPtr->fileName, -1); + if (!strcmp(prefix, libraryPtr->prefix)) { + resultObj = Tcl_NewStringObj(libraryPtr->fileName, -1); break; } } @@ -1098,15 +1102,15 @@ TclGetLoadedPackagesEx( } /* - * Return information about only the packages that are loaded in a given + * Return information about only the libraries that are loaded in a given * interpreter. */ TclNewObj(resultObj); for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { - pkgPtr = ipPtr->pkgPtr; - pkgDesc[0] = Tcl_NewStringObj(pkgPtr->fileName, -1); - pkgDesc[1] = Tcl_NewStringObj(pkgPtr->packageName, -1); + libraryPtr = ipPtr->libraryPtr; + pkgDesc[0] = Tcl_NewStringObj(libraryPtr->fileName, -1); + pkgDesc[1] = Tcl_NewStringObj(libraryPtr->prefix, -1); Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewListObj(2, pkgDesc)); } Tcl_SetObjResult(interp, resultObj); @@ -1118,7 +1122,7 @@ TclGetLoadedPackagesEx( * * LoadCleanupProc -- * - * This function is called to delete all of the InterpPackage structures + * This function is called to delete all of the InterpLibrary structures * for an interpreter when the interpreter is deleted. It gets invoked * via the Tcl AssocData mechanism. * @@ -1126,20 +1130,20 @@ TclGetLoadedPackagesEx( * None. * * Side effects: - * Storage for all of the InterpPackage functions for interp get deleted. + * Storage for all of the InterpLibrary functions for interp get deleted. * *---------------------------------------------------------------------- */ static void LoadCleanupProc( - ClientData clientData, /* Pointer to first InterpPackage structure + ClientData clientData, /* Pointer to first InterpLibrary structure * for interp. */ TCL_UNUSED(Tcl_Interp *)) { - InterpPackage *ipPtr, *nextPtr; + InterpLibrary *ipPtr, *nextPtr; - ipPtr = (InterpPackage *)clientData; + ipPtr = (InterpLibrary *)clientData; while (ipPtr != NULL) { nextPtr = ipPtr->nextPtr; ckfree(ipPtr); @@ -1153,7 +1157,7 @@ LoadCleanupProc( * TclFinalizeLoad -- * * This function is invoked just before the application exits. It frees - * all of the LoadedPackage structures. + * all of the LoadedLibrary structures. * * Results: * None. @@ -1167,18 +1171,18 @@ LoadCleanupProc( void TclFinalizeLoad(void) { - LoadedPackage *pkgPtr; + LoadedLibrary *libraryPtr; /* * No synchronization here because there should just be one thread alive - * at this point. Logically, packageMutex should be grabbed at this point, + * at this point. Logically, libraryMutex should be grabbed at this point, * but the Mutexes get finalized before the call to this routine. The only * subsystem left alive at this point is the memory allocator. */ - while (firstPackagePtr != NULL) { - pkgPtr = firstPackagePtr; - firstPackagePtr = pkgPtr->nextPtr; + while (firstLibraryPtr != NULL) { + libraryPtr = firstLibraryPtr; + firstLibraryPtr = libraryPtr->nextPtr; #if defined(TCL_UNLOAD_DLLS) || defined(_WIN32) /* @@ -1188,14 +1192,14 @@ TclFinalizeLoad(void) * it has been unloaded. */ - if (pkgPtr->fileName[0] != '\0') { - Tcl_FSUnloadFile(NULL, pkgPtr->loadHandle); + if (libraryPtr->fileName[0] != '\0') { + Tcl_FSUnloadFile(NULL, libraryPtr->loadHandle); } #endif - ckfree(pkgPtr->fileName); - ckfree(pkgPtr->packageName); - ckfree(pkgPtr); + ckfree(libraryPtr->fileName); + ckfree(libraryPtr->prefix); + ckfree(libraryPtr); } } diff --git a/generic/tclLoadNone.c b/generic/tclLoadNone.c index e9f79e2..f60f843 100644 --- a/generic/tclLoadNone.c +++ b/generic/tclLoadNone.c @@ -4,7 +4,7 @@ * This procedure provides a version of the TclpDlopen for use in * systems that don't support dynamic loading; it just returns an error. * - * Copyright (c) 1995-1997 Sun Microsystems, Inc. + * Copyright © 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclMain.c b/generic/tclMain.c index cc9a829..bb48dbb 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -8,9 +8,9 @@ * application. Or, it can be used as a template for creating new main * programs for Tcl applications. * - * Copyright (c) 1988-1994 The Regents of the University of California. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. - * Copyright (c) 2000 Ajuba Solutions. + * Copyright © 1988-1994 The Regents of the University of California. + * Copyright © 1994-1997 Sun Microsystems, Inc. + * Copyright © 2000 Ajuba Solutions. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -64,11 +64,6 @@ NewNativeObj( * source directory to make their own modified versions). */ -#if defined _MSC_VER && _MSC_VER < 1900 -/* isatty is always defined on MSVC 14.0, but not necessarily as CRTIMPORT. */ -extern CRTIMPORT int isatty(int fd); -#endif - /* * The thread-local variables for this file's functions. */ diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index e493db1..f57b7e1 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -7,11 +7,11 @@ * children of the global namespace. These other namespaces contain * special-purpose commands and variables for packages. * - * Copyright (c) 1993-1997 Lucent Technologies. - * Copyright (c) 1997 Sun Microsystems, Inc. - * Copyright (c) 1998-1999 by Scriptics Corporation. - * Copyright (c) 2002-2005 Donal K. Fellows. - * Copyright (c) 2006 Neil Madden. + * Copyright © 1993-1997 Lucent Technologies. + * Copyright © 1997 Sun Microsystems, Inc. + * Copyright © 1998-1999 Scriptics Corporation. + * Copyright © 2002-2005 Donal K. Fellows. + * Copyright © 2006 Neil Madden. * Contributions from Don Porter, NIST, 2007. (not subject to US copyright) * * Originally implemented by diff --git a/generic/tclNotify.c b/generic/tclNotify.c index 65b4197..12b40b1 100644 --- a/generic/tclNotify.c +++ b/generic/tclNotify.c @@ -7,9 +7,10 @@ * of the notifier is defined in the tcl*Notify.c files in each platform * directory. * - * Copyright (c) 1995-1997 Sun Microsystems, Inc. - * Copyright (c) 1998 by Scriptics Corporation. - * Copyright (c) 2003 by Kevin B. Kenny. All rights reserved. + * Copyright © 1995-1997 Sun Microsystems, Inc. + * Copyright © 1998 Scriptics Corporation. + * Copyright © 2003 Kevin B. Kenny. All rights reserved. + * Copyright © 2021 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -18,11 +19,11 @@ #include "tclInt.h" /* - * Module-scope struct of notifier hooks that are checked in the default + * Notifier hooks that are checked in the public wrappers for the default * notifier functions (for overriding via Tcl_SetNotifier). */ -Tcl_NotifierProcs tclNotifierHooks = { +static Tcl_NotifierProcs tclNotifierHooks = { NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL }; @@ -174,7 +175,8 @@ TclFinalizeNotifier(void) Tcl_Event *evPtr, *hold; if (!tsdPtr->initialized) { - return; /* Notifier not initialized for the current thread */ + return; /* Notifier not initialized for the current + * thread. */ } Tcl_MutexLock(&(tsdPtr->queueMutex)); @@ -227,6 +229,38 @@ Tcl_SetNotifier( Tcl_NotifierProcs *notifierProcPtr) { tclNotifierHooks = *notifierProcPtr; + + /* + * Don't allow hooks to refer to the hook point functions; avoids infinite + * loop. + */ + + if (tclNotifierHooks.setTimerProc == Tcl_SetTimer) { + tclNotifierHooks.setTimerProc = NULL; + } + if (tclNotifierHooks.waitForEventProc == Tcl_WaitForEvent) { + tclNotifierHooks.waitForEventProc = NULL; + } + if (tclNotifierHooks.initNotifierProc == Tcl_InitNotifier) { + tclNotifierHooks.initNotifierProc = NULL; + } + if (tclNotifierHooks.finalizeNotifierProc == Tcl_FinalizeNotifier) { + tclNotifierHooks.finalizeNotifierProc = NULL; + } + if (tclNotifierHooks.alertNotifierProc == Tcl_AlertNotifier) { + tclNotifierHooks.alertNotifierProc = NULL; + } + if (tclNotifierHooks.serviceModeHookProc == Tcl_ServiceModeHook) { + tclNotifierHooks.serviceModeHookProc = NULL; + } +#ifndef _WIN32 + if (tclNotifierHooks.createFileHandlerProc == Tcl_CreateFileHandler) { + tclNotifierHooks.createFileHandlerProc = NULL; + } + if (tclNotifierHooks.deleteFileHandlerProc == Tcl_DeleteFileHandler) { + tclNotifierHooks.deleteFileHandlerProc = NULL; + } +#endif /* !_WIN32 */ } /* @@ -276,7 +310,7 @@ Tcl_CreateEventSource( * checkProc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - EventSource *sourcePtr = (EventSource *)ckalloc(sizeof(EventSource)); + EventSource *sourcePtr = (EventSource *) ckalloc(sizeof(EventSource)); sourcePtr->setupProc = setupProc; sourcePtr->checkProc = checkProc; @@ -794,7 +828,7 @@ Tcl_SetServiceMode( void Tcl_SetMaxBlockTime( - const Tcl_Time *timePtr) /* Specifies a maximum elapsed time for the + const Tcl_Time *timePtr) /* Specifies a maximum elapsed time for the * next blocking operation in the event * tsdPtr-> */ { @@ -1133,6 +1167,260 @@ Tcl_ThreadAlert( } /* + *---------------------------------------------------------------------- + * + * Tcl_InitNotifier -- + * + * Initializes the platform specific notifier state. Forwards to the + * platform implementation when the hook is not enabled. + * + * Results: + * Returns a handle to the notifier state for this thread.. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ClientData +Tcl_InitNotifier(void) +{ + if (tclNotifierHooks.initNotifierProc) { + return tclNotifierHooks.initNotifierProc(); + } else { + return TclpInitNotifier(); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FinalizeNotifier -- + * + * This function is called to cleanup the notifier state before a thread + * is terminated. Forwards to the platform implementation when the hook + * is not enabled. + * + * Results: + * None. + * + * Side effects: + * If no finalizeNotifierProc notifier hook exists, TclpFinalizeNotifier + * is called. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_FinalizeNotifier( + ClientData clientData) +{ + if (tclNotifierHooks.finalizeNotifierProc) { + tclNotifierHooks.finalizeNotifierProc(clientData); + } else { + TclpFinalizeNotifier(clientData); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AlertNotifier -- + * + * Wake up the specified notifier from any thread. This routine is called + * by the platform independent notifier code whenever the Tcl_ThreadAlert + * routine is called. This routine is guaranteed not to be called by Tcl + * on a given notifier after Tcl_FinalizeNotifier is called for that + * notifier. This routine is typically called from a thread other than + * the notifier's thread. Forwards to the platform implementation when + * the hook is not enabled. + * + * Results: + * None. + * + * Side effects: + * See the platform-specific implementations. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AlertNotifier( + ClientData clientData) /* Pointer to thread data. */ +{ + if (tclNotifierHooks.alertNotifierProc) { + tclNotifierHooks.alertNotifierProc(clientData); + } else { + TclpAlertNotifier(clientData); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ServiceModeHook -- + * + * This function is invoked whenever the service mode changes. Forwards + * to the platform implementation when the hook is not enabled. + * + * Results: + * None. + * + * Side effects: + * See the platform-specific implementations. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_ServiceModeHook( + int mode) /* Either TCL_SERVICE_ALL, or + * TCL_SERVICE_NONE. */ +{ + if (tclNotifierHooks.serviceModeHookProc) { + tclNotifierHooks.serviceModeHookProc(mode); + } else { + TclpServiceModeHook(mode); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetTimer -- + * + * This function sets the current notifier timer value. Forwards to the + * platform implementation when the hook is not enabled. + * + * Results: + * None. + * + * Side effects: + * See the platform-specific implementations. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetTimer( + const Tcl_Time *timePtr) /* Timeout value, may be NULL. */ +{ + if (tclNotifierHooks.setTimerProc) { + tclNotifierHooks.setTimerProc(timePtr); + } else { + TclpSetTimer(timePtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_WaitForEvent -- + * + * This function is called by Tcl_DoOneEvent to wait for new events on + * the notifier's message queue. If the block time is 0, then + * Tcl_WaitForEvent just polls without blocking. Forwards to the + * platform implementation when the hook is not enabled. + * + * Results: + * Returns -1 if the wait would block forever, 1 if an out-of-loop source + * was processed (see platform-specific notes) and otherwise returns 0. + * + * Side effects: + * Queues file events that are detected by the notifier. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_WaitForEvent( + const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ +{ + if (tclNotifierHooks.waitForEventProc) { + return tclNotifierHooks.waitForEventProc(timePtr); + } else { + return TclpWaitForEvent(timePtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateFileHandler -- + * + * This function registers a file descriptor handler with the notifier. + * Forwards to the platform implementation when the hook is not enabled. + * + * This function is not defined on Windows. The OS API there is too + * different. + * + * Results: + * None. + * + * Side effects: + * Creates a new file handler structure. + * + *---------------------------------------------------------------------- + */ + +#ifndef _WIN32 +void +Tcl_CreateFileHandler( + int fd, /* Handle of stream to watch. */ + int mask, /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, and TCL_EXCEPTION: indicates + * conditions under which proc should be + * called. */ + Tcl_FileProc *proc, /* Function to call for each selected + * event. */ + ClientData clientData) /* Arbitrary data to pass to proc. */ +{ + if (tclNotifierHooks.createFileHandlerProc) { + tclNotifierHooks.createFileHandlerProc(fd, mask, proc, clientData); + } else { + TclpCreateFileHandler(fd, mask, proc, clientData); + } +} +#endif /* !_WIN32 */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteFileHandler -- + * + * Cancel a previously-arranged callback arrangement for a file + * descriptor. Forwards to the platform implementation when the hook is + * not enabled. + * + * This function is not defined on Windows. The OS API there is too + * different. + * + * Results: + * None. + * + * Side effects: + * If a callback was previously registered on the file descriptor, remove + * it. + * + *---------------------------------------------------------------------- + */ + +#ifndef _WIN32 +void +Tcl_DeleteFileHandler( + int fd) /* Stream id for which to remove callback + * function. */ +{ + if (tclNotifierHooks.deleteFileHandlerProc) { + tclNotifierHooks.deleteFileHandlerProc(fd); + } else { + TclpDeleteFileHandler(fd); + } +} +#endif /* !_WIN32 */ + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclOO.c b/generic/tclOO.c index b60ab1f..405d5d0 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -3,8 +3,8 @@ * * This file contains the object-system core (NB: not Tcl_Obj, but ::oo) * - * Copyright (c) 2005-2012 by Donal K. Fellows - * Copyright (c) 2017 by Nathan Coulter + * Copyright © 2005-2012 Donal K. Fellows + * Copyright © 2017 Nathan Coulter * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -138,7 +138,10 @@ static const Tcl_MethodType classConstructor = { */ static const char *initScript = +#ifndef TCL_NO_DEPRECATED "package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};" +#endif +"package ifneeded tcl::oo " TCLOO_PATCHLEVEL " {# Already present, OK?};" "namespace eval ::oo { variable version " TCLOO_VERSION " };" "namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };"; /* "tcl_findLibrary tcloo $oo::version $oo::version" */ @@ -257,7 +260,11 @@ TclOOInit( return TCL_ERROR; } - return Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL, +#ifndef TCL_NO_DEPRECATED + Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL, + (void *) &tclOOStubs); +#endif + return Tcl_PkgProvideEx(interp, "tcl::oo", TCLOO_PATCHLEVEL, (void *) &tclOOStubs); } diff --git a/generic/tclOO.decls b/generic/tclOO.decls index f1bb320..4602460 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -5,7 +5,7 @@ # library via the stubs table. This file is used to generate the # tclOODecls.h, tclOOIntDecls.h and tclOOStubInit.c files. # -# Copyright (c) 2008-2013 by Donal K. Fellows. +# Copyright © 2008-2013 Donal K. Fellows. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 19f68fc..6ea4681 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -4,7 +4,7 @@ * This file contains implementations of the "simple" commands and * methods from the object-system core. * - * Copyright (c) 2005-2013 by Donal K. Fellows + * Copyright © 2005-2013 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 9191989..b7df93e 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -4,7 +4,7 @@ * This file contains the method call chain management code for the * object-system core. * - * Copyright (c) 2005-2012 by Donal K. Fellows + * Copyright © 2005-2012 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index e1d88ec..8cf3eb3 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -4,7 +4,7 @@ * This file contains the implementation of the ::oo::define command, * part of the object-system core (NB: not Tcl_Obj, but ::oo). * - * Copyright (c) 2006-2013 by Donal K. Fellows + * Copyright © 2006-2013 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index c9e136c..4e5b55b 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -4,7 +4,7 @@ * This file contains the implementation of the ::oo-related [info] * subcommands. * - * Copyright (c) 2006-2011 by Donal K. Fellows + * Copyright © 2006-2011 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index f65462e..f111461 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -3,7 +3,7 @@ * * This file contains code to create and manage methods. * - * Copyright (c) 2005-2011 by Donal K. Fellows + * Copyright © 2005-2011 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclOOStubLib.c b/generic/tclOOStubLib.c index a9fa212..221d99a 100644 --- a/generic/tclOOStubLib.c +++ b/generic/tclOOStubLib.c @@ -35,14 +35,19 @@ TclOOInitializeStubs( const char *version) { int exact = 0; - const char *packageName = "TclOO"; + const char *packageName = "tcl::oo"; const char *errMsg = NULL; TclOOStubs *stubsPtr = NULL; const char *actualVersion = tclStubsPtr->tcl_PkgRequireEx(interp, packageName, version, exact, &stubsPtr); if (actualVersion == NULL) { - return NULL; + packageName = "TclOO"; + actualVersion = tclStubsPtr->tcl_PkgRequireEx(interp, + packageName, version, exact, &stubsPtr); + if (actualVersion == NULL) { + return NULL; + } } if (stubsPtr == NULL) { errMsg = "missing stub table pointer"; diff --git a/generic/tclObj.c b/generic/tclObj.c index 6e17141..421c1da 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -4,11 +4,11 @@ * This file contains Tcl object-related functions that are used by many * Tcl commands. * - * Copyright (c) 1995-1997 Sun Microsystems, Inc. - * Copyright (c) 1999 by Scriptics Corporation. - * Copyright (c) 2001 by ActiveState Corporation. - * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved. - * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> + * Copyright © 1995-1997 Sun Microsystems, Inc. + * Copyright © 1999 Scriptics Corporation. + * Copyright © 2001 ActiveState Corporation. + * Copyright © 2005 Kevin B. Kenny. All rights reserved. + * Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -1617,6 +1617,7 @@ TclSetDuplicateObj( *---------------------------------------------------------------------- */ +#undef Tcl_GetString char * Tcl_GetString( Tcl_Obj *objPtr) /* Object whose string rep byte pointer should @@ -1653,7 +1654,7 @@ Tcl_GetString( /* *---------------------------------------------------------------------- * - * Tcl_GetStringFromObj -- + * Tcl_GetStringFromObj/TclGetStringFromObj -- * * Returns the string representation's byte array pointer and length for * an object. @@ -1673,6 +1674,7 @@ Tcl_GetString( *---------------------------------------------------------------------- */ +#undef Tcl_GetStringFromObj char * Tcl_GetStringFromObj( Tcl_Obj *objPtr, /* Object whose string rep byte pointer should @@ -1711,6 +1713,51 @@ Tcl_GetStringFromObj( } return objPtr->bytes; } + +#undef TclGetStringFromObj +char * +TclGetStringFromObj( + Tcl_Obj *objPtr, /* Object whose string rep byte pointer should + * be returned. */ + size_t *lengthPtr) /* If non-NULL, the location where the string + * rep's byte array length should * be stored. + * If NULL, no length is stored. */ +{ + if (objPtr->bytes == NULL) { + /* + * Note we do not check for objPtr->typePtr == NULL. An invariant + * of a properly maintained Tcl_Obj is that at least one of + * objPtr->bytes and objPtr->typePtr must not be NULL. If broken + * extensions fail to maintain that invariant, we can crash here. + */ + + if (objPtr->typePtr->updateStringProc == NULL) { + /* + * Those Tcl_ObjTypes which choose not to define an + * updateStringProc must be written in such a way that + * (objPtr->bytes) never becomes NULL. + */ + Tcl_Panic("UpdateStringProc should not be invoked for type %s", + objPtr->typePtr->name); + } + objPtr->typePtr->updateStringProc(objPtr); + if (objPtr->bytes == NULL || objPtr->length < 0 + || objPtr->bytes[objPtr->length] != '\0') { + Tcl_Panic("UpdateStringProc for type '%s' " + "failed to create a valid string rep", + objPtr->typePtr->name); + } + } + if (lengthPtr != NULL) { +#if TCL_MAJOR_VERSION > 8 + *lengthPtr = objPtr->length; +#else + *lengthPtr = ((size_t)(unsigned)(objPtr->length + 1)) - 1; +#endif + } + return objPtr->bytes; +} + /* *---------------------------------------------------------------------- @@ -2193,7 +2240,7 @@ TclSetBooleanFromAny( badBoolean: if (interp != NULL) { int length; - const char *str = TclGetStringFromObj(objPtr, &length); + const char *str = Tcl_GetStringFromObj(objPtr, &length); Tcl_Obj *msg; TclNewLiteralStringObj(msg, "expected boolean value but got \""); @@ -2713,6 +2760,7 @@ Tcl_GetIntFromObj( return TCL_OK; #endif } + /* *---------------------------------------------------------------------- @@ -4313,7 +4361,7 @@ TclHashObjKey( { Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr; int length; - const char *string = TclGetStringFromObj(objPtr, &length); + const char *string = Tcl_GetStringFromObj(objPtr, &length); TCL_HASH_TYPE result = 0; /* diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index 4383c62..de28b0c 100644 --- a/generic/tclOptimize.c +++ b/generic/tclOptimize.c @@ -3,7 +3,7 @@ * * This file contains the bytecode optimizer. * - * Copyright (c) 2013 by Donal Fellows. + * Copyright © 2013 Donal Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclPanic.c b/generic/tclPanic.c index da5c134..394661f 100644 --- a/generic/tclPanic.c +++ b/generic/tclPanic.c @@ -5,9 +5,9 @@ * applications will probably call Tcl_SetPanicProc() to set an * application-specific panic procedure. * - * Copyright (c) 1988-1993 The Regents of the University of California. - * Copyright (c) 1994 Sun Microsystems, Inc. - * Copyright (c) 1998-1999 by Scriptics Corporation. + * Copyright © 1988-1993 The Regents of the University of California. + * Copyright © 1994 Sun Microsystems, Inc. + * Copyright © 1998-1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclParse.c b/generic/tclParse.c index b863ff2..4de0356 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -5,8 +5,8 @@ * general-purpose fashion that can be used for many different purposes, * including compilation, direct execution, code analysis, etc. * - * Copyright (c) 1997 Sun Microsystems, Inc. - * Copyright (c) 1998-2000 Ajuba Solutions. + * Copyright © 1997 Sun Microsystems, Inc. + * Copyright © 1998-2000 Ajuba Solutions. * Contributions from Don Porter, NIST, 2002. (not subject to US copyright) * * See the file "license.terms" for information on usage and redistribution of @@ -935,7 +935,7 @@ TclParseBackslash( * #217987] test subst-3.2 */ - if (TclUCS4Complete(p, numBytes - 1)) { + if (Tcl_UtfCharComplete(p, numBytes - 1)) { count = TclUtfToUCS4(p, &unichar) + 1; /* +1 for '\' */ } else { char utfBytes[8]; diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 8b1f199..e4826ad 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -5,7 +5,7 @@ * to represent and manipulate a general (virtual) filesystem entity in * an efficient manner. * - * Copyright (c) 2003 Vince Darley. + * Copyright © 2003 Vince Darley. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclPipe.c b/generic/tclPipe.c index e9ad4e6..699d559 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -4,7 +4,7 @@ * This file contains the generic portion of the command channel driver * as well as various utility routines used in managing subprocesses. * - * Copyright (c) 1997 by Sun Microsystems, Inc. + * Copyright © 1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 89fb0c4..c3f2f17 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -4,8 +4,8 @@ * This file implements package and version control for Tcl via the * "package" command and a few C APIs. * - * Copyright (c) 1996 Sun Microsystems, Inc. - * Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> + * Copyright © 1996 Sun Microsystems, Inc. + * Copyright © 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclPkgConfig.c b/generic/tclPkgConfig.c index 12df68e..d84472c 100644 --- a/generic/tclPkgConfig.c +++ b/generic/tclPkgConfig.c @@ -2,9 +2,9 @@ * tclPkgConfig.c -- * * This file contains the configuration information to embed into the tcl - * binary library. + * library. * - * Copyright (c) 2002 Andreas Kupries <andreas_kupries@users.sourceforge.net> + * Copyright © 2002 Andreas Kupries <andreas_kupries@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -109,8 +109,9 @@ static Tcl_Config const cfg[] = { {"scriptdir,runtime", CFG_RUNTIME_SCRDIR}, {"includedir,runtime", CFG_RUNTIME_INCDIR}, {"docdir,runtime", CFG_RUNTIME_DOCDIR}, +#if !defined(STATIC_BUILD) {"dllfile,runtime", CFG_RUNTIME_DLLFILE}, - {"zipfile,runtime", CFG_RUNTIME_ZIPFILE}, +#endif /* Installation paths to various stuff */ diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h index 4b06148..f2bc0da 100644 --- a/generic/tclPlatDecls.h +++ b/generic/tclPlatDecls.h @@ -40,6 +40,14 @@ # define _TCHAR_DEFINED #endif +#ifndef MODULE_SCOPE +# ifdef __cplusplus +# define MODULE_SCOPE extern "C" +# else +# define MODULE_SCOPE extern +# endif +#endif + /* !BEGIN!: Do not edit below this line. */ #ifdef __cplusplus @@ -57,6 +65,9 @@ EXTERN TCHAR * Tcl_WinUtfToTChar(const char *str, int len, /* 1 */ EXTERN char * Tcl_WinTCharToUtf(const TCHAR *str, int len, Tcl_DString *dsPtr); +/* Slot 2 is reserved */ +/* 3 */ +EXTERN void Tcl_WinConvertError(unsigned errCode); #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ /* 0 */ @@ -69,6 +80,9 @@ EXTERN int Tcl_MacOSXOpenVersionedBundleResources( const char *bundleVersion, int hasResourceFile, int maxPathLen, char *libraryPath); +/* 2 */ +EXTERN void Tcl_MacOSXNotifierAddRunLoopMode( + const void *runLoopMode); #endif /* MACOSX */ typedef struct TclPlatStubs { @@ -78,10 +92,13 @@ typedef struct TclPlatStubs { #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ TCHAR * (*tcl_WinUtfToTChar) (const char *str, int len, Tcl_DString *dsPtr); /* 0 */ char * (*tcl_WinTCharToUtf) (const TCHAR *str, int len, Tcl_DString *dsPtr); /* 1 */ + void (*reserved2)(void); + void (*tcl_WinConvertError) (unsigned errCode); /* 3 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ int (*tcl_MacOSXOpenBundleResources) (Tcl_Interp *interp, const char *bundleName, int hasResourceFile, int maxPathLen, char *libraryPath); /* 0 */ int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, int maxPathLen, char *libraryPath); /* 1 */ + void (*tcl_MacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 2 */ #endif /* MACOSX */ } TclPlatStubs; @@ -102,12 +119,17 @@ extern const TclPlatStubs *tclPlatStubsPtr; (tclPlatStubsPtr->tcl_WinUtfToTChar) /* 0 */ #define Tcl_WinTCharToUtf \ (tclPlatStubsPtr->tcl_WinTCharToUtf) /* 1 */ +/* Slot 2 is reserved */ +#define Tcl_WinConvertError \ + (tclPlatStubsPtr->tcl_WinConvertError) /* 3 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ #define Tcl_MacOSXOpenBundleResources \ (tclPlatStubsPtr->tcl_MacOSXOpenBundleResources) /* 0 */ #define Tcl_MacOSXOpenVersionedBundleResources \ (tclPlatStubsPtr->tcl_MacOSXOpenVersionedBundleResources) /* 1 */ +#define Tcl_MacOSXNotifierAddRunLoopMode \ + (tclPlatStubsPtr->tcl_MacOSXNotifierAddRunLoopMode) /* 2 */ #endif /* MACOSX */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclPosixStr.c b/generic/tclPosixStr.c index 411eb27..d91a9c4 100644 --- a/generic/tclPosixStr.c +++ b/generic/tclPosixStr.c @@ -4,8 +4,8 @@ * This file contains procedures that generate strings corresponding to * various POSIX-related codes, such as errno and signals. * - * Copyright (c) 1991-1994 The Regents of the University of California. - * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * Copyright © 1991-1994 The Regents of the University of California. + * Copyright © 1994-1996 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclPreserve.c b/generic/tclPreserve.c index d60ebec..b32dd63 100644 --- a/generic/tclPreserve.c +++ b/generic/tclPreserve.c @@ -5,8 +5,8 @@ * sure that widget records and other data structures aren't reallocated * when there are nested functions that depend on their existence. * - * Copyright (c) 1991-1994 The Regents of the University of California. - * Copyright (c) 1994-1998 Sun Microsystems, Inc. + * Copyright © 1991-1994 The Regents of the University of California. + * Copyright © 1994-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclProc.c b/generic/tclProc.c index 20af5fe..b3de29a 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -4,10 +4,10 @@ * This file contains routines that implement Tcl procedures, including * the "proc" and "uplevel" commands. * - * Copyright (c) 1987-1993 The Regents of the University of California. - * Copyright (c) 1994-1998 Sun Microsystems, Inc. - * Copyright (c) 2004-2006 Miguel Sofer - * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> + * Copyright © 1987-1993 The Regents of the University of California. + * Copyright © 1994-1998 Sun Microsystems, Inc. + * Copyright © 2004-2006 Miguel Sofer + * Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclProcess.c b/generic/tclProcess.c index 7bd5e1a..fcb7bfd 100644 --- a/generic/tclProcess.c +++ b/generic/tclProcess.c @@ -4,7 +4,7 @@ * This file implements the "tcl::process" ensemble for subprocess * management as defined by TIP #462. * - * Copyright (c) 2017 Frederic Bonnet. + * Copyright © 2017 Frederic Bonnet. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index 99135d3..f161782 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -4,8 +4,8 @@ * This file contains the public interfaces to the Tcl regular expression * mechanism. * - * Copyright (c) 1998 by Sun Microsystems, Inc. - * Copyright (c) 1998-1999 by Scriptics Corporation. + * Copyright © 1998 Sun Microsystems, Inc. + * Copyright © 1998-1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -26,7 +26,7 @@ * regex.h regexec.c regfree.c * regfronts.c regguts.h * - * Copyright (c) 1998 Henry Spencer. All rights reserved. + * Copyright © 1998 Henry Spencer. All rights reserved. * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics diff --git a/generic/tclResolve.c b/generic/tclResolve.c index ca53014..ff88ffd 100644 --- a/generic/tclResolve.c +++ b/generic/tclResolve.c @@ -6,7 +6,7 @@ * name resolution rules to the Tcl language. Rules can be applied to a * particular namespace, to the interpreter as a whole, or both. * - * Copyright (c) 1998 Lucent Technologies, Inc. + * Copyright © 1998 Lucent Technologies, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclResult.c b/generic/tclResult.c index 1fb2ad0..5b7a8e5 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -3,7 +3,7 @@ * * This file contains code to manage the interpreter result. * - * Copyright (c) 1997 by Sun Microsystems, Inc. + * Copyright © 1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -464,6 +464,7 @@ Tcl_SetResult( ResetObjResult(iPtr); } +#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -482,10 +483,12 @@ Tcl_SetResult( *---------------------------------------------------------------------- */ +#undef Tcl_GetStringResult const char * Tcl_GetStringResult( Tcl_Interp *interp)/* Interpreter whose result to return. */ { +#ifndef TCL_NO_DEPRECATED Interp *iPtr = (Interp *) interp; /* * If the string result is empty, move the object result to the string @@ -497,8 +500,10 @@ Tcl_GetStringResult( TCL_VOLATILE); } return iPtr->result; +#else + return TclGetString(Tcl_GetObjResult(interp)); +#endif } -#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- diff --git a/generic/tclScan.c b/generic/tclScan.c index 67fe6f3..f35b376 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -3,7 +3,7 @@ * * This file contains the implementation of the "scan" command. * - * Copyright (c) 1998 by Scriptics Corporation. + * Copyright © 1998 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 35850d2..b213bed 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -7,7 +7,7 @@ * into strings of digits, and procedures for interconversion among * 'double' and 'mp_int' types. * - * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved. + * Copyright © 2005 Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -22,6 +22,11 @@ #define copysign _copysign #endif +#ifndef PRIx64 +# define PRIx64 TCL_LL_MODIFIER "x" +#endif + + /* * This code supports (at least hypothetically), IBM, Cray, VAX and IEEE-754 * floating point; of these, only IEEE-754 can represent NaN. IEEE-754 can be @@ -538,7 +543,7 @@ TclParseNumber( int under = 0; /* Flag trailing '_' as error if true once * number is accepted. */ -#define ALL_BITS ((Tcl_WideUInt)-1) +#define ALL_BITS UWIDE_MAX #define MOST_BITS (ALL_BITS >> 1) /* @@ -725,7 +730,7 @@ TclParseNumber( && (((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt)) || (octalSignificandWide > - ((Tcl_WideUInt)-1 >> shift)))) { + (UWIDE_MAX >> shift)))) { octalSignificandOverflow = 1; err = mp_init_u64(&octalSignificandBig, octalSignificandWide); @@ -865,7 +870,7 @@ TclParseNumber( if (significandWide != 0 && ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || - significandWide > ((Tcl_WideUInt)-1 >> shift))) { + significandWide > (UWIDE_MAX >> shift))) { significandOverflow = 1; err = mp_init_u64(&significandBig, significandWide); @@ -899,12 +904,14 @@ TclParseNumber( under = 0; state = BINARY; break; - } else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) { - /* Ignore numeric "white space" */ - under = 1; - break; + } else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) { + /* Ignore numeric "white space" */ + under = 1; + break; } else if (c != '1') { goto endgame; + } else { + under = 0; } if (objPtr != NULL) { shift = numTrailZeros + 1; @@ -917,7 +924,7 @@ TclParseNumber( if (significandWide != 0 && ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || - significandWide > ((Tcl_WideUInt)-1 >> shift))) { + significandWide > (UWIDE_MAX >> shift))) { significandOverflow = 1; err = mp_init_u64(&significandBig, significandWide); @@ -944,11 +951,11 @@ TclParseNumber( under = 0; numTrailZeros++; } else if ( ! isdigit(UCHAR(c))) { - if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) { - /* Ignore numeric "white space" */ - under = 1; - break; - } + if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) { + /* Ignore numeric "white space" */ + under = 1; + break; + } goto endgame; } under = 0; @@ -1597,7 +1604,7 @@ AccumulateDecimalDigit( *wideRepPtr = digit; return 0; } else if (numZeros >= maxpow10_wide - || w > ((Tcl_WideUInt)-1-digit)/pow10_wide[numZeros+1]) { + || w > (UWIDE_MAX-digit)/pow10_wide[numZeros+1]) { /* * Wide multiplication will overflow. Expand the number to a * bignum and fall through into the bignum case. @@ -5251,23 +5258,23 @@ TclFormatNaN( #else union { double dv; - Tcl_WideUInt iv; + uint64_t iv; } bitwhack; bitwhack.dv = value; if (n770_fp) { bitwhack.iv = Nokia770Twiddle(bitwhack.iv); } - if (bitwhack.iv & ((Tcl_WideUInt) 1 << 63)) { - bitwhack.iv &= ~ ((Tcl_WideUInt) 1 << 63); + if (bitwhack.iv & (UINT64_C(1) << 63)) { + bitwhack.iv &= ~ (UINT64_C(1) << 63); *buffer++ = '-'; } *buffer++ = 'N'; *buffer++ = 'a'; *buffer++ = 'N'; - bitwhack.iv &= (((Tcl_WideUInt) 1) << 51) - 1; + bitwhack.iv &= ((UINT64_C(1)) << 51) - 1; if (bitwhack.iv != 0) { - sprintf(buffer, "(%" TCL_LL_MODIFIER "x)", bitwhack.iv); + sprintf(buffer, "(%" PRIx64 ")", bitwhack.iv); } else { *buffer = '\0'; } diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 03aceaf..508b280 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -27,8 +27,8 @@ * internal representation to keep track of how much space is used vs. * allocated. * - * Copyright (c) 1995-1997 Sun Microsystems, Inc. - * Copyright (c) 1999 by Scriptics Corporation. + * Copyright © 1995-1997 Sun Microsystems, Inc. + * Copyright © 1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -70,6 +70,11 @@ static void SetUnicodeObj(Tcl_Obj *objPtr, static int UnicodeLength(const Tcl_UniChar *unicode); static void UpdateStringOfString(Tcl_Obj *objPtr); +#define ISCONTINUATION(bytes) (\ + ((((bytes)[0] & 0xC0) == 0x80) || (((bytes)[0] == '\xED') \ + && (((bytes)[1] & 0xF0) == 0xB0) && (((bytes)[2] & 0xC0) == 0x80)))) + + /* * The structure below defines the string Tcl object type by means of * functions that can be invoked by generic object code. @@ -604,6 +609,7 @@ Tcl_GetUniChar( *---------------------------------------------------------------------- */ +#undef Tcl_GetUnicodeFromObj #ifndef TCL_NO_DEPRECATED #undef Tcl_GetUnicode Tcl_UniChar * @@ -611,14 +617,14 @@ Tcl_GetUnicode( Tcl_Obj *objPtr) /* The object to find the unicode string * for. */ { - return Tcl_GetUnicodeFromObj(objPtr, NULL); + return Tcl_GetUnicodeFromObj(objPtr, (int *)NULL); } #endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- * - * Tcl_GetUnicodeFromObj -- + * Tcl_GetUnicodeFromObj/TclGetUnicodeFromObj -- * * Get the Unicode form of the String object with length. If the object * is not already a String object, it will be converted to one. If the @@ -657,6 +663,33 @@ Tcl_GetUnicodeFromObj( } return stringPtr->unicode; } +Tcl_UniChar * +TclGetUnicodeFromObj( + Tcl_Obj *objPtr, /* The object to find the unicode string + * for. */ + size_t *lengthPtr) /* If non-NULL, the location where the string + * rep's unichar length should be stored. If + * NULL, no length is stored. */ +{ + String *stringPtr; + + SetStringFromAny(NULL, objPtr); + stringPtr = GET_STRING(objPtr); + + if (stringPtr->hasUnicode == 0) { + FillUnicodeRep(objPtr); + stringPtr = GET_STRING(objPtr); + } + + if (lengthPtr != NULL) { +#if TCL_MAJOR_VERSION > 8 + *lengthPtr = stringPtr->numChars; +#else + *lengthPtr = ((size_t)(unsigned)(stringPtr->numChars + 1)) - 1; +#endif + } + return stringPtr->unicode; +} /* *---------------------------------------------------------------------- @@ -1171,10 +1204,10 @@ Tcl_AppendLimitedToObj( } eLen = strlen(ellipsis); while (eLen > limit) { - eLen = TclUtfPrev(ellipsis+eLen, ellipsis) - ellipsis; + eLen = Tcl_UtfPrev(ellipsis+eLen, ellipsis) - ellipsis; } - toCopy = TclUtfPrev(bytes+limit+1-eLen, bytes) - bytes; + toCopy = Tcl_UtfPrev(bytes+limit+1-eLen, bytes) - bytes; } /* @@ -1190,6 +1223,12 @@ Tcl_AppendLimitedToObj( SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); + /* If appended string starts with a continuation byte or a lower surrogate, + * force objPtr to unicode representation. See [7f1162a867] */ + if (bytes && ISCONTINUATION(bytes)) { + Tcl_GetUnicode(objPtr); + stringPtr = GET_STRING(objPtr); + } if (stringPtr->hasUnicode && stringPtr->numChars > 0) { AppendUtfToUnicodeRep(objPtr, bytes, toCopy); } else { @@ -1376,7 +1415,7 @@ Tcl_AppendObjToObj( */ TclAppendBytesToByteArray(objPtr, - Tcl_GetByteArrayFromObj(appendObjPtr, NULL), lengthSrc); + TclGetByteArrayFromObj(appendObjPtr, NULL), lengthSrc); return; } @@ -1387,6 +1426,13 @@ Tcl_AppendObjToObj( SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); + /* If appended string starts with a continuation byte or a lower surrogate, + * force objPtr to unicode representation. See [7f1162a867] + * This fixes append-3.4, append-3.7 and utf-1.18 testcases. */ + if (ISCONTINUATION(TclGetString(appendObjPtr))) { + Tcl_GetUnicode(objPtr); + stringPtr = GET_STRING(objPtr); + } /* * If objPtr has a valid Unicode rep, then get a Unicode string from * appendObjPtr and append it. @@ -2616,7 +2662,7 @@ AppendPrintfToObjVA( * multi-byte characters. */ - q = TclUtfPrev(end, bytes); + q = Tcl_UtfPrev(end, bytes); if (!Tcl_UtfCharComplete(q, (int)(end - q))) { end = q; } @@ -2916,7 +2962,7 @@ TclStringRepeat( done *= 2; } TclAppendBytesToByteArray(objResultPtr, - Tcl_GetByteArrayFromObj(objResultPtr, NULL), + TclGetByteArrayFromObj(objResultPtr, NULL), (count - done) * length); } else if (unichar) { /* @@ -3004,7 +3050,7 @@ TclStringCat( { Tcl_Obj *objResultPtr, * const *ov; int oc, length = 0, binary = 1; - int allowUniChar = 1, requestUniChar = 0; + int allowUniChar = 1, requestUniChar = 0, forceUniChar = 0; int first = objc - 1; /* Index of first value possibly not empty */ int last = 0; /* Index of last value possibly not empty */ int inPlace = flags & TCL_STRING_IN_PLACE; @@ -3040,7 +3086,9 @@ TclStringCat( */ binary = 0; - if ((objPtr->typePtr) && (objPtr->typePtr != &tclStringType)) { + if (ov > objv+1 && ISCONTINUATION(TclGetString(objPtr))) { + forceUniChar = 1; + } else if ((objPtr->typePtr) && (objPtr->typePtr != &tclStringType)) { /* Prevent shimmer of non-string types. */ allowUniChar = 0; } @@ -3089,7 +3137,7 @@ TclStringCat( } } } while (--oc); - } else if (allowUniChar && requestUniChar) { + } else if ((allowUniChar && requestUniChar) || forceUniChar) { /* * Result will be pure Tcl_UniChar array. Pre-size it. */ @@ -3242,7 +3290,7 @@ TclStringCat( dst += more; } } - } else if (allowUniChar && requestUniChar) { + } else if ((allowUniChar && requestUniChar) || forceUniChar) { /* Efficiently produce a pure Tcl_UniChar array result */ Tcl_UniChar *dst; @@ -3428,7 +3476,7 @@ TclStringCmp( s1 = (char *) Tcl_GetUnicode(value1Ptr); s2 = (char *) Tcl_GetUnicode(value2Ptr); if ( -#ifdef WORDS_BIGENDIAN +#if defined(WORDS_BIGENDIAN) && (TCL_UTF_MAX > 3) 1 #else checkEq @@ -3781,6 +3829,9 @@ TclStringReverse( String *stringPtr; Tcl_UniChar ch = 0; int inPlace = flags & TCL_STRING_IN_PLACE; +#if TCL_UTF_MAX < 4 + int needFlip = 0; +#endif if (TclIsPureByteArray(objPtr)) { int numBytes; @@ -3789,7 +3840,7 @@ TclStringReverse( if (!inPlace || Tcl_IsShared(objPtr)) { objPtr = Tcl_NewByteArrayObj(NULL, numBytes); } - ReverseBytes(Tcl_GetByteArrayFromObj(objPtr, NULL), from, numBytes); + ReverseBytes(TclGetByteArrayFromObj(objPtr, NULL), from, numBytes); return objPtr; } @@ -3798,11 +3849,11 @@ TclStringReverse( if (stringPtr->hasUnicode) { Tcl_UniChar *from = Tcl_GetUnicode(objPtr); + stringPtr = GET_STRING(objPtr); Tcl_UniChar *src = from + stringPtr->numChars; + Tcl_UniChar *to; if (!inPlace || Tcl_IsShared(objPtr)) { - Tcl_UniChar *to; - /* * Create a non-empty, pure unicode value, so we can coax * Tcl_SetObjLength into growing the unicode rep buffer. @@ -3811,20 +3862,56 @@ TclStringReverse( objPtr = Tcl_NewUnicodeObj(&ch, 1); Tcl_SetObjLength(objPtr, stringPtr->numChars); to = Tcl_GetUnicode(objPtr); + stringPtr = GET_STRING(objPtr); while (--src >= from) { +#if TCL_UTF_MAX < 4 + ch = *src; + if ((ch & 0xF800) == 0xD800) { + needFlip = 1; + } + *to++ = ch; +#else *to++ = *src; +#endif } } else { /* * Reversing in place. */ +#if TCL_UTF_MAX < 4 + to = src; +#endif while (--src > from) { ch = *src; +#if TCL_UTF_MAX < 4 + if ((ch & 0xF800) == 0xD800) { + needFlip = 1; + } +#endif *src = *from; *from++ = ch; } } +#if TCL_UTF_MAX < 4 + if (needFlip) { + /* + * Flip back surrogate pairs. + */ + + from = to - stringPtr->numChars; + while (--to >= from) { + ch = *to; + if ((ch & 0xFC00) == 0xD800) { + if ((to-1 >= from) && ((to[-1] & 0xFC00) == 0xDC00)) { + to[0] = to[-1]; + to[-1] = ch; + --to; + } + } + } + } +#endif } if (objPtr->bytes) { @@ -3848,8 +3935,8 @@ TclStringReverse( * Pass 1. Reverse the bytes of each multi-byte character. */ - int charCount = 0; int bytesLeft = numBytes; + int chw; while (bytesLeft) { /* @@ -3858,18 +3945,16 @@ TclStringReverse( * skip calling Tcl_UtfCharComplete() here. */ - int bytesInChar = TclUtfToUniChar(from, &ch); + int bytesInChar = TclUtfToUCS4(from, &chw); ReverseBytes((unsigned char *)to, (unsigned char *)from, bytesInChar); to += bytesInChar; from += bytesInChar; bytesLeft -= bytesInChar; - charCount++; } from = to = objPtr->bytes; - stringPtr->numChars = charCount; } /* Pass 2. Reverse all the bytes. */ ReverseBytes((unsigned char *)to, (unsigned char *)from, numBytes); @@ -4082,9 +4167,22 @@ ExtendUnicodeRepWithString( } else { numAppendChars = 0; } - for (dst=stringPtr->unicode + numOrigChars; numAppendChars-- > 0; dst++) { + dst = stringPtr->unicode + numOrigChars; + if (numAppendChars-- > 0) { bytes += TclUtfToUniChar(bytes, &unichar); - *dst = unichar; +#if TCL_UTF_MAX > 3 + /* join upper/lower surrogate */ + if (bytes && (stringPtr->unicode[numOrigChars - 1] | 0x3FF) == 0xDBFF && (unichar | 0x3FF) == 0xDFFF) { + stringPtr->numChars--; + unichar = ((stringPtr->unicode[numOrigChars - 1] & 0x3FF) << 10) + (unichar & 0x3FF) + 0x10000; + dst--; + } +#endif + *dst++ = unichar; + while (numAppendChars-- > 0) { + bytes += TclUtfToUniChar(bytes, &unichar); + *dst++ = unichar; + } } *dst = 0; } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 0204bca..41ece01 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -3,7 +3,7 @@ * * This file contains the initializers for the Tcl stub vectors. * - * Copyright (c) 1998-1999 by Scriptics Corporation. + * Copyright © 1998-1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -65,15 +65,22 @@ #undef TclWinGetSockOpt #undef TclWinSetSockOpt #undef TclWinNToHS -#undef TclStaticPackage +#undef TclStaticLibrary #undef Tcl_BackgroundError #undef TclGuessPackageName #undef TclGetLoadedPackages -#define TclStaticPackage Tcl_StaticPackage +#define TclStaticLibrary Tcl_StaticLibrary #undef Tcl_UniCharToUtfDString #undef Tcl_UtfToUniCharDString #undef Tcl_UtfToUniChar #undef Tcl_MacOSXOpenBundleResources +#undef TclWinConvertWSAError +#undef TclWinConvertError +#if defined(_WIN32) || defined(__CYGWIN__) +#define TclWinConvertWSAError (void (*)(DWORD))(void *)Tcl_WinConvertError +#define TclWinConvertError (void (*)(DWORD))(void *)Tcl_WinConvertError +#endif + #if TCL_UTF_MAX > 3 static void uniCodePanic(void) { @@ -90,6 +97,32 @@ static void uniCodePanic(void) { # define Tcl_UniCharNcmp (int(*)(const Tcl_UniChar *, const Tcl_UniChar *, unsigned long))(void *)uniCodePanic #endif +#define TclUtfCharComplete UtfCharComplete +#define TclUtfNext UtfNext +#define TclUtfPrev UtfPrev + +static int TclUtfCharComplete(const char *src, int length) { + if ((unsigned)((unsigned char)*(src) - 0xF0) < 5) { + return length < 3; + } + return Tcl_UtfCharComplete(src, length); +} + +static const char *TclUtfNext(const char *src) { + if ((unsigned)((unsigned char)*(src) - 0xF0) < 5) { + return src + 1; + } + return Tcl_UtfNext(src); +} + +static const char *TclUtfPrev(const char *src, const char *start) { + if ((src >= start + 3) && ((src[-1] & 0xC0) == 0x80) + && ((src[-2] & 0xC0) == 0x80) && ((src[-3] & 0xC0) == 0x80)) { + return src - 3; + } + return Tcl_UtfPrev(src, start); +} + #define TclBN_mp_add mp_add #define TclBN_mp_and mp_and #define TclBN_mp_clamp mp_clamp @@ -138,10 +171,11 @@ static void uniCodePanic(void) { #define TclBN_mp_to_radix mp_to_radix #define TclBN_mp_to_ubin mp_to_ubin #define TclBN_mp_ubin_size mp_ubin_size +#define TclBN_mp_unpack mp_unpack #define TclBN_mp_xor mp_xor #define TclBN_mp_zero mp_zero #define TclBN_s_mp_add s_mp_add -#define TclBN_s_mp_balance_mul mp_balance_mul +#define TclBN_s_mp_balance_mul s_mp_balance_mul #define TclBN_mp_karatsuba_mul s_mp_karatsuba_mul #define TclBN_mp_karatsuba_sqr s_mp_karatsuba_sqr #define TclBN_s_mp_mul_digs s_mp_mul_digs @@ -206,7 +240,7 @@ mp_err TclBN_mp_div_ld(const mp_int *a, uint64_t b, mp_int *c, uint64_t *d) { if ((b | (mp_digit)-1) != (mp_digit)-1) { return MP_VAL; } - result = mp_div_d(a, b, c, (d ? &d2 : NULL)); + result = mp_div_d(a, (mp_digit)b, c, (d ? &d2 : NULL)); if (d) { *d = d2; } @@ -282,7 +316,7 @@ static int TclGetLoadedPackages( * otherwise, just return info about this * interpreter. */ { - return TclGetLoadedPackagesEx(interp, targetName, NULL); + return TclGetLoadedLibraries(interp, targetName, NULL); } mp_err TclBN_mp_div_3(const mp_int *a, mp_int *c, unsigned int *d) { @@ -396,7 +430,9 @@ TclWinGetPlatformId(void) #define TclpCreateTempFile_ TclpCreateTempFile #define TclUnixWaitForFile_ TclUnixWaitForFile -#ifndef MAC_OSX_TCL /* On UNIX, fill with other stub entries */ +#ifdef MAC_OSX_TCL /* On UNIX, fill with other stub entries */ +#define TclMacOSXNotifierAddRunLoopMode Tcl_MacOSXNotifierAddRunLoopMode +#else #define TclMacOSXGetFileAttribute (int (*)(Tcl_Interp *, int, Tcl_Obj *, Tcl_Obj **))(void *)TclpCreateProcess #define TclMacOSXSetFileAttribute (int (*)(Tcl_Interp *, int, Tcl_Obj *, Tcl_Obj *))(void *)isatty #define TclMacOSXCopyFileAttributes (int (*)(const char *, const char *, const Tcl_StatBuf *))(void *)TclUnixCopyFile @@ -599,8 +635,6 @@ static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){ # define Tcl_Eval 0 # undef Tcl_GlobalEval # define Tcl_GlobalEval 0 -# undef Tcl_GetStringResult -# define Tcl_GetStringResult 0 # undef Tcl_SaveResult # define Tcl_SaveResult 0 # undef Tcl_RestoreResult @@ -1003,7 +1037,7 @@ static const TclIntStubs tclIntStubs = { TclPtrIncrObjVar, /* 254 */ TclPtrObjMakeUpvar, /* 255 */ TclPtrUnsetVar, /* 256 */ - TclStaticPackage, /* 257 */ + TclStaticLibrary, /* 257 */ TclpCreateTemporaryDirectory, /* 258 */ TclGetBytesFromObj, /* 259 */ TclUnusedStubEntry, /* 260 */ @@ -1119,10 +1153,13 @@ static const TclPlatStubs tclPlatStubs = { #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ Tcl_WinUtfToTChar, /* 0 */ Tcl_WinTCharToUtf, /* 1 */ + 0, /* 2 */ + Tcl_WinConvertError, /* 3 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ Tcl_MacOSXOpenBundleResources, /* 0 */ Tcl_MacOSXOpenVersionedBundleResources, /* 1 */ + Tcl_MacOSXNotifierAddRunLoopMode, /* 2 */ #endif /* MACOSX */ }; @@ -1200,7 +1237,7 @@ const TclTomMathStubs tclTomMathStubs = { TclBN_mp_set_u64, /* 68 */ TclBN_mp_get_mag_u64, /* 69 */ TclBN_mp_set_i64, /* 70 */ - 0, /* 71 */ + TclBN_mp_unpack, /* 71 */ 0, /* 72 */ TclBN_mp_tc_and, /* 73 */ TclBN_mp_tc_or, /* 74 */ @@ -1489,7 +1526,7 @@ const TclStubs tclStubs = { Tcl_SourceRCFile, /* 241 */ Tcl_SplitList, /* 242 */ Tcl_SplitPath, /* 243 */ - Tcl_StaticPackage, /* 244 */ + Tcl_StaticLibrary, /* 244 */ Tcl_StringMatch, /* 245 */ Tcl_TellOld, /* 246 */ Tcl_TraceVar, /* 247 */ @@ -1571,12 +1608,12 @@ const TclStubs tclStubs = { Tcl_UniCharToUpper, /* 323 */ Tcl_UniCharToUtf, /* 324 */ Tcl_UtfAtIndex, /* 325 */ - Tcl_UtfCharComplete, /* 326 */ + TclUtfCharComplete, /* 326 */ Tcl_UtfBackslash, /* 327 */ Tcl_UtfFindFirst, /* 328 */ Tcl_UtfFindLast, /* 329 */ - Tcl_UtfNext, /* 330 */ - Tcl_UtfPrev, /* 331 */ + TclUtfNext, /* 330 */ + TclUtfPrev, /* 331 */ Tcl_UtfToExternal, /* 332 */ Tcl_UtfToExternalDString, /* 333 */ Tcl_UtfToLower, /* 334 */ @@ -1894,6 +1931,14 @@ const TclStubs tclStubs = { Tcl_UtfToUniChar, /* 646 */ Tcl_UniCharToUtfDString, /* 647 */ Tcl_UtfToUniCharDString, /* 648 */ + 0, /* 649 */ + 0, /* 650 */ + TclGetStringFromObj, /* 651 */ + TclGetUnicodeFromObj, /* 652 */ + TclGetByteArrayFromObj, /* 653 */ + Tcl_UtfCharComplete, /* 654 */ + Tcl_UtfNext, /* 655 */ + Tcl_UtfPrev, /* 656 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c index 22e8b9b..46d2f90 100644 --- a/generic/tclStubLib.c +++ b/generic/tclStubLib.c @@ -4,8 +4,8 @@ * Stub object that will be statically linked into extensions that want * to access Tcl. * - * Copyright (c) 1998-1999 by Scriptics Corporation. - * Copyright (c) 1998 Paul Duffin. + * Copyright © 1998-1999 Scriptics Corporation. + * Copyright © 1998 Paul Duffin. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -54,10 +54,11 @@ Tcl_InitStubs( int exact, int magic) { - Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *)interp; const char *actualVersion = NULL; ClientData pkgData = NULL; const TclStubs *stubsPtr = iPtr->stubTable; + const char *tclName = (((exact&0xFF00) >= 0x900) ? "tcl" : "Tcl"); /* * We can't optimize this check by caching tclStubsPtr because that @@ -67,11 +68,11 @@ Tcl_InitStubs( if (!stubsPtr || (stubsPtr->magic != (((exact&0xFF00) >= 0x900) ? magic : TCL_STUB_MAGIC))) { iPtr->result = (char *)"interpreter uses an incompatible stubs mechanism"; - iPtr->freeProc = 0; + iPtr->freeProc = 0; /* TCL_STATIC */ return NULL; } - actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 0, &pkgData); + actualVersion = stubsPtr->tcl_PkgRequireEx(interp, tclName, version, 0, &pkgData); if (actualVersion == NULL) { return NULL; } @@ -91,11 +92,11 @@ Tcl_InitStubs( } if (*p || ISDIGIT(*q)) { /* Construct error message */ - stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL); + stubsPtr->tcl_PkgRequireEx(interp, tclName, version, 1, NULL); return NULL; } } else { - actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL); + actualVersion = stubsPtr->tcl_PkgRequireEx(interp, tclName, version, 1, NULL); if (actualVersion == NULL) { return NULL; } diff --git a/generic/tclTest.c b/generic/tclTest.c index c31abf3..39bd392 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -6,10 +6,10 @@ * commands are not normally included in Tcl applications; they're only * used for testing. * - * Copyright (c) 1993-1994 The Regents of the University of California. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. - * Copyright (c) 1998-2000 Ajuba Solutions. - * Copyright (c) 2003 by Kevin B. Kenny. All rights reserved. + * Copyright © 1993-1994 The Regents of the University of California. + * Copyright © 1994-1997 Sun Microsystems, Inc. + * Copyright © 1998-2000 Ajuba Solutions. + * Copyright © 2003 Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -19,6 +19,9 @@ #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif +#ifndef TCL_NO_DEPRECATED +# define TCL_NO_DEPRECATED +#endif #include "tclInt.h" #ifdef TCL_WITH_EXTERNAL_TOMMATH # include "tommath.h" @@ -274,7 +277,7 @@ static Tcl_CmdProc Testset2Cmd; static Tcl_CmdProc TestseterrorcodeCmd; static Tcl_ObjCmdProc TestsetobjerrorcodeCmd; static Tcl_CmdProc TestsetplatformCmd; -static Tcl_CmdProc TeststaticpkgCmd; +static Tcl_CmdProc TeststaticlibraryCmd; static Tcl_CmdProc TesttranslatefilenameCmd; static Tcl_CmdProc TestupvarCmd; static Tcl_ObjCmdProc TestWrongNumArgsObjCmd; @@ -460,7 +463,7 @@ Tcltest_Init( } /* TIP #268: Full patchlevel instead of just major.minor */ - if (Tcl_PkgProvideEx(interp, "Tcltest", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) { + if (Tcl_PkgProvideEx(interp, "tcl::test", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) { return TCL_ERROR; } @@ -601,7 +604,7 @@ Tcltest_Init( NULL, NULL); Tcl_CreateCommand(interp, "testsocket", TestSocketCmd, NULL, NULL); - Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd, + Tcl_CreateCommand(interp, "teststaticlibrary", TeststaticlibraryCmd, NULL, NULL); Tcl_CreateCommand(interp, "testtranslatefilename", TesttranslatefilenameCmd, NULL, NULL); @@ -4214,10 +4217,10 @@ TestsetplatformCmd( /* *---------------------------------------------------------------------- * - * TeststaticpkgCmd -- + * TeststaticlibraryCmd -- * - * This procedure implements the "teststaticpkg" command. - * It is used to test the procedure Tcl_StaticPackage. + * This procedure implements the "teststaticlibrary" command. + * It is used to test the procedure Tcl_StaticLibrary. * * Results: * A standard Tcl result. @@ -4230,7 +4233,7 @@ TestsetplatformCmd( */ static int -TeststaticpkgCmd( +TeststaticlibraryCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ @@ -4240,7 +4243,7 @@ TeststaticpkgCmd( if (argc != 4) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", - argv[0], " pkgName safe loaded\"", NULL); + argv[0], " prefix safe loaded\"", NULL); return TCL_ERROR; } if (Tcl_GetInt(interp, argv[2], &safe) != TCL_OK) { @@ -4249,7 +4252,7 @@ TeststaticpkgCmd( if (Tcl_GetInt(interp, argv[3], &loaded) != TCL_OK) { return TCL_ERROR; } - Tcl_StaticPackage((loaded) ? interp : NULL, argv[1], + Tcl_StaticLibrary((loaded) ? interp : NULL, argv[1], StaticInitProc, (safe) ? StaticInitProc : NULL); return TCL_OK; } @@ -6962,7 +6965,7 @@ TestUtfPrevCmd( } else { offset = numBytes; } - result = TclUtfPrev(bytes + offset, bytes); + result = Tcl_UtfPrev(bytes + offset, bytes); Tcl_SetObjResult(interp, Tcl_NewIntObj(result - bytes)); return TCL_OK; } diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index bd5d92e..17546a4 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -6,9 +6,9 @@ * These commands are not normally included in Tcl applications; they're * only used for testing. * - * Copyright (c) 1995-1998 Sun Microsystems, Inc. - * Copyright (c) 1999 by Scriptics Corporation. - * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved. + * Copyright © 1995-1998 Sun Microsystems, Inc. + * Copyright © 1999 Scriptics Corporation. + * Copyright © 2005 Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -1176,6 +1176,7 @@ TeststringobjCmd( { Tcl_UniChar *unicode; int varIndex, option, i, length; + int size; #define MAX_STRINGS 11 const char *index, *string, *strings[MAX_STRINGS+1]; String *strPtr; @@ -1308,12 +1309,12 @@ TeststringobjCmd( * is "copy on write". */ - string = Tcl_GetStringFromObj(objv[3], &length); + string = Tcl_GetStringFromObj(objv[3], &size); if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetStringObj(varPtr[varIndex], string, length); + Tcl_SetStringObj(varPtr[varIndex], string, size); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewStringObj(string, length)); + SetVarToObj(varPtr, varIndex, Tcl_NewStringObj(string, size)); } Tcl_SetObjResult(interp, varPtr[varIndex]); break; @@ -1365,18 +1366,18 @@ TeststringobjCmd( SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex])); } - string = Tcl_GetStringFromObj(varPtr[varIndex], &length); + string = Tcl_GetStringFromObj(varPtr[varIndex], &size); if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) { return TCL_ERROR; } - if ((i < 0) || (i > length)) { + if ((i < 0) || (i > size)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "index value out of range", -1)); return TCL_ERROR; } - Tcl_AppendToObj(varPtr[varIndex], string + i, length - i); + Tcl_AppendToObj(varPtr[varIndex], string + i, size - i); Tcl_SetObjResult(interp, varPtr[varIndex]); break; case 11: /* appendself2 */ @@ -1396,18 +1397,18 @@ TeststringobjCmd( SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex])); } - unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &length); + unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &size); if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) { return TCL_ERROR; } - if ((i < 0) || (i > length)) { + if ((i < 0) || (i > size)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "index value out of range", -1)); return TCL_ERROR; } - Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + i, length - i); + Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + i, size - i); Tcl_SetObjResult(interp, varPtr[varIndex]); break; } diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c index db6ec8a..38cfaaa 100644 --- a/generic/tclTestProcBodyObj.c +++ b/generic/tclTestProcBodyObj.c @@ -5,7 +5,7 @@ * creation of Tcl procedures whose body argument is a Tcl_Obj of type * "procbody" rather than a string. * - * Copyright (c) 1998 by Scriptics Corporation. + * Copyright © 1998 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -20,7 +20,7 @@ * name and version of this package */ -static const char packageName[] = "procbodytest"; +static const char packageName[] = "tcl::procbodytest"; static const char packageVersion[] = "1.1"; /* @@ -75,7 +75,7 @@ static const CmdTable safeCommands[] = { * * Procbodytest_Init -- * - * This function initializes the "procbodytest" package. + * This function initializes the "tcl::procbodytest" package. * * Results: * A standard Tcl result. @@ -99,7 +99,7 @@ Procbodytest_Init( * * Procbodytest_SafeInit -- * - * This function initializes the "procbodytest" package. + * This function initializes the "tcl::procbodytest" package. * * Results: * A standard Tcl result. @@ -315,7 +315,7 @@ ProcBodyTestProcObjCmd( * procbodytest::check * * Performs an internal check that the Tcl_PkgPresent() command returns - * the same version number as was registered when the procbodytest package + * the same version number as was registered when the tcl::procbodytest package * was provided. Places a boolean in the interp result indicating the * test outcome. * diff --git a/generic/tclThread.c b/generic/tclThread.c index 76aaf4b..0e6e874 100644 --- a/generic/tclThread.c +++ b/generic/tclThread.c @@ -4,8 +4,8 @@ * This file implements Platform independent thread operations. Most of * the real work is done in the platform dependent files. * - * Copyright (c) 1998 by Sun Microsystems, Inc. - * Copyright (c) 2008 by George Peter Staplin + * Copyright © 1998 Sun Microsystems, Inc. + * Copyright © 2008 George Peter Staplin * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c index eb8a35d..727f061 100644 --- a/generic/tclThreadAlloc.c +++ b/generic/tclThreadAlloc.c @@ -6,7 +6,7 @@ * fixed size blocks from block caches. * * The Initial Developer of the Original Code is America Online, Inc. - * Portions created by AOL are Copyright (C) 1999 America Online, Inc. + * Portions created by AOL are Copyright © 1999 America Online, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -82,18 +82,17 @@ typedef union Block { * and statistics information. */ -typedef struct Bucket { +typedef struct { Block *firstPtr; /* First block available */ Block *lastPtr; /* End of block list */ - long numFree; /* Number of blocks available */ + size_t numFree; /* Number of blocks available */ /* All fields below for accounting only */ - long numRemoves; /* Number of removes from bucket */ - long numInserts; /* Number of inserts into bucket */ - long numWaits; /* Number of waits to acquire a lock */ - long numLocks; /* Number of locks acquired */ - long totalAssigned; /* Total space assigned to bucket */ + size_t numRemoves; /* Number of removes from bucket */ + size_t numInserts; /* Number of inserts into bucket */ + size_t numLocks; /* Number of locks acquired */ + size_t totalAssigned; /* Total space assigned to bucket */ } Bucket; /* @@ -107,9 +106,9 @@ typedef struct Cache { struct Cache *nextPtr; /* Linked list of cache entries */ Tcl_ThreadId owner; /* Which thread's cache is this? */ Tcl_Obj *firstObjPtr; /* List of free objects for thread */ - int numObjects; /* Number of objects for thread */ + size_t numObjects; /* Number of objects for thread */ Tcl_Obj *lastPtr; /* Last object in this cache */ - int totalAssigned; /* Total space assigned to thread */ + size_t totalAssigned; /* Total space assigned to thread */ Bucket buckets[NBUCKETS]; /* The buckets for this thread */ } Cache; @@ -120,8 +119,8 @@ typedef struct Cache { static struct { size_t blockSize; /* Bucket blocksize. */ - int maxBlocks; /* Max blocks before move to share. */ - int numMove; /* Num blocks to move to share. */ + size_t maxBlocks; /* Max blocks before move to share. */ + size_t numMove; /* Num blocks to move to share. */ Tcl_Mutex *lockPtr; /* Share bucket lock. */ } bucketInfo[NBUCKETS]; @@ -132,12 +131,12 @@ static struct { static Cache * GetCache(void); static void LockBucket(Cache *cachePtr, int bucket); static void UnlockBucket(Cache *cachePtr, int bucket); -static void PutBlocks(Cache *cachePtr, int bucket, int numMove); +static void PutBlocks(Cache *cachePtr, int bucket, size_t numMove); static int GetBlocks(Cache *cachePtr, int bucket); static Block * Ptr2Block(void *ptr); -static void * Block2Ptr(Block *blockPtr, int bucket, unsigned int reqSize); -static void MoveObjs(Cache *fromPtr, Cache *toPtr, int numMove); -static void PutObjs(Cache *fromPtr, int numMove); +static void * Block2Ptr(Block *blockPtr, int bucket, size_t reqSize); +static void MoveObjs(Cache *fromPtr, Cache *toPtr, size_t numMove); +static void PutObjs(Cache *fromPtr, size_t numMove); /* * Local variables defined in this file and initialized at startup. @@ -548,7 +547,7 @@ TclThreadAllocObj(void) */ if (cachePtr->numObjects == 0) { - int numMove; + size_t numMove; Tcl_MutexLock(objLockPtr); numMove = sharedPtr->numObjects; @@ -565,11 +564,11 @@ TclThreadAllocObj(void) cachePtr->numObjects = numMove = NOBJALLOC; newObjsPtr = (Tcl_Obj *)TclpSysAlloc(sizeof(Tcl_Obj) * numMove, 0); if (newObjsPtr == NULL) { - Tcl_Panic("alloc: could not allocate %d new objects", numMove); + Tcl_Panic("alloc: could not allocate %" TCL_Z_MODIFIER "u new objects", numMove); } cachePtr->lastPtr = newObjsPtr + numMove - 1; objPtr = cachePtr->firstObjPtr; /* NULL */ - while (--numMove >= 0) { + while (numMove-- > 0) { newObjsPtr[numMove].internalRep.twoPtrValue.ptr1 = objPtr; objPtr = newObjsPtr + numMove; } @@ -671,14 +670,14 @@ Tcl_GetMemoryInfo( Tcl_DStringAppendElement(dsPtr, buf); } for (n = 0; n < NBUCKETS; ++n) { - sprintf(buf, "%lu %ld %ld %ld %ld %ld %ld", - (unsigned long) bucketInfo[n].blockSize, + sprintf(buf, "%" TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u %" + TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u", + bucketInfo[n].blockSize, cachePtr->buckets[n].numFree, cachePtr->buckets[n].numRemoves, cachePtr->buckets[n].numInserts, cachePtr->buckets[n].totalAssigned, - cachePtr->buckets[n].numLocks, - cachePtr->buckets[n].numWaits); + cachePtr->buckets[n].numLocks); Tcl_DStringAppendElement(dsPtr, buf); } Tcl_DStringEndSublist(dsPtr); @@ -707,7 +706,7 @@ static void MoveObjs( Cache *fromPtr, Cache *toPtr, - int numMove) + size_t numMove) { Tcl_Obj *objPtr = fromPtr->firstObjPtr; Tcl_Obj *fromFirstObjPtr = objPtr; @@ -720,7 +719,7 @@ MoveObjs( * to be moved) as the first object in the 'from' cache. */ - while (--numMove) { + while (numMove-- > 1) { objPtr = (Tcl_Obj *)objPtr->internalRep.twoPtrValue.ptr1; } fromPtr->firstObjPtr = (Tcl_Obj *)objPtr->internalRep.twoPtrValue.ptr1; @@ -754,9 +753,9 @@ MoveObjs( static void PutObjs( Cache *fromPtr, - int numMove) + size_t numMove) { - int keep = fromPtr->numObjects - numMove; + size_t keep = fromPtr->numObjects - numMove; Tcl_Obj *firstPtr, *lastPtr = NULL; fromPtr->numObjects = keep; @@ -767,7 +766,7 @@ PutObjs( do { lastPtr = firstPtr; firstPtr = (Tcl_Obj *)firstPtr->internalRep.twoPtrValue.ptr1; - } while (--keep > 0); + } while (keep-- > 1); lastPtr->internalRep.twoPtrValue.ptr1 = NULL; } @@ -808,7 +807,7 @@ static void * Block2Ptr( Block *blockPtr, int bucket, - unsigned int reqSize) + size_t reqSize) { void *ptr; @@ -898,14 +897,14 @@ static void PutBlocks( Cache *cachePtr, int bucket, - int numMove) + size_t numMove) { /* * We have numFree. Want to shed numMove. So compute how many * Blocks to keep. */ - int keep = cachePtr->buckets[bucket].numFree - numMove; + size_t keep = cachePtr->buckets[bucket].numFree - numMove; Block *lastPtr = NULL, *firstPtr; cachePtr->buckets[bucket].numFree = keep; @@ -916,7 +915,7 @@ PutBlocks( do { lastPtr = firstPtr; firstPtr = firstPtr->nextBlock; - } while (--keep > 0); + } while (keep-- > 1); lastPtr->nextBlock = NULL; } @@ -961,7 +960,7 @@ GetBlocks( int bucket) { Block *blockPtr; - int n; + size_t n; /* * First, atttempt to move blocks from the shared cache. Note the @@ -994,7 +993,7 @@ GetBlocks( cachePtr->buckets[bucket].firstPtr = blockPtr; sharedPtr->buckets[bucket].numFree -= n; cachePtr->buckets[bucket].numFree = n; - while (--n > 0) { + while (n-- > 1) { blockPtr = blockPtr->nextBlock; } sharedPtr->buckets[bucket].firstPtr = blockPtr->nextBlock; @@ -1016,7 +1015,7 @@ GetBlocks( blockPtr = NULL; n = NBUCKETS; size = 0; - while (--n > bucket) { + while (n-- > (size_t)bucket + 1) { if (cachePtr->buckets[n].numFree > 0) { size = bucketInfo[n].blockSize; blockPtr = cachePtr->buckets[n].firstPtr; @@ -1045,7 +1044,7 @@ GetBlocks( n = size / bucketInfo[bucket].blockSize; cachePtr->buckets[bucket].numFree = n; cachePtr->buckets[bucket].firstPtr = blockPtr; - while (--n > 0) { + while (n-- > 1) { blockPtr->nextBlock = (Block *) ((char *) blockPtr + bucketInfo[bucket].blockSize); blockPtr = blockPtr->nextBlock; @@ -1082,9 +1081,9 @@ TclInitThreadAlloc(void) objLockPtr = TclpNewAllocMutex(); for (i = 0; i < NBUCKETS; ++i) { bucketInfo[i].blockSize = MINALLOC << i; - bucketInfo[i].maxBlocks = 1 << (NBUCKETS - 1 - i); + bucketInfo[i].maxBlocks = ((size_t)1) << (NBUCKETS - 1 - i); bucketInfo[i].numMove = i < NBUCKETS - 1 ? - 1 << (NBUCKETS - 2 - i) : 1; + (size_t)1 << (NBUCKETS - 2 - i) : 1; bucketInfo[i].lockPtr = TclpNewAllocMutex(); } TclpInitAllocCache(); diff --git a/generic/tclThreadJoin.c b/generic/tclThreadJoin.c index 0aff0a7..4d2aca5 100644 --- a/generic/tclThreadJoin.c +++ b/generic/tclThreadJoin.c @@ -6,7 +6,7 @@ * provide the functionality of joining threads. This code is currently * not necessary on Unix. * - * Copyright (c) 2000 by Scriptics Corporation + * Copyright © 2000 Scriptics Corporation * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -305,6 +305,8 @@ TclSignalExitThread( Tcl_MutexUnlock(&threadPtr->threadMutex); } +#else +TCL_MAC_EMPTY_FILE(generic_tclThreadJoin_c) #endif /* _WIN32 */ /* diff --git a/generic/tclThreadStorage.c b/generic/tclThreadStorage.c index 74c23af..b2de9b4 100644 --- a/generic/tclThreadStorage.c +++ b/generic/tclThreadStorage.c @@ -4,8 +4,8 @@ * This file implements platform independent thread storage operations to * work around system limits on the number of thread-specific variables. * - * Copyright (c) 2003-2004 by Joe Mistachkin - * Copyright (c) 2008 by George Peter Staplin + * Copyright © 2003-2004 Joe Mistachkin + * Copyright © 2008 George Peter Staplin * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index 0bb55e1..9f08d83 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -6,8 +6,8 @@ * Some of this code is based on work done by Richard Hipp on behalf of * Conservation Through Innovation, Limited, with their permission. * - * Copyright (c) 1998 by Sun Microsystems, Inc. - * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. + * Copyright © 1998 Sun Microsystems, Inc. + * Copyright © 2006-2008 Joe Mistachkin. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -368,9 +368,9 @@ ThreadObjCmd( if (result == TCL_OK) { Tcl_SetIntObj(Tcl_GetObjResult(interp), status); } else { - char buf[20]; + char buf[TCL_INTEGER_SPACE]; - sprintf(buf, "%" TCL_LL_MODIFIER "d", id); + sprintf(buf, "%" TCL_LL_MODIFIER "d", (long long)id); Tcl_AppendResult(interp, "cannot join thread ", buf, NULL); } return result; diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 6b94cbb..bd9e321 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -4,7 +4,7 @@ * This file provides timer event management facilities for Tcl, * including the "after" command. * - * Copyright (c) 1997 by Sun Microsystems, Inc. + * Copyright © 1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclTomMath.decls b/generic/tclTomMath.decls index 9d6eb1c..3a3b9a8 100644 --- a/generic/tclTomMath.decls +++ b/generic/tclTomMath.decls @@ -7,7 +7,7 @@ # If you edit this file, advance the revision number (and the epoch # if the new stubs are not backward compatible) in tclTomMathDecls.h # -# Copyright (c) 2005 by Kevin B. Kenny. All rights reserved. +# Copyright © 2005 Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -17,7 +17,6 @@ library tcl # Define the unsupported generic interfaces. interface tclTomMath -# hooks {tclTomMathInt} scspec EXTERN # Declare each of the functions in the Tcl tommath interface @@ -244,6 +243,10 @@ declare 69 { declare 70 { void TclBN_mp_set_i64(mp_int *a, int64_t i) } +declare 71 { + mp_err MP_WUR TclBN_mp_unpack(mp_int *rop, size_t count, mp_order order, size_t size, + mp_endian endian, size_t nails, const void *op) +} # Added in libtommath 1.1.0 declare 73 {deprecated {merged with mp_and}} { diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h index 1427e8b..1b2c05f 100644 --- a/generic/tclTomMathDecls.h +++ b/generic/tclTomMathDecls.h @@ -53,7 +53,11 @@ #define MP_FREE(mem, size) TclBNFree(mem) #ifndef MODULE_SCOPE -# define MODULE_SCOPE extern +# ifdef __cplusplus +# define MODULE_SCOPE extern "C" +# else +# define MODULE_SCOPE extern +# endif #endif #ifdef __cplusplus @@ -69,6 +73,11 @@ MODULE_SCOPE mp_err TclBN_s_mp_mul_d(const mp_int *a, mp_digit b, mp_int *c); MODULE_SCOPE void TclBN_s_mp_reverse(unsigned char *s, size_t len); MODULE_SCOPE void TclBN_s_mp_set(mp_int *a, mp_digit b); MODULE_SCOPE mp_err TclBN_s_mp_sub_d(const mp_int *a, mp_digit b, mp_int *c); +MODULE_SCOPE mp_err TclBN_s_mp_balance_mul(const mp_int *a, const mp_int *b, mp_int *c); +MODULE_SCOPE const char *const TclBN_mp_s_rmap; +MODULE_SCOPE const uint8_t TclBN_mp_s_rmap_reverse[]; +MODULE_SCOPE const size_t TclBN_mp_s_rmap_reverse_sz; +MODULE_SCOPE mp_err TclBN_mp_set_int(mp_int *a, unsigned long b); #ifdef __cplusplus } #endif @@ -141,10 +150,11 @@ MODULE_SCOPE mp_err TclBN_s_mp_sub_d(const mp_int *a, mp_digit b, mp_int *c); #define mp_to_radix TclBN_mp_to_radix #define mp_to_ubin TclBN_mp_to_ubin #define mp_ubin_size TclBN_mp_ubin_size +#define mp_unpack TclBN_mp_unpack #define mp_xor TclBN_mp_xor #define mp_zero TclBN_mp_zero #define s_mp_add TclBN_s_mp_add -#define s_mp_balance_mul TclBN_mp_balance_mul +#define s_mp_balance_mul TclBN_s_mp_balance_mul #define s_mp_karatsuba_mul TclBN_mp_karatsuba_mul #define s_mp_karatsuba_sqr TclBN_mp_karatsuba_sqr #define s_mp_mul_digs TclBN_s_mp_mul_digs @@ -379,7 +389,11 @@ EXTERN void TclBN_mp_set_u64(mp_int *a, uint64_t i); EXTERN uint64_t TclBN_mp_get_mag_u64(const mp_int *a) MP_WUR; /* 70 */ EXTERN void TclBN_mp_set_i64(mp_int *a, int64_t i); -/* Slot 71 is reserved */ +/* 71 */ +EXTERN mp_err TclBN_mp_unpack(mp_int *rop, size_t count, + mp_order order, size_t size, + mp_endian endian, size_t nails, + const void *op) MP_WUR; /* Slot 72 is reserved */ /* 73 */ TCL_DEPRECATED("merged with mp_and") @@ -482,7 +496,7 @@ typedef struct TclTomMathStubs { void (*tclBN_mp_set_u64) (mp_int *a, uint64_t i); /* 68 */ uint64_t (*tclBN_mp_get_mag_u64) (const mp_int *a) MP_WUR; /* 69 */ void (*tclBN_mp_set_i64) (mp_int *a, int64_t i); /* 70 */ - void (*reserved71)(void); + mp_err (*tclBN_mp_unpack) (mp_int *rop, size_t count, mp_order order, size_t size, mp_endian endian, size_t nails, const void *op) MP_WUR; /* 71 */ void (*reserved72)(void); TCL_DEPRECATED_API("merged with mp_and") mp_err (*tclBN_mp_tc_and) (const mp_int *a, const mp_int *b, mp_int *c); /* 73 */ TCL_DEPRECATED_API("merged with mp_or") mp_err (*tclBN_mp_tc_or) (const mp_int *a, const mp_int *b, mp_int *c); /* 74 */ @@ -648,7 +662,8 @@ extern const TclTomMathStubs *tclTomMathStubsPtr; (tclTomMathStubsPtr->tclBN_mp_get_mag_u64) /* 69 */ #define TclBN_mp_set_i64 \ (tclTomMathStubsPtr->tclBN_mp_set_i64) /* 70 */ -/* Slot 71 is reserved */ +#define TclBN_mp_unpack \ + (tclTomMathStubsPtr->tclBN_mp_unpack) /* 71 */ /* Slot 72 is reserved */ #define TclBN_mp_tc_and \ (tclTomMathStubsPtr->tclBN_mp_tc_and) /* 73 */ diff --git a/generic/tclTomMathInterface.c b/generic/tclTomMathInterface.c index 60ed123..149ee34 100644 --- a/generic/tclTomMathInterface.c +++ b/generic/tclTomMathInterface.c @@ -6,7 +6,7 @@ * This file contains procedures that are used as a 'glue' layer between * Tcl and libtommath. * - * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved. + * Copyright © 2005 Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclTomMathStubLib.c b/generic/tclTomMathStubLib.c index 7bebe12..c0786c9 100644 --- a/generic/tclTomMathStubLib.c +++ b/generic/tclTomMathStubLib.c @@ -4,8 +4,8 @@ * Stub object that will be statically linked into extensions that want * to access Tcl. * - * Copyright (c) 1998-1999 by Scriptics Corporation. - * Copyright (c) 1998 Paul Duffin. + * Copyright © 1998-1999 Scriptics Corporation. + * Copyright © 1998 Paul Duffin. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclTrace.c b/generic/tclTrace.c index d189581..acb0fa4 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -3,10 +3,10 @@ * * This file contains code to handle most trace management. * - * Copyright (c) 1987-1993 The Regents of the University of California. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. - * Copyright (c) 1998-2000 Scriptics Corporation. - * Copyright (c) 2002 ActiveState Corporation. + * Copyright © 1987-1993 The Regents of the University of California. + * Copyright © 1994-1997 Sun Microsystems, Inc. + * Copyright © 1998-2000 Scriptics Corporation. + * Copyright © 2002 ActiveState Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclUniData.c b/generic/tclUniData.c index ad47dda..f6e0c6b 100644 --- a/generic/tclUniData.c +++ b/generic/tclUniData.c @@ -5,7 +5,7 @@ * automatically generated by the tools/uniParse.tcl script. Do not * modify this file by hand. * - * Copyright (c) 1998 by Scriptics Corporation. + * Copyright © 1998 Scriptics Corporation. * All rights reserved. */ diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 525cd50..28f725a 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -3,7 +3,7 @@ * * Routines for manipulating UTF-8 strings. * - * Copyright (c) 1997-1998 Sun Microsystems, Inc. + * Copyright © 1997-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -64,20 +64,12 @@ static const unsigned char totalBytes[256] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, -/* Tcl_UtfCharComplete() might point to 2nd byte of valid 4-byte sequence */ - 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, - 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, -/* End of "continuation byte section" */ + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, - 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, -#if TCL_UTF_MAX > 3 - 4,4,4,4,4, -#else - 1,1,1,1,1, -#endif - 1,1,1,1,1,1,1,1,1,1,1 + 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,4,4,4,4,4,1,1,1,1,1,1,1,1,1,1,1 }; - + static const unsigned char complete[256] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, @@ -88,15 +80,9 @@ static const unsigned char complete[256] = { 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, /* End of "continuation byte section" */ 2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, - 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, -#if TCL_UTF_MAX > 3 - 4,4,4,4,4, -#else - 3,3,3,3,3, -#endif - 1,1,1,1,1,1,1,1,1,1,1 + 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,4,4,4,4,4,1,1,1,1,1,1,1,1,1,1,1 }; - + /* * Functions used only in this module. */ @@ -694,7 +680,7 @@ Tcl_UtfToUniCharDString( p += TclUtfToUCS4(p, &ch); *w++ = ch; } - while ((p < endPtr) && TclUCS4Complete(p, endPtr-p)) { + while ((p < endPtr) && Tcl_UtfCharComplete(p, endPtr-p)) { p += TclUtfToUCS4(p, &ch); *w++ = ch; } @@ -752,7 +738,7 @@ Tcl_UtfToChar16DString( *w++ = ch; } while (p < endPtr) { - if (TclChar16Complete(p, endPtr-p)) { + if (Tcl_UtfCharComplete(p, endPtr-p)) { p += Tcl_UtfToChar16(p, &ch); *w++ = ch; } else { @@ -833,7 +819,7 @@ Tcl_NumUtfChars( /* Pointer to the end of string. Never read endPtr[0] */ const char *endPtr = src + length; /* Pointer to last byte where optimization still can be used */ - const char *optPtr = endPtr - TCL_UTF_MAX; + const char *optPtr = endPtr - 4; /* * Optimize away the call in this loop. Justified because... @@ -970,6 +956,10 @@ Tcl_UtfNext( const char *next; if (((*src) & 0xC0) == 0x80) { + /* Continuation byte, so we start 'inside' a (possible valid) UTF-8 + * sequence. Since we are not allowed to access src[-1], we cannot + * check if the sequence is actually valid, the best we can do is + * just assume it is valid and locate the end. */ if ((((*++src) & 0xC0) == 0x80) && (((*++src) & 0xC0) == 0x80)) { ++src; } @@ -1064,7 +1054,7 @@ Tcl_UtfPrev( * it (the fallback) is correct. */ - || (trailBytesSeen >= complete[byte])) { + || (trailBytesSeen >= totalBytes[byte])) { /* * That is, (1 + trailBytesSeen > needed). * We've examined more bytes than needed to complete @@ -1105,19 +1095,14 @@ Tcl_UtfPrev( /* Continue the search backwards... */ look--; - } while (trailBytesSeen < TCL_UTF_MAX); + } while (trailBytesSeen < 4); /* - * We've seen TCL_UTF_MAX trail bytes, so we know there will not be a + * We've seen 4 trail bytes, so we know there will not be a * properly formed byte sequence to find, and we can stop looking, - * accepting the fallback (for TCL_UTF_MAX > 3) or just go back as - * far as we can. + * accepting the fallback. */ -#if TCL_UTF_MAX > 3 return fallback; -#else - return src - TCL_UTF_MAX; -#endif } /* @@ -1744,7 +1729,7 @@ Tcl_UniCharToLower( /* Clear away extension bits, if any */ return ch & 0x1FFFFF; } - + /* *---------------------------------------------------------------------- * @@ -1838,7 +1823,7 @@ Tcl_UniCharNcmp( const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */ unsigned long numChars) /* Number of unichars to compare. */ { -#ifdef WORDS_BIGENDIAN +#if defined(WORDS_BIGENDIAN) && (TCL_UTF_MAX > 3) /* * We are definitely on a big-endian machine; memcmp() is safe */ @@ -1852,6 +1837,14 @@ Tcl_UniCharNcmp( for ( ; numChars != 0; ucs++, uct++, numChars--) { if (*ucs != *uct) { +#if TCL_UTF_MAX < 4 + /* special case for handling upper surrogates */ + if (((*ucs & 0xFC00) == 0xD800) && ((*uct & 0xFC00) != 0xD800)) { + return 1; + } else if (((*uct & 0xFC00) == 0xD800)) { + return -1; + } +#endif return (*ucs - *uct); } } @@ -1889,6 +1882,14 @@ Tcl_UniCharNcasecmp( Tcl_UniChar lct = Tcl_UniCharToLower(*uct); if (lcs != lct) { +#if TCL_UTF_MAX < 4 + /* special case for handling upper surrogates */ + if (((lcs & 0xFC00) == 0xD800) && ((lct & 0xFC00) != 0xD800)) { + return 1; + } else if (((lct & 0xFC00) == 0xD800)) { + return -1; + } +#endif return (lcs - lct); } } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 170a85e..bbacbe2 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -4,9 +4,9 @@ * This file contains utility functions that are used by many Tcl * commands. * - * Copyright (c) 1987-1993 The Regents of the University of California. - * Copyright (c) 1994-1998 Sun Microsystems, Inc. - * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. + * Copyright © 1987-1993 The Regents of the University of California. + * Copyright © 1994-1998 Sun Microsystems, Inc. + * Copyright © 2001 Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -1707,7 +1707,7 @@ TclTrimRight( const char *q = trim; int pInc = 0, bytesLeft = numTrim; - pp = TclUtfPrev(p, bytes); + pp = Tcl_UtfPrev(p, bytes); do { pp += pInc; pInc = TclUtfToUCS4(pp, &ch1); @@ -1718,14 +1718,14 @@ TclTrimRight( */ do { - int qInc = TclUtfToUCS4(q, &ch2); + pInc = TclUtfToUCS4(q, &ch2); if (ch1 == ch2) { break; } - q += qInc; - bytesLeft -= qInc; + q += pInc; + bytesLeft -= pInc; } while (bytesLeft); if (bytesLeft == 0) { @@ -1771,7 +1771,7 @@ TclTrimLeft( * rely on (trim[numTrim] == '\0'). */ { const char *p = bytes; - int ch1, ch2; + int ch1, ch2; /* Empty strings -> nothing to do */ if ((numBytes == 0) || (numTrim == 0)) { @@ -2030,7 +2030,14 @@ Tcl_ConcatObj( continue; } if (resPtr) { - if (TCL_OK != Tcl_ListObjAppendList(NULL, resPtr, objPtr)) { + Tcl_Obj *elemPtr = NULL; + + Tcl_ListObjIndex(NULL, objPtr, 0, &elemPtr); + if (elemPtr == NULL) { + continue; + } + if (Tcl_GetString(elemPtr)[0] == '#' || TCL_OK + != Tcl_ListObjAppendList(NULL, resPtr, objPtr)) { /* Abandon ship! */ Tcl_DecrRefCount(resPtr); goto slow; diff --git a/generic/tclVar.c b/generic/tclVar.c index 0f0bc25..51c51f8 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -7,11 +7,11 @@ * The implementation of arrays is modelled after an initial * implementation by Mark Diekhans and Karl Lehenbauer. * - * Copyright (c) 1987-1994 The Regents of the University of California. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. - * Copyright (c) 1998-1999 by Scriptics Corporation. - * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. - * Copyright (c) 2007 Miguel Sofer + * Copyright © 1987-1994 The Regents of the University of California. + * Copyright © 1994-1997 Sun Microsystems, Inc. + * Copyright © 1998-1999 Scriptics Corporation. + * Copyright © 2001 Kevin B. Kenny. All rights reserved. + * Copyright © 2007 Miguel Sofer * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 4a13970..8706d5a 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -2,10 +2,10 @@ * tclZipfs.c -- * * Implementation of the ZIP filesystem used in TIP 430 - * Adapted from the implentation for AndroWish. + * Adapted from the implementation for AndroWish. * - * Copyright (c) 2016-2017 Sean Woods <yoda@etoyoc.com> - * Copyright (c) 2013-2015 Christian Werner <chw@ch-werner.de> + * Copyright © 2016-2017 Sean Woods <yoda@etoyoc.com> + * Copyright © 2013-2015 Christian Werner <chw@ch-werner.de> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -38,8 +38,6 @@ #include "zutil.h" #include "crc32.h" -#ifdef CFG_RUNTIME_DLLFILE - /* ** We are compiling as part of the core. ** TIP430 style zipfs prefix @@ -49,22 +47,7 @@ #define ZIPFS_VOLUME_LEN 9 #define ZIPFS_APP_MOUNT "//zipfs:/app" #define ZIPFS_ZIP_MOUNT "//zipfs:/lib/tcl" - -#else /* !CFG_RUNTIME_DLLFILE */ - -/* -** We are compiling from the /compat folder of tclconfig -** Pre TIP430 style zipfs prefix -** //zipfs:/ doesn't work straight out of the box on either windows or Unix -** without other changes made to tip 430 -*/ - -#define ZIPFS_VOLUME "zipfs:/" -#define ZIPFS_VOLUME_LEN 7 -#define ZIPFS_APP_MOUNT "zipfs:/app" -#define ZIPFS_ZIP_MOUNT "zipfs:/lib/tcl" - -#endif /* CFG_RUNTIME_DLLFILE */ +#define ZIPFS_FALLBACK_ENCODING "cp437" /* * Various constants and offsets found in ZIP archive files @@ -147,6 +130,14 @@ Tcl_SetObjResult(interp, Tcl_NewStringObj(errstr, -1)); \ } \ } while (0) +#define ZIPFS_MEM_ERROR(interp) \ + do { \ + if (interp) { \ + Tcl_SetObjResult(interp, Tcl_NewStringObj( \ + "out of memory", -1)); \ + Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); \ + } \ + } while (0) #define ZIPFS_POSIX_ERROR(interp,errstr) \ do { \ if (interp) { \ @@ -154,27 +145,11 @@ "%s: %s", errstr, Tcl_PosixError(interp))); \ } \ } while (0) - -/* - * Macros to read and write 16 and 32 bit integers from/to ZIP archives. - */ - -#define ZipReadInt(p) \ - ((p)[0] | ((p)[1] << 8) | ((p)[2] << 16) | ((p)[3] << 24)) -#define ZipReadShort(p) \ - ((p)[0] | ((p)[1] << 8)) - -#define ZipWriteInt(p, v) \ - do { \ - (p)[0] = (v) & 0xff; \ - (p)[1] = ((v) >> 8) & 0xff; \ - (p)[2] = ((v) >> 16) & 0xff; \ - (p)[3] = ((v) >> 24) & 0xff; \ - } while (0) -#define ZipWriteShort(p, v) \ - do { \ - (p)[0] = (v) & 0xff; \ - (p)[1] = ((v) >> 8) & 0xff; \ +#define ZIPFS_ERROR_CODE(interp,errcode) \ + do { \ + if (interp) { \ + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", errcode, NULL); \ + } \ } while (0) /* @@ -195,6 +170,12 @@ TCL_DECLARE_MUTEX(localtimeMutex) #endif /* !_WIN32 && !HAVE_LOCALTIME_R && TCL_THREADS */ /* + * Forward declaration. + */ + +struct ZipEntry; + +/* * In-core description of mounted ZIP archive file. */ @@ -223,12 +204,13 @@ typedef struct ZipFile { /* * In-core description of file contained in mounted ZIP archive. + * ZIP_ATTR_ */ typedef struct ZipEntry { char *name; /* The full pathname of the virtual file */ ZipFile *zipFilePtr; /* The ZIP file holding this virtual file */ - Tcl_WideInt offset; /* Data offset into memory mapped ZIP file */ + size_t offset; /* Data offset into memory mapped ZIP file */ int numBytes; /* Uncompressed size of the virtual file */ int numCompressedBytes; /* Compressed size of the virtual file */ int compressMethod; /* Compress method */ @@ -278,12 +260,22 @@ static struct { int initialized; /* True when initialized */ int lock; /* RW lock, see below */ int waiters; /* RW lock, see below */ - int wrmax; /* Maximum write size of a file */ + int wrmax; /* Maximum write size of a file; only written + * to from Tcl code in a trusted interpreter, + * so NOT protected by mutex. */ + char *fallbackEntryEncoding;/* The fallback encoding for ZIP entries when + * they are believed to not be UTF-8; only + * written to from Tcl code in a trusted + * interpreter, so not protected by mutex. */ + Tcl_Encoding utf8; /* The UTF-8 encoding that we prefer to use + * for the strings (especially filenames) + * embedded in a ZIP. Other encodings are used + * dynamically. */ int idCount; /* Counter for channel names */ Tcl_HashTable fileHash; /* File name to ZipEntry mapping */ Tcl_HashTable zipHash; /* Mount to ZipFile mapping */ } ZipFS = { - 0, 0, 0, DEFAULT_WRITE_MAX_SIZE, 0, + 0, 0, 0, DEFAULT_WRITE_MAX_SIZE, NULL, NULL, 0, {0,{0,0,0,0},0,0,0,0,0,0,0,0,0}, {0,{0,0,0,0},0,0,0,0,0,0,0,0,0} }; @@ -300,10 +292,33 @@ static const char *zipfs_literal_tcl_library = NULL; /* Function prototypes */ +static int CopyImageFile(Tcl_Interp *interp, const char *imgName, + Tcl_Channel out); static inline int DescribeMounted(Tcl_Interp *interp, const char *mountPoint); +static int InitReadableChannel(Tcl_Interp *interp, + ZipChannel *info, ZipEntry *z); +static int InitWritableChannel(Tcl_Interp *interp, + ZipChannel *info, ZipEntry *z, int trunc); static inline int ListMountPoints(Tcl_Interp *interp); +static void SerializeCentralDirectoryEntry( + const unsigned char *start, + const unsigned char *end, unsigned char *buf, + ZipEntry *z, size_t nameLength, + long long dataStartOffset); +static void SerializeCentralDirectorySuffix( + const unsigned char *start, + const unsigned char *end, unsigned char *buf, + int entryCount, long long dataStartOffset, + long long directoryStartOffset, + long long suffixStartOffset); +static void SerializeLocalEntryHeader( + const unsigned char *start, + const unsigned char *end, unsigned char *buf, + ZipEntry *z, int nameLength, int align); +#if !defined(STATIC_BUILD) static int ZipfsAppHookFindTclInit(const char *archive); +#endif static int ZipFSPathInFilesystemProc(Tcl_Obj *pathPtr, void **clientDataPtr); static Tcl_Obj * ZipFSFilesystemPathTypeProc(Tcl_Obj *pathPtr); @@ -315,6 +330,9 @@ static Tcl_Channel ZipFSOpenFileChannelProc(Tcl_Interp *interp, static int ZipFSMatchInDirectoryProc(Tcl_Interp *interp, Tcl_Obj *result, Tcl_Obj *pathPtr, const char *pattern, Tcl_GlobTypeData *types); +static void ZipFSMatchMountPoints(Tcl_Obj *result, + Tcl_Obj *normPathPtr, const char *pattern, + Tcl_DString *prefix); static Tcl_Obj * ZipFSListVolumesProc(void); static const char *const *ZipFSFileAttrStringsProc(Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); @@ -325,6 +343,8 @@ static int ZipFSFileAttrsSetProc(Tcl_Interp *interp, int index, static int ZipFSLoadFile(Tcl_Interp *interp, Tcl_Obj *path, Tcl_LoadHandle *loadHandle, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); +static int ZipMapArchive(Tcl_Interp *interp, ZipFile *zf, + void *handle); static void ZipfsExitHandler(ClientData clientData); static void ZipfsSetup(void); static int ZipChannelClose(void *instanceData, @@ -332,12 +352,12 @@ static int ZipChannelClose(void *instanceData, static Tcl_DriverGetHandleProc ZipChannelGetFile; static int ZipChannelRead(void *instanceData, char *buf, int toRead, int *errloc); -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) static int ZipChannelSeek(void *instanceData, long offset, int mode, int *errloc); #endif -static Tcl_WideInt ZipChannelWideSeek(void *instanceData, Tcl_WideInt offset, - int mode, int *errloc); +static long long ZipChannelWideSeek(void *instanceData, + long long offset, int mode, int *errloc); static void ZipChannelWatchChannel(void *instanceData, int mask); static int ZipChannelWrite(void *instanceData, @@ -376,7 +396,7 @@ static const Tcl_Filesystem zipfsFilesystem = { NULL, /* renameFileProc */ NULL, /* copyDirectoryProc */ NULL, /* lstatProc */ - (Tcl_FSLoadFileProc *)(void *)ZipFSLoadFile, + (Tcl_FSLoadFileProc *) (void *) ZipFSLoadFile, NULL, /* getCwdProc */ NULL, /* chdirProc */ }; @@ -386,27 +406,28 @@ static const Tcl_Filesystem zipfsFilesystem = { */ static Tcl_ChannelType ZipChannelType = { - "zip", /* Type name. */ + "zip", /* Type name. */ TCL_CHANNEL_VERSION_5, - TCL_CLOSE2PROC, /* Close channel, clean instance data */ - ZipChannelRead, /* Handle read request */ - ZipChannelWrite, /* Handle write request */ -#ifndef TCL_NO_DEPRECATED - ZipChannelSeek, /* Move location of access point, NULL'able */ + TCL_CLOSE2PROC, /* Close channel, clean instance data */ + ZipChannelRead, /* Handle read request */ + ZipChannelWrite, /* Handle write request */ +#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) + ZipChannelSeek, /* Move location of access point, NULL'able */ #else - NULL, /* Move location of access point, NULL'able */ + NULL, /* Move location of access point, NULL'able */ #endif - NULL, /* Set options, NULL'able */ - NULL, /* Get options, NULL'able */ - ZipChannelWatchChannel, /* Initialize notifier */ - ZipChannelGetFile, /* Get OS handle from the channel */ - ZipChannelClose, /* 2nd version of close channel, NULL'able */ - NULL, /* Set blocking mode for raw channel, NULL'able */ - NULL, /* Function to flush channel, NULL'able */ - NULL, /* Function to handle event, NULL'able */ - ZipChannelWideSeek, /* Wide seek function, NULL'able */ - NULL, /* Thread action function, NULL'able */ - NULL, /* Truncate function, NULL'able */ + NULL, /* Set options, NULL'able */ + NULL, /* Get options, NULL'able */ + ZipChannelWatchChannel, /* Initialize notifier */ + ZipChannelGetFile, /* Get OS handle from the channel */ + ZipChannelClose, /* 2nd version of close channel, NULL'able */ + NULL, /* Set blocking mode for raw channel, + * NULL'able */ + NULL, /* Function to flush channel, NULL'able */ + NULL, /* Function to handle event, NULL'able */ + ZipChannelWideSeek, /* Wide seek function, NULL'able */ + NULL, /* Thread action function, NULL'able */ + NULL, /* Truncate function, NULL'able */ }; /* @@ -418,6 +439,79 @@ static Tcl_ChannelType ZipChannelType = { /* *------------------------------------------------------------------------- * + * ZipReadInt, ZipReadShort, ZipWriteInt, ZipWriteShort -- + * + * Inline functions to read and write little-endian 16 and 32 bit + * integers from/to buffers representing parts of ZIP archives. + * + * These take bufferStart and bufferEnd pointers, which are used to + * maintain a guarantee that out-of-bounds accesses don't happen when + * reading or writing critical directory structures. + * + *------------------------------------------------------------------------- + */ + +static inline unsigned int +ZipReadInt( + const unsigned char *bufferStart, + const unsigned char *bufferEnd, + const unsigned char *ptr) +{ + if (ptr < bufferStart || ptr + 4 > bufferEnd) { + Tcl_Panic("out of bounds read(4): start=%p, end=%p, ptr=%p", + bufferStart, bufferEnd, ptr); + } + return ptr[0] | (ptr[1] << 8) | (ptr[2] << 16) | (ptr[3] << 24); +} + +static inline unsigned short +ZipReadShort( + const unsigned char *bufferStart, + const unsigned char *bufferEnd, + const unsigned char *ptr) +{ + if (ptr < bufferStart || ptr + 2 > bufferEnd) { + Tcl_Panic("out of bounds read(2): start=%p, end=%p, ptr=%p", + bufferStart, bufferEnd, ptr); + } + return ptr[0] | (ptr[1] << 8); +} + +static inline void +ZipWriteInt( + const unsigned char *bufferStart, + const unsigned char *bufferEnd, + unsigned char *ptr, + unsigned int value) +{ + if (ptr < bufferStart || ptr + 4 > bufferEnd) { + Tcl_Panic("out of bounds write(4): start=%p, end=%p, ptr=%p", + bufferStart, bufferEnd, ptr); + } + ptr[0] = value & 0xff; + ptr[1] = (value >> 8) & 0xff; + ptr[2] = (value >> 16) & 0xff; + ptr[3] = (value >> 24) & 0xff; +} + +static inline void +ZipWriteShort( + const unsigned char *bufferStart, + const unsigned char *bufferEnd, + unsigned char *ptr, + unsigned short value) +{ + if (ptr < bufferStart || ptr + 2 > bufferEnd) { + Tcl_Panic("out of bounds write(2): start=%p, end=%p, ptr=%p", + bufferStart, bufferEnd, ptr); + } + ptr[0] = value & 0xff; + ptr[1] = (value >> 8) & 0xff; +} + +/* + *------------------------------------------------------------------------- + * * ReadLock, WriteLock, Unlock -- * * POSIX like rwlock functions to support multiple readers and single @@ -436,7 +530,7 @@ TCL_DECLARE_MUTEX(ZipFSMutex) static Tcl_Condition ZipFSCond; -static void +static inline void ReadLock(void) { Tcl_MutexLock(&ZipFSMutex); @@ -449,7 +543,7 @@ ReadLock(void) Tcl_MutexUnlock(&ZipFSMutex); } -static void +static inline void WriteLock(void) { Tcl_MutexLock(&ZipFSMutex); @@ -462,7 +556,7 @@ WriteLock(void) Tcl_MutexUnlock(&ZipFSMutex); } -static void +static inline void Unlock(void) { Tcl_MutexLock(&ZipFSMutex); @@ -582,7 +676,7 @@ ToDosDate( *------------------------------------------------------------------------- */ -static int +static inline int CountSlashes( const char *string) { @@ -601,6 +695,115 @@ CountSlashes( /* *------------------------------------------------------------------------- * + * DecodeZipEntryText -- + * + * Given a sequence of bytes from an entry in a ZIP central directory, + * convert that into a Tcl string. This is complicated because we don't + * actually know what encoding is in use! So we try to use UTF-8, and if + * that goes wrong, we fall back to a user-specified encoding, or to an + * encoding we specify (Windows code page 437), or to ISO 8859-1 if + * absolutely nothing else works. + * + * During Tcl startup, we skip the user-specified encoding and cp437, as + * we may well not have any loadable encodings yet. Tcl's own library + * files ought to be using ASCII filenames. + * + * Results: + * The decoded filename; the filename is owned by the argument DString. + * + * Side effects: + * Updates dstPtr. + * + *------------------------------------------------------------------------- + */ + +static char * +DecodeZipEntryText( + const unsigned char *inputBytes, + unsigned int inputLength, + Tcl_DString *dstPtr) +{ + Tcl_Encoding encoding; + const char *src; + char *dst; + int dstLen, srcLen = inputLength, flags; + Tcl_EncodingState state; + + Tcl_DStringInit(dstPtr); + if (inputLength < 1) { + return Tcl_DStringValue(dstPtr); + } + + /* + * We can't use Tcl_ExternalToUtfDString at this point; it has no way to + * fail. So we use this modified version of it that can report encoding + * errors to us (so we can fall back to something else). + * + * The utf-8 encoding is implemented internally, and so is guaranteed to + * be present. + */ + + src = (const char *) inputBytes; + dst = Tcl_DStringValue(dstPtr); + dstLen = dstPtr->spaceAvl - 1; + flags = TCL_ENCODING_START | TCL_ENCODING_END | + TCL_ENCODING_STOPONERROR; /* Special flag! */ + + while (1) { + int srcRead, dstWrote; + int result = Tcl_ExternalToUtf(NULL, ZipFS.utf8, src, srcLen, flags, + &state, dst, dstLen, &srcRead, &dstWrote, NULL); + int soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); + + if (result == TCL_OK) { + Tcl_DStringSetLength(dstPtr, soFar); + return Tcl_DStringValue(dstPtr); + } else if (result != TCL_CONVERT_NOSPACE) { + break; + } + + flags &= ~TCL_ENCODING_START; + src += srcRead; + srcLen -= srcRead; + if (Tcl_DStringLength(dstPtr) == 0) { + Tcl_DStringSetLength(dstPtr, dstLen); + } + Tcl_DStringSetLength(dstPtr, 2 * Tcl_DStringLength(dstPtr) + 1); + dst = Tcl_DStringValue(dstPtr) + soFar; + dstLen = Tcl_DStringLength(dstPtr) - soFar - 1; + } + + /* + * Something went wrong. Fall back to another encoding. Those *can* use + * Tcl_ExternalToUtfDString(). + */ + + encoding = NULL; + if (ZipFS.fallbackEntryEncoding) { + encoding = Tcl_GetEncoding(NULL, ZipFS.fallbackEntryEncoding); + } + if (!encoding) { + encoding = Tcl_GetEncoding(NULL, ZIPFS_FALLBACK_ENCODING); + } + if (!encoding) { + /* + * Fallback to internal encoding that always converts all bytes. + * Should only happen when a filename isn't UTF-8 and we've not got + * our encodings initialised for some reason. + */ + + encoding = Tcl_GetEncoding(NULL, "iso8859-1"); + } + + char *converted = Tcl_ExternalToUtfDString(encoding, + (const char *) inputBytes, inputLength, dstPtr); + Tcl_FreeEncoding(encoding); + return converted; +} + +/* + *------------------------------------------------------------------------- + * * CanonicalPath -- * * This function computes the canonical path from a directory and file @@ -786,16 +989,16 @@ CanonicalPath( *------------------------------------------------------------------------- */ -static ZipEntry * +static inline ZipEntry * ZipFSLookup( - char *filename) + const char *filename) { Tcl_HashEntry *hPtr; ZipEntry *z = NULL; hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, filename); if (hPtr) { - z = (ZipEntry *)Tcl_GetHashValue(hPtr); + z = (ZipEntry *) Tcl_GetHashValue(hPtr); } return z; } @@ -803,13 +1006,13 @@ ZipFSLookup( /* *------------------------------------------------------------------------- * - * ZipFSLookupMount -- + * ZipFSLookupZip -- * - * This function returns an indication if the given file name corresponds - * to a mounted ZIP archive file. + * This function gets the structure for a mounted ZIP archive. * * Results: - * Returns true, if the given file name is a mounted ZIP archive file. + * Returns a pointer to the structure, or NULL if the file is ZIP file is + * unknown/not mounted. * * Side effects: * None. @@ -817,25 +1020,76 @@ ZipFSLookup( *------------------------------------------------------------------------- */ -#ifdef NEVER_USED -static int -ZipFSLookupMount( - char *filename) +static inline ZipFile * +ZipFSLookupZip( + const char *mountPoint) { Tcl_HashEntry *hPtr; - Tcl_HashSearch search; + ZipFile *zf = NULL; - for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; - hPtr = Tcl_NextHashEntry(&search)) { - ZipFile *zf = Tcl_GetHashValue(hPtr); + hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mountPoint); + if (hPtr) { + zf = (ZipFile *) Tcl_GetHashValue(hPtr); + } + return zf; +} + +/* + *------------------------------------------------------------------------- + * + * AllocateZipFile, AllocateZipEntry, AllocateZipChannel -- + * + * Allocates the memory for a datastructure. Always ensures that it is + * zeroed out for safety. + * + * Returns: + * The allocated structure, or NULL if allocate fails. + * + * Side effects: + * The interpreter result may be written to on error. Which might fail + * (for ZipFile) in a low-memory situation. Always panics if ZipEntry + * allocation fails. + * + *------------------------------------------------------------------------- + */ - if (strcmp(zf->mountPoint, filename) == 0) { - return 1; - } +static inline ZipFile * +AllocateZipFile( + Tcl_Interp *interp, + size_t mountPointNameLength) +{ + size_t size = sizeof(ZipFile) + mountPointNameLength + 1; + ZipFile *zf = (ZipFile *) attemptckalloc(size); + + if (!zf) { + ZIPFS_MEM_ERROR(interp); + } else { + memset(zf, 0, size); + } + return zf; +} + +static inline ZipEntry * +AllocateZipEntry(void) +{ + ZipEntry *z = (ZipEntry *) ckalloc(sizeof(ZipEntry)); + memset(z, 0, sizeof(ZipEntry)); + return z; +} + +static inline ZipChannel * +AllocateZipChannel( + Tcl_Interp *interp) +{ + ZipChannel *zc = (ZipChannel *) attemptckalloc(sizeof(ZipChannel)); + + if (!zc) { + ZIPFS_MEM_ERROR(interp); + } else { + memset(zc, 0, sizeof(ZipChannel)); } - return 0; + return zc; } -#endif /* NEVER_USED */ /* *------------------------------------------------------------------------- @@ -872,6 +1126,10 @@ ZipFSCloseArchive( return; } + /* + * Remove the memory mapping, if we have one. + */ + #ifdef _WIN32 if (zf->data && !zf->ptrToFree) { UnmapViewOfFile(zf->data); @@ -883,7 +1141,7 @@ ZipFSCloseArchive( #else /* !_WIN32 */ if ((zf->data != MAP_FAILED) && !zf->ptrToFree) { munmap(zf->data, zf->length); - zf->data = (unsigned char *)MAP_FAILED; + zf->data = (unsigned char *) MAP_FAILED; } #endif /* _WIN32 */ @@ -904,7 +1162,7 @@ ZipFSCloseArchive( * * This function takes a memory mapped zip file and indexes the contents. * When "needZip" is zero an embedded ZIP archive in an executable file - * is accepted. + * is accepted. Note that we do not support ZIP64. * * Results: * TCL_OK on success, TCL_ERROR otherwise with an error message placed @@ -924,12 +1182,20 @@ ZipFSFindTOC( ZipFile *zf) { size_t i; - unsigned char *p, *q; + const unsigned char *p, *q; + const unsigned char *start = zf->data; + const unsigned char *end = zf->data + zf->length; + + /* + * Scan backwards from the end of the file for the signature. This is + * necessary because ZIP archives aren't the only things that get tagged + * on the end of executables; digital signatures can also go there. + */ p = zf->data + zf->length - ZIP_CENTRAL_END_LEN; - while (p >= zf->data) { + while (p >= start) { if (*p == (ZIP_CENTRAL_END_SIG & 0xFF)) { - if (ZipReadInt(p) == ZIP_CENTRAL_END_SIG) { + if (ZipReadInt(start, end, p) == ZIP_CENTRAL_END_SIG) { break; } p -= ZIP_SIG_LEN; @@ -938,73 +1204,93 @@ ZipFSFindTOC( } } if (p < zf->data) { + /* + * Didn't find it (or not enough space for a central directory!); not + * a ZIP archive. This might be OK or a problem. + */ + if (!needZip) { zf->baseOffset = zf->passOffset = zf->length; return TCL_OK; } ZIPFS_ERROR(interp, "wrong end signature"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "END_SIG", NULL); - } + ZIPFS_ERROR_CODE(interp, "END_SIG"); goto error; } - zf->numFiles = ZipReadShort(p + ZIP_CENTRAL_ENTS_OFFS); + + /* + * How many files in the archive? If that's bogus, we're done here. + */ + + zf->numFiles = ZipReadShort(start, end, p + ZIP_CENTRAL_ENTS_OFFS); if (zf->numFiles == 0) { if (!needZip) { zf->baseOffset = zf->passOffset = zf->length; return TCL_OK; } ZIPFS_ERROR(interp, "empty archive"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "EMPTY", NULL); - } + ZIPFS_ERROR_CODE(interp, "EMPTY"); goto error; } - q = zf->data + ZipReadInt(p + ZIP_CENTRAL_DIRSTART_OFFS); - p -= ZipReadInt(p + ZIP_CENTRAL_DIRSIZE_OFFS); - if ((p < zf->data) || (p > zf->data + zf->length) + + /* + * Where does the central directory start? + */ + + q = zf->data + ZipReadInt(start, end, p + ZIP_CENTRAL_DIRSTART_OFFS); + p -= ZipReadInt(start, end, p + ZIP_CENTRAL_DIRSIZE_OFFS); + if ((p < q) || (p < zf->data) || (p > zf->data + zf->length) || (q < zf->data) || (q > zf->data + zf->length)) { if (!needZip) { zf->baseOffset = zf->passOffset = zf->length; return TCL_OK; } ZIPFS_ERROR(interp, "archive directory not found"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_DIR", NULL); - } + ZIPFS_ERROR_CODE(interp, "NO_DIR"); goto error; } + + /* + * Read the central directory. + */ + zf->baseOffset = zf->passOffset = p - q; zf->directoryOffset = p - zf->data; q = p; for (i = 0; i < zf->numFiles; i++) { int pathlen, comlen, extra; - if (q + ZIP_CENTRAL_HEADER_LEN > zf->data + zf->length) { + if (q + ZIP_CENTRAL_HEADER_LEN > end) { ZIPFS_ERROR(interp, "wrong header length"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "HDR_LEN", NULL); - } + ZIPFS_ERROR_CODE(interp, "HDR_LEN"); goto error; } - if (ZipReadInt(q) != ZIP_CENTRAL_HEADER_SIG) { + if (ZipReadInt(start, end, q) != ZIP_CENTRAL_HEADER_SIG) { ZIPFS_ERROR(interp, "wrong header signature"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "HDR_SIG", NULL); - } + ZIPFS_ERROR_CODE(interp, "HDR_SIG"); goto error; } - pathlen = ZipReadShort(q + ZIP_CENTRAL_PATHLEN_OFFS); - comlen = ZipReadShort(q + ZIP_CENTRAL_FCOMMENTLEN_OFFS); - extra = ZipReadShort(q + ZIP_CENTRAL_EXTRALEN_OFFS); + pathlen = ZipReadShort(start, end, q + ZIP_CENTRAL_PATHLEN_OFFS); + comlen = ZipReadShort(start, end, q + ZIP_CENTRAL_FCOMMENTLEN_OFFS); + extra = ZipReadShort(start, end, q + ZIP_CENTRAL_EXTRALEN_OFFS); q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN; } + + /* + * If there's also an encoded password, extract that too (but don't decode + * yet). + */ + q = zf->data + zf->baseOffset; - if ((zf->baseOffset >= 6) && (ZipReadInt(q - 4) == ZIP_PASSWORD_END_SIG)) { + if ((zf->baseOffset >= 6) && + (ZipReadInt(start, end, q - 4) == ZIP_PASSWORD_END_SIG)) { + const unsigned char *passPtr; + i = q[-5]; - if (q - 5 - i > zf->data) { + passPtr = q - 5 - i; + if (passPtr >= start && passPtr + i < end) { zf->passBuf[0] = i; - memcpy(zf->passBuf + 1, q - 5 - i, i); + memcpy(zf->passBuf + 1, passPtr, i); zf->passOffset -= i ? (5 + i) : 0; } } @@ -1053,18 +1339,42 @@ ZipFSOpenArchive( zf->data = NULL; zf->mountHandle = INVALID_HANDLE_VALUE; #else /* !_WIN32 */ - zf->data = (unsigned char *)MAP_FAILED; + zf->data = (unsigned char *) MAP_FAILED; #endif /* _WIN32 */ zf->length = 0; zf->numFiles = 0; zf->baseOffset = zf->passOffset = 0; zf->ptrToFree = NULL; zf->passBuf[0] = 0; + + /* + * Actually open the file. + */ + zf->chan = Tcl_OpenFileChannel(interp, zipname, "rb", 0); if (!zf->chan) { return TCL_ERROR; } - if (Tcl_GetChannelHandle(zf->chan, TCL_READABLE, &handle) != TCL_OK) { + + /* + * See if we can get the OS handle. If we can, we can use that to memory + * map the file, which is nice and efficient. However, it totally depends + * on the filename pointing to a real regular OS file. + * + * Opening real filesystem entities that are not files will lead to an + * error. + */ + + if (Tcl_GetChannelHandle(zf->chan, TCL_READABLE, &handle) == TCL_OK) { + if (ZipMapArchive(interp, zf, handle) != TCL_OK) { + goto error; + } + } else { + /* + * Not an OS file, but rather something in a Tcl VFS. Must copy into + * memory. + */ + zf->length = Tcl_Seek(zf->chan, 0, SEEK_END); if (zf->length == ERROR_LENGTH) { ZIPFS_POSIX_ERROR(interp, "seek error"); @@ -1073,21 +1383,16 @@ ZipFSOpenArchive( if ((zf->length - ZIP_CENTRAL_END_LEN) > (64 * 1024 * 1024 - ZIP_CENTRAL_END_LEN)) { ZIPFS_ERROR(interp, "illegal file size"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "FILE_SIZE", NULL); - } + ZIPFS_ERROR_CODE(interp, "FILE_SIZE"); goto error; } if (Tcl_Seek(zf->chan, 0, SEEK_SET) == -1) { ZIPFS_POSIX_ERROR(interp, "seek error"); goto error; } - zf->ptrToFree = zf->data = (unsigned char *)attemptckalloc(zf->length); + zf->ptrToFree = zf->data = (unsigned char *) attemptckalloc(zf->length); if (!zf->ptrToFree) { - ZIPFS_ERROR(interp, "out of memory"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); - } + ZIPFS_MEM_ERROR(interp); goto error; } i = Tcl_Read(zf->chan, (char *) zf->data, zf->length); @@ -1097,67 +1402,137 @@ ZipFSOpenArchive( } Tcl_Close(interp, zf->chan); zf->chan = NULL; - } else { + } + return ZipFSFindTOC(interp, needZip, zf); + + /* + * Handle errors by closing the archive. This includes closing the channel + * handle for the archive file. + */ + + error: + ZipFSCloseArchive(interp, zf); + return TCL_ERROR; +} + +/* + *------------------------------------------------------------------------- + * + * ZipMapArchive -- + * + * Wrapper around the platform-specific parts of mmap() (and Windows's + * equivalent) because it's not part of the standard channel API. + * + *------------------------------------------------------------------------- + */ + +static int +ZipMapArchive( + Tcl_Interp *interp, /* Interpreter for error reporting. */ + ZipFile *zf, /* The archive descriptor structure. */ + void *handle) /* The OS handle to the open archive. */ +{ #ifdef _WIN32 - int readSuccessful; + HANDLE hFile = (HANDLE) handle; + int readSuccessful; + + /* + * Determine the file size. + */ + # ifdef _WIN64 - i = GetFileSizeEx((HANDLE) handle, (PLARGE_INTEGER) &zf->length); - readSuccessful = (i != 0); + readSuccessful = GetFileSizeEx(hFile, (PLARGE_INTEGER) &zf->length) != 0; # else /* !_WIN64 */ - zf->length = GetFileSize((HANDLE) handle, 0); - readSuccessful = (zf->length != (size_t) INVALID_FILE_SIZE); + zf->length = GetFileSize(hFile, 0); + readSuccessful = (zf->length != (size_t) INVALID_FILE_SIZE); # endif /* _WIN64 */ - if (!readSuccessful || (zf->length < ZIP_CENTRAL_END_LEN)) { - ZIPFS_POSIX_ERROR(interp, "invalid file size"); - goto error; - } - zf->mountHandle = CreateFileMappingW((HANDLE) handle, 0, PAGE_READONLY, - 0, zf->length, 0); - if (zf->mountHandle == INVALID_HANDLE_VALUE) { - ZIPFS_POSIX_ERROR(interp, "file mapping failed"); - goto error; - } - zf->data = (unsigned char *)MapViewOfFile(zf->mountHandle, FILE_MAP_READ, 0, 0, - zf->length); - if (!zf->data) { - ZIPFS_POSIX_ERROR(interp, "file mapping failed"); - goto error; - } + if (!readSuccessful || (zf->length < ZIP_CENTRAL_END_LEN)) { + ZIPFS_POSIX_ERROR(interp, "invalid file size"); + return TCL_ERROR; + } + + /* + * Map the file. + */ + + zf->mountHandle = CreateFileMappingW(hFile, 0, PAGE_READONLY, 0, + zf->length, 0); + if (zf->mountHandle == INVALID_HANDLE_VALUE) { + ZIPFS_POSIX_ERROR(interp, "file mapping failed"); + return TCL_ERROR; + } + zf->data = (unsigned char *) + MapViewOfFile(zf->mountHandle, FILE_MAP_READ, 0, 0, zf->length); + if (!zf->data) { + ZIPFS_POSIX_ERROR(interp, "file mapping failed"); + return TCL_ERROR; + } #else /* !_WIN32 */ - zf->length = lseek(PTR2INT(handle), 0, SEEK_END); - if (zf->length == ERROR_LENGTH || zf->length < ZIP_CENTRAL_END_LEN) { - ZIPFS_POSIX_ERROR(interp, "invalid file size"); - goto error; - } - lseek(PTR2INT(handle), 0, SEEK_SET); - zf->data = (unsigned char *) mmap(0, zf->length, PROT_READ, - MAP_FILE | MAP_PRIVATE, PTR2INT(handle), 0); - if (zf->data == MAP_FAILED) { - ZIPFS_POSIX_ERROR(interp, "file mapping failed"); - goto error; - } -#endif /* _WIN32 */ + int fd = PTR2INT(handle); + + /* + * Determine the file size. + */ + + zf->length = lseek(fd, 0, SEEK_END); + if (zf->length == ERROR_LENGTH || zf->length < ZIP_CENTRAL_END_LEN) { + ZIPFS_POSIX_ERROR(interp, "invalid file size"); + return TCL_ERROR; } - return ZipFSFindTOC(interp, needZip, zf); + lseek(fd, 0, SEEK_SET); - error: - ZipFSCloseArchive(interp, zf); - return TCL_ERROR; + zf->data = (unsigned char *) + mmap(0, zf->length, PROT_READ, MAP_FILE | MAP_PRIVATE, fd, 0); + if (zf->data == MAP_FAILED) { + ZIPFS_POSIX_ERROR(interp, "file mapping failed"); + return TCL_ERROR; + } +#endif /* _WIN32 */ + return TCL_OK; } /* *------------------------------------------------------------------------- * - * ZipFSRootNode -- + * IsPasswordValid -- * - * This function generates the root node for a ZIPFS filesystem. + * Basic test for whether a passowrd is valid. If the test fails, sets an + * error message in the interpreter. + * + * Returns: + * TCL_OK if the test passes, TCL_ERROR if it fails. + * + *------------------------------------------------------------------------- + */ + +static inline int +IsPasswordValid( + Tcl_Interp *interp, + const char *passwd, + int pwlen) +{ + if ((pwlen > 255) || strchr(passwd, 0xff)) { + ZIPFS_ERROR(interp, "illegal password"); + ZIPFS_ERROR_CODE(interp, "BAD_PASS"); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSCatalogFilesystem -- + * + * This function generates the root node for a ZIPFS filesystem by + * reading the ZIP's central directory. * * Results: * TCL_OK on success, TCL_ERROR otherwise with an error message placed * into the given "interp" if it is not NULL. * * Side effects: - * ... + * Will acquire and release the write lock. * *------------------------------------------------------------------------- */ @@ -1165,7 +1540,7 @@ ZipFSOpenArchive( static int ZipFSCatalogFilesystem( Tcl_Interp *interp, /* Current interpreter. NULLable. */ - ZipFile *zf0, + ZipFile *zf, /* Temporary buffer hold archive descriptors */ const char *mountPoint, /* Mount point path. */ const char *passwd, /* Password for opening the ZIP, or NULL if * the ZIP is unprotected. */ @@ -1173,7 +1548,7 @@ ZipFSCatalogFilesystem( { int pwlen, isNew; size_t i; - ZipFile *zf; + ZipFile *zf0; ZipEntry *z; Tcl_HashEntry *hPtr; Tcl_DString ds, dsm, fpBuf; @@ -1186,16 +1561,24 @@ ZipFSCatalogFilesystem( pwlen = 0; if (passwd) { pwlen = strlen(passwd); - if ((pwlen > 255) || strchr(passwd, 0xff)) { - if (interp) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("illegal password", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_PASS", NULL); - } + if (IsPasswordValid(interp, passwd, pwlen) != TCL_OK) { return TCL_ERROR; } } + /* + * Validate the TOC data. If that's bad, things fall apart. + */ + + if (zf->baseOffset >= zf->length || zf->passOffset >= zf->length || + zf->directoryOffset >= zf->length) { + ZIPFS_ERROR(interp, "bad zip data"); + ZIPFS_ERROR_CODE(interp, "BAD_ZIP"); + ZipFSCloseArchive(interp, zf); + ckfree(zf); + return TCL_ERROR; + } + WriteLock(); /* @@ -1213,37 +1596,30 @@ ZipFSCatalogFilesystem( hPtr = Tcl_CreateHashEntry(&ZipFS.zipHash, mountPoint, &isNew); if (!isNew) { if (interp) { - zf = (ZipFile *)Tcl_GetHashValue(hPtr); + zf0 = (ZipFile *) Tcl_GetHashValue(hPtr); Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s is already mounted on %s", zf->name, mountPoint)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "MOUNTED", NULL); - } - Unlock(); - ZipFSCloseArchive(interp, zf0); - return TCL_ERROR; - } - zf = (ZipFile *)attemptckalloc(sizeof(ZipFile) + strlen(mountPoint) + 1); - if (!zf) { - if (interp) { - Tcl_AppendResult(interp, "out of memory", (char *) NULL); - Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); + "%s is already mounted on %s", zf0->name, mountPoint)); + ZIPFS_ERROR_CODE(interp, "MOUNTED"); } Unlock(); - ZipFSCloseArchive(interp, zf0); + ZipFSCloseArchive(interp, zf); + ckfree(zf); return TCL_ERROR; } Unlock(); - *zf = *zf0; - zf->mountPoint = (char *)Tcl_GetHashKey(&ZipFS.zipHash, hPtr); + /* + * Convert to a real archive descriptor. + */ + + zf->mountPoint = (char *) Tcl_GetHashKey(&ZipFS.zipHash, hPtr); Tcl_CreateExitHandler(ZipfsExitHandler, zf); zf->mountPointLen = strlen(zf->mountPoint); + zf->nameLength = strlen(zipname); - zf->name = (char *)ckalloc(zf->nameLength + 1); + zf->name = (char *) ckalloc(zf->nameLength + 1); memcpy(zf->name, zipname, zf->nameLength + 1); - zf->entries = NULL; - zf->topEnts = NULL; - zf->numOpen = 0; + Tcl_SetHashValue(hPtr, zf); if ((zf->passBuf[0] == 0) && pwlen) { int k = 0; @@ -1258,21 +1634,15 @@ ZipFSCatalogFilesystem( if (mountPoint[0] != '\0') { hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, mountPoint, &isNew); if (isNew) { - z = (ZipEntry *)ckalloc(sizeof(ZipEntry)); + z = AllocateZipEntry(); Tcl_SetHashValue(hPtr, z); - z->tnext = NULL; z->depth = CountSlashes(mountPoint); z->zipFilePtr = zf; z->isDirectory = (zf->baseOffset == 0) ? 1 : -1; /* root marker */ - z->isEncrypted = 0; z->offset = zf->baseOffset; - z->crc32 = 0; - z->timestamp = 0; - z->numBytes = z->numCompressedBytes = 0; z->compressMethod = ZIP_COMPMETH_STORED; - z->data = NULL; - z->name = (char *)Tcl_GetHashKey(&ZipFS.fileHash, hPtr); + z->name = (char *) Tcl_GetHashKey(&ZipFS.fileHash, hPtr); z->next = zf->entries; zf->entries = z; } @@ -1280,17 +1650,17 @@ ZipFSCatalogFilesystem( q = zf->data + zf->directoryOffset; Tcl_DStringInit(&fpBuf); for (i = 0; i < zf->numFiles; i++) { + const unsigned char *start = zf->data; + const unsigned char *end = zf->data + zf->length; int extra, isdir = 0, dosTime, dosDate, nbcompr; size_t offs, pathlen, comlen; unsigned char *lq, *gq = NULL; char *fullpath, *path; - pathlen = ZipReadShort(q + ZIP_CENTRAL_PATHLEN_OFFS); - comlen = ZipReadShort(q + ZIP_CENTRAL_FCOMMENTLEN_OFFS); - extra = ZipReadShort(q + ZIP_CENTRAL_EXTRALEN_OFFS); - Tcl_DStringSetLength(&ds, 0); - Tcl_DStringAppend(&ds, (char *) q + ZIP_CENTRAL_HEADER_LEN, pathlen); - path = Tcl_DStringValue(&ds); + pathlen = ZipReadShort(start, end, q + ZIP_CENTRAL_PATHLEN_OFFS); + comlen = ZipReadShort(start, end, q + ZIP_CENTRAL_FCOMMENTLEN_OFFS); + extra = ZipReadShort(start, end, q + ZIP_CENTRAL_EXTRALEN_OFFS); + path = DecodeZipEntryText(q + ZIP_CENTRAL_HEADER_LEN, pathlen, &ds); if ((pathlen > 0) && (path[pathlen - 1] == '/')) { Tcl_DStringSetLength(&ds, pathlen - 1); path = Tcl_DStringValue(&ds); @@ -1300,24 +1670,25 @@ ZipFSCatalogFilesystem( goto nextent; } lq = zf->data + zf->baseOffset - + ZipReadInt(q + ZIP_CENTRAL_LOCALHDR_OFFS); - if ((lq < zf->data) || (lq > zf->data + zf->length)) { + + ZipReadInt(start, end, q + ZIP_CENTRAL_LOCALHDR_OFFS); + if ((lq < start) || (lq + ZIP_LOCAL_HEADER_LEN > end)) { goto nextent; } - nbcompr = ZipReadInt(lq + ZIP_LOCAL_COMPLEN_OFFS); + nbcompr = ZipReadInt(start, end, lq + ZIP_LOCAL_COMPLEN_OFFS); if (!isdir && (nbcompr == 0) - && (ZipReadInt(lq + ZIP_LOCAL_UNCOMPLEN_OFFS) == 0) - && (ZipReadInt(lq + ZIP_LOCAL_CRC32_OFFS) == 0)) { + && (ZipReadInt(start, end, lq + ZIP_LOCAL_UNCOMPLEN_OFFS) == 0) + && (ZipReadInt(start, end, lq + ZIP_LOCAL_CRC32_OFFS) == 0)) { gq = q; - nbcompr = ZipReadInt(gq + ZIP_CENTRAL_COMPLEN_OFFS); + nbcompr = ZipReadInt(start, end, gq + ZIP_CENTRAL_COMPLEN_OFFS); } offs = (lq - zf->data) + ZIP_LOCAL_HEADER_LEN - + ZipReadShort(lq + ZIP_LOCAL_PATHLEN_OFFS) - + ZipReadShort(lq + ZIP_LOCAL_EXTRALEN_OFFS); + + ZipReadShort(start, end, lq + ZIP_LOCAL_PATHLEN_OFFS) + + ZipReadShort(start, end, lq + ZIP_LOCAL_EXTRALEN_OFFS); if (offs + nbcompr > zf->length) { goto nextent; } + if (!isdir && (mountPoint[0] == '\0') && !CountSlashes(path)) { #ifdef ANDROID /* @@ -1333,8 +1704,7 @@ ZipFSCatalogFilesystem( Tcl_DStringInit(&ds2); Tcl_DStringAppend(&ds2, "assets/.root/", -1); Tcl_DStringAppend(&ds2, path, -1); - hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, Tcl_DStringValue(&ds2)); - if (hPtr) { + if (ZipFSLookup(Tcl_DStringValue(&ds2))) { /* should not happen but skip it anyway */ Tcl_DStringFree(&ds2); goto nextent; @@ -1351,83 +1721,91 @@ ZipFSCatalogFilesystem( goto nextent; #endif /* ANDROID */ } + Tcl_DStringSetLength(&fpBuf, 0); fullpath = CanonicalPath(mountPoint, path, &fpBuf, 1); - z = (ZipEntry *)ckalloc(sizeof(ZipEntry)); - z->name = NULL; - z->tnext = NULL; + z = AllocateZipEntry(); z->depth = CountSlashes(fullpath); z->zipFilePtr = zf; z->isDirectory = isdir; - z->isEncrypted = (ZipReadShort(lq + ZIP_LOCAL_FLAGS_OFFS) & 1) + z->isEncrypted = + (ZipReadShort(start, end, lq + ZIP_LOCAL_FLAGS_OFFS) & 1) && (nbcompr > 12); z->offset = offs; if (gq) { - z->crc32 = ZipReadInt(gq + ZIP_CENTRAL_CRC32_OFFS); - dosDate = ZipReadShort(gq + ZIP_CENTRAL_MDATE_OFFS); - dosTime = ZipReadShort(gq + ZIP_CENTRAL_MTIME_OFFS); + z->crc32 = ZipReadInt(start, end, gq + ZIP_CENTRAL_CRC32_OFFS); + dosDate = ZipReadShort(start, end, gq + ZIP_CENTRAL_MDATE_OFFS); + dosTime = ZipReadShort(start, end, gq + ZIP_CENTRAL_MTIME_OFFS); z->timestamp = DosTimeDate(dosDate, dosTime); - z->numBytes = ZipReadInt(gq + ZIP_CENTRAL_UNCOMPLEN_OFFS); - z->compressMethod = ZipReadShort(gq + ZIP_CENTRAL_COMPMETH_OFFS); + z->numBytes = ZipReadInt(start, end, + gq + ZIP_CENTRAL_UNCOMPLEN_OFFS); + z->compressMethod = ZipReadShort(start, end, + gq + ZIP_CENTRAL_COMPMETH_OFFS); } else { - z->crc32 = ZipReadInt(lq + ZIP_LOCAL_CRC32_OFFS); - dosDate = ZipReadShort(lq + ZIP_LOCAL_MDATE_OFFS); - dosTime = ZipReadShort(lq + ZIP_LOCAL_MTIME_OFFS); + z->crc32 = ZipReadInt(start, end, lq + ZIP_LOCAL_CRC32_OFFS); + dosDate = ZipReadShort(start, end, lq + ZIP_LOCAL_MDATE_OFFS); + dosTime = ZipReadShort(start, end, lq + ZIP_LOCAL_MTIME_OFFS); z->timestamp = DosTimeDate(dosDate, dosTime); - z->numBytes = ZipReadInt(lq + ZIP_LOCAL_UNCOMPLEN_OFFS); - z->compressMethod = ZipReadShort(lq + ZIP_LOCAL_COMPMETH_OFFS); + z->numBytes = ZipReadInt(start, end, + lq + ZIP_LOCAL_UNCOMPLEN_OFFS); + z->compressMethod = ZipReadShort(start, end, + lq + ZIP_LOCAL_COMPMETH_OFFS); } z->numCompressedBytes = nbcompr; - z->data = NULL; hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, fullpath, &isNew); if (!isNew) { /* should not happen but skip it anyway */ ckfree(z); - } else { - Tcl_SetHashValue(hPtr, z); - z->name = (char *)Tcl_GetHashKey(&ZipFS.fileHash, hPtr); - z->next = zf->entries; - zf->entries = z; - if (isdir && (mountPoint[0] == '\0') && (z->depth == 1)) { - z->tnext = zf->topEnts; - zf->topEnts = z; - } - if (!z->isDirectory && (z->depth > 1)) { - char *dir, *end; - ZipEntry *zd; - - Tcl_DStringSetLength(&ds, strlen(z->name) + 8); - Tcl_DStringSetLength(&ds, 0); - Tcl_DStringAppend(&ds, z->name, -1); - dir = Tcl_DStringValue(&ds); - for (end = strrchr(dir, '/'); end && (end != dir); - end = strrchr(dir, '/')) { - Tcl_DStringSetLength(&ds, end - dir); - hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, dir, &isNew); - if (!isNew) { - break; - } - zd = (ZipEntry *)ckalloc(sizeof(ZipEntry)); - zd->name = NULL; - zd->tnext = NULL; - zd->depth = CountSlashes(dir); - zd->zipFilePtr = zf; - zd->isDirectory = 1; - zd->isEncrypted = 0; - zd->offset = z->offset; - zd->crc32 = 0; - zd->timestamp = z->timestamp; - zd->numBytes = zd->numCompressedBytes = 0; - zd->compressMethod = ZIP_COMPMETH_STORED; - zd->data = NULL; - Tcl_SetHashValue(hPtr, zd); - zd->name = (char *)Tcl_GetHashKey(&ZipFS.fileHash, hPtr); - zd->next = zf->entries; - zf->entries = zd; - if ((mountPoint[0] == '\0') && (zd->depth == 1)) { - zd->tnext = zf->topEnts; - zf->topEnts = zd; - } + goto nextent; + } + + Tcl_SetHashValue(hPtr, z); + z->name = (char *) Tcl_GetHashKey(&ZipFS.fileHash, hPtr); + z->next = zf->entries; + zf->entries = z; + if (isdir && (mountPoint[0] == '\0') && (z->depth == 1)) { + z->tnext = zf->topEnts; + zf->topEnts = z; + } + + /* + * Make any directory nodes we need. ZIPs are not consistent about + * containing directory nodes. + */ + + if (!z->isDirectory && (z->depth > 1)) { + char *dir, *endPtr; + ZipEntry *zd; + + Tcl_DStringSetLength(&ds, strlen(z->name) + 8); + Tcl_DStringSetLength(&ds, 0); + Tcl_DStringAppend(&ds, z->name, -1); + dir = Tcl_DStringValue(&ds); + for (endPtr = strrchr(dir, '/'); endPtr && (endPtr != dir); + endPtr = strrchr(dir, '/')) { + Tcl_DStringSetLength(&ds, endPtr - dir); + hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, dir, &isNew); + if (!isNew) { + /* + * Already made. That's fine. + */ + break; + } + + zd = AllocateZipEntry(); + zd->depth = CountSlashes(dir); + zd->zipFilePtr = zf; + zd->isDirectory = 1; + zd->offset = z->offset; + zd->timestamp = z->timestamp; + zd->compressMethod = ZIP_COMPMETH_STORED; + Tcl_SetHashValue(hPtr, zd); + zd->name = (char *) Tcl_GetHashKey(&ZipFS.fileHash, hPtr); + zd->next = zf->entries; + zf->entries = zd; + if ((mountPoint[0] == '\0') && (zd->depth == 1)) { + zd->tnext = zf->topEnts; + zf->topEnts = zd; } } } @@ -1472,6 +1850,10 @@ ZipfsSetup(void) Tcl_InitHashTable(&ZipFS.zipHash, TCL_STRING_KEYS); ZipFS.idCount = 1; ZipFS.wrmax = DEFAULT_WRITE_MAX_SIZE; + ZipFS.fallbackEntryEncoding = (char *) + ckalloc(strlen(ZIPFS_FALLBACK_ENCODING) + 1); + strcpy(ZipFS.fallbackEntryEncoding, ZIPFS_FALLBACK_ENCODING); + ZipFS.utf8 = Tcl_GetEncoding(NULL, "utf-8"); ZipFS.initialized = 1; } @@ -1501,17 +1883,28 @@ ListMountPoints( Tcl_HashEntry *hPtr; Tcl_HashSearch search; ZipFile *zf; + Tcl_Obj *resultList; + if (!interp) { + /* + * Are there any entries in the zipHash? Don't need to enumerate them + * all to know. + */ + + return (ZipFS.zipHash.numEntries ? TCL_OK : TCL_BREAK); + } + + resultList = Tcl_NewObj(); for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; hPtr = Tcl_NextHashEntry(&search)) { - if (!interp) { - return TCL_OK; - } - zf = (ZipFile *)Tcl_GetHashValue(hPtr); - Tcl_AppendElement(interp, zf->mountPoint); - Tcl_AppendElement(interp, zf->name); + zf = (ZipFile *) Tcl_GetHashValue(hPtr); + Tcl_ListObjAppendElement(NULL, resultList, Tcl_NewStringObj( + zf->mountPoint, -1)); + Tcl_ListObjAppendElement(NULL, resultList, Tcl_NewStringObj( + zf->name, -1)); } - return (interp ? TCL_OK : TCL_BREAK); + Tcl_SetObjResult(interp, resultList); + return TCL_OK; } /* @@ -1538,13 +1931,10 @@ DescribeMounted( Tcl_Interp *interp, const char *mountPoint) { - Tcl_HashEntry *hPtr; - ZipFile *zf; - if (interp) { - hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mountPoint); - if (hPtr) { - zf = (ZipFile *)Tcl_GetHashValue(hPtr); + ZipFile *zf = ZipFSLookupZip(mountPoint); + + if (zf) { Tcl_SetObjResult(interp, Tcl_NewStringObj(zf->name, -1)); return TCL_OK; } @@ -1574,7 +1964,8 @@ int TclZipfs_Mount( Tcl_Interp *interp, /* Current interpreter. NULLable. */ const char *mountPoint, /* Mount point path. */ - const char *zipname, /* Path to ZIP file to mount. */ + const char *zipname, /* Path to ZIP file to mount; should be + * normalized. */ const char *passwd) /* Password for opening the ZIP, or NULL if * the ZIP is unprotected. */ { @@ -1611,22 +2002,11 @@ TclZipfs_Mount( * Have both a mount point and a file (name) to mount there. */ - if (passwd) { - if ((strlen(passwd) > 255) || strchr(passwd, 0xff)) { - if (interp) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("illegal password", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_PASS", NULL); - } - return TCL_ERROR; - } + if (passwd && IsPasswordValid(interp, passwd, strlen(passwd)) != TCL_OK) { + return TCL_ERROR; } - zf = (ZipFile *)attemptckalloc(sizeof(ZipFile) + strlen(mountPoint) + 1); + zf = AllocateZipFile(interp, strlen(mountPoint)); if (!zf) { - if (interp) { - Tcl_AppendResult(interp, "out of memory", (char *) NULL); - Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); - } return TCL_ERROR; } if (ZipFSOpenArchive(interp, zipname, 1, zf) != TCL_OK) { @@ -1635,10 +2015,8 @@ TclZipfs_Mount( } if (ZipFSCatalogFilesystem(interp, zf, mountPoint, passwd, zipname) != TCL_OK) { - ckfree(zf); return TCL_ERROR; } - ckfree(zf); return TCL_OK; } @@ -1702,23 +2080,16 @@ TclZipfs_MountBuffer( * Have both a mount point and data to mount there. */ - zf = (ZipFile *)attemptckalloc(sizeof(ZipFile) + strlen(mountPoint) + 1); + zf = AllocateZipFile(interp, strlen(mountPoint)); if (!zf) { - if (interp) { - Tcl_AppendResult(interp, "out of memory", (char *) NULL); - Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); - } return TCL_ERROR; } zf->isMemBuffer = 1; zf->length = datalen; if (copy) { - zf->data = (unsigned char *)attemptckalloc(datalen); + zf->data = (unsigned char *) attemptckalloc(datalen); if (!zf->data) { - if (interp) { - Tcl_AppendResult(interp, "out of memory", (char *) NULL); - Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); - } + ZIPFS_MEM_ERROR(interp); return TCL_ERROR; } memcpy(zf->data, data, datalen); @@ -1727,13 +2098,11 @@ TclZipfs_MountBuffer( zf->data = data; zf->ptrToFree = NULL; } - zf->passBuf[0] = 0; /* stop valgrind cries */ if (ZipFSFindTOC(interp, 0, zf) != TCL_OK) { return TCL_ERROR; } result = ZipFSCatalogFilesystem(interp, zf, mountPoint, NULL, "Memory Buffer"); - ckfree(zf); return result; } @@ -1783,13 +2152,20 @@ TclZipfs_Unmount( goto done; } - zf = (ZipFile *)Tcl_GetHashValue(hPtr); + zf = (ZipFile *) Tcl_GetHashValue(hPtr); if (zf->numOpen > 0) { ZIPFS_ERROR(interp, "filesystem is busy"); + ZIPFS_ERROR_CODE(interp, "BUSY"); ret = TCL_ERROR; goto done; } Tcl_DeleteHashEntry(hPtr); + + /* + * Now no longer mounted - the rest of the code won't find it - but we're + * still cleaning things up. + */ + for (z = zf->entries; z; z = znext) { znext = z->next; hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, z->name); @@ -1805,6 +2181,7 @@ TclZipfs_Unmount( Tcl_DeleteExitHandler(ZipfsExitHandler, zf); ckfree(zf); unmounted = 1; + done: Unlock(); if (unmounted) { @@ -1836,16 +2213,38 @@ ZipFSMountObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + const char *mountPoint = NULL, *zipFile = NULL, *password = NULL; + Tcl_Obj *zipFileObj = NULL; + int result; if (objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "?mountpoint? ?zipfile? ?password?"); return TCL_ERROR; } + if (objc > 1) { + mountPoint = Tcl_GetString(objv[1]); + } + if (objc > 2) { + zipFileObj = Tcl_FSGetNormalizedPath(interp, objv[2]); + if (!zipFileObj) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "could not normalize zip filename", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NORMALIZE", NULL); + return TCL_ERROR; + } + Tcl_IncrRefCount(zipFileObj); + zipFile = Tcl_GetString(zipFileObj); + } + if (objc > 3) { + password = Tcl_GetString(objv[3]); + } - return TclZipfs_Mount(interp, (objc > 1) ? Tcl_GetString(objv[1]) : NULL, - (objc > 2) ? Tcl_GetString(objv[2]) : NULL, - (objc > 3) ? Tcl_GetString(objv[3]) : NULL); + result = TclZipfs_Mount(interp, mountPoint, zipFile, password); + if (zipFileObj != NULL) { + Tcl_DecrRefCount(zipFileObj); + } + return result; } /* @@ -1953,7 +2352,6 @@ ZipFSUnmountObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "zipfile"); return TCL_ERROR; @@ -1986,37 +2384,80 @@ ZipFSMkKeyObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { int len, i = 0; - char *pw, passBuf[264]; + const char *pw; + Tcl_Obj *passObj; + unsigned char *passBuf; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "password"); return TCL_ERROR; } - pw = Tcl_GetString(objv[1]); - len = strlen(pw); + pw = Tcl_GetStringFromObj(objv[1], &len); if (len == 0) { return TCL_OK; } - if ((len > 255) || strchr(pw, 0xff)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("illegal password", -1)); + if (IsPasswordValid(interp, pw, len) != TCL_OK) { return TCL_ERROR; } + + passObj = Tcl_NewByteArrayObj(NULL, 264); + passBuf = Tcl_GetByteArrayFromObj(passObj, (int *)NULL); while (len > 0) { int ch = pw[len - 1]; - passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; - i++; + passBuf[i++] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; len--; } passBuf[i] = i; - ++i; - passBuf[i++] = (char) ZIP_PASSWORD_END_SIG; - passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 8); - passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 16); - passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 24); - passBuf[i] = '\0'; - Tcl_AppendResult(interp, passBuf, (char *) NULL); + i++; + ZipWriteInt(passBuf, passBuf + 264, passBuf + i, ZIP_PASSWORD_END_SIG); + Tcl_SetByteArrayLength(passObj, i + 4); + Tcl_SetObjResult(interp, passObj); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * RandomChar -- + * + * Worker for ZipAddFile(). Picks a random character (range: 0..255) + * using Tcl's standard PRNG. + * + * Returns: + * Tcl result code. Updates chPtr with random character on success. + * + * Side effects: + * Advances the PRNG state. May reenter the Tcl interpreter if the user + * has replaced the PRNG. + * + *------------------------------------------------------------------------- + */ + +static int +RandomChar( + Tcl_Interp *interp, + int step, + int *chPtr) +{ + double r; + Tcl_Obj *ret; + + if (Tcl_EvalEx(interp, "::tcl::mathfunc::rand", -1, 0) != TCL_OK) { + goto failed; + } + ret = Tcl_GetObjResult(interp); + if (Tcl_GetDoubleFromObj(interp, ret, &r) != TCL_OK) { + goto failed; + } + *chPtr = (int) (r * 256); return TCL_OK; + + failed: + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (evaluating PRNG step %d for password encoding)", + step)); + return TCL_ERROR; } /* @@ -2024,11 +2465,14 @@ ZipFSMkKeyObjCmd( * * ZipAddFile -- * - * This procedure is used by ZipFSMkZipOrImgCmd() to add a single file to + * This procedure is used by ZipFSMkZipOrImg() to add a single file to * the output ZIP archive file being written. A ZipEntry struct about the * input file is added to the given fileHash table for later creation of * the central ZIP directory. * + * Tcl *always* encodes filenames in the ZIP as UTF-8. Similarly, it + * would always encode comments as UTF-8, if it supported comments. + * * Results: * A standard Tcl result. * @@ -2042,23 +2486,30 @@ ZipFSMkKeyObjCmd( static int ZipAddFile( Tcl_Interp *interp, /* Current interpreter. */ - const char *path, - const char *name, - Tcl_Channel out, + Tcl_Obj *pathObj, /* Actual name of the file to add. */ + const char *name, /* Name to use in the ZIP archive, in Tcl's + * internal encoding. */ + Tcl_Channel out, /* The open ZIP archive being built. */ const char *passwd, /* Password for encoding the file, or NULL if * the file is to be unprotected. */ - char *buf, - int bufsize, - Tcl_HashTable *fileHash) + char *buf, /* Working buffer. */ + int bufsize, /* Size of buf */ + Tcl_HashTable *fileHash) /* Where to record ZIP entry metdata so we can + * built the central directory. */ { + const unsigned char *start = (unsigned char *) buf; + const unsigned char *end = (unsigned char *) buf + bufsize; Tcl_Channel in; Tcl_HashEntry *hPtr; ZipEntry *z; z_stream stream; - const char *zpath; + Tcl_DString zpathDs; /* Buffer for the encoded filename. */ + const char *zpathExt; /* Filename in external encoding (true + * UTF-8). */ + const char *zpathTcl; /* Filename in Tcl's internal encoding. */ int crc, flush, zpathlen; size_t nbyte, nbytecompr, len, olen, align = 0; - Tcl_WideInt pos[3]; + long long headerStartOffset, dataStartOffset, dataEndOffset; int mtime = 0, isNew, compMeth; unsigned long keys[3], keys0[3]; char obuf[4096]; @@ -2068,23 +2519,31 @@ ZipAddFile( * nothing to do. */ - zpath = name; - while (zpath && zpath[0] == '/') { - zpath++; + zpathTcl = name; + while (zpathTcl && zpathTcl[0] == '/') { + zpathTcl++; } - if (!zpath || (zpath[0] == '\0')) { + if (!zpathTcl || (zpathTcl[0] == '\0')) { return TCL_OK; } - zpathlen = strlen(zpath); + /* + * Convert to encoded form. Note that we use strlen() here; if someone's + * crazy enough to embed NULs in filenames, they deserve what they get! + */ + + zpathExt = Tcl_UtfToExternalDString(ZipFS.utf8, zpathTcl, -1, &zpathDs); + zpathlen = strlen(zpathExt); if (zpathlen + ZIP_CENTRAL_HEADER_LEN > bufsize) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "path too long for \"%s\"", path)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "PATH_LEN", NULL); + "path too long for \"%s\"", Tcl_GetString(pathObj))); + ZIPFS_ERROR_CODE(interp, "PATH_LEN"); + Tcl_DStringFree(&zpathDs); return TCL_ERROR; } - in = Tcl_OpenFileChannel(interp, path, "rb", 0); + in = Tcl_FSOpenFileChannel(interp, pathObj, "rb", 0); if (!in) { + Tcl_DStringFree(&zpathDs); #ifdef _WIN32 /* hopefully a directory */ if (strcmp("permission denied", Tcl_PosixError(interp)) == 0) { @@ -2095,27 +2554,31 @@ ZipAddFile( Tcl_Close(interp, in); return TCL_ERROR; } else { - Tcl_Obj *pathObj = Tcl_NewStringObj(path, -1); Tcl_StatBuf statBuf; - Tcl_IncrRefCount(pathObj); if (Tcl_FSStat(pathObj, &statBuf) != -1) { mtime = statBuf.st_mtime; } - Tcl_DecrRefCount(pathObj); } Tcl_ResetResult(interp); + + /* + * Compute the CRC. + */ + crc = 0; nbyte = nbytecompr = 0; while (1) { len = Tcl_Read(in, buf, bufsize); if (len == ERROR_LENGTH) { + Tcl_DStringFree(&zpathDs); if (nbyte == 0 && errno == EISDIR) { Tcl_Close(interp, in); return TCL_OK; } + readErrorWithChannelOpen: Tcl_SetObjResult(interp, Tcl_ObjPrintf("read error on \"%s\": %s", - path, Tcl_PosixError(interp))); + Tcl_GetString(pathObj), Tcl_PosixError(interp))); Tcl_Close(interp, in); return TCL_ERROR; } @@ -2127,66 +2590,70 @@ ZipAddFile( } if (Tcl_Seek(in, 0, SEEK_SET) == -1) { Tcl_SetObjResult(interp, Tcl_ObjPrintf("seek error on \"%s\": %s", - path, Tcl_PosixError(interp))); + Tcl_GetString(pathObj), Tcl_PosixError(interp))); Tcl_Close(interp, in); + Tcl_DStringFree(&zpathDs); return TCL_ERROR; } - pos[0] = Tcl_Tell(out); + + /* + * Remember where we've got to so far so we can write the header (after + * writing the file). + */ + + headerStartOffset = Tcl_Tell(out); + + /* + * Reserve space for the per-file header. Includes writing the file name + * as we already know that. + */ + memset(buf, '\0', ZIP_LOCAL_HEADER_LEN); - memcpy(buf + ZIP_LOCAL_HEADER_LEN, zpath, zpathlen); + memcpy(buf + ZIP_LOCAL_HEADER_LEN, zpathExt, zpathlen); len = zpathlen + ZIP_LOCAL_HEADER_LEN; if ((size_t) Tcl_Write(out, buf, len) != len) { - wrerr: + writeErrorWithChannelOpen: Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "write error on %s: %s", path, Tcl_PosixError(interp))); + "write error on \"%s\": %s", + Tcl_GetString(pathObj), Tcl_PosixError(interp))); Tcl_Close(interp, in); + Tcl_DStringFree(&zpathDs); return TCL_ERROR; } - if ((len + pos[0]) & 3) { - unsigned char abuf[8]; - /* - * Align payload to next 4-byte boundary using a dummy extra entry - * similar to the zipalign tool from Android's SDK. - */ + /* + * Align payload to next 4-byte boundary (if necessary) using a dummy + * extra entry similar to the zipalign tool from Android's SDK. + */ - align = 4 + ((len + pos[0]) & 3); - ZipWriteShort(abuf, 0xffff); - ZipWriteShort(abuf + 2, align - 4); - ZipWriteInt(abuf + 4, 0x03020100); + if ((len + headerStartOffset) & 3) { + unsigned char abuf[8]; + const unsigned char *astart = abuf; + const unsigned char *aend = abuf + 8; + + align = 4 + ((len + headerStartOffset) & 3); + ZipWriteShort(astart, aend, abuf, 0xffff); + ZipWriteShort(astart, aend, abuf + 2, align - 4); + ZipWriteInt(astart, aend, abuf + 4, 0x03020100); if ((size_t) Tcl_Write(out, (const char *) abuf, align) != align) { - goto wrerr; + goto writeErrorWithChannelOpen; } } + + /* + * Set up encryption if we were asked to. + */ + if (passwd) { int i, ch, tmp; unsigned char kvbuf[24]; - Tcl_Obj *ret; init_keys(passwd, keys, crc32tab); for (i = 0; i < 12 - 2; i++) { - double r; - - if (Tcl_EvalEx(interp, "::tcl::mathfunc::rand", -1, 0) != TCL_OK) { - Tcl_Obj *eiPtr = Tcl_ObjPrintf( - "\n (evaluating PRNG step %d for password encoding)", - i); - - Tcl_AppendObjToErrorInfo(interp, eiPtr); + if (RandomChar(interp, i, &ch) != TCL_OK) { Tcl_Close(interp, in); return TCL_ERROR; } - ret = Tcl_GetObjResult(interp); - if (Tcl_GetDoubleFromObj(interp, ret, &r) != TCL_OK) { - Tcl_Obj *eiPtr = Tcl_ObjPrintf( - "\n (evaluating PRNG step %d for password encoding)", - i); - - Tcl_AppendObjToErrorInfo(interp, eiPtr); - Tcl_Close(interp, in); - return TCL_ERROR; - } - ch = (int) (r * 256); kvbuf[i + 12] = UCHAR(zencode(keys, crc32tab, ch, tmp)); } Tcl_ResetResult(interp); @@ -2199,16 +2666,23 @@ ZipAddFile( len = Tcl_Write(out, (char *) kvbuf, 12); memset(kvbuf, 0, 24); if (len != 12) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "write error on %s: %s", path, Tcl_PosixError(interp))); - Tcl_Close(interp, in); - return TCL_ERROR; + goto writeErrorWithChannelOpen; } memcpy(keys0, keys, sizeof(keys0)); nbytecompr += 12; } + + /* + * Save where we've got to in case we need to just store this file. + */ + Tcl_Flush(out); - pos[2] = Tcl_Tell(out); + dataStartOffset = Tcl_Tell(out); + + /* + * Compress the stream. + */ + compMeth = ZIP_COMPMETH_DEFLATED; memset(&stream, 0, sizeof(z_stream)); stream.zalloc = Z_NULL; @@ -2217,19 +2691,18 @@ ZipAddFile( if (deflateInit2(&stream, 9, Z_DEFLATED, -15, 8, Z_DEFAULT_STRATEGY) != Z_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "compression init error on \"%s\"", path)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DEFLATE_INIT", NULL); + "compression init error on \"%s\"", Tcl_GetString(pathObj))); + ZIPFS_ERROR_CODE(interp, "DEFLATE_INIT"); Tcl_Close(interp, in); + Tcl_DStringFree(&zpathDs); return TCL_ERROR; } + do { len = Tcl_Read(in, buf, bufsize); if (len == ERROR_LENGTH) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "read error on %s: %s", path, Tcl_PosixError(interp))); deflateEnd(&stream); - Tcl_Close(interp, in); - return TCL_ERROR; + goto readErrorWithChannelOpen; } stream.avail_in = len; stream.next_in = (unsigned char *) buf; @@ -2240,10 +2713,11 @@ ZipAddFile( len = deflate(&stream, flush); if (len == (size_t) Z_STREAM_ERROR) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "deflate error on %s", path)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DEFLATE", NULL); + "deflate error on \"%s\"", Tcl_GetString(pathObj))); + ZIPFS_ERROR_CODE(interp, "DEFLATE"); deflateEnd(&stream); Tcl_Close(interp, in); + Tcl_DStringFree(&zpathDs); return TCL_ERROR; } olen = sizeof(obuf) - stream.avail_out; @@ -2256,41 +2730,42 @@ ZipAddFile( } } if (olen && ((size_t) Tcl_Write(out, obuf, olen) != olen)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "write error: %s", Tcl_PosixError(interp))); deflateEnd(&stream); - Tcl_Close(interp, in); - return TCL_ERROR; + goto writeErrorWithChannelOpen; } nbytecompr += olen; } while (stream.avail_out == 0); } while (flush != Z_FINISH); deflateEnd(&stream); + + /* + * Work out where we've got to. + */ + Tcl_Flush(out); - pos[1] = Tcl_Tell(out); + dataEndOffset = Tcl_Tell(out); + if (nbyte - nbytecompr <= 0) { /* * Compressed file larger than input, write it again uncompressed. */ + if (Tcl_Seek(in, 0, SEEK_SET) != 0) { goto seekErr; } - if (Tcl_Seek(out, pos[2], SEEK_SET) != pos[2]) { + if (Tcl_Seek(out, dataStartOffset, SEEK_SET) != dataStartOffset) { seekErr: - Tcl_Close(interp, in); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "seek error: %s", Tcl_PosixError(interp))); + Tcl_Close(interp, in); + Tcl_DStringFree(&zpathDs); return TCL_ERROR; } nbytecompr = (passwd ? 12 : 0); while (1) { len = Tcl_Read(in, buf, bufsize); if (len == ERROR_LENGTH) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "read error on \"%s\": %s", - path, Tcl_PosixError(interp))); - Tcl_Close(interp, in); - return TCL_ERROR; + goto readErrorWithChannelOpen; } else if (len == 0) { break; } @@ -2303,61 +2778,57 @@ ZipAddFile( } } if ((size_t) Tcl_Write(out, buf, len) != len) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "write error: %s", Tcl_PosixError(interp))); - Tcl_Close(interp, in); - return TCL_ERROR; + goto writeErrorWithChannelOpen; } nbytecompr += len; } compMeth = ZIP_COMPMETH_STORED; + + /* + * Chop off everything after this; it's the over-large compressed data + * and we don't know if it is going to get overwritten otherwise. + */ + Tcl_Flush(out); - pos[1] = Tcl_Tell(out); - Tcl_TruncateChannel(out, pos[1]); + dataEndOffset = Tcl_Tell(out); + Tcl_TruncateChannel(out, dataEndOffset); } Tcl_Close(interp, in); + Tcl_DStringFree(&zpathDs); + zpathExt = NULL; - hPtr = Tcl_CreateHashEntry(fileHash, zpath, &isNew); + hPtr = Tcl_CreateHashEntry(fileHash, zpathTcl, &isNew); if (!isNew) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "non-unique path name \"%s\"", path)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DUPLICATE_PATH", NULL); + "non-unique path name \"%s\"", Tcl_GetString(pathObj))); + ZIPFS_ERROR_CODE(interp, "DUPLICATE_PATH"); return TCL_ERROR; } - z = (ZipEntry *)ckalloc(sizeof(ZipEntry)); + /* + * Remember that we've written the file (for central directory generation) + * and generate the local (per-file) header in the space that we reserved + * earlier. + */ + + z = AllocateZipEntry(); Tcl_SetHashValue(hPtr, z); - z->name = NULL; - z->tnext = NULL; - z->depth = 0; - z->zipFilePtr = NULL; - z->isDirectory = 0; z->isEncrypted = (passwd ? 1 : 0); - z->offset = pos[0]; + z->offset = headerStartOffset; z->crc32 = crc; z->timestamp = mtime; z->numBytes = nbyte; z->numCompressedBytes = nbytecompr; z->compressMethod = compMeth; - z->data = NULL; - z->name = (char *)Tcl_GetHashKey(fileHash, hPtr); - z->next = NULL; + z->name = (char *) Tcl_GetHashKey(fileHash, hPtr); /* * Write final local header information. */ - ZipWriteInt(buf + ZIP_LOCAL_SIG_OFFS, ZIP_LOCAL_HEADER_SIG); - ZipWriteShort(buf + ZIP_LOCAL_VERSION_OFFS, ZIP_MIN_VERSION); - ZipWriteShort(buf + ZIP_LOCAL_FLAGS_OFFS, z->isEncrypted); - ZipWriteShort(buf + ZIP_LOCAL_COMPMETH_OFFS, z->compressMethod); - ZipWriteShort(buf + ZIP_LOCAL_MTIME_OFFS, ToDosTime(z->timestamp)); - ZipWriteShort(buf + ZIP_LOCAL_MDATE_OFFS, ToDosDate(z->timestamp)); - ZipWriteInt(buf + ZIP_LOCAL_CRC32_OFFS, z->crc32); - ZipWriteInt(buf + ZIP_LOCAL_COMPLEN_OFFS, z->numCompressedBytes); - ZipWriteInt(buf + ZIP_LOCAL_UNCOMPLEN_OFFS, z->numBytes); - ZipWriteShort(buf + ZIP_LOCAL_PATHLEN_OFFS, zpathlen); - ZipWriteShort(buf + ZIP_LOCAL_EXTRALEN_OFFS, align); - if (Tcl_Seek(out, pos[0], SEEK_SET) != pos[0]) { + + SerializeLocalEntryHeader(start, end, (unsigned char *) buf, z, + zpathlen, align); + if (Tcl_Seek(out, headerStartOffset, SEEK_SET) != headerStartOffset) { Tcl_DeleteHashEntry(hPtr); ckfree(z); Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2372,7 +2843,7 @@ ZipAddFile( return TCL_ERROR; } Tcl_Flush(out); - if (Tcl_Seek(out, pos[1], SEEK_SET) != pos[1]) { + if (Tcl_Seek(out, dataEndOffset, SEEK_SET) != dataEndOffset) { Tcl_DeleteHashEntry(hPtr); ckfree(z); Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2385,12 +2856,101 @@ ZipAddFile( /* *------------------------------------------------------------------------- * - * ZipFSMkZipOrImgObjCmd -- + * ZipFSFind -- + * + * Worker for ZipFSMkZipOrImg() that discovers the list of files to add. + * Simple wrapper around [zipfs find]. + * + *------------------------------------------------------------------------- + */ + +static Tcl_Obj * +ZipFSFind( + Tcl_Interp *interp, + Tcl_Obj *dirRoot) +{ + Tcl_Obj *cmd[2]; + int result; + + cmd[0] = Tcl_NewStringObj("::tcl::zipfs::find", -1); + cmd[1] = dirRoot; + Tcl_IncrRefCount(cmd[0]); + result = Tcl_EvalObjv(interp, 2, cmd, 0); + Tcl_DecrRefCount(cmd[0]); + if (result != TCL_OK) { + return NULL; + } + return Tcl_GetObjResult(interp); +} + +/* + *------------------------------------------------------------------------- + * + * ComputeNameInArchive -- + * + * Helper for ZipFSMkZipOrImg() that computes what the actual name of a + * file in the ZIP archive should be, stripping a prefix (if appropriate) + * and any leading slashes. If the result is an empty string, the entry + * should be skipped. + * + * Returns: + * Pointer to the name (in Tcl's internal encoding), which will be in + * memory owned by one of the argument objects. + * + * Side effects: + * None (if Tcl_Objs have string representations) + * + *------------------------------------------------------------------------- + */ + +static inline const char * +ComputeNameInArchive( + Tcl_Obj *pathObj, /* The path to the origin file */ + Tcl_Obj *directNameObj, /* User-specified name for use in the ZIP + * archive */ + const char *strip, /* A prefix to strip; may be NULL if no + * stripping need be done. */ + int slen) /* The length of the prefix; must be 0 if no + * stripping need be done. */ +{ + const char *name; + int len; + + if (directNameObj) { + name = Tcl_GetString(directNameObj); + } else { + name = Tcl_GetStringFromObj(pathObj, &len); + if (slen > 0) { + if ((len <= slen) || (strncmp(strip, name, slen) != 0)) { + /* + * Guaranteed to be a NUL at the end, which will make this + * entry be skipped. + */ + + return name + len; + } + name += slen; + } + } + while (name[0] == '/') { + ++name; + } + return name; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSMkZipOrImg -- * * This procedure is creates a new ZIP archive file or image file given * output filename, input directory of files to be archived, optional * password, and optional image to be prepended to the output ZIP archive - * file. + * file. It's the core of the implementation of [zipfs mkzip], [zipfs + * mkimg], [zipfs lmkzip] and [zipfs lmkimg]. + * + * Tcl *always* encodes filenames in the ZIP as UTF-8. Similarly, it + * would always encode comments as UTF-8, if it supported comments. * * Results: * A standard Tcl result. @@ -2402,95 +2962,103 @@ ZipAddFile( */ static int -ZipFSMkZipOrImgObjCmd( +ZipFSMkZipOrImg( Tcl_Interp *interp, /* Current interpreter. */ - int isImg, - int isList, - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + int isImg, /* Are we making an image? */ + Tcl_Obj *targetFile, /* What file are we making? */ + Tcl_Obj *dirRoot, /* What directory do we take files from? Do + * not specify at the same time as + * mappingList (one must be NULL). */ + Tcl_Obj *mappingList, /* What files are we putting in, and with what + * names? Do not specify at the same time as + * dirRoot (one must be NULL). */ + Tcl_Obj *originFile, /* If we're making an image, what file does + * the non-ZIP part of the image come from? */ + Tcl_Obj *stripPrefix, /* Are we going to strip a prefix from + * filenames found beneath dirRoot? If NULL, + * do not strip anything (except for dirRoot + * itself). */ + Tcl_Obj *passwordObj) /* The password for encoding things. NULL if + * there's no password protection. */ { Tcl_Channel out; - int pwlen = 0, count, ret = TCL_ERROR, lobjc; - size_t len, slen = 0, i = 0; - Tcl_WideInt pos[3]; - Tcl_Obj **lobjv, *list = NULL; + int pwlen = 0, slen = 0, count, ret = TCL_ERROR, lobjc; + size_t len, i = 0; + long long dataStartOffset; /* The overall file offset of the start of the + * data section of the file. */ + long long directoryStartOffset; + /* The overall file offset of the start of the + * central directory. */ + long long suffixStartOffset;/* The overall file offset of the start of the + * suffix of the central directory (i.e., + * where this data will be written). */ + Tcl_Obj **lobjv, *list = mappingList; ZipEntry *z; Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_HashTable fileHash; char *strip = NULL, *pw = NULL, passBuf[264], buf[4096]; + unsigned char *start = (unsigned char *) buf; + unsigned char *end = start + sizeof(buf); /* * Caller has verified that the number of arguments is correct. */ passBuf[0] = 0; - if (objc > (isList ? 3 : 4)) { - pw = Tcl_GetString(objv[isList ? 3 : 4]); - pwlen = strlen(pw); - if ((pwlen > 255) || strchr(pw, 0xff)) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("illegal password", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_PASS", NULL); + if (passwordObj != NULL) { + pw = Tcl_GetStringFromObj(passwordObj, &pwlen); + if (IsPasswordValid(interp, pw, pwlen) != TCL_OK) { return TCL_ERROR; } + if (pwlen <= 0) { + pw = NULL; + pwlen = 0; + } } - if (isList) { - list = objv[2]; - Tcl_IncrRefCount(list); - } else { - Tcl_Obj *cmd[3]; - - cmd[1] = Tcl_NewStringObj("::tcl::zipfs::find", -1); - cmd[2] = objv[2]; - cmd[0] = Tcl_NewListObj(2, cmd + 1); - Tcl_IncrRefCount(cmd[0]); - if (Tcl_EvalObjEx(interp, cmd[0], TCL_EVAL_DIRECT) != TCL_OK) { - Tcl_DecrRefCount(cmd[0]); + if (dirRoot != NULL) { + list = ZipFSFind(interp, dirRoot); + if (!list) { return TCL_ERROR; } - Tcl_DecrRefCount(cmd[0]); - list = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(list); } + Tcl_IncrRefCount(list); if (Tcl_ListObjGetElements(interp, list, &lobjc, &lobjv) != TCL_OK) { Tcl_DecrRefCount(list); return TCL_ERROR; } - if (isList && (lobjc % 2)) { + if (mappingList && (lobjc % 2)) { Tcl_DecrRefCount(list); - Tcl_SetObjResult(interp, - Tcl_NewStringObj("need even number of elements", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "LIST_LENGTH", NULL); + ZIPFS_ERROR(interp, "need even number of elements"); + ZIPFS_ERROR_CODE(interp, "LIST_LENGTH"); return TCL_ERROR; } if (lobjc == 0) { Tcl_DecrRefCount(list); - Tcl_SetObjResult(interp, Tcl_NewStringObj("empty archive", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "EMPTY", NULL); + ZIPFS_ERROR(interp, "empty archive"); + ZIPFS_ERROR_CODE(interp, "EMPTY"); return TCL_ERROR; } - out = Tcl_OpenFileChannel(interp, Tcl_GetString(objv[1]), "wb", 0755); + out = Tcl_FSOpenFileChannel(interp, targetFile, "wb", 0755); if (out == NULL) { Tcl_DecrRefCount(list); return TCL_ERROR; } - if (pwlen <= 0) { - pw = NULL; - pwlen = 0; - } + + /* + * Copy the existing contents from the image if it is an executable image. + * Care must be taken because this might include an existing ZIP, which + * needs to be stripped. + */ + if (isImg) { ZipFile *zf, zf0; int isMounted = 0; const char *imgName; - if (isList) { - imgName = (objc > 4) ? Tcl_GetString(objv[4]) : - Tcl_GetNameOfExecutable(); - } else { - imgName = (objc > 5) ? Tcl_GetString(objv[5]) : - Tcl_GetNameOfExecutable(); - } + // TODO: normalize the origin file name + imgName = (originFile != NULL) ? Tcl_GetString(originFile) : + Tcl_GetNameOfExecutable(); if (pwlen) { i = 0; for (len = pwlen; len-- > 0;) { @@ -2515,7 +3083,7 @@ ZipFSMkZipOrImgObjCmd( WriteLock(); for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; hPtr = Tcl_NextHashEntry(&search)) { - zf = (ZipFile *)Tcl_GetHashValue(hPtr); + zf = (ZipFile *) Tcl_GetHashValue(hPtr); if (strcmp(zf->name, imgName) == 0) { isMounted = 1; zf->numOpen++; @@ -2523,10 +3091,16 @@ ZipFSMkZipOrImgObjCmd( } } Unlock(); + if (!isMounted) { zf = &zf0; + memset(&zf0, 0, sizeof(ZipFile)); } if (isMounted || ZipFSOpenArchive(interp, imgName, 0, zf) == TCL_OK) { + /* + * Copy everything up to the ZIP-related suffix. + */ + if ((size_t) Tcl_Write(out, (char *) zf->data, zf->passOffset) != zf->passOffset) { memset(passBuf, 0, sizeof(passBuf)); @@ -2551,56 +3125,23 @@ ZipFSMkZipOrImgObjCmd( Unlock(); } } else { - size_t k; - int m, n; - Tcl_Channel in; - const char *errMsg = "seek error"; - /* * Fall back to read it as plain file which hopefully is a static * tclsh or wish binary with proper zipfs infrastructure built in. */ - Tcl_ResetResult(interp); - in = Tcl_OpenFileChannel(interp, imgName, "rb", 0644); - if (!in) { + if (CopyImageFile(interp, imgName, out) != TCL_OK) { memset(passBuf, 0, sizeof(passBuf)); Tcl_DecrRefCount(list); Tcl_Close(interp, out); return TCL_ERROR; } - i = Tcl_Seek(in, 0, SEEK_END); - if (i == ERROR_LENGTH) { - cperr: - memset(passBuf, 0, sizeof(passBuf)); - Tcl_DecrRefCount(list); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s: %s", errMsg, Tcl_PosixError(interp))); - Tcl_Close(interp, out); - Tcl_Close(interp, in); - return TCL_ERROR; - } - Tcl_Seek(in, 0, SEEK_SET); - for (k = 0; k < i; k += m) { - m = i - k; - if (m > (int) sizeof(buf)) { - m = (int) sizeof(buf); - } - n = Tcl_Read(in, buf, m); - if (n == -1) { - errMsg = "read error"; - goto cperr; - } else if (n == 0) { - break; - } - m = Tcl_Write(out, buf, n); - if (m != n) { - errMsg = "write error"; - goto cperr; - } - } - Tcl_Close(interp, in); } + + /* + * Store the password so that the automounter can find it. + */ + len = strlen(passBuf); if (len > 0) { i = Tcl_Write(out, passBuf, len); @@ -2615,105 +3156,74 @@ ZipFSMkZipOrImgObjCmd( memset(passBuf, 0, sizeof(passBuf)); Tcl_Flush(out); } + + /* + * Prepare the contents of the ZIP archive. + */ + Tcl_InitHashTable(&fileHash, TCL_STRING_KEYS); - pos[0] = Tcl_Tell(out); - if (!isList && (objc > 3)) { - strip = Tcl_GetString(objv[3]); - slen = strlen(strip); + dataStartOffset = Tcl_Tell(out); + if (mappingList == NULL && stripPrefix != NULL) { + strip = Tcl_GetStringFromObj(stripPrefix, &slen); + if (!slen) { + strip = NULL; + } } - for (i = 0; i < (size_t) lobjc; i += (isList ? 2 : 1)) { - const char *path, *name; + for (i = 0; i < (size_t) lobjc; i += (mappingList ? 2 : 1)) { + Tcl_Obj *pathObj = lobjv[i]; + const char *name = ComputeNameInArchive(pathObj, + (mappingList ? lobjv[i + 1] : NULL), strip, slen); - path = Tcl_GetString(lobjv[i]); - if (isList) { - name = Tcl_GetString(lobjv[i + 1]); - } else { - name = path; - if (slen > 0) { - len = strlen(name); - if ((len <= slen) || (strncmp(strip, name, slen) != 0)) { - continue; - } - name += slen; - } - } - while (name[0] == '/') { - ++name; - } if (name[0] == '\0') { continue; } - if (ZipAddFile(interp, path, name, out, pw, buf, sizeof(buf), + if (ZipAddFile(interp, pathObj, name, out, pw, buf, sizeof(buf), &fileHash) != TCL_OK) { goto done; } } - pos[1] = Tcl_Tell(out); + + /* + * Construct the contents of the ZIP central directory. + */ + + directoryStartOffset = Tcl_Tell(out); count = 0; - for (i = 0; i < (size_t) lobjc; i += (isList ? 2 : 1)) { - const char *path, *name; + for (i = 0; i < (size_t) lobjc; i += (mappingList ? 2 : 1)) { + const char *name = ComputeNameInArchive(lobjv[i], + (mappingList ? lobjv[i + 1] : NULL), strip, slen); + Tcl_DString ds; - path = Tcl_GetString(lobjv[i]); - if (isList) { - name = Tcl_GetString(lobjv[i + 1]); - } else { - name = path; - if (slen > 0) { - len = strlen(name); - if ((len <= slen) || (strncmp(strip, name, slen) != 0)) { - continue; - } - name += slen; - } - } - while (name[0] == '/') { - ++name; - } - if (name[0] == '\0') { - continue; - } hPtr = Tcl_FindHashEntry(&fileHash, name); if (!hPtr) { continue; } - z = (ZipEntry *)Tcl_GetHashValue(hPtr); - len = strlen(z->name); - ZipWriteInt(buf + ZIP_CENTRAL_SIG_OFFS, ZIP_CENTRAL_HEADER_SIG); - ZipWriteShort(buf + ZIP_CENTRAL_VERSIONMADE_OFFS, ZIP_MIN_VERSION); - ZipWriteShort(buf + ZIP_CENTRAL_VERSION_OFFS, ZIP_MIN_VERSION); - ZipWriteShort(buf + ZIP_CENTRAL_FLAGS_OFFS, z->isEncrypted); - ZipWriteShort(buf + ZIP_CENTRAL_COMPMETH_OFFS, z->compressMethod); - ZipWriteShort(buf + ZIP_CENTRAL_MTIME_OFFS, ToDosTime(z->timestamp)); - ZipWriteShort(buf + ZIP_CENTRAL_MDATE_OFFS, ToDosDate(z->timestamp)); - ZipWriteInt(buf + ZIP_CENTRAL_CRC32_OFFS, z->crc32); - ZipWriteInt(buf + ZIP_CENTRAL_COMPLEN_OFFS, z->numCompressedBytes); - ZipWriteInt(buf + ZIP_CENTRAL_UNCOMPLEN_OFFS, z->numBytes); - ZipWriteShort(buf + ZIP_CENTRAL_PATHLEN_OFFS, len); - ZipWriteShort(buf + ZIP_CENTRAL_EXTRALEN_OFFS, 0); - ZipWriteShort(buf + ZIP_CENTRAL_FCOMMENTLEN_OFFS, 0); - ZipWriteShort(buf + ZIP_CENTRAL_DISKFILE_OFFS, 0); - ZipWriteShort(buf + ZIP_CENTRAL_IATTR_OFFS, 0); - ZipWriteInt(buf + ZIP_CENTRAL_EATTR_OFFS, 0); - ZipWriteInt(buf + ZIP_CENTRAL_LOCALHDR_OFFS, z->offset - pos[0]); - if ((Tcl_Write(out, buf, - ZIP_CENTRAL_HEADER_LEN) != ZIP_CENTRAL_HEADER_LEN) - || ((size_t) Tcl_Write(out, z->name, len) != len)) { + z = (ZipEntry *) Tcl_GetHashValue(hPtr); + + name = Tcl_UtfToExternalDString(ZipFS.utf8, z->name, -1, &ds); + len = Tcl_DStringLength(&ds); + SerializeCentralDirectoryEntry(start, end, (unsigned char *) buf, + z, len, dataStartOffset); + if ((Tcl_Write(out, buf, ZIP_CENTRAL_HEADER_LEN) + != ZIP_CENTRAL_HEADER_LEN) + || ((size_t) Tcl_Write(out, name, len) != len)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "write error: %s", Tcl_PosixError(interp))); + Tcl_DStringFree(&ds); goto done; } + Tcl_DStringFree(&ds); count++; } + + /* + * Finalize the central directory. + */ + Tcl_Flush(out); - pos[2] = Tcl_Tell(out); - ZipWriteInt(buf + ZIP_CENTRAL_END_SIG_OFFS, ZIP_CENTRAL_END_SIG); - ZipWriteShort(buf + ZIP_CENTRAL_DISKNO_OFFS, 0); - ZipWriteShort(buf + ZIP_CENTRAL_DISKDIR_OFFS, 0); - ZipWriteShort(buf + ZIP_CENTRAL_ENTS_OFFS, count); - ZipWriteShort(buf + ZIP_CENTRAL_TOTALENTS_OFFS, count); - ZipWriteInt(buf + ZIP_CENTRAL_DIRSIZE_OFFS, pos[2] - pos[1]); - ZipWriteInt(buf + ZIP_CENTRAL_DIRSTART_OFFS, pos[1] - pos[0]); - ZipWriteShort(buf + ZIP_CENTRAL_COMMENTLEN_OFFS, 0); + suffixStartOffset = Tcl_Tell(out); + SerializeCentralDirectorySuffix(start, end, (unsigned char *) buf, + count, dataStartOffset, directoryStartOffset, suffixStartOffset); if (Tcl_Write(out, buf, ZIP_CENTRAL_END_LEN) != ZIP_CENTRAL_END_LEN) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "write error: %s", Tcl_PosixError(interp))); @@ -2731,7 +3241,7 @@ ZipFSMkZipOrImgObjCmd( Tcl_DecrRefCount(list); for (hPtr = Tcl_FirstHashEntry(&fileHash, &search); hPtr; hPtr = Tcl_NextHashEntry(&search)) { - z = (ZipEntry *)Tcl_GetHashValue(hPtr); + z = (ZipEntry *) Tcl_GetHashValue(hPtr); ckfree(z); Tcl_DeleteHashEntry(hPtr); } @@ -2740,18 +3250,207 @@ ZipFSMkZipOrImgObjCmd( } /* + * --------------------------------------------------------------------- + * + * CopyImageFile -- + * + * A simple file copy function that is used (by ZipFSMkZipOrImg) for + * anything that is not an image with a ZIP appended. + * + * Returns: + * A Tcl result code. + * + * Side effects: + * Writes to an output channel. + * + * --------------------------------------------------------------------- + */ + +static int +CopyImageFile( + Tcl_Interp *interp, /* For error reporting. */ + const char *imgName, /* Where to copy from. */ + Tcl_Channel out) /* Where to copy to; already open for writing + * binary data. */ +{ + size_t i, k; + int m, n; + Tcl_Channel in; + char buf[4096]; + const char *errMsg; + + Tcl_ResetResult(interp); + in = Tcl_OpenFileChannel(interp, imgName, "rb", 0644); + if (!in) { + return TCL_ERROR; + } + + /* + * Get the length of the file (and exclude non-files). + */ + + i = Tcl_Seek(in, 0, SEEK_END); + if (i == ERROR_LENGTH) { + errMsg = "seek error"; + goto copyError; + } + Tcl_Seek(in, 0, SEEK_SET); + + /* + * Copy the whole file, 8 blocks at a time (reasonably efficient). Note + * that this totally ignores things like Windows's Alternate File Streams. + */ + + for (k = 0; k < i; k += m) { + m = i - k; + if (m > (int) sizeof(buf)) { + m = (int) sizeof(buf); + } + n = Tcl_Read(in, buf, m); + if (n == -1) { + errMsg = "read error"; + goto copyError; + } else if (n == 0) { + break; + } + m = Tcl_Write(out, buf, n); + if (m != n) { + errMsg = "write error"; + goto copyError; + } + } + Tcl_Close(interp, in); + return TCL_OK; + + copyError: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s: %s", errMsg, Tcl_PosixError(interp))); + Tcl_Close(interp, in); + return TCL_ERROR; +} + +/* + * --------------------------------------------------------------------- + * + * SerializeLocalEntryHeader, SerializeCentralDirectoryEntry, + * SerializeCentralDirectorySuffix -- + * + * Create serialized forms of the structures that make up the ZIP + * metadata. Note that the both the local entry and the central directory + * entry need to have the name of the entry written directly afterwards. + * + * We could write these as structs except we need to guarantee that we + * are writing these out as little-endian values. + * + * Side effects: + * Both update their buffer arguments, but otherwise change nothing. + * + * --------------------------------------------------------------------- + */ + +static void +SerializeLocalEntryHeader( + const unsigned char *start, /* The start of writable memory. */ + const unsigned char *end, /* The end of writable memory. */ + unsigned char *buf, /* Where to serialize to */ + ZipEntry *z, /* The description of what to serialize. */ + int nameLength, /* The length of the name. */ + int align) /* The number of alignment bytes. */ +{ + ZipWriteInt(start, end, buf + ZIP_LOCAL_SIG_OFFS, ZIP_LOCAL_HEADER_SIG); + ZipWriteShort(start, end, buf + ZIP_LOCAL_VERSION_OFFS, ZIP_MIN_VERSION); + ZipWriteShort(start, end, buf + ZIP_LOCAL_FLAGS_OFFS, z->isEncrypted); + ZipWriteShort(start, end, buf + ZIP_LOCAL_COMPMETH_OFFS, + z->compressMethod); + ZipWriteShort(start, end, buf + ZIP_LOCAL_MTIME_OFFS, + ToDosTime(z->timestamp)); + ZipWriteShort(start, end, buf + ZIP_LOCAL_MDATE_OFFS, + ToDosDate(z->timestamp)); + ZipWriteInt(start, end, buf + ZIP_LOCAL_CRC32_OFFS, z->crc32); + ZipWriteInt(start, end, buf + ZIP_LOCAL_COMPLEN_OFFS, + z->numCompressedBytes); + ZipWriteInt(start, end, buf + ZIP_LOCAL_UNCOMPLEN_OFFS, z->numBytes); + ZipWriteShort(start, end, buf + ZIP_LOCAL_PATHLEN_OFFS, nameLength); + ZipWriteShort(start, end, buf + ZIP_LOCAL_EXTRALEN_OFFS, align); +} + +static void +SerializeCentralDirectoryEntry( + const unsigned char *start, /* The start of writable memory. */ + const unsigned char *end, /* The end of writable memory. */ + unsigned char *buf, /* Where to serialize to */ + ZipEntry *z, /* The description of what to serialize. */ + size_t nameLength, /* The length of the name. */ + long long dataStartOffset) /* The overall file offset of the start of the + * data section of the file. */ +{ + ZipWriteInt(start, end, buf + ZIP_CENTRAL_SIG_OFFS, + ZIP_CENTRAL_HEADER_SIG); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_VERSIONMADE_OFFS, + ZIP_MIN_VERSION); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_VERSION_OFFS, ZIP_MIN_VERSION); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_FLAGS_OFFS, z->isEncrypted); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_COMPMETH_OFFS, + z->compressMethod); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_MTIME_OFFS, + ToDosTime(z->timestamp)); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_MDATE_OFFS, + ToDosDate(z->timestamp)); + ZipWriteInt(start, end, buf + ZIP_CENTRAL_CRC32_OFFS, z->crc32); + ZipWriteInt(start, end, buf + ZIP_CENTRAL_COMPLEN_OFFS, + z->numCompressedBytes); + ZipWriteInt(start, end, buf + ZIP_CENTRAL_UNCOMPLEN_OFFS, z->numBytes); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_PATHLEN_OFFS, nameLength); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_EXTRALEN_OFFS, 0); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_FCOMMENTLEN_OFFS, 0); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_DISKFILE_OFFS, 0); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_IATTR_OFFS, 0); + ZipWriteInt(start, end, buf + ZIP_CENTRAL_EATTR_OFFS, 0); + ZipWriteInt(start, end, buf + ZIP_CENTRAL_LOCALHDR_OFFS, + z->offset - dataStartOffset); +} + +static void +SerializeCentralDirectorySuffix( + const unsigned char *start, /* The start of writable memory. */ + const unsigned char *end, /* The end of writable memory. */ + unsigned char *buf, /* Where to serialize to */ + int entryCount, /* The number of entries in the directory */ + long long dataStartOffset, /* The overall file offset of the start of the + * data section of the file. */ + long long directoryStartOffset, + /* The overall file offset of the start of the + * central directory. */ + long long suffixStartOffset)/* The overall file offset of the start of the + * suffix of the central directory (i.e., + * where this data will be written). */ +{ + ZipWriteInt(start, end, buf + ZIP_CENTRAL_END_SIG_OFFS, + ZIP_CENTRAL_END_SIG); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_DISKNO_OFFS, 0); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_DISKDIR_OFFS, 0); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_ENTS_OFFS, entryCount); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_TOTALENTS_OFFS, entryCount); + ZipWriteInt(start, end, buf + ZIP_CENTRAL_DIRSIZE_OFFS, + suffixStartOffset - directoryStartOffset); + ZipWriteInt(start, end, buf + ZIP_CENTRAL_DIRSTART_OFFS, + directoryStartOffset - dataStartOffset); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_COMMENTLEN_OFFS, 0); +} + +/* *------------------------------------------------------------------------- * * ZipFSMkZipObjCmd, ZipFSLMkZipObjCmd -- * * These procedures are invoked to process the [zipfs mkzip] and [zipfs - * lmkzip] commands. See description of ZipFSMkZipOrImgCmd(). + * lmkzip] commands. See description of ZipFSMkZipOrImg(). * * Results: * A standard Tcl result. * * Side effects: - * See description of ZipFSMkZipOrImgCmd(). + * See description of ZipFSMkZipOrImg(). * *------------------------------------------------------------------------- */ @@ -2763,17 +3462,22 @@ ZipFSMkZipObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + Tcl_Obj *stripPrefix, *password; + if (objc < 3 || objc > 5) { Tcl_WrongNumArgs(interp, 1, objv, "outfile indir ?strip? ?password?"); return TCL_ERROR; } if (Tcl_IsSafe(interp)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "operation not permitted in a safe interpreter", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL); + ZIPFS_ERROR(interp, "operation not permitted in a safe interpreter"); + ZIPFS_ERROR_CODE(interp, "SAFE_INTERP"); return TCL_ERROR; } - return ZipFSMkZipOrImgObjCmd(interp, 0, 0, objc, objv); + + stripPrefix = (objc > 3 ? objv[3] : NULL); + password = (objc > 4 ? objv[4] : NULL); + return ZipFSMkZipOrImg(interp, 0, objv[1], objv[2], NULL, NULL, + stripPrefix, password); } static int @@ -2783,17 +3487,21 @@ ZipFSLMkZipObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + Tcl_Obj *password; + if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "outfile inlist ?password?"); return TCL_ERROR; } if (Tcl_IsSafe(interp)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "operation not permitted in a safe interpreter", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL); + ZIPFS_ERROR(interp, "operation not permitted in a safe interpreter"); + ZIPFS_ERROR_CODE(interp, "SAFE_INTERP"); return TCL_ERROR; } - return ZipFSMkZipOrImgObjCmd(interp, 0, 1, objc, objv); + + password = (objc > 3 ? objv[3] : NULL); + return ZipFSMkZipOrImg(interp, 0, objv[1], NULL, objv[2], NULL, + NULL, password); } /* @@ -2802,13 +3510,13 @@ ZipFSLMkZipObjCmd( * ZipFSMkImgObjCmd, ZipFSLMkImgObjCmd -- * * These procedures are invoked to process the [zipfs mkimg] and [zipfs - * lmkimg] commands. See description of ZipFSMkZipOrImgCmd(). + * lmkimg] commands. See description of ZipFSMkZipOrImg(). * * Results: * A standard Tcl result. * * Side effects: - * See description of ZipFSMkZipOrImgCmd(). + * See description of ZipFSMkZipOrImg(). * *------------------------------------------------------------------------- */ @@ -2820,18 +3528,24 @@ ZipFSMkImgObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + Tcl_Obj *originFile, *stripPrefix, *password; + if (objc < 3 || objc > 6) { Tcl_WrongNumArgs(interp, 1, objv, "outfile indir ?strip? ?password? ?infile?"); return TCL_ERROR; } if (Tcl_IsSafe(interp)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "operation not permitted in a safe interpreter", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL); + ZIPFS_ERROR(interp, "operation not permitted in a safe interpreter"); + ZIPFS_ERROR_CODE(interp, "SAFE_INTERP"); return TCL_ERROR; } - return ZipFSMkZipOrImgObjCmd(interp, 1, 0, objc, objv); + + originFile = (objc > 5 ? objv[5] : NULL); + stripPrefix = (objc > 3 ? objv[3] : NULL); + password = (objc > 4 ? objv[4] : NULL); + return ZipFSMkZipOrImg(interp, 1, objv[1], objv[2], NULL, + originFile, stripPrefix, password); } static int @@ -2841,17 +3555,22 @@ ZipFSLMkImgObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + Tcl_Obj *originFile, *password; + if (objc < 3 || objc > 5) { Tcl_WrongNumArgs(interp, 1, objv, "outfile inlist ?password infile?"); return TCL_ERROR; } if (Tcl_IsSafe(interp)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "operation not permitted in a safe interpreter", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL); + ZIPFS_ERROR(interp, "operation not permitted in a safe interpreter"); + ZIPFS_ERROR_CODE(interp, "SAFE_INTERP"); return TCL_ERROR; } - return ZipFSMkZipOrImgObjCmd(interp, 1, 1, objc, objv); + + originFile = (objc > 4 ? objv[4] : NULL); + password = (objc > 3 ? objv[3] : NULL); + return ZipFSMkZipOrImg(interp, 1, objv[1], NULL, objv[2], + originFile, NULL, password); } /* @@ -2966,7 +3685,7 @@ ZipFSExistsObjCmd( * * ZipFSInfoObjCmd -- * - * This procedure is invoked to process the [zipfs info] command. On + * This procedure is invoked to process the [zipfs info] command. On * success, it returns a Tcl list made up of name of ZIP archive file, * size uncompressed, size compressed, and archive offset of a file in * the ZIP filesystem. @@ -3042,36 +3761,48 @@ ZipFSListObjCmd( Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_Obj *result = Tcl_GetObjResult(interp); + const char *options[] = {"-glob", "-regexp", NULL}; + enum list_options { OPT_GLOB, OPT_REGEXP }; + + /* + * Parse arguments. + */ if (objc > 3) { Tcl_WrongNumArgs(interp, 1, objv, "?(-glob|-regexp)? ?pattern?"); return TCL_ERROR; } if (objc == 3) { - int n; - char *what = Tcl_GetStringFromObj(objv[1], &n); + int idx; - if ((n >= 2) && (strncmp(what, "-glob", n) == 0)) { + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", + 0, &idx) != TCL_OK) { + return TCL_ERROR; + } + switch (idx) { + case OPT_GLOB: pattern = Tcl_GetString(objv[2]); - } else if ((n >= 2) && (strncmp(what, "-regexp", n) == 0)) { + break; + case OPT_REGEXP: regexp = Tcl_RegExpCompile(interp, Tcl_GetString(objv[2])); if (!regexp) { return TCL_ERROR; } - } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unknown option \"%s\"", what)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_OPT", NULL); - return TCL_ERROR; + break; } } else if (objc == 2) { pattern = Tcl_GetString(objv[1]); } + + /* + * Scan for matching entries. + */ + ReadLock(); if (pattern) { for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - ZipEntry *z = (ZipEntry *)Tcl_GetHashValue(hPtr); + ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); if (Tcl_StringMatch(z->name, pattern)) { Tcl_ListObjAppendElement(interp, result, @@ -3081,7 +3812,7 @@ ZipFSListObjCmd( } else if (regexp) { for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); hPtr; hPtr = Tcl_NextHashEntry(&search)) { - ZipEntry *z = (ZipEntry *)Tcl_GetHashValue(hPtr); + ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); if (Tcl_RegExpExec(interp, regexp, z->name, z->name)) { Tcl_ListObjAppendElement(interp, result, @@ -3091,7 +3822,7 @@ ZipFSListObjCmd( } else { for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); hPtr; hPtr = Tcl_NextHashEntry(&search)) { - ZipEntry *z = (ZipEntry *)Tcl_GetHashValue(hPtr); + ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); Tcl_ListObjAppendElement(interp, result, Tcl_NewStringObj(z->name, -1)); @@ -3120,16 +3851,13 @@ ZipFSListObjCmd( *------------------------------------------------------------------------- */ -#ifdef _WIN32 -#define LIBRARY_SIZE 64 -#endif /* _WIN32 */ - Tcl_Obj * TclZipfs_TclLibrary(void) { Tcl_Obj *vfsInitScript; int found; -#ifdef _WIN32 +#if (defined(_WIN32) || defined(__CYGWIN__)) && !defined(STATIC_BUILD) +# define LIBRARY_SIZE 64 HMODULE hModule; WCHAR wName[MAX_PATH + LIBRARY_SIZE]; char dllName[(MAX_PATH + LIBRARY_SIZE) * 3]; @@ -3163,38 +3891,25 @@ TclZipfs_TclLibrary(void) * that we must mount the zip file and dll before releasing to search. */ -#if defined(_WIN32) - hModule = TclWinGetTclInstance(); +#if !defined(STATIC_BUILD) +#if defined(_WIN32) || defined(__CYGWIN__) + hModule = (HMODULE)TclWinGetTclInstance(); GetModuleFileNameW(hModule, wName, MAX_PATH); +#ifdef __CYGWIN__ + cygwin_conv_path(3, wName, dllName, sizeof(dllName)); +#else WideCharToMultiByte(CP_UTF8, 0, wName, -1, dllName, sizeof(dllName), NULL, NULL); +#endif if (ZipfsAppHookFindTclInit(dllName) == TCL_OK) { return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); } -#elif /* !_WIN32 && */ defined(CFG_RUNTIME_DLLFILE) - if (ZipfsAppHookFindTclInit( - CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_DLLFILE) == TCL_OK) { - return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); - } -#endif /* _WIN32 || CFG_RUNTIME_DLLFILE */ - - /* - * If we're configured to know about a ZIP archive we should use, do that. - */ - -#ifdef CFG_RUNTIME_ZIPFILE - if (ZipfsAppHookFindTclInit( - CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_ZIPFILE) == TCL_OK) { - return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); - } - if (ZipfsAppHookFindTclInit( - CFG_RUNTIME_SCRDIR "/" CFG_RUNTIME_ZIPFILE) == TCL_OK) { - return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); - } - if (ZipfsAppHookFindTclInit(CFG_RUNTIME_ZIPFILE) == TCL_OK) { +#else + if (ZipfsAppHookFindTclInit(CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_DLLFILE) == TCL_OK) { return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); } -#endif /* CFG_RUNTIME_ZIPFILE */ +#endif /* _WIN32 */ +#endif /* !defined(STATIC_BUILD) */ /* * If anything set the cache (but subsequently failed) go with that @@ -3267,7 +3982,7 @@ ZipChannelClose( TCL_UNUSED(Tcl_Interp *), int flags) { - ZipChannel *info = (ZipChannel *)instanceData; + ZipChannel *info = (ZipChannel *) instanceData; if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) { return EINVAL; @@ -3283,7 +3998,8 @@ ZipChannelClose( } if (info->isWriting) { ZipEntry *z = info->zipEntryPtr; - unsigned char *newdata = (unsigned char *)attemptckrealloc(info->ubuf, info->numRead); + unsigned char *newdata = (unsigned char *) + attemptckrealloc(info->ubuf, info->numRead); if (newdata) { if (z->data) { @@ -3444,10 +4160,10 @@ ZipChannelWrite( *------------------------------------------------------------------------- */ -static Tcl_WideInt +static long long ZipChannelWideSeek( void *instanceData, - Tcl_WideInt offset, + long long offset, int mode, int *errloc) { @@ -3499,7 +4215,7 @@ ZipChannelWideSeek( return info->numRead; } -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) static int ZipChannelSeek( void *instanceData, @@ -3568,7 +4284,7 @@ ZipChannelGetFile( * ZipChannelOpen -- * * This function opens a Tcl_Channel on a file from a mounted ZIP archive - * according to given open mode. + * according to given open mode (already parsed by caller). * * Results: * Tcl_Channel on success, or NULL on error. @@ -3582,24 +4298,19 @@ ZipChannelGetFile( static Tcl_Channel ZipChannelOpen( Tcl_Interp *interp, /* Current interpreter. */ - char *filename, - int mode, - TCL_UNUSED(int) /*permissions*/) + char *filename, /* What are we opening. */ + int wr, /* True if we're opening in write mode. */ + int trunc) /* True if we're opening in truncate mode. */ { ZipEntry *z; ZipChannel *info; - int i, ch, trunc, wr, flags = 0; + int flags = 0; char cname[128]; - if ((mode & O_APPEND) - || ((ZipFS.wrmax <= 0) && (mode & (O_WRONLY | O_RDWR)))) { - if (interp) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("unsupported open mode", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_MODE", NULL); - } - return NULL; - } + /* + * Is the file there? + */ + WriteLock(); z = ZipFSLookup(filename); if (!z) { @@ -3611,188 +4322,161 @@ ZipChannelOpen( } goto error; } - trunc = (mode & O_TRUNC) != 0; - wr = (mode & (O_WRONLY | O_RDWR)) != 0; - if ((z->compressMethod != ZIP_COMPMETH_STORED) - && (z->compressMethod != ZIP_COMPMETH_DEFLATED)) { - ZIPFS_ERROR(interp, "unsupported compression method"); + + /* + * Do we support opening the file that way? + */ + + if (wr && z->isDirectory) { + Tcl_SetErrno(EISDIR); if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "COMP_METHOD", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unsupported file type: %s", + Tcl_PosixError(interp))); } goto error; } - if (wr && z->isDirectory) { - ZIPFS_ERROR(interp, "unsupported file type"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "FILE_TYPE", NULL); - } + if ((z->compressMethod != ZIP_COMPMETH_STORED) + && (z->compressMethod != ZIP_COMPMETH_DEFLATED)) { + ZIPFS_ERROR(interp, "unsupported compression method"); + ZIPFS_ERROR_CODE(interp, "COMP_METHOD"); goto error; } if (!trunc) { flags |= TCL_READABLE; if (z->isEncrypted && (z->zipFilePtr->passBuf[0] == 0)) { ZIPFS_ERROR(interp, "decryption failed"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DECRYPT", NULL); - } + ZIPFS_ERROR_CODE(interp, "DECRYPT"); goto error; } else if (wr && !z->data && (z->numBytes > ZipFS.wrmax)) { ZIPFS_ERROR(interp, "file too large"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "FILE_SIZE", NULL); - } + ZIPFS_ERROR_CODE(interp, "FILE_SIZE"); goto error; } } else { flags = TCL_WRITABLE; } - info = (ZipChannel *)attemptckalloc(sizeof(ZipChannel)); + + info = AllocateZipChannel(interp); if (!info) { - ZIPFS_ERROR(interp, "out of memory"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); - } goto error; } info->zipFilePtr = z->zipFilePtr; info->zipEntryPtr = z; - info->numRead = 0; if (wr) { + /* + * Set up a writable channel. + */ + flags |= TCL_WRITABLE; - info->isWriting = 1; - info->isDirectory = 0; - info->maxWrite = ZipFS.wrmax; - info->iscompr = 0; - info->isEncrypted = 0; - info->ubuf = (unsigned char *)attemptckalloc(info->maxWrite); - if (!info->ubuf) { - merror0: - if (info->ubuf) { - ckfree(info->ubuf); - } + if (InitWritableChannel(interp, info, z, trunc) == TCL_ERROR) { ckfree(info); - ZIPFS_ERROR(interp, "out of memory"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); - } goto error; } - memset(info->ubuf, 0, info->maxWrite); - if (trunc) { - info->numBytes = 0; - } else if (z->data) { - unsigned int j = z->numBytes; - - if (j > info->maxWrite) { - j = info->maxWrite; - } - memcpy(info->ubuf, z->data, j); - info->numBytes = j; - } else { - unsigned char *zbuf = z->zipFilePtr->data + z->offset; - - if (z->isEncrypted) { - int len = z->zipFilePtr->passBuf[0] & 0xFF; - char passBuf[260]; - - for (i = 0; i < len; i++) { - ch = z->zipFilePtr->passBuf[len - i]; - passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; - } - passBuf[i] = '\0'; - init_keys(passBuf, info->keys, crc32tab); - memset(passBuf, 0, sizeof(passBuf)); - for (i = 0; i < 12; i++) { - ch = info->ubuf[i]; - zdecode(info->keys, crc32tab, ch); - } - zbuf += i; - } - if (z->compressMethod == ZIP_COMPMETH_DEFLATED) { - z_stream stream; - int err; - unsigned char *cbuf = NULL; - - memset(&stream, 0, sizeof(z_stream)); - stream.zalloc = Z_NULL; - stream.zfree = Z_NULL; - stream.opaque = Z_NULL; - stream.avail_in = z->numCompressedBytes; - if (z->isEncrypted) { - unsigned int j; - - stream.avail_in -= 12; - cbuf = (unsigned char *)attemptckalloc(stream.avail_in); - if (!cbuf) { - goto merror0; - } - for (j = 0; j < stream.avail_in; j++) { - ch = info->ubuf[j]; - cbuf[j] = zdecode(info->keys, crc32tab, ch); - } - stream.next_in = cbuf; - } else { - stream.next_in = zbuf; - } - stream.next_out = info->ubuf; - stream.avail_out = info->maxWrite; - if (inflateInit2(&stream, -15) != Z_OK) { - goto cerror0; - } - err = inflate(&stream, Z_SYNC_FLUSH); - inflateEnd(&stream); - if ((err == Z_STREAM_END) - || ((err == Z_OK) && (stream.avail_in == 0))) { - if (cbuf) { - memset(info->keys, 0, sizeof(info->keys)); - ckfree(cbuf); - } - goto wrapchan; - } - cerror0: - if (cbuf) { - memset(info->keys, 0, sizeof(info->keys)); - ckfree(cbuf); - } - if (info->ubuf) { - ckfree(info->ubuf); - } - ckfree(info); - ZIPFS_ERROR(interp, "decompression error"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "CORRUPT", NULL); - } - goto error; - } else if (z->isEncrypted) { - for (i = 0; i < z->numBytes - 12; i++) { - ch = zbuf[i]; - info->ubuf[i] = zdecode(info->keys, crc32tab, ch); - } - } else { - memcpy(info->ubuf, zbuf, z->numBytes); - } - memset(info->keys, 0, sizeof(info->keys)); - goto wrapchan; - } } else if (z->data) { + /* + * Set up a readable channel for direct data. + */ + flags |= TCL_READABLE; - info->isWriting = 0; - info->iscompr = 0; - info->isDirectory = 0; - info->isEncrypted = 0; info->numBytes = z->numBytes; - info->maxWrite = 0; info->ubuf = z->data; } else { + /* + * Set up a readable channel. + */ + flags |= TCL_READABLE; - info->isWriting = 0; - info->iscompr = (z->compressMethod == ZIP_COMPMETH_DEFLATED); - info->ubuf = z->zipFilePtr->data + z->offset; - info->isDirectory = z->isDirectory; - info->isEncrypted = z->isEncrypted; - info->numBytes = z->numBytes; - info->maxWrite = 0; - if (info->isEncrypted) { + if (InitReadableChannel(interp, info, z) == TCL_ERROR) { + ckfree(info); + goto error; + } + } + + /* + * Wrap the ZipChannel into a Tcl_Channel. + */ + + sprintf(cname, "zipfs_%" TCL_Z_MODIFIER "x_%d", z->offset, + ZipFS.idCount++); + z->zipFilePtr->numOpen++; + Unlock(); + return Tcl_CreateChannel(&ZipChannelType, cname, info, flags); + + error: + Unlock(); + return NULL; +} + +/* + *------------------------------------------------------------------------- + * + * InitWritableChannel -- + * + * Assistant for ZipChannelOpen() that sets up a writable channel. It's + * up to the caller to actually register the channel. + * + * Returns: + * Tcl result code. + * + * Side effects: + * Allocates memory for the implementation of the channel. Writes to the + * interpreter's result on error. + * + *------------------------------------------------------------------------- + */ + +static int +InitWritableChannel( + Tcl_Interp *interp, /* Current interpreter, or NULL (when errors + * will be silent). */ + ZipChannel *info, /* The channel to set up. */ + ZipEntry *z, /* The zipped file that the channel will write + * to. */ + int trunc) /* Whether to truncate the data. */ +{ + int i, ch; + unsigned char *cbuf = NULL; + + /* + * Set up a writable channel. + */ + + info->isWriting = 1; + info->maxWrite = ZipFS.wrmax; + + info->ubuf = (unsigned char *) attemptckalloc(info->maxWrite); + if (!info->ubuf) { + goto memoryError; + } + memset(info->ubuf, 0, info->maxWrite); + + if (trunc) { + /* + * Truncate; nothing there. + */ + + info->numBytes = 0; + } else if (z->data) { + /* + * Already got uncompressed data. + */ + + unsigned int j = z->numBytes; + + if (j > info->maxWrite) { + j = info->maxWrite; + } + memcpy(info->ubuf, z->data, j); + info->numBytes = j; + } else { + /* + * Need to uncompress the existing data. + */ + + unsigned char *zbuf = z->zipFilePtr->data + z->offset; + + if (z->isEncrypted) { int len = z->zipFilePtr->passBuf[0] & 0xFF; char passBuf[260]; @@ -3807,118 +4491,244 @@ ZipChannelOpen( ch = info->ubuf[i]; zdecode(info->keys, crc32tab, ch); } - info->ubuf += i; + zbuf += i; } - if (info->iscompr) { + + if (z->compressMethod == ZIP_COMPMETH_DEFLATED) { z_stream stream; int err; - unsigned char *ubuf = NULL; - unsigned int j; memset(&stream, 0, sizeof(z_stream)); stream.zalloc = Z_NULL; stream.zfree = Z_NULL; stream.opaque = Z_NULL; stream.avail_in = z->numCompressedBytes; - if (info->isEncrypted) { + if (z->isEncrypted) { + unsigned int j; + stream.avail_in -= 12; - ubuf = (unsigned char *)attemptckalloc(stream.avail_in); - if (!ubuf) { - info->ubuf = NULL; - goto merror; + cbuf = (unsigned char *) attemptckalloc(stream.avail_in); + if (!cbuf) { + goto memoryError; } for (j = 0; j < stream.avail_in; j++) { ch = info->ubuf[j]; - ubuf[j] = zdecode(info->keys, crc32tab, ch); + cbuf[j] = zdecode(info->keys, crc32tab, ch); } - stream.next_in = ubuf; + stream.next_in = cbuf; } else { - stream.next_in = info->ubuf; - } - stream.next_out = info->ubuf = (unsigned char *)attemptckalloc(info->numBytes); - if (!info->ubuf) { - merror: - if (ubuf) { - info->isEncrypted = 0; - memset(info->keys, 0, sizeof(info->keys)); - ckfree(ubuf); - } - ckfree(info); - if (interp) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("out of memory", -1)); - Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); - } - goto error; + stream.next_in = zbuf; } - stream.avail_out = info->numBytes; + stream.next_out = info->ubuf; + stream.avail_out = info->maxWrite; if (inflateInit2(&stream, -15) != Z_OK) { - goto cerror; + goto corruptionError; } err = inflate(&stream, Z_SYNC_FLUSH); inflateEnd(&stream); if ((err == Z_STREAM_END) || ((err == Z_OK) && (stream.avail_in == 0))) { - if (ubuf) { - info->isEncrypted = 0; + if (cbuf) { memset(info->keys, 0, sizeof(info->keys)); - ckfree(ubuf); + ckfree(cbuf); } - goto wrapchan; - } - cerror: - if (ubuf) { - info->isEncrypted = 0; - memset(info->keys, 0, sizeof(info->keys)); - ckfree(ubuf); - } - if (info->ubuf) { - ckfree(info->ubuf); - } - ckfree(info); - ZIPFS_ERROR(interp, "decompression error"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "CORRUPT", NULL); + return TCL_OK; } - goto error; - } else if (info->isEncrypted) { - unsigned char *ubuf = NULL; - unsigned int j, len; + goto corruptionError; + } else if (z->isEncrypted) { + /* + * Need to decrypt some otherwise-simple stored data. + */ + for (i = 0; i < z->numBytes - 12; i++) { + ch = zbuf[i]; + info->ubuf[i] = zdecode(info->keys, crc32tab, ch); + } + } else { /* - * Decode encrypted but uncompressed file, since we support - * Tcl_Seek() on it, and it can be randomly accessed later. + * Simple stored data. Copy into our working buffer. */ - len = z->numCompressedBytes - 12; - ubuf = (unsigned char *) attemptckalloc(len); - if (ubuf == NULL) { - ckfree((char *) info); - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("out of memory", -1)); - } - goto error; + memcpy(info->ubuf, zbuf, z->numBytes); + } + memset(info->keys, 0, sizeof(info->keys)); + } + return TCL_OK; + + memoryError: + if (info->ubuf) { + ckfree(info->ubuf); + } + ZIPFS_MEM_ERROR(interp); + return TCL_ERROR; + + corruptionError: + if (cbuf) { + memset(info->keys, 0, sizeof(info->keys)); + ckfree(cbuf); + } + if (info->ubuf) { + ckfree(info->ubuf); + } + ZIPFS_ERROR(interp, "decompression error"); + ZIPFS_ERROR_CODE(interp, "CORRUPT"); + return TCL_ERROR; +} + +/* + *------------------------------------------------------------------------- + * + * InitReadableChannel -- + * + * Assistant for ZipChannelOpen() that sets up a readable channel. It's + * up to the caller to actually register the channel. + * + * Returns: + * Tcl result code. + * + * Side effects: + * Allocates memory for the implementation of the channel. Writes to the + * interpreter's result on error. + * + *------------------------------------------------------------------------- + */ + +static int +InitReadableChannel( + Tcl_Interp *interp, /* Current interpreter, or NULL (when errors + * will be silent). */ + ZipChannel *info, /* The channel to set up. */ + ZipEntry *z) /* The zipped file that the channel will read + * from. */ +{ + unsigned char *ubuf = NULL; + int i, ch; + + info->iscompr = (z->compressMethod == ZIP_COMPMETH_DEFLATED); + info->ubuf = z->zipFilePtr->data + z->offset; + info->isDirectory = z->isDirectory; + info->isEncrypted = z->isEncrypted; + info->numBytes = z->numBytes; + + if (info->isEncrypted) { + int len = z->zipFilePtr->passBuf[0] & 0xFF; + char passBuf[260]; + + for (i = 0; i < len; i++) { + ch = z->zipFilePtr->passBuf[len - i]; + passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; + } + passBuf[i] = '\0'; + init_keys(passBuf, info->keys, crc32tab); + memset(passBuf, 0, sizeof(passBuf)); + for (i = 0; i < 12; i++) { + ch = info->ubuf[i]; + zdecode(info->keys, crc32tab, ch); + } + info->ubuf += i; + } + + if (info->iscompr) { + z_stream stream; + int err; + unsigned int j; + + /* + * Data to decode is compressed, and possibly encrpyted too. + */ + + memset(&stream, 0, sizeof(z_stream)); + stream.zalloc = Z_NULL; + stream.zfree = Z_NULL; + stream.opaque = Z_NULL; + stream.avail_in = z->numCompressedBytes; + if (info->isEncrypted) { + stream.avail_in -= 12; + ubuf = (unsigned char *) attemptckalloc(stream.avail_in); + if (!ubuf) { + info->ubuf = NULL; + goto memoryError; } - for (j = 0; j < len; j++) { + + for (j = 0; j < stream.avail_in; j++) { ch = info->ubuf[j]; ubuf[j] = zdecode(info->keys, crc32tab, ch); } - info->ubuf = ubuf; + stream.next_in = ubuf; + } else { + stream.next_in = info->ubuf; + } + stream.next_out = info->ubuf = (unsigned char *) + attemptckalloc(info->numBytes); + if (!info->ubuf) { + goto memoryError; + } + stream.avail_out = info->numBytes; + if (inflateInit2(&stream, -15) != Z_OK) { + goto corruptionError; + } + err = inflate(&stream, Z_SYNC_FLUSH); + inflateEnd(&stream); + + /* + * Decompression was successful if we're either in the END state, or + * in the OK state with no buffered bytes. + */ + + if ((err != Z_STREAM_END) + && ((err != Z_OK) || (stream.avail_in != 0))) { + goto corruptionError; + } + + if (ubuf) { info->isEncrypted = 0; + memset(info->keys, 0, sizeof(info->keys)); + ckfree(ubuf); + } + return TCL_OK; + } else if (info->isEncrypted) { + unsigned int j, len; + + /* + * Decode encrypted but uncompressed file, since we support Tcl_Seek() + * on it, and it can be randomly accessed later. + */ + + len = z->numCompressedBytes - 12; + ubuf = (unsigned char *) attemptckalloc(len); + if (ubuf == NULL) { + goto memoryError; + } + for (j = 0; j < len; j++) { + ch = info->ubuf[j]; + ubuf[j] = zdecode(info->keys, crc32tab, ch); } + info->ubuf = ubuf; + info->isEncrypted = 0; } + return TCL_OK; - wrapchan: - sprintf(cname, "zipfs_%" TCL_LL_MODIFIER "x_%d", z->offset, - ZipFS.idCount++); - z->zipFilePtr->numOpen++; - Unlock(); - return Tcl_CreateChannel(&ZipChannelType, cname, info, flags); + corruptionError: + if (ubuf) { + info->isEncrypted = 0; + memset(info->keys, 0, sizeof(info->keys)); + ckfree(ubuf); + } + if (info->ubuf) { + ckfree(info->ubuf); + } + ZIPFS_ERROR(interp, "decompression error"); + ZIPFS_ERROR_CODE(interp, "CORRUPT"); + return TCL_ERROR; - error: - Unlock(); - return NULL; + memoryError: + if (ubuf) { + info->isEncrypted = 0; + memset(info->keys, 0, sizeof(info->keys)); + ckfree(ubuf); + } + ZIPFS_MEM_ERROR(interp); + return TCL_ERROR; } /* @@ -4003,9 +4813,14 @@ ZipEntryAccess( * * ZipFSOpenFileChannelProc -- * + * Open a channel to a file in a mounted ZIP archive. Delegates to + * ZipChannelOpen(). + * * Results: + * Tcl_Channel on success, or NULL on error. * * Side effects: + * Allocates memory. * *------------------------------------------------------------------------- */ @@ -4015,16 +4830,31 @@ ZipFSOpenFileChannelProc( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *pathPtr, int mode, - int permissions) + TCL_UNUSED(int) /* permissions */) { - int len; + int trunc = (mode & O_TRUNC) != 0; + int wr = (mode & (O_WRONLY | O_RDWR)) != 0; pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (!pathPtr) { return NULL; } - return ZipChannelOpen(interp, Tcl_GetStringFromObj(pathPtr, &len), mode, - permissions); + + /* + * Check for unsupported modes. + */ + + if ((mode & O_APPEND) || ((ZipFS.wrmax <= 0) && wr)) { + Tcl_SetErrno(EACCES); + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "write access not supported: %s", + Tcl_PosixError(interp))); + } + return NULL; + } + + return ZipChannelOpen(interp, Tcl_GetString(pathPtr), wr, trunc); } /* @@ -4049,13 +4879,11 @@ ZipFSStatProc( Tcl_Obj *pathPtr, Tcl_StatBuf *buf) { - int len; - pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (!pathPtr) { return -1; } - return ZipEntryStat(Tcl_GetStringFromObj(pathPtr, &len), buf); + return ZipEntryStat(Tcl_GetString(pathPtr), buf); } /* @@ -4080,13 +4908,11 @@ ZipFSAccessProc( Tcl_Obj *pathPtr, int mode) { - int len; - pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (!pathPtr) { return -1; } - return ZipEntryAccess(Tcl_GetStringFromObj(pathPtr, &len), mode); + return ZipEntryAccess(Tcl_GetString(pathPtr), mode); } /* @@ -4118,6 +4944,38 @@ ZipFSFilesystemSeparatorProc( /* *------------------------------------------------------------------------- * + * AppendWithPrefix -- + * + * Worker for ZipFSMatchInDirectoryProc() that is a wrapper around + * Tcl_ListObjAppendElement() which knows about handling prefixes. + * + *------------------------------------------------------------------------- + */ + +static inline void +AppendWithPrefix( + Tcl_Obj *result, /* Where to append a list element to. */ + Tcl_DString *prefix, /* The prefix to add to the element, or NULL + * for don't do that. */ + const char *name, /* The name to append. */ + int nameLen) /* The length of the name. May be -1 for + * append-up-to-NUL-byte. */ +{ + if (prefix) { + int prefixLength = Tcl_DStringLength(prefix); + + Tcl_DStringAppend(prefix, name, nameLen); + Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj( + Tcl_DStringValue(prefix), Tcl_DStringLength(prefix))); + Tcl_DStringSetLength(prefix, prefixLength); + } else { + Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj(name, nameLen)); + } +} + +/* + *------------------------------------------------------------------------- + * * ZipFSMatchInDirectoryProc -- * * This routine is used by the globbing code to search a directory for @@ -4137,24 +4995,24 @@ ZipFSFilesystemSeparatorProc( static int ZipFSMatchInDirectoryProc( TCL_UNUSED(Tcl_Interp *), - Tcl_Obj *result, - Tcl_Obj *pathPtr, - const char *pattern, - Tcl_GlobTypeData *types) + Tcl_Obj *result, /* Where to append matched items to. */ + Tcl_Obj *pathPtr, /* Where we are looking. */ + const char *pattern, /* What names we are looking for. */ + Tcl_GlobTypeData *types) /* What types we are looking for. */ { Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_Obj *normPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); - int scnt, l, dirOnly = -1, prefixLen, strip = 0; - size_t len; + int scnt, l, dirOnly = -1, prefixLen, strip = 0, mounts = 0, len; char *pat, *prefix, *path; - Tcl_DString dsPref; + Tcl_DString dsPref, *prefixBuf = NULL; if (!normPathPtr) { return -1; } if (types) { dirOnly = (types->type & TCL_GLOB_TYPE_DIR) == TCL_GLOB_TYPE_DIR; + mounts = (types->type == TCL_GLOB_TYPE_MOUNT); } /* @@ -4167,107 +5025,58 @@ ZipFSMatchInDirectoryProc( * The (normalized) path we're searching. */ - path = Tcl_GetString(normPathPtr); - len = normPathPtr->length; + path = Tcl_GetStringFromObj(normPathPtr, &len); Tcl_DStringInit(&dsPref); - Tcl_DStringAppend(&dsPref, prefix, prefixLen); - if (strcmp(prefix, path) == 0) { - prefix = NULL; + prefixBuf = NULL; } else { + /* + * We need to strip the normalized prefix of the filenames and replace + * it with the official prefix that we were expecting to get. + */ + strip = len + 1; - } - if (prefix) { + Tcl_DStringAppend(&dsPref, prefix, prefixLen); Tcl_DStringAppend(&dsPref, "/", 1); - prefixLen++; prefix = Tcl_DStringValue(&dsPref); + prefixBuf = &dsPref; } + ReadLock(); - if (types && (types->type == TCL_GLOB_TYPE_MOUNT)) { - l = CountSlashes(path); - if (path[len - 1] == '/') { - len--; - } else { - l++; - } - if (!pattern || (pattern[0] == '\0')) { - pattern = "*"; - } - for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; - hPtr = Tcl_NextHashEntry(&search)) { - ZipFile *zf = (ZipFile *)Tcl_GetHashValue(hPtr); - - if (zf->mountPointLen == 0) { - ZipEntry *z; - - for (z = zf->topEnts; z; z = z->tnext) { - size_t lenz = strlen(z->name); - - if ((lenz > len + 1) && (strncmp(z->name, path, len) == 0) - && (z->name[len] == '/') - && (CountSlashes(z->name) == l) - && Tcl_StringCaseMatch(z->name + len + 1, pattern, - 0)) { - if (prefix) { - Tcl_DStringAppend(&dsPref, z->name, lenz); - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(Tcl_DStringValue(&dsPref), - Tcl_DStringLength(&dsPref))); - Tcl_DStringSetLength(&dsPref, prefixLen); - } else { - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(z->name, lenz)); - } - } - } - } else if ((zf->mountPointLen > len + 1) - && (strncmp(zf->mountPoint, path, len) == 0) - && (zf->mountPoint[len] == '/') - && (CountSlashes(zf->mountPoint) == l) - && Tcl_StringCaseMatch(zf->mountPoint + len + 1, - pattern, 0)) { - if (prefix) { - Tcl_DStringAppend(&dsPref, zf->mountPoint, - zf->mountPointLen); - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(Tcl_DStringValue(&dsPref), - Tcl_DStringLength(&dsPref))); - Tcl_DStringSetLength(&dsPref, prefixLen); - } else { - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(zf->mountPoint, - zf->mountPointLen)); - } - } - } + + /* + * Are we globbing the mount points? + */ + + if (mounts) { + ZipFSMatchMountPoints(result, normPathPtr, pattern, prefixBuf); goto end; } + /* + * Can we skip the complexity of actual globbing? Without a pattern, yes; + * it's a directory existence test. + */ + if (!pattern || (pattern[0] == '\0')) { - hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path); - if (hPtr) { - ZipEntry *z = (ZipEntry *)Tcl_GetHashValue(hPtr); - - if ((dirOnly < 0) || (!dirOnly && !z->isDirectory) - || (dirOnly && z->isDirectory)) { - if (prefix) { - Tcl_DStringAppend(&dsPref, z->name, -1); - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(Tcl_DStringValue(&dsPref), - Tcl_DStringLength(&dsPref))); - Tcl_DStringSetLength(&dsPref, prefixLen); - } else { - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(z->name, -1)); - } - } + ZipEntry *z = ZipFSLookup(path); + + if (z && ((dirOnly < 0) || (!dirOnly && !z->isDirectory) + || (dirOnly && z->isDirectory))) { + AppendWithPrefix(result, prefixBuf, z->name, -1); } goto end; } + /* + * We've got to work for our supper and do the actual globbing. And all + * we've got really is an undifferentiated pile of all the filenames we've + * got from all our ZIP mounts. + */ + l = strlen(pattern); - pat = (char *)ckalloc(len + l + 2); + pat = (char *) ckalloc(len + l + 2); memcpy(pat, path, len); while ((len > 1) && (pat[len - 1] == '/')) { --len; @@ -4278,25 +5087,17 @@ ZipFSMatchInDirectoryProc( } memcpy(pat + len, pattern, l + 1); scnt = CountSlashes(pat); + for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); hPtr; hPtr = Tcl_NextHashEntry(&search)) { - ZipEntry *z = (ZipEntry *)Tcl_GetHashValue(hPtr); + ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); if ((dirOnly >= 0) && ((dirOnly && !z->isDirectory) || (!dirOnly && z->isDirectory))) { continue; } if ((z->depth == scnt) && Tcl_StringCaseMatch(z->name, pat, 0)) { - if (prefix) { - Tcl_DStringAppend(&dsPref, z->name + strip, -1); - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(Tcl_DStringValue(&dsPref), - Tcl_DStringLength(&dsPref))); - Tcl_DStringSetLength(&dsPref, prefixLen); - } else { - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(z->name + strip, -1)); - } + AppendWithPrefix(result, prefixBuf, z->name + strip, -1); } } ckfree(pat); @@ -4310,6 +5111,94 @@ ZipFSMatchInDirectoryProc( /* *------------------------------------------------------------------------- * + * ZipFSMatchMountPoints -- + * + * This routine is a worker for ZipFSMatchInDirectoryProc, used by the + * globbing code to search for all mount points files which match a given + * pattern. + * + * Results: + * None. + * + * Side effects: + * Adds the matching mounts to the list in result, uses prefix as working + * space if it is non-NULL. + * + *------------------------------------------------------------------------- + */ + +static void +ZipFSMatchMountPoints( + Tcl_Obj *result, /* The list of matches being built. */ + Tcl_Obj *normPathPtr, /* Where we're looking from. */ + const char *pattern, /* What we're looking for. NULL for a full + * list. */ + Tcl_DString *prefix) /* Workspace filled with a prefix for all the + * filenames, or NULL if no prefix is to be + * used. */ +{ + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + int l, normLength; + const char *path = Tcl_GetStringFromObj(normPathPtr, &normLength); + size_t len = (size_t) normLength; + + if (len < 1) { + /* + * Shouldn't happen. But "shouldn't"... + */ + + return; + } + l = CountSlashes(path); + if (path[len - 1] == '/') { + len--; + } else { + l++; + } + if (!pattern || (pattern[0] == '\0')) { + pattern = "*"; + } + + for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; + hPtr = Tcl_NextHashEntry(&search)) { + ZipFile *zf = (ZipFile *) Tcl_GetHashValue(hPtr); + + if (zf->mountPointLen == 0) { + ZipEntry *z; + + /* + * Enumerate the contents of the ZIP; it's mounted on the root. + */ + + for (z = zf->topEnts; z; z = z->tnext) { + size_t lenz = strlen(z->name); + + if ((lenz > len + 1) && (strncmp(z->name, path, len) == 0) + && (z->name[len] == '/') + && (CountSlashes(z->name) == l) + && Tcl_StringCaseMatch(z->name + len + 1, pattern, 0)) { + AppendWithPrefix(result, prefix, z->name, lenz); + } + } + } else if ((zf->mountPointLen > len + 1) + && (strncmp(zf->mountPoint, path, len) == 0) + && (zf->mountPoint[len] == '/') + && (CountSlashes(zf->mountPoint) == l) + && Tcl_StringCaseMatch(zf->mountPoint + len + 1, + pattern, 0)) { + /* + * Standard mount; append if it matches. + */ + + AppendWithPrefix(result, prefix, zf->mountPoint, zf->mountPointLen); + } + } +} + +/* + *------------------------------------------------------------------------- + * * ZipFSPathInFilesystemProc -- * * This function determines if the given path object is in the ZIP @@ -4331,22 +5220,18 @@ ZipFSPathInFilesystemProc( { Tcl_HashEntry *hPtr; Tcl_HashSearch search; - int ret = -1; - size_t len; + int ret = -1, len; char *path; pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (!pathPtr) { return -1; } - - path = Tcl_GetString(pathPtr); + path = Tcl_GetStringFromObj(pathPtr, &len); if (strncmp(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) != 0) { return -1; } - len = pathPtr->length; - ReadLock(); hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path); if (hPtr) { @@ -4356,7 +5241,7 @@ ZipFSPathInFilesystemProc( for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; hPtr = Tcl_NextHashEntry(&search)) { - ZipFile *zf = (ZipFile *)Tcl_GetHashValue(hPtr); + ZipFile *zf = (ZipFile *) Tcl_GetHashValue(hPtr); if (zf->mountPointLen == 0) { ZipEntry *z; @@ -4364,12 +5249,13 @@ ZipFSPathInFilesystemProc( for (z = zf->topEnts; z != NULL; z = z->tnext) { size_t lenz = strlen(z->name); - if ((len >= lenz) && (strncmp(path, z->name, lenz) == 0)) { + if (((size_t) len >= lenz) && + (strncmp(path, z->name, lenz) == 0)) { ret = TCL_OK; goto endloop; } } - } else if ((len >= zf->mountPointLen) && + } else if (((size_t) len >= zf->mountPointLen) && (strncmp(path, zf->mountPoint, zf->mountPointLen) == 0)) { ret = TCL_OK; break; @@ -4421,11 +5307,25 @@ ZipFSListVolumesProc(void) *------------------------------------------------------------------------- */ +enum ZipFileAttrs { + ZIP_ATTR_UNCOMPSIZE, + ZIP_ATTR_COMPSIZE, + ZIP_ATTR_OFFSET, + ZIP_ATTR_MOUNT, + ZIP_ATTR_ARCHIVE, + ZIP_ATTR_PERMISSIONS, + ZIP_ATTR_CRC +}; + static const char *const * ZipFSFileAttrStringsProc( TCL_UNUSED(Tcl_Obj *) /*pathPtr*/, TCL_UNUSED(Tcl_Obj **) /*objPtrRef*/) { + /* + * Must match up with ZipFileAttrs enum above. + */ + static const char *const attrs[] = { "-uncompsize", "-compsize", @@ -4433,6 +5333,7 @@ ZipFSFileAttrStringsProc( "-mount", "-archive", "-permissions", + "-crc", NULL, }; @@ -4484,27 +5385,31 @@ ZipFSFileAttrsGetProc( goto done; } switch (index) { - case 0: + case ZIP_ATTR_UNCOMPSIZE: TclNewIntObj(*objPtrRef, z->numBytes); break; - case 1: + case ZIP_ATTR_COMPSIZE: TclNewIntObj(*objPtrRef, z->numCompressedBytes); break; - case 2: + case ZIP_ATTR_OFFSET: TclNewIntObj(*objPtrRef, z->offset); break; - case 3: + case ZIP_ATTR_MOUNT: *objPtrRef = Tcl_NewStringObj(z->zipFilePtr->mountPoint, z->zipFilePtr->mountPointLen); break; - case 4: + case ZIP_ATTR_ARCHIVE: *objPtrRef = Tcl_NewStringObj(z->zipFilePtr->name, -1); break; - case 5: + case ZIP_ATTR_PERMISSIONS: *objPtrRef = Tcl_NewStringObj("0o555", -1); break; + case ZIP_ATTR_CRC: + TclNewIntObj(*objPtrRef, z->crc32); + break; default: ZIPFS_ERROR(interp, "unknown attribute"); + ZIPFS_ERROR_CODE(interp, "FILE_ATTR"); ret = TCL_ERROR; } @@ -4537,10 +5442,8 @@ ZipFSFileAttrsSetProc( TCL_UNUSED(Tcl_Obj *) /*pathPtr*/, TCL_UNUSED(Tcl_Obj *) /*objPtr*/) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("unsupported operation", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "UNSUPPORTED_OP", NULL); - } + ZIPFS_ERROR(interp, "unsupported operation"); + ZIPFS_ERROR_CODE(interp, "UNSUPPORTED_OP"); return TCL_ERROR; } @@ -4642,7 +5545,7 @@ ZipFSLoadFile( if (execName) { const char *p = strrchr(execName, '/'); - if (p > execName + 1) { + if (p && p > execName + 1) { --p; objs[0] = Tcl_NewStringObj(execName, p - execName); } @@ -4668,7 +5571,8 @@ ZipFSLoadFile( Tcl_DecrRefCount(objs[1]); } - loadFileProc = (Tcl_FSLoadFileProc2 *)(void *)tclNativeFilesystem.loadFileProc; + loadFileProc = (Tcl_FSLoadFileProc2 *) (void *) + tclNativeFilesystem.loadFileProc; if (loadFileProc) { ret = loadFileProc(interp, path, loadHandle, unloadProcPtr, flags); } else { @@ -4757,8 +5661,12 @@ TclZipfs_Init( Tcl_Obj *mapObj; Tcl_EvalEx(interp, findproc, -1, TCL_EVAL_GLOBAL); - Tcl_LinkVar(interp, "::tcl::zipfs::wrmax", (char *) &ZipFS.wrmax, - TCL_LINK_INT); + if (!Tcl_IsSafe(interp)) { + Tcl_LinkVar(interp, "::tcl::zipfs::wrmax", (char *) &ZipFS.wrmax, + TCL_LINK_INT); + Tcl_LinkVar(interp, "::tcl::zipfs::fallbackEntryEncoding", + (char *) &ZipFS.fallbackEntryEncoding, TCL_LINK_STRING); + } ensemble = TclMakeEnsemble(interp, "zipfs", Tcl_IsSafe(interp) ? (initMap + 4) : initMap); @@ -4771,16 +5679,17 @@ TclZipfs_Init( Tcl_NewStringObj("::tcl::zipfs::find", -1)); Tcl_CreateObjCommand(interp, "::tcl::zipfs::tcl_library_init", ZipFSTclLibraryObjCmd, NULL, NULL); - Tcl_PkgProvide(interp, "zipfs", "2.0"); + Tcl_PkgProvide(interp, "tcl::zipfs", "2.0"); } return TCL_OK; #else /* !HAVE_ZLIB */ ZIPFS_ERROR(interp, "no zlib available"); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL); + ZIPFS_ERROR_CODE(interp, "NO_ZLIB"); return TCL_ERROR; #endif /* HAVE_ZLIB */ } +#if !defined(STATIC_BUILD) static int ZipfsAppHookFindTclInit( const char *archive) @@ -4817,12 +5726,13 @@ ZipfsAppHookFindTclInit( return TCL_ERROR; } +#endif static void ZipfsExitHandler( ClientData clientData) { - ZipFile *zf = (ZipFile *)clientData; + ZipFile *zf = (ZipFile *) clientData; if (TCL_OK != TclZipfs_Unmount(NULL, zf->mountPoint)) { Tcl_Panic("tried to unmount busy filesystem"); @@ -4852,14 +5762,14 @@ TclZipfs_AppHook( char ***argvPtr) /* Pointer to argv */ #endif /* _WIN32 */ { - char *archive; + const char *archive; #ifdef _WIN32 Tcl_FindExecutable(NULL); #else Tcl_FindExecutable((*argvPtr)[0]); #endif - archive = (char *) Tcl_GetNameOfExecutable(); + archive = Tcl_GetNameOfExecutable(); TclZipfs_Init(NULL); /* @@ -4984,9 +5894,7 @@ TclZipfs_Mount( * the ZIP is unprotected. */ { ZIPFS_ERROR(interp, "no zlib available"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL); - } + ZIPFS_ERROR_CODE(interp, "NO_ZLIB"); return TCL_ERROR; } @@ -4999,9 +5907,7 @@ TclZipfs_MountBuffer( int copy) { ZIPFS_ERROR(interp, "no zlib available"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL); - } + ZIPFS_ERROR_CODE(interp, "NO_ZLIB"); return TCL_ERROR; } @@ -5011,9 +5917,7 @@ TclZipfs_Unmount( const char *mountPoint) /* Mount point path. */ { ZIPFS_ERROR(interp, "no zlib available"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL); - } + ZIPFS_ERROR_CODE(interp, "NO_ZLIB"); return TCL_ERROR; } #endif /* !HAVE_ZLIB */ diff --git a/generic/tclZlib.c b/generic/tclZlib.c index ea6a1f2..440bb9a 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -3,9 +3,9 @@ * * This file provides the interface to the Zlib library. * - * Copyright (C) 2004-2005 Pascal Scheffers <pascal@scheffers.net> - * Copyright (C) 2005 Unitas Software B.V. - * Copyright (c) 2008-2012 Donal K. Fellows + * Copyright © 2004-2005 Pascal Scheffers <pascal@scheffers.net> + * Copyright © 2005 Unitas Software B.V. + * Copyright © 2008-2012 Donal K. Fellows * * Parts written by Jean-Claude Wippler, as part of Tclkit, placed in the * public domain March 2003. @@ -3709,7 +3709,7 @@ ZlibStackChannelTransform( if (compDictObj != NULL) { cd->compDictObj = Tcl_DuplicateObj(compDictObj); Tcl_IncrRefCount(cd->compDictObj); - Tcl_GetByteArrayFromObj(cd->compDictObj, NULL); + TclGetByteArrayFromObj(cd->compDictObj, NULL); } if (format == TCL_ZLIB_FORMAT_RAW) { @@ -3957,7 +3957,10 @@ TclZlibInit( * Formally provide the package as a Tcl built-in. */ - return Tcl_PkgProvide(interp, "zlib", TCL_ZLIB_VERSION); +#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) + Tcl_PkgProvide(interp, "zlib", TCL_ZLIB_VERSION); +#endif + return Tcl_PkgProvide(interp, "tcl::zlib", TCL_ZLIB_VERSION); } /* |