diff --git a/amd64/bin/tcl86t.dll b/amd64/bin/tcl86t.dll index df5f703..dedfe22 100644 Binary files a/amd64/bin/tcl86t.dll and b/amd64/bin/tcl86t.dll differ diff --git a/amd64/bin/tclsh86t.exe b/amd64/bin/tclsh86t.exe index ca7cd1a..259ff9c 100644 Binary files a/amd64/bin/tclsh86t.exe and b/amd64/bin/tclsh86t.exe differ diff --git a/amd64/bin/tk86t.dll b/amd64/bin/tk86t.dll index da57657..5539faf 100644 Binary files a/amd64/bin/tk86t.dll and b/amd64/bin/tk86t.dll differ diff --git a/amd64/bin/wish86t.exe b/amd64/bin/wish86t.exe index 5af6dab..a84f342 100644 Binary files a/amd64/bin/wish86t.exe and b/amd64/bin/wish86t.exe differ diff --git a/amd64/include/X11/Xlib.h b/amd64/include/X11/Xlib.h index e8940d9..1977939 100644 --- a/amd64/include/X11/Xlib.h +++ b/amd64/include/X11/Xlib.h @@ -331,7 +331,7 @@ typedef struct _XImage { unsigned long blue_mask; XPointer obdata; /* hook for the object routines to hang on */ #if defined(MAC_OSX_TK) - int pixelpower; /* n such that pixels are 2^n x 2^n blocks*/ + int pixelpower; /* No longer used. */ #endif struct funcs { /* image manipulation routines */ struct _XImage *(*create_image)(); @@ -541,7 +541,7 @@ typedef struct { Bool send_event; /* true if this came from a SendEvent request */ Display *display; /* Display the event was read from */ Window window; /* "event" window it is reported relative to */ - Window root; /* root window that the event occured on */ + Window root; /* root window that the event occurred on */ Window subwindow; /* child window */ Time time; /* milliseconds */ int x, y; /* pointer x, y coordinates in event window */ @@ -549,9 +549,6 @@ typedef struct { unsigned int state; /* key or button mask */ unsigned int keycode; /* detail */ Bool same_screen; /* same screen flag */ - char trans_chars[XMaxTransChars]; - /* translated characters */ - unsigned char nbytes; } XKeyEvent; typedef XKeyEvent XKeyPressedEvent; typedef XKeyEvent XKeyReleasedEvent; @@ -562,7 +559,7 @@ typedef struct { Bool send_event; /* true if this came from a SendEvent request */ Display *display; /* Display the event was read from */ Window window; /* "event" window it is reported relative to */ - Window root; /* root window that the event occured on */ + Window root; /* root window that the event occurred on */ Window subwindow; /* child window */ Time time; /* milliseconds */ int x, y; /* pointer x, y coordinates in event window */ @@ -580,7 +577,7 @@ typedef struct { Bool send_event; /* true if this came from a SendEvent request */ Display *display; /* Display the event was read from */ Window window; /* "event" window reported relative to */ - Window root; /* root window that the event occured on */ + Window root; /* root window that the event occurred on */ Window subwindow; /* child window */ Time time; /* milliseconds */ int x, y; /* pointer x, y coordinates in event window */ @@ -597,7 +594,7 @@ typedef struct { Bool send_event; /* true if this came from a SendEvent request */ Display *display; /* Display the event was read from */ Window window; /* "event" window reported relative to */ - Window root; /* root window that the event occured on */ + Window root; /* root window that the event occurred on */ Window subwindow; /* child window */ Time time; /* milliseconds */ int x, y; /* pointer x, y coordinates in event window */ @@ -959,7 +956,7 @@ typedef union _XEvent { XMappingEvent xmapping; XErrorEvent xerror; XKeymapEvent xkeymap; - long pad[24]; + XID pad[24]; } XEvent; #endif diff --git a/amd64/include/X11/keysymdef.h b/amd64/include/X11/keysymdef.h index 460c72d..d334cf2 100644 --- a/amd64/include/X11/keysymdef.h +++ b/amd64/include/X11/keysymdef.h @@ -30,7 +30,7 @@ SOFTWARE. /* * TTY Functions, cleverly chosen to map to ascii, for convenience of * programming, but could have been arbitrary (at the cost of lookup - * tables in client code. + * tables in client code). */ #define XK_BackSpace 0xFF08 /* back space, back char */ diff --git a/amd64/include/tcl.h b/amd64/include/tcl.h index 458072a..822d17b 100644 --- a/amd64/include/tcl.h +++ b/amd64/include/tcl.h @@ -51,10 +51,10 @@ extern "C" { #define TCL_MAJOR_VERSION 8 #define TCL_MINOR_VERSION 6 #define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE -#define TCL_RELEASE_SERIAL 10 +#define TCL_RELEASE_SERIAL 11 #define TCL_VERSION "8.6" -#define TCL_PATCH_LEVEL "8.6.10" +#define TCL_PATCH_LEVEL "8.6.11" /* *---------------------------------------------------------------------------- @@ -384,7 +384,7 @@ typedef long LONG; */ #if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG) -# if defined(_WIN32) +# if defined(_WIN32) && (!defined(__USE_MINGW_ANSI_STDIO) || !__USE_MINGW_ANSI_STDIO) # define TCL_WIDE_INT_TYPE __int64 # ifdef __BORLANDC__ # define TCL_LL_MODIFIER "L" @@ -2517,7 +2517,7 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); # define Tcl_DecrRefCount(objPtr) \ do { \ Tcl_Obj *_objPtr = (objPtr); \ - if ((_objPtr)->refCount-- <= 1) { \ + if (_objPtr->refCount-- <= 1) { \ TclFreeObj(_objPtr); \ } \ } while(0) diff --git a/amd64/include/tclDecls.h b/amd64/include/tclDecls.h index 719cdf3..0f18dd4 100644 --- a/amd64/include/tclDecls.h +++ b/amd64/include/tclDecls.h @@ -279,13 +279,13 @@ EXTERN int Tcl_ConvertElement(const char *src, char *dst, EXTERN int Tcl_ConvertCountedElement(const char *src, int length, char *dst, int flags); /* 86 */ -EXTERN int Tcl_CreateAlias(Tcl_Interp *slave, - const char *slaveCmd, Tcl_Interp *target, +EXTERN int Tcl_CreateAlias(Tcl_Interp *childInterp, + const char *childCmd, Tcl_Interp *target, const char *targetCmd, int argc, CONST84 char *const *argv); /* 87 */ -EXTERN int Tcl_CreateAliasObj(Tcl_Interp *slave, - const char *slaveCmd, Tcl_Interp *target, +EXTERN int Tcl_CreateAliasObj(Tcl_Interp *childInterp, + const char *childCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 88 */ @@ -323,8 +323,8 @@ EXTERN Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 97 */ -EXTERN Tcl_Interp * Tcl_CreateSlave(Tcl_Interp *interp, - const char *slaveName, int isSafe); +EXTERN Tcl_Interp * Tcl_CreateSlave(Tcl_Interp *interp, const char *name, + int isSafe); /* 98 */ EXTERN Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds, Tcl_TimerProc *proc, ClientData clientData); @@ -458,13 +458,13 @@ EXTERN int Tcl_Flush(Tcl_Channel chan); EXTERN void Tcl_FreeResult(Tcl_Interp *interp); /* 148 */ EXTERN int Tcl_GetAlias(Tcl_Interp *interp, - const char *slaveCmd, + const char *childCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *argcPtr, CONST84 char ***argvPtr); /* 149 */ EXTERN int Tcl_GetAliasObj(Tcl_Interp *interp, - const char *slaveCmd, + const char *childCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); @@ -503,8 +503,8 @@ EXTERN int Tcl_GetErrno(void); /* 162 */ EXTERN CONST84_RETURN char * Tcl_GetHostName(void); /* 163 */ -EXTERN int Tcl_GetInterpPath(Tcl_Interp *askInterp, - Tcl_Interp *slaveInterp); +EXTERN int Tcl_GetInterpPath(Tcl_Interp *interp, + Tcl_Interp *childInterp); /* 164 */ EXTERN Tcl_Interp * Tcl_GetMaster(Tcl_Interp *interp); /* 165 */ @@ -532,8 +532,7 @@ EXTERN int Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr); /* 171 */ EXTERN int Tcl_GetServiceMode(void); /* 172 */ -EXTERN Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp, - const char *slaveName); +EXTERN Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp, const char *name); /* 173 */ EXTERN Tcl_Channel Tcl_GetStdChannel(int type); /* 174 */ @@ -1749,7 +1748,7 @@ EXTERN int Tcl_GetErrorLine(Tcl_Interp *interp); EXTERN void Tcl_SetErrorLine(Tcl_Interp *interp, int lineNum); /* 607 */ EXTERN void Tcl_TransferResult(Tcl_Interp *sourceInterp, - int result, Tcl_Interp *targetInterp); + int code, Tcl_Interp *targetInterp); /* 608 */ EXTERN int Tcl_InterpActive(Tcl_Interp *interp); /* 609 */ @@ -1833,7 +1832,8 @@ EXTERN void Tcl_ZlibStreamSetCompressionDictionary( /* Slot 645 is reserved */ /* Slot 646 is reserved */ /* Slot 647 is reserved */ -/* 648 */ +/* Slot 648 is reserved */ +/* 649 */ EXTERN void TclUnusedStubEntry(void); typedef struct { @@ -1948,8 +1948,8 @@ typedef struct TclStubs { char * (*tcl_Concat) (int argc, CONST84 char *const *argv); /* 83 */ int (*tcl_ConvertElement) (const char *src, char *dst, int flags); /* 84 */ int (*tcl_ConvertCountedElement) (const char *src, int length, char *dst, int flags); /* 85 */ - int (*tcl_CreateAlias) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, CONST84 char *const *argv); /* 86 */ - int (*tcl_CreateAliasObj) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 87 */ + int (*tcl_CreateAlias) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int argc, CONST84 char *const *argv); /* 86 */ + int (*tcl_CreateAliasObj) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 87 */ Tcl_Channel (*tcl_CreateChannel) (const Tcl_ChannelType *typePtr, const char *chanName, ClientData instanceData, int mask); /* 88 */ void (*tcl_CreateChannelHandler) (Tcl_Channel chan, int mask, Tcl_ChannelProc *proc, ClientData clientData); /* 89 */ void (*tcl_CreateCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, ClientData clientData); /* 90 */ @@ -1959,7 +1959,7 @@ typedef struct TclStubs { Tcl_Interp * (*tcl_CreateInterp) (void); /* 94 */ void (*tcl_CreateMathFunc) (Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData); /* 95 */ Tcl_Command (*tcl_CreateObjCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 96 */ - Tcl_Interp * (*tcl_CreateSlave) (Tcl_Interp *interp, const char *slaveName, int isSafe); /* 97 */ + Tcl_Interp * (*tcl_CreateSlave) (Tcl_Interp *interp, const char *name, int isSafe); /* 97 */ Tcl_TimerToken (*tcl_CreateTimerHandler) (int milliseconds, Tcl_TimerProc *proc, ClientData clientData); /* 98 */ Tcl_Trace (*tcl_CreateTrace) (Tcl_Interp *interp, int level, Tcl_CmdTraceProc *proc, ClientData clientData); /* 99 */ void (*tcl_DeleteAssocData) (Tcl_Interp *interp, const char *name); /* 100 */ @@ -2010,8 +2010,8 @@ typedef struct TclStubs { Tcl_HashEntry * (*tcl_FirstHashEntry) (Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 145 */ int (*tcl_Flush) (Tcl_Channel chan); /* 146 */ void (*tcl_FreeResult) (Tcl_Interp *interp); /* 147 */ - int (*tcl_GetAlias) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *argcPtr, CONST84 char ***argvPtr); /* 148 */ - int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */ + int (*tcl_GetAlias) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *argcPtr, CONST84 char ***argvPtr); /* 148 */ + int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */ ClientData (*tcl_GetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 150 */ Tcl_Channel (*tcl_GetChannel) (Tcl_Interp *interp, const char *chanName, int *modePtr); /* 151 */ int (*tcl_GetChannelBufferSize) (Tcl_Channel chan); /* 152 */ @@ -2025,7 +2025,7 @@ typedef struct TclStubs { CONST84_RETURN char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */ int (*tcl_GetErrno) (void); /* 161 */ CONST84_RETURN char * (*tcl_GetHostName) (void); /* 162 */ - int (*tcl_GetInterpPath) (Tcl_Interp *askInterp, Tcl_Interp *slaveInterp); /* 163 */ + int (*tcl_GetInterpPath) (Tcl_Interp *interp, Tcl_Interp *childInterp); /* 163 */ Tcl_Interp * (*tcl_GetMaster) (Tcl_Interp *interp); /* 164 */ const char * (*tcl_GetNameOfExecutable) (void); /* 165 */ Tcl_Obj * (*tcl_GetObjResult) (Tcl_Interp *interp); /* 166 */ @@ -2042,7 +2042,7 @@ typedef struct TclStubs { int (*tcl_Gets) (Tcl_Channel chan, Tcl_DString *dsPtr); /* 169 */ int (*tcl_GetsObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 170 */ int (*tcl_GetServiceMode) (void); /* 171 */ - Tcl_Interp * (*tcl_GetSlave) (Tcl_Interp *interp, const char *slaveName); /* 172 */ + Tcl_Interp * (*tcl_GetSlave) (Tcl_Interp *interp, const char *name); /* 172 */ Tcl_Channel (*tcl_GetStdChannel) (int type); /* 173 */ CONST84_RETURN char * (*tcl_GetStringResult) (Tcl_Interp *interp); /* 174 */ CONST84_RETURN char * (*tcl_GetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 175 */ @@ -2477,7 +2477,7 @@ typedef struct TclStubs { int (*tcl_ParseArgsObjv) (Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, int *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv); /* 604 */ int (*tcl_GetErrorLine) (Tcl_Interp *interp); /* 605 */ void (*tcl_SetErrorLine) (Tcl_Interp *interp, int lineNum); /* 606 */ - void (*tcl_TransferResult) (Tcl_Interp *sourceInterp, int result, Tcl_Interp *targetInterp); /* 607 */ + void (*tcl_TransferResult) (Tcl_Interp *sourceInterp, int code, Tcl_Interp *targetInterp); /* 607 */ int (*tcl_InterpActive) (Tcl_Interp *interp); /* 608 */ void (*tcl_BackgroundException) (Tcl_Interp *interp, int code); /* 609 */ int (*tcl_ZlibDeflate) (Tcl_Interp *interp, int format, Tcl_Obj *data, int level, Tcl_Obj *gzipHeaderDictObj); /* 610 */ @@ -2518,7 +2518,8 @@ typedef struct TclStubs { void (*reserved645)(void); void (*reserved646)(void); void (*reserved647)(void); - void (*tclUnusedStubEntry) (void); /* 648 */ + void (*reserved648)(void); + void (*tclUnusedStubEntry) (void); /* 649 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3828,8 +3829,9 @@ extern const TclStubs *tclStubsPtr; /* Slot 645 is reserved */ /* Slot 646 is reserved */ /* Slot 647 is reserved */ +/* Slot 648 is reserved */ #define TclUnusedStubEntry \ - (tclStubsPtr->tclUnusedStubEntry) /* 648 */ + (tclStubsPtr->tclUnusedStubEntry) /* 649 */ #endif /* defined(USE_TCL_STUBS) */ @@ -3971,5 +3973,8 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_GlobalEvalObj #define Tcl_GlobalEvalObj(interp,objPtr) \ Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL) +#define Tcl_CreateChild Tcl_CreateSlave +#define Tcl_GetChild Tcl_GetSlave +#define Tcl_GetParent Tcl_GetMaster #endif /* _TCLDECLS */ diff --git a/amd64/include/tclPlatDecls.h b/amd64/include/tclPlatDecls.h index abc8ee8..974bafa 100644 --- a/amd64/include/tclPlatDecls.h +++ b/amd64/include/tclPlatDecls.h @@ -114,6 +114,11 @@ extern const TclPlatStubs *tclPlatStubsPtr; /* !END!: Do not edit above this line. */ +#ifdef MAC_OSX_TCL /* MACOSX */ +#undef Tcl_MacOSXOpenBundleResources +#define Tcl_MacOSXOpenBundleResources(a,b,c,d,e) Tcl_MacOSXOpenVersionedBundleResources(a,b,NULL,c,d,e) +#endif + #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT diff --git a/amd64/include/tclTomMathDecls.h b/amd64/include/tclTomMathDecls.h index 3436798..6991643 100644 --- a/amd64/include/tclTomMathDecls.h +++ b/amd64/include/tclTomMathDecls.h @@ -72,6 +72,7 @@ #define mp_expt_d TclBN_mp_expt_d #define mp_expt_d_ex TclBN_mp_expt_d_ex #define mp_expt_u32 TclBN_mp_expt_d +#define mp_get_mag_ull TclBN_mp_get_mag_ull #define mp_grow TclBN_mp_grow #define mp_init TclBN_mp_init #define mp_init_copy TclBN_mp_init_copy @@ -93,6 +94,7 @@ #define mp_rshd TclBN_mp_rshd #define mp_set TclBN_mp_set #define mp_set_int(a,b) (TclBN_mp_set_int(a,(unsigned int)(b)),MP_OKAY) +#define mp_set_ll TclBN_mp_set_ll #define mp_set_long(a,b) (TclBN_mp_set_int(a,b),MP_OKAY) #define mp_set_ul(a,b) (void)TclBN_mp_set_int(a,b) #define mp_set_ull TclBN_mp_set_ull @@ -323,8 +325,10 @@ EXTERN mp_err TclBN_mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast); /* 68 */ EXTERN void TclBN_mp_set_ull(mp_int *a, Tcl_WideUInt i); -/* Slot 69 is reserved */ -/* Slot 70 is reserved */ +/* 69 */ +EXTERN Tcl_WideUInt TclBN_mp_get_mag_ull(const mp_int *a); +/* 70 */ +EXTERN void TclBN_mp_set_ll(mp_int *a, Tcl_WideInt i); /* Slot 71 is reserved */ /* Slot 72 is reserved */ /* 73 */ @@ -343,7 +347,9 @@ EXTERN mp_err TclBN_mp_signed_rsh(const mp_int *a, int b, /* 78 */ EXTERN int TclBN_mp_to_ubin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written); -/* Slot 79 is reserved */ +/* 79 */ +EXTERN mp_err TclBN_mp_div_ld(const mp_int *a, Tcl_WideUInt b, + mp_int *q, Tcl_WideUInt *r); /* 80 */ EXTERN int TclBN_mp_to_radix(const mp_int *a, char *str, size_t maxlen, size_t *written, int radix); @@ -421,8 +427,8 @@ typedef struct TclTomMathStubs { int (*tclBNInitBignumFromWideUInt) (mp_int *bignum, Tcl_WideUInt initVal); /* 66 */ mp_err (*tclBN_mp_expt_d_ex) (const mp_int *a, mp_digit b, mp_int *c, int fast); /* 67 */ void (*tclBN_mp_set_ull) (mp_int *a, Tcl_WideUInt i); /* 68 */ - void (*reserved69)(void); - void (*reserved70)(void); + Tcl_WideUInt (*tclBN_mp_get_mag_ull) (const mp_int *a); /* 69 */ + void (*tclBN_mp_set_ll) (mp_int *a, Tcl_WideInt i); /* 70 */ void (*reserved71)(void); void (*reserved72)(void); mp_err (*tclBN_mp_tc_and) (const mp_int *a, const mp_int *b, mp_int *c); /* 73 */ @@ -431,7 +437,7 @@ typedef struct TclTomMathStubs { mp_err (*tclBN_mp_signed_rsh) (const mp_int *a, int b, mp_int *c); /* 76 */ void (*reserved77)(void); int (*tclBN_mp_to_ubin) (const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written); /* 78 */ - void (*reserved79)(void); + mp_err (*tclBN_mp_div_ld) (const mp_int *a, Tcl_WideUInt b, mp_int *q, Tcl_WideUInt *r); /* 79 */ int (*tclBN_mp_to_radix) (const mp_int *a, char *str, size_t maxlen, size_t *written, int radix); /* 80 */ } TclTomMathStubs; @@ -585,8 +591,10 @@ extern const TclTomMathStubs *tclTomMathStubsPtr; (tclTomMathStubsPtr->tclBN_mp_expt_d_ex) /* 67 */ #define TclBN_mp_set_ull \ (tclTomMathStubsPtr->tclBN_mp_set_ull) /* 68 */ -/* Slot 69 is reserved */ -/* Slot 70 is reserved */ +#define TclBN_mp_get_mag_ull \ + (tclTomMathStubsPtr->tclBN_mp_get_mag_ull) /* 69 */ +#define TclBN_mp_set_ll \ + (tclTomMathStubsPtr->tclBN_mp_set_ll) /* 70 */ /* Slot 71 is reserved */ /* Slot 72 is reserved */ #define TclBN_mp_tc_and \ @@ -600,7 +608,8 @@ extern const TclTomMathStubs *tclTomMathStubsPtr; /* Slot 77 is reserved */ #define TclBN_mp_to_ubin \ (tclTomMathStubsPtr->tclBN_mp_to_ubin) /* 78 */ -/* Slot 79 is reserved */ +#define TclBN_mp_div_ld \ + (tclTomMathStubsPtr->tclBN_mp_div_ld) /* 79 */ #define TclBN_mp_to_radix \ (tclTomMathStubsPtr->tclBN_mp_to_radix) /* 80 */ diff --git a/amd64/include/tk.h b/amd64/include/tk.h index ce5902d..af8e5ca 100644 --- a/amd64/include/tk.h +++ b/amd64/include/tk.h @@ -75,10 +75,10 @@ extern "C" { #define TK_MAJOR_VERSION 8 #define TK_MINOR_VERSION 6 #define TK_RELEASE_LEVEL TCL_FINAL_RELEASE -#define TK_RELEASE_SERIAL 10 +#define TK_RELEASE_SERIAL 11 #define TK_VERSION "8.6" -#define TK_PATCH_LEVEL "8.6.10" +#define TK_PATCH_LEVEL "8.6.11" /* * A special definition used to allow this header file to be included from @@ -122,6 +122,7 @@ extern "C" { * Dummy types that are used by clients: */ +#define Tk_ImageModel Tk_ImageMaster typedef struct Tk_BindingTable_ *Tk_BindingTable; typedef struct Tk_Canvas_ *Tk_Canvas; typedef struct Tk_Cursor_ *Tk_Cursor; @@ -614,21 +615,22 @@ typedef struct Tk_ClassProcs { * the geometry manager to carry out certain functions. */ +#define Tk_GeomLostContentProc Tk_GeomLostSlaveProc typedef void (Tk_GeomRequestProc) (ClientData clientData, Tk_Window tkwin); -typedef void (Tk_GeomLostSlaveProc) (ClientData clientData, Tk_Window tkwin); +typedef void (Tk_GeomLostContentProc) (ClientData clientData, Tk_Window tkwin); typedef struct Tk_GeomMgr { const char *name; /* Name of the geometry manager (command used * to invoke it, or name of widget class that * allows embedded widgets). */ Tk_GeomRequestProc *requestProc; - /* Procedure to invoke when a slave's + /* Procedure to invoke when a content's * requested geometry changes. */ - Tk_GeomLostSlaveProc *lostSlaveProc; - /* Procedure to invoke when a slave is taken + Tk_GeomLostContentProc *lostSlaveProc; + /* Procedure to invoke when content is taken * away from one geometry manager by another. * NULL means geometry manager doesn't care - * when slaves are lost. */ + * when content lost. */ } Tk_GeomMgr; /* @@ -884,6 +886,10 @@ typedef struct Tk_FakeWin { * window. * TK_WM_MANAGEABLE 1 marks a window as capable of being converted * into a toplevel using [wm manage]. + * TK_CAN_INPUT_TEXT 1 means that this window accepts text input. + * Used on macOS to indicate that key events can be + * processed with the NSTextInputClient protocol. + * Not currently accessible through the public API. */ #define TK_MAPPED 1 @@ -897,6 +903,7 @@ typedef struct Tk_FakeWin { #define TK_EMBEDDED 0x100 #define TK_CONTAINER 0x200 #define TK_BOTH_HALVES 0x400 + #define TK_WRAPPER 0x1000 #define TK_REPARENTED 0x2000 #define TK_ANONYMOUS_WINDOW 0x4000 @@ -905,6 +912,7 @@ typedef struct Tk_FakeWin { #define TK_TOP_HIERARCHY 0x20000 #define TK_PROP_PROPCHANGE 0x40000 #define TK_WM_MANAGEABLE 0x80000 +#define TK_CAN_INPUT_TEXT 0x100000 /* *---------------------------------------------------------------------- @@ -1222,19 +1230,19 @@ typedef struct Tk_Outline { typedef struct Tk_ImageType Tk_ImageType; #ifdef USE_OLD_IMAGE typedef int (Tk_ImageCreateProc) (Tcl_Interp *interp, char *name, int argc, - char **argv, Tk_ImageType *typePtr, Tk_ImageMaster master, - ClientData *masterDataPtr); + char **argv, Tk_ImageType *typePtr, Tk_ImageMaster model, + ClientData *clientDataPtr); #else typedef int (Tk_ImageCreateProc) (Tcl_Interp *interp, CONST86 char *name, int objc, - Tcl_Obj *const objv[], CONST86 Tk_ImageType *typePtr, Tk_ImageMaster master, - ClientData *masterDataPtr); + Tcl_Obj *const objv[], CONST86 Tk_ImageType *typePtr, Tk_ImageMaster model, + ClientData *clientDataPtr); #endif /* USE_OLD_IMAGE */ -typedef ClientData (Tk_ImageGetProc) (Tk_Window tkwin, ClientData masterData); -typedef void (Tk_ImageDisplayProc) (ClientData instanceData, Display *display, +typedef ClientData (Tk_ImageGetProc) (Tk_Window tkwin, ClientData clientData); +typedef void (Tk_ImageDisplayProc) (ClientData clientData, Display *display, Drawable drawable, int imageX, int imageY, int width, int height, int drawableX, int drawableY); -typedef void (Tk_ImageFreeProc) (ClientData instanceData, Display *display); -typedef void (Tk_ImageDeleteProc) (ClientData masterData); +typedef void (Tk_ImageFreeProc) (ClientData clientData, Display *display); +typedef void (Tk_ImageDeleteProc) (ClientData clientData); typedef void (Tk_ImageChangedProc) (ClientData clientData, int x, int y, int width, int height, int imageWidth, int imageHeight); typedef int (Tk_ImagePostscriptProc) (ClientData clientData, diff --git a/amd64/include/tkDecls.h b/amd64/include/tkDecls.h index 64c32cd..2072930 100644 --- a/amd64/include/tkDecls.h +++ b/amd64/include/tkDecls.h @@ -402,7 +402,7 @@ EXTERN void Tk_HandleEvent(XEvent *eventPtr); /* 116 */ EXTERN Tk_Window Tk_IdToWindow(Display *display, Window window); /* 117 */ -EXTERN void Tk_ImageChanged(Tk_ImageMaster master, int x, int y, +EXTERN void Tk_ImageChanged(Tk_ImageMaster model, int x, int y, int width, int height, int imageWidth, int imageHeight); /* 118 */ @@ -413,8 +413,8 @@ EXTERN Atom Tk_InternAtom(Tk_Window tkwin, const char *name); EXTERN int Tk_IntersectTextLayout(Tk_TextLayout layout, int x, int y, int width, int height); /* 121 */ -EXTERN void Tk_MaintainGeometry(Tk_Window slave, - Tk_Window master, int x, int y, int width, +EXTERN void Tk_MaintainGeometry(Tk_Window window, + Tk_Window container, int x, int y, int width, int height); /* 122 */ EXTERN Tk_Window Tk_MainWindow(Tcl_Interp *interp); @@ -453,7 +453,7 @@ EXTERN CONST84_RETURN char * Tk_NameOfCursor(Display *display, /* 136 */ EXTERN CONST84_RETURN char * Tk_NameOfFont(Tk_Font font); /* 137 */ -EXTERN CONST84_RETURN char * Tk_NameOfImage(Tk_ImageMaster imageMaster); +EXTERN CONST84_RETURN char * Tk_NameOfImage(Tk_ImageMaster model); /* 138 */ EXTERN CONST84_RETURN char * Tk_NameOfJoinStyle(int join); /* 139 */ @@ -582,8 +582,8 @@ EXTERN void Tk_UnderlineTextLayout(Display *display, /* 180 */ EXTERN void Tk_Ungrab(Tk_Window tkwin); /* 181 */ -EXTERN void Tk_UnmaintainGeometry(Tk_Window slave, - Tk_Window master); +EXTERN void Tk_UnmaintainGeometry(Tk_Window window, + Tk_Window container); /* 182 */ EXTERN void Tk_UnmapWindow(Tk_Window tkwin); /* 183 */ @@ -864,6 +864,14 @@ EXTERN void Tk_CreateOldImageType(const Tk_ImageType *typePtr); /* 273 */ EXTERN void Tk_CreateOldPhotoImageFormat( const Tk_PhotoImageFormat *formatPtr); +/* Slot 274 is reserved */ +/* Slot 275 is reserved */ +/* Slot 276 is reserved */ +/* Slot 277 is reserved */ +/* Slot 278 is reserved */ +/* Slot 279 is reserved */ +/* 280 */ +EXTERN void TkUnusedStubEntry(void); typedef struct { const struct TkPlatStubs *tkPlatStubs; @@ -993,11 +1001,11 @@ typedef struct TkStubs { int (*tk_Grab) (Tcl_Interp *interp, Tk_Window tkwin, int grabGlobal); /* 114 */ void (*tk_HandleEvent) (XEvent *eventPtr); /* 115 */ Tk_Window (*tk_IdToWindow) (Display *display, Window window); /* 116 */ - void (*tk_ImageChanged) (Tk_ImageMaster master, int x, int y, int width, int height, int imageWidth, int imageHeight); /* 117 */ + void (*tk_ImageChanged) (Tk_ImageMaster model, int x, int y, int width, int height, int imageWidth, int imageHeight); /* 117 */ int (*tk_Init) (Tcl_Interp *interp); /* 118 */ Atom (*tk_InternAtom) (Tk_Window tkwin, const char *name); /* 119 */ int (*tk_IntersectTextLayout) (Tk_TextLayout layout, int x, int y, int width, int height); /* 120 */ - void (*tk_MaintainGeometry) (Tk_Window slave, Tk_Window master, int x, int y, int width, int height); /* 121 */ + void (*tk_MaintainGeometry) (Tk_Window window, Tk_Window container, int x, int y, int width, int height); /* 121 */ Tk_Window (*tk_MainWindow) (Tcl_Interp *interp); /* 122 */ void (*tk_MakeWindowExist) (Tk_Window tkwin); /* 123 */ void (*tk_ManageGeometry) (Tk_Window tkwin, const Tk_GeomMgr *mgrPtr, ClientData clientData); /* 124 */ @@ -1013,7 +1021,7 @@ typedef struct TkStubs { CONST84_RETURN char * (*tk_NameOfColor) (XColor *colorPtr); /* 134 */ CONST84_RETURN char * (*tk_NameOfCursor) (Display *display, Tk_Cursor cursor); /* 135 */ CONST84_RETURN char * (*tk_NameOfFont) (Tk_Font font); /* 136 */ - CONST84_RETURN char * (*tk_NameOfImage) (Tk_ImageMaster imageMaster); /* 137 */ + CONST84_RETURN char * (*tk_NameOfImage) (Tk_ImageMaster model); /* 137 */ CONST84_RETURN char * (*tk_NameOfJoinStyle) (int join); /* 138 */ CONST84_RETURN char * (*tk_NameOfJustify) (Tk_Justify justify); /* 139 */ CONST84_RETURN char * (*tk_NameOfRelief) (int relief); /* 140 */ @@ -1057,7 +1065,7 @@ typedef struct TkStubs { void (*tk_UnderlineChars) (Display *display, Drawable drawable, GC gc, Tk_Font tkfont, const char *source, int x, int y, int firstByte, int lastByte); /* 178 */ void (*tk_UnderlineTextLayout) (Display *display, Drawable drawable, GC gc, Tk_TextLayout layout, int x, int y, int underline); /* 179 */ void (*tk_Ungrab) (Tk_Window tkwin); /* 180 */ - void (*tk_UnmaintainGeometry) (Tk_Window slave, Tk_Window master); /* 181 */ + void (*tk_UnmaintainGeometry) (Tk_Window window, Tk_Window container); /* 181 */ void (*tk_UnmapWindow) (Tk_Window tkwin); /* 182 */ void (*tk_UnsetGrid) (Tk_Window tkwin); /* 183 */ void (*tk_UpdatePointer) (Tk_Window tkwin, int x, int y, int state); /* 184 */ @@ -1150,6 +1158,13 @@ typedef struct TkStubs { Tcl_Interp * (*tk_Interp) (Tk_Window tkwin); /* 271 */ void (*tk_CreateOldImageType) (const Tk_ImageType *typePtr); /* 272 */ void (*tk_CreateOldPhotoImageFormat) (const Tk_PhotoImageFormat *formatPtr); /* 273 */ + void (*reserved274)(void); + void (*reserved275)(void); + void (*reserved276)(void); + void (*reserved277)(void); + void (*reserved278)(void); + void (*reserved279)(void); + void (*tkUnusedStubEntry) (void); /* 280 */ } TkStubs; extern const TkStubs *tkStubsPtr; @@ -1710,6 +1725,14 @@ extern const TkStubs *tkStubsPtr; (tkStubsPtr->tk_CreateOldImageType) /* 272 */ #define Tk_CreateOldPhotoImageFormat \ (tkStubsPtr->tk_CreateOldPhotoImageFormat) /* 273 */ +/* Slot 274 is reserved */ +/* Slot 275 is reserved */ +/* Slot 276 is reserved */ +/* Slot 277 is reserved */ +/* Slot 278 is reserved */ +/* Slot 279 is reserved */ +#define TkUnusedStubEntry \ + (tkStubsPtr->tkUnusedStubEntry) /* 280 */ #endif /* defined(USE_TK_STUBS) */ @@ -1720,6 +1743,7 @@ extern const TkStubs *tkStubsPtr; #undef Tk_Init #undef Tk_SafeInit #undef Tk_CreateConsoleWindow +#define Tk_GetImageModelData Tk_GetImageMasterData #if defined(_WIN32) && defined(UNICODE) # define Tk_MainEx Tk_MainExW @@ -1730,4 +1754,6 @@ extern const TkStubs *tkStubsPtr; #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT +#undef TkUnusedStubEntry + #endif /* _TKDECLS */ diff --git a/amd64/include/tkIntXlibDecls.h b/amd64/include/tkIntXlibDecls.h index 4b91440..9d4200a 100644 --- a/amd64/include/tkIntXlibDecls.h +++ b/amd64/include/tkIntXlibDecls.h @@ -413,6 +413,28 @@ EXTERN int XReparentWindow(Display *d, Window w, Window p, EXTERN int XPutImage(Display *d, Drawable dr, GC gc, XImage *im, int sx, int sy, int dx, int dy, unsigned int w, unsigned int h); +/* Slot 138 is reserved */ +/* Slot 139 is reserved */ +/* Slot 140 is reserved */ +/* Slot 141 is reserved */ +/* Slot 142 is reserved */ +/* Slot 143 is reserved */ +/* Slot 144 is reserved */ +/* Slot 145 is reserved */ +/* Slot 146 is reserved */ +/* Slot 147 is reserved */ +/* Slot 148 is reserved */ +/* Slot 149 is reserved */ +/* Slot 150 is reserved */ +/* Slot 151 is reserved */ +/* Slot 152 is reserved */ +/* Slot 153 is reserved */ +/* Slot 154 is reserved */ +/* Slot 155 is reserved */ +/* Slot 156 is reserved */ +/* Slot 157 is reserved */ +/* 158 */ +EXTERN void TkUnusedStubEntry(void); #endif /* WIN */ #ifdef MAC_OSX_TK /* AQUA */ /* 0 */ @@ -691,7 +713,10 @@ EXTERN int XSync(Display *display, Bool discard); /* Slot 103 is reserved */ /* Slot 104 is reserved */ /* Slot 105 is reserved */ -/* Slot 106 is reserved */ +/* 106 */ +EXTERN int XSetClipRectangles(Display *display, GC gc, + int clip_x_origin, int clip_y_origin, + XRectangle rectangles[], int n, int ordering); /* 107 */ EXTERN int XFlush(Display *display); /* 108 */ @@ -712,7 +737,8 @@ EXTERN VisualID XVisualIDFromVisual(Visual *visual); /* Slot 117 is reserved */ /* Slot 118 is reserved */ /* Slot 119 is reserved */ -/* Slot 120 is reserved */ +/* 120 */ +EXTERN int XOffsetRegion(void *rgn, int dx, int dy); /* Slot 121 is reserved */ /* Slot 122 is reserved */ /* Slot 123 is reserved */ @@ -721,7 +747,8 @@ EXTERN VisualID XVisualIDFromVisual(Visual *visual); /* Slot 126 is reserved */ /* Slot 127 is reserved */ /* Slot 128 is reserved */ -/* Slot 129 is reserved */ +/* 129 */ +EXTERN int XLowerWindow(Display *d, Window w); /* Slot 130 is reserved */ /* Slot 131 is reserved */ /* Slot 132 is reserved */ @@ -733,6 +760,37 @@ EXTERN VisualID XVisualIDFromVisual(Visual *visual); EXTERN int XPutImage(Display *d, Drawable dr, GC gc, XImage *im, int sx, int sy, int dx, int dy, unsigned int w, unsigned int h); +/* Slot 138 is reserved */ +/* Slot 139 is reserved */ +/* Slot 140 is reserved */ +/* Slot 141 is reserved */ +/* Slot 142 is reserved */ +/* Slot 143 is reserved */ +/* 144 */ +EXTERN void XDestroyIC(XIC xic); +/* 145 */ +EXTERN Cursor XCreatePixmapCursor(Display *d, Pixmap p1, Pixmap p2, + XColor *x1, XColor *x2, unsigned int ui1, + unsigned int ui2); +/* 146 */ +EXTERN Cursor XCreateGlyphCursor(Display *d, Font f1, Font f2, + unsigned int ui1, unsigned int ui2, + XColor _Xconst *x1, XColor _Xconst *x2); +/* Slot 147 is reserved */ +/* Slot 148 is reserved */ +/* Slot 149 is reserved */ +/* Slot 150 is reserved */ +/* Slot 151 is reserved */ +/* Slot 152 is reserved */ +/* Slot 153 is reserved */ +/* Slot 154 is reserved */ +/* Slot 155 is reserved */ +/* Slot 156 is reserved */ +/* 157 */ +EXTERN KeySym XkbKeycodeToKeysym(Display *d, unsigned int k, int g, + int i); +/* 158 */ +EXTERN void TkUnusedStubEntry(void); #endif /* AQUA */ typedef struct TkIntXlibStubs { @@ -878,6 +936,27 @@ typedef struct TkIntXlibStubs { int (*xDrawPoints) (Display *d, Drawable dr, GC gc, XPoint *p, int n, int m); /* 135 */ int (*xReparentWindow) (Display *d, Window w, Window p, int x, int y); /* 136 */ int (*xPutImage) (Display *d, Drawable dr, GC gc, XImage *im, int sx, int sy, int dx, int dy, unsigned int w, unsigned int h); /* 137 */ + void (*reserved138)(void); + void (*reserved139)(void); + void (*reserved140)(void); + void (*reserved141)(void); + void (*reserved142)(void); + void (*reserved143)(void); + void (*reserved144)(void); + void (*reserved145)(void); + void (*reserved146)(void); + void (*reserved147)(void); + void (*reserved148)(void); + void (*reserved149)(void); + void (*reserved150)(void); + void (*reserved151)(void); + void (*reserved152)(void); + void (*reserved153)(void); + void (*reserved154)(void); + void (*reserved155)(void); + void (*reserved156)(void); + void (*reserved157)(void); + void (*tkUnusedStubEntry) (void); /* 158 */ #endif /* WIN */ #ifdef MAC_OSX_TK /* AQUA */ int (*xSetDashes) (Display *display, GC gc, int dash_offset, _Xconst char *dash_list, int n); /* 0 */ @@ -986,7 +1065,7 @@ typedef struct TkIntXlibStubs { void (*reserved103)(void); void (*reserved104)(void); void (*reserved105)(void); - void (*reserved106)(void); + int (*xSetClipRectangles) (Display *display, GC gc, int clip_x_origin, int clip_y_origin, XRectangle rectangles[], int n, int ordering); /* 106 */ int (*xFlush) (Display *display); /* 107 */ int (*xGrabServer) (Display *display); /* 108 */ int (*xUngrabServer) (Display *display); /* 109 */ @@ -1000,7 +1079,7 @@ typedef struct TkIntXlibStubs { void (*reserved117)(void); void (*reserved118)(void); void (*reserved119)(void); - void (*reserved120)(void); + int (*xOffsetRegion) (void *rgn, int dx, int dy); /* 120 */ void (*reserved121)(void); void (*reserved122)(void); void (*reserved123)(void); @@ -1009,7 +1088,7 @@ typedef struct TkIntXlibStubs { void (*reserved126)(void); void (*reserved127)(void); void (*reserved128)(void); - void (*reserved129)(void); + int (*xLowerWindow) (Display *d, Window w); /* 129 */ void (*reserved130)(void); void (*reserved131)(void); void (*reserved132)(void); @@ -1018,6 +1097,27 @@ typedef struct TkIntXlibStubs { void (*reserved135)(void); void (*reserved136)(void); int (*xPutImage) (Display *d, Drawable dr, GC gc, XImage *im, int sx, int sy, int dx, int dy, unsigned int w, unsigned int h); /* 137 */ + void (*reserved138)(void); + void (*reserved139)(void); + void (*reserved140)(void); + void (*reserved141)(void); + void (*reserved142)(void); + void (*reserved143)(void); + void (*xDestroyIC) (XIC xic); /* 144 */ + Cursor (*xCreatePixmapCursor) (Display *d, Pixmap p1, Pixmap p2, XColor *x1, XColor *x2, unsigned int ui1, unsigned int ui2); /* 145 */ + Cursor (*xCreateGlyphCursor) (Display *d, Font f1, Font f2, unsigned int ui1, unsigned int ui2, XColor _Xconst *x1, XColor _Xconst *x2); /* 146 */ + void (*reserved147)(void); + void (*reserved148)(void); + void (*reserved149)(void); + void (*reserved150)(void); + void (*reserved151)(void); + void (*reserved152)(void); + void (*reserved153)(void); + void (*reserved154)(void); + void (*reserved155)(void); + void (*reserved156)(void); + KeySym (*xkbKeycodeToKeysym) (Display *d, unsigned int k, int g, int i); /* 157 */ + void (*tkUnusedStubEntry) (void); /* 158 */ #endif /* AQUA */ } TkIntXlibStubs; @@ -1298,6 +1398,28 @@ extern const TkIntXlibStubs *tkIntXlibStubsPtr; (tkIntXlibStubsPtr->xReparentWindow) /* 136 */ #define XPutImage \ (tkIntXlibStubsPtr->xPutImage) /* 137 */ +/* Slot 138 is reserved */ +/* Slot 139 is reserved */ +/* Slot 140 is reserved */ +/* Slot 141 is reserved */ +/* Slot 142 is reserved */ +/* Slot 143 is reserved */ +/* Slot 144 is reserved */ +/* Slot 145 is reserved */ +/* Slot 146 is reserved */ +/* Slot 147 is reserved */ +/* Slot 148 is reserved */ +/* Slot 149 is reserved */ +/* Slot 150 is reserved */ +/* Slot 151 is reserved */ +/* Slot 152 is reserved */ +/* Slot 153 is reserved */ +/* Slot 154 is reserved */ +/* Slot 155 is reserved */ +/* Slot 156 is reserved */ +/* Slot 157 is reserved */ +#define TkUnusedStubEntry \ + (tkIntXlibStubsPtr->tkUnusedStubEntry) /* 158 */ #endif /* WIN */ #ifdef MAC_OSX_TK /* AQUA */ #define XSetDashes \ @@ -1498,7 +1620,8 @@ extern const TkIntXlibStubs *tkIntXlibStubsPtr; /* Slot 103 is reserved */ /* Slot 104 is reserved */ /* Slot 105 is reserved */ -/* Slot 106 is reserved */ +#define XSetClipRectangles \ + (tkIntXlibStubsPtr->xSetClipRectangles) /* 106 */ #define XFlush \ (tkIntXlibStubsPtr->xFlush) /* 107 */ #define XGrabServer \ @@ -1519,7 +1642,8 @@ extern const TkIntXlibStubs *tkIntXlibStubsPtr; /* Slot 117 is reserved */ /* Slot 118 is reserved */ /* Slot 119 is reserved */ -/* Slot 120 is reserved */ +#define XOffsetRegion \ + (tkIntXlibStubsPtr->xOffsetRegion) /* 120 */ /* Slot 121 is reserved */ /* Slot 122 is reserved */ /* Slot 123 is reserved */ @@ -1528,7 +1652,8 @@ extern const TkIntXlibStubs *tkIntXlibStubsPtr; /* Slot 126 is reserved */ /* Slot 127 is reserved */ /* Slot 128 is reserved */ -/* Slot 129 is reserved */ +#define XLowerWindow \ + (tkIntXlibStubsPtr->xLowerWindow) /* 129 */ /* Slot 130 is reserved */ /* Slot 131 is reserved */ /* Slot 132 is reserved */ @@ -1538,6 +1663,32 @@ extern const TkIntXlibStubs *tkIntXlibStubsPtr; /* Slot 136 is reserved */ #define XPutImage \ (tkIntXlibStubsPtr->xPutImage) /* 137 */ +/* Slot 138 is reserved */ +/* Slot 139 is reserved */ +/* Slot 140 is reserved */ +/* Slot 141 is reserved */ +/* Slot 142 is reserved */ +/* Slot 143 is reserved */ +#define XDestroyIC \ + (tkIntXlibStubsPtr->xDestroyIC) /* 144 */ +#define XCreatePixmapCursor \ + (tkIntXlibStubsPtr->xCreatePixmapCursor) /* 145 */ +#define XCreateGlyphCursor \ + (tkIntXlibStubsPtr->xCreateGlyphCursor) /* 146 */ +/* Slot 147 is reserved */ +/* Slot 148 is reserved */ +/* Slot 149 is reserved */ +/* Slot 150 is reserved */ +/* Slot 151 is reserved */ +/* Slot 152 is reserved */ +/* Slot 153 is reserved */ +/* Slot 154 is reserved */ +/* Slot 155 is reserved */ +/* Slot 156 is reserved */ +#define XkbKeycodeToKeysym \ + (tkIntXlibStubsPtr->xkbKeycodeToKeysym) /* 157 */ +#define TkUnusedStubEntry \ + (tkIntXlibStubsPtr->tkUnusedStubEntry) /* 158 */ #endif /* AQUA */ #endif /* defined(USE_TK_STUBS) */ @@ -1547,4 +1698,6 @@ extern const TkIntXlibStubs *tkIntXlibStubsPtr; #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT +#undef TkUnusedStubEntry + #endif /* _TKINTXLIBDECLS */ diff --git a/amd64/include/tkPlatDecls.h b/amd64/include/tkPlatDecls.h index 1e69c88..bad633f 100644 --- a/amd64/include/tkPlatDecls.h +++ b/amd64/include/tkPlatDecls.h @@ -82,6 +82,17 @@ EXTERN void * TkMacOSXGetRootControl(Drawable drawable); EXTERN void Tk_MacOSXSetupTkNotifier(void); /* 10 */ EXTERN int Tk_MacOSXIsAppInFront(void); +/* 11 */ +EXTERN Tk_Window Tk_MacOSXGetTkWindow(void *w); +/* 12 */ +EXTERN void * Tk_MacOSXGetCGContextForDrawable(Drawable drawable); +/* 13 */ +EXTERN void * Tk_MacOSXGetNSWindowForDrawable(Drawable drawable); +/* Slot 14 is reserved */ +/* Slot 15 is reserved */ +/* 16 */ +EXTERN void TkGenWMConfigureEvent_(Tk_Window tkwin, int x, int y, + int width, int height, int flags); #endif /* AQUA */ typedef struct TkPlatStubs { @@ -108,6 +119,12 @@ typedef struct TkPlatStubs { void * (*tkMacOSXGetRootControl) (Drawable drawable); /* 8 */ void (*tk_MacOSXSetupTkNotifier) (void); /* 9 */ int (*tk_MacOSXIsAppInFront) (void); /* 10 */ + Tk_Window (*tk_MacOSXGetTkWindow) (void *w); /* 11 */ + void * (*tk_MacOSXGetCGContextForDrawable) (Drawable drawable); /* 12 */ + void * (*tk_MacOSXGetNSWindowForDrawable) (Drawable drawable); /* 13 */ + void (*reserved14)(void); + void (*reserved15)(void); + void (*tkGenWMConfigureEvent_) (Tk_Window tkwin, int x, int y, int width, int height, int flags); /* 16 */ #endif /* AQUA */ } TkPlatStubs; @@ -160,6 +177,16 @@ extern const TkPlatStubs *tkPlatStubsPtr; (tkPlatStubsPtr->tk_MacOSXSetupTkNotifier) /* 9 */ #define Tk_MacOSXIsAppInFront \ (tkPlatStubsPtr->tk_MacOSXIsAppInFront) /* 10 */ +#define Tk_MacOSXGetTkWindow \ + (tkPlatStubsPtr->tk_MacOSXGetTkWindow) /* 11 */ +#define Tk_MacOSXGetCGContextForDrawable \ + (tkPlatStubsPtr->tk_MacOSXGetCGContextForDrawable) /* 12 */ +#define Tk_MacOSXGetNSWindowForDrawable \ + (tkPlatStubsPtr->tk_MacOSXGetNSWindowForDrawable) /* 13 */ +/* Slot 14 is reserved */ +/* Slot 15 is reserved */ +#define TkGenWMConfigureEvent_ \ + (tkPlatStubsPtr->tkGenWMConfigureEvent_) /* 16 */ #endif /* AQUA */ #endif /* defined(USE_TK_STUBS) */ @@ -173,4 +200,7 @@ extern const TkPlatStubs *tkPlatStubsPtr; #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT +#undef TkGenWMConfigureEvent_ +#define Tk_MacOSXGetNSViewForDrawable TkMacOSXGetRootControl + #endif /* _TKPLATDECLS */ diff --git a/amd64/lib/dde1.4/pkgIndex.tcl b/amd64/lib/dde1.4/pkgIndex.tcl index f6a479d..1ca9c5a 100644 --- a/amd64/lib/dde1.4/pkgIndex.tcl +++ b/amd64/lib/dde1.4/pkgIndex.tcl @@ -1,7 +1,7 @@ if {![package vsatisfies [package provide Tcl] 8.5]} return if {[info sharedlibextension] != ".dll"} return if {[::tcl::pkgconfig get debug]} { - package ifneeded dde 1.4.2 [list load [file join $dir tcldde14g.dll] dde] + package ifneeded dde 1.4.3 [list load [file join $dir tcldde14g.dll] Dde] } else { - package ifneeded dde 1.4.2 [list load [file join $dir tcldde14.dll] dde] + package ifneeded dde 1.4.3 [list load [file join $dir tcldde14.dll] Dde] } diff --git a/amd64/lib/dde1.4/tcldde14.dll b/amd64/lib/dde1.4/tcldde14.dll index 0ce6618..473e737 100644 Binary files a/amd64/lib/dde1.4/tcldde14.dll and b/amd64/lib/dde1.4/tcldde14.dll differ diff --git a/amd64/lib/nmake/nmakehlp.c b/amd64/lib/nmake/nmakehlp.c index fac32ee..7536ede 100644 --- a/amd64/lib/nmake/nmakehlp.c +++ b/amd64/lib/nmake/nmakehlp.c @@ -708,7 +708,7 @@ QualifyPath( { char szCwd[MAX_PATH + 1]; - GetFullPathName(szPath, sizeof(szCwd)-1, szCwd, NULL); + GetFullPathName(szPath, sizeof(szCwd)-1, szCwd, NULL); printf("%s\n", szCwd); return 0; } diff --git a/amd64/lib/nmake/rules.vc b/amd64/lib/nmake/rules.vc index cf80c91..13e3879 100644 --- a/amd64/lib/nmake/rules.vc +++ b/amd64/lib/nmake/rules.vc @@ -6,7 +6,7 @@ # compiler switches, defining common targets and macros. The Tcl makefile # directly includes this. Extensions include it via "rules-ext.vc". # -# See TIP 477 (https://core.tcl-lang.org/tips/doc/trunk/tip/477.md) for +# See TIP 477 (https://core.tcl-lang.org/tips/doc/main/tip/477.md) for # detailed documentation. # # See the file "license.terms" for information on usage and redistribution @@ -24,7 +24,7 @@ _RULES_VC = 1 # For modifications that are not backward-compatible, you *must* change # the major version. RULES_VERSION_MAJOR = 1 -RULES_VERSION_MINOR = 4 +RULES_VERSION_MINOR = 8 # The PROJECT macro must be defined by parent makefile. !if "$(PROJECT)" == "" @@ -302,7 +302,7 @@ TCLDIR = $(_INSTALLDIR)\.. _TCLDIR = $(_INSTALLDIR)\.. _TCL_H = $(_TCLDIR)\include\tcl.h -!else # exist(...) && ! $(NEED_TCL_SOURCE) +!else # exist(...) && !$(NEED_TCL_SOURCE) !if [echo _TCLDIR = \> nmakehlp.out] \ || [nmakehlp -L generic\tcl.h >> nmakehlp.out] @@ -313,7 +313,7 @@ TCLINSTALL = 0 TCLDIR = $(_TCLDIR) _TCL_H = $(_TCLDIR)\generic\tcl.h -!endif # exist(...) && ! $(NEED_TCL_SOURCE) +!endif # exist(...) && !$(NEED_TCL_SOURCE) !endif # TCLDIR @@ -415,9 +415,6 @@ _INSTALLDIR=$(_INSTALLDIR)\lib # NATIVE_ARCH - set to IX86 or AMD64 for the host machine # MACHINE - same as $(ARCH) - legacy # _VC_MANIFEST_EMBED_{DLL,EXE} - commands for embedding a manifest if needed -# CFG_ENCODING - set to an character encoding. -# TBD - this is passed to compiler as TCL_CFGVAL_ENCODING but can't -# see where it is used cc32 = $(CC) # built-in default. link32 = link @@ -503,10 +500,6 @@ _VC_MANIFEST_EMBED_EXE=if exist $@.manifest mt -nologo -manifest $@.manifest -ou _VC_MANIFEST_EMBED_DLL=if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2 !endif -!ifndef CFG_ENCODING -CFG_ENCODING = \"cp1252\" -!endif - ################################################################ # 4. Build the nmakehlp program # This is a helper app we need to overcome nmake's limiting @@ -514,7 +507,7 @@ CFG_ENCODING = \"cp1252\" # information about supported compiler options etc. # # Tcl itself will always use the nmakehlp.c program which is -# in its own source. This is the "master" copy and kept updated. +# in its own source. It will be kept updated there. # # Extensions built against an installed Tcl will use the installed # copy of Tcl's nmakehlp.c if there is one and their own version @@ -537,7 +530,7 @@ NMAKEHLPC = nmakehlp.c !if exist("$(_TCLDIR)\lib\nmake\nmakehlp.c") NMAKEHLPC = $(_TCLDIR)\lib\nmake\nmakehlp.c !endif -!else # ! $(TCLINSTALL) +!else # !$(TCLINSTALL) !if exist("$(_TCLDIR)\win\nmakehlp.c") NMAKEHLPC = $(_TCLDIR)\win\nmakehlp.c !endif @@ -659,8 +652,130 @@ LINKERFLAGS = $(LINKERFLAGS) -ltcg !endif !endif + +################################################################ +# 6. Extract various version numbers from headers +# For Tcl and Tk, version numbers are extracted from tcl.h and tk.h +# respectively. For extensions, versions are extracted from the +# configure.in or configure.ac from the TEA configuration if it +# exists, and unset otherwise. +# Sets the following macros: +# TCL_MAJOR_VERSION +# TCL_MINOR_VERSION +# TCL_RELEASE_SERIAL +# TCL_PATCH_LEVEL +# TCL_PATCH_LETTER +# TCL_VERSION +# TK_MAJOR_VERSION +# TK_MINOR_VERSION +# TK_RELEASE_SERIAL +# TK_PATCH_LEVEL +# TK_PATCH_LETTER +# TK_VERSION +# DOTVERSION - set as (for example) 2.5 +# VERSION - set as (for example 25) +#-------------------------------------------------------------- + +!if [echo REM = This file is generated from rules.vc > versions.vc] +!endif +!if [echo TCL_MAJOR_VERSION = \>> versions.vc] \ + && [nmakehlp -V "$(_TCL_H)" TCL_MAJOR_VERSION >> versions.vc] +!endif +!if [echo TCL_MINOR_VERSION = \>> versions.vc] \ + && [nmakehlp -V "$(_TCL_H)" TCL_MINOR_VERSION >> versions.vc] +!endif +!if [echo TCL_RELEASE_SERIAL = \>> versions.vc] \ + && [nmakehlp -V "$(_TCL_H)" TCL_RELEASE_SERIAL >> versions.vc] +!endif +!if [echo TCL_PATCH_LEVEL = \>> versions.vc] \ + && [nmakehlp -V "$(_TCL_H)" TCL_PATCH_LEVEL >> versions.vc] +!endif + +!if defined(_TK_H) +!if [echo TK_MAJOR_VERSION = \>> versions.vc] \ + && [nmakehlp -V $(_TK_H) TK_MAJOR_VERSION >> versions.vc] +!endif +!if [echo TK_MINOR_VERSION = \>> versions.vc] \ + && [nmakehlp -V $(_TK_H) TK_MINOR_VERSION >> versions.vc] +!endif +!if [echo TK_RELEASE_SERIAL = \>> versions.vc] \ + && [nmakehlp -V "$(_TK_H)" TK_RELEASE_SERIAL >> versions.vc] +!endif +!if [echo TK_PATCH_LEVEL = \>> versions.vc] \ + && [nmakehlp -V $(_TK_H) TK_PATCH_LEVEL >> versions.vc] +!endif +!endif # _TK_H + +!include versions.vc + +TCL_VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION) +TCL_DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) +!if [nmakehlp -f $(TCL_PATCH_LEVEL) "a"] +TCL_PATCH_LETTER = a +!elseif [nmakehlp -f $(TCL_PATCH_LEVEL) "b"] +TCL_PATCH_LETTER = b +!else +TCL_PATCH_LETTER = . +!endif + +!if defined(_TK_H) + +TK_VERSION = $(TK_MAJOR_VERSION)$(TK_MINOR_VERSION) +TK_DOTVERSION = $(TK_MAJOR_VERSION).$(TK_MINOR_VERSION) +!if [nmakehlp -f $(TK_PATCH_LEVEL) "a"] +TK_PATCH_LETTER = a +!elseif [nmakehlp -f $(TK_PATCH_LEVEL) "b"] +TK_PATCH_LETTER = b +!else +TK_PATCH_LETTER = . +!endif + +!endif + +# Set DOTVERSION and VERSION +!if $(DOING_TCL) + +DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) +VERSION = $(TCL_VERSION) + +!elseif $(DOING_TK) + +DOTVERSION = $(TK_DOTVERSION) +VERSION = $(TK_VERSION) + +!else # Doing a non-Tk extension + +# If parent makefile has not defined DOTVERSION, try to get it from TEA +# first from a configure.in file, and then from configure.ac +!ifndef DOTVERSION +!if [echo DOTVERSION = \> versions.vc] \ + || [nmakehlp -V $(ROOT)\configure.in ^[$(PROJECT)^] >> versions.vc] +!if [echo DOTVERSION = \> versions.vc] \ + || [nmakehlp -V $(ROOT)\configure.ac ^[$(PROJECT)^] >> versions.vc] +!error *** Could not figure out extension version. Please define DOTVERSION in parent makefile before including rules.vc. +!endif +!endif +!include versions.vc +!endif # DOTVERSION +VERSION = $(DOTVERSION:.=) + +!endif # $(DOING_TCL) ... etc. + +# Windows RC files have 3 version components. Ensure this irrespective +# of how many components the package has specified. Basically, ensure +# minimum 4 components by appending 4 0's and then pick out the first 4. +# Also take care of the fact that DOTVERSION may have "a" or "b" instead +# of "." separating the version components. +DOTSEPARATED=$(DOTVERSION:a=.) +DOTSEPARATED=$(DOTSEPARATED:b=.) +!if [echo RCCOMMAVERSION = \> versions.vc] \ + || [for /f "tokens=1,2,3,4,5* delims=." %a in ("$(DOTSEPARATED).0.0.0.0") do echo %a,%b,%c,%d >> versions.vc] +!error *** Could not generate RCCOMMAVERSION *** +!endif +!include versions.vc + ######################################################################## -# 6. Parse the OPTS macro to work out the requested build configuration. +# 7. Parse the OPTS macro to work out the requested build configuration. # Based on this, we will construct the actual switches to be passed to the # compiler and linker using the macros defined in the previous section. # The following macros are defined by this section based on OPTS @@ -674,9 +789,10 @@ LINKERFLAGS = $(LINKERFLAGS) -ltcg # MSVCRT - 1 -> link to dynamic C runtime even when building static Tcl build # 0 -> link to static C runtime for static Tcl build. # Does not impact shared Tcl builds (STATIC_BUILD == 0) +# Default: 1 for Tcl 8.7 and up, 0 otherwise. # TCL_USE_STATIC_PACKAGES - 1 -> statically link the registry and dde extensions -# in the Tcl shell. 0 -> keep them as shared libraries -# Does not impact shared Tcl builds. +# in the Tcl and Wish shell. 0 -> keep them as shared libraries. Does +# not impact shared Tcl builds. Implied by STATIC_BUILD since Tcl 8.7. # USE_THREAD_ALLOC - 1 -> Use a shared global free pool for allocation. # 0 -> Use the non-thread allocator. # UNCHECKED - 1 -> when doing a debug build with symbols, use the release @@ -685,7 +801,9 @@ LINKERFLAGS = $(LINKERFLAGS) -ltcg # CONFIG_CHECK - 1 -> check current build configuration against Tcl # configuration (ignored for Tcl itself) # _USE_64BIT_TIME_T - forces a build using 64-bit time_t for 32-bit build -# (CRT library should support this) +# (CRT library should support this, not needed for Tcl 9.x) +# TCL_UTF_MAX=4 - forces a build allowing 4-byte UTF-8 sequences internally. +# (Not needed for Tcl 9.x) # Further, LINKERFLAGS are modified based on above. # Default values for all the above @@ -728,11 +846,8 @@ MSVCRT = 0 !else !if [nmakehlp -f $(OPTS) "msvcrt"] !message *** Doing msvcrt -MSVCRT = 1 -!else -!if !$(STATIC_BUILD) -MSVCRT = 1 !else +!if $(TCL_MAJOR_VERSION) == 8 && $(TCL_MINOR_VERSION) < 7 && $(STATIC_BUILD) MSVCRT = 0 !endif !endif @@ -741,24 +856,26 @@ MSVCRT = 0 !if [nmakehlp -f $(OPTS) "staticpkg"] && $(STATIC_BUILD) !message *** Doing staticpkg TCL_USE_STATIC_PACKAGES = 1 -!else -TCL_USE_STATIC_PACKAGES = 0 !endif !if [nmakehlp -f $(OPTS) "nothreads"] !message *** Compile explicitly for non-threaded tcl TCL_THREADS = 0 USE_THREAD_ALLOC= 0 -!else -TCL_THREADS = 1 -USE_THREAD_ALLOC= 1 !endif +!if $(TCL_MAJOR_VERSION) == 8 !if [nmakehlp -f $(OPTS) "time64bit"] !message *** Force 64-bit time_t _USE_64BIT_TIME_T = 1 !endif +!if [nmakehlp -f $(OPTS) "utfmax"] +!message *** Force allowing 4-byte UTF-8 sequences internally +TCL_UTF_MAX = 4 +!endif +!endif + # Yes, it's weird that the "symbols" option controls DEBUG and # the "pdbs" option controls SYMBOLS. That's historical. !if [nmakehlp -f $(OPTS) "symbols"] @@ -842,7 +959,7 @@ This compiler does not support profile guided optimization. !endif ################################################################ -# 7. Parse the STATS macro to configure code instrumentation +# 8. Parse the STATS macro to configure code instrumentation # The following macros are set by this section: # TCL_MEM_DEBUG - 1 -> enables memory allocation instrumentation # 0 -> disables @@ -872,7 +989,7 @@ TCL_COMPILE_DEBUG = 0 !endif #################################################################### -# 8. Parse the CHECKS macro to configure additional compiler checks +# 9. Parse the CHECKS macro to configure additional compiler checks # The following macros are set by this section: # WARNINGS - compiler switches that control the warnings level # TCL_NO_DEPRECATED - 1 -> disable support for deprecated functions @@ -904,86 +1021,6 @@ WARNINGS = $(WARNINGS) -Wp64 !endif -################################################################ -# 9. Extract various version numbers -# For Tcl and Tk, version numbers are extracted from tcl.h and tk.h -# respectively. For extensions, versions are extracted from the -# configure.in or configure.ac from the TEA configuration if it -# exists, and unset otherwise. -# Sets the following macros: -# TCL_MAJOR_VERSION -# TCL_MINOR_VERSION -# TCL_PATCH_LEVEL -# TCL_VERSION -# TK_MAJOR_VERSION -# TK_MINOR_VERSION -# TK_PATCH_LEVEL -# TK_VERSION -# DOTVERSION - set as (for example) 2.5 -# VERSION - set as (for example 25) -#-------------------------------------------------------------- - -!if [echo REM = This file is generated from rules.vc > versions.vc] -!endif -!if [echo TCL_MAJOR_VERSION = \>> versions.vc] \ - && [nmakehlp -V "$(_TCL_H)" TCL_MAJOR_VERSION >> versions.vc] -!endif -!if [echo TCL_MINOR_VERSION = \>> versions.vc] \ - && [nmakehlp -V "$(_TCL_H)" TCL_MINOR_VERSION >> versions.vc] -!endif -!if [echo TCL_PATCH_LEVEL = \>> versions.vc] \ - && [nmakehlp -V "$(_TCL_H)" TCL_PATCH_LEVEL >> versions.vc] -!endif - -!if defined(_TK_H) -!if [echo TK_MAJOR_VERSION = \>> versions.vc] \ - && [nmakehlp -V $(_TK_H) TK_MAJOR_VERSION >> versions.vc] -!endif -!if [echo TK_MINOR_VERSION = \>> versions.vc] \ - && [nmakehlp -V $(_TK_H) TK_MINOR_VERSION >> versions.vc] -!endif -!if [echo TK_PATCH_LEVEL = \>> versions.vc] \ - && [nmakehlp -V $(_TK_H) TK_PATCH_LEVEL >> versions.vc] -!endif -!endif # _TK_H - -!include versions.vc - -TCL_VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION) -TCL_DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) -!if defined(_TK_H) -TK_VERSION = $(TK_MAJOR_VERSION)$(TK_MINOR_VERSION) -TK_DOTVERSION = $(TK_MAJOR_VERSION).$(TK_MINOR_VERSION) -!endif - -# Set DOTVERSION and VERSION -!if $(DOING_TCL) - -DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) -VERSION = $(TCL_VERSION) - -!elseif $(DOING_TK) - -DOTVERSION = $(TK_DOTVERSION) -VERSION = $(TK_VERSION) - -!else # Doing a non-Tk extension - -# If parent makefile has not defined DOTVERSION, try to get it from TEA -# first from a configure.in file, and then from configure.ac -!ifndef DOTVERSION -!if [echo DOTVERSION = \> versions.vc] \ - || [nmakehlp -V $(ROOT)\configure.in ^[$(PROJECT)^] >> versions.vc] -!if [echo DOTVERSION = \> versions.vc] \ - || [nmakehlp -V $(ROOT)\configure.ac ^[$(PROJECT)^] >> versions.vc] -!error *** Could not figure out extension version. Please define DOTVERSION in parent makefile before including rules.vc. -!endif -!endif -!include versions.vc -!endif # DOTVERSION -VERSION = $(DOTVERSION:.=) - -!endif # $(DOING_TCL) ... etc. ################################################################ # 10. Construct output directory and file paths @@ -1029,7 +1066,7 @@ BUILDDIRTOP =$(BUILDDIRTOP)_$(MACHINE) BUILDDIRTOP =$(BUILDDIRTOP)_VC$(VCVER) !endif -!if !$(DEBUG) || $(DEBUG) && $(UNCHECKED) +!if !$(DEBUG) || $(TCL_VERSION) > 86 || $(DEBUG) && $(UNCHECKED) SUFX = $(SUFX:g=) !endif @@ -1080,20 +1117,35 @@ OUT_DIR = $(TMP_DIR) # The name of the stubs library for the project being built STUBPREFIX = $(PROJECT)stub +# # Set up paths to various Tcl executables and libraries needed by extensions -!if $(DOING_TCL) +# +# TIP 430. Unused for 8.6 but no harm defining it to allow a common rules.vc +!if "$(TCL_PATCH_LETTER)" == "." +TCLSCRIPTZIPNAME = libtcl_$(TCL_MAJOR_VERSION)_$(TCL_MINOR_VERSION)_$(TCL_RELEASE_SERIAL).zip +!else +TCLSCRIPTZIPNAME = libtcl_$(TCL_MAJOR_VERSION)_$(TCL_MINOR_VERSION)_$(TCL_PATCH_LETTER)$(TCL_RELEASE_SERIAL).zip +!endif +!if "$(TK_PATCH_LETTER)" == "." +TKSCRIPTZIPNAME = libtk_$(TK_MAJOR_VERSION)_$(TK_MINOR_VERSION)_$(TK_RELEASE_SERIAL).zip +!else +TKSCRIPTZIPNAME = libtk_$(TK_MAJOR_VERSION)_$(TK_MINOR_VERSION)_$(TK_PATCH_LETTER)$(TK_RELEASE_SERIAL).zip +!endif + +!if $(DOING_TCL) TCLSHNAME = $(PROJECT)sh$(VERSION)$(SUFX).exe TCLSH = $(OUT_DIR)\$(TCLSHNAME) TCLIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib TCLLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT) TCLLIB = $(OUT_DIR)\$(TCLLIBNAME) +TCLSCRIPTZIP = $(OUT_DIR)\$(TCLSCRIPTZIPNAME) TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib TCLSTUBLIB = $(OUT_DIR)\$(TCLSTUBLIBNAME) TCL_INCLUDES = -I"$(WIN_DIR)" -I"$(GENERICDIR)" -!else # ! $(DOING_TCL) +!else # !$(DOING_TCL) !if $(TCLINSTALL) # Building against an installed Tcl @@ -1115,6 +1167,7 @@ TCLIMPLIB = $(_TCLDIR)\lib\tcl$(TCL_VERSION)t$(SUFX:t=).lib TCL_LIBRARY = $(_TCLDIR)\lib TCLREGLIB = $(_TCLDIR)\lib\tclreg13$(SUFX:t=).lib TCLDDELIB = $(_TCLDIR)\lib\tcldde14$(SUFX:t=).lib +TCLSCRIPTZIP = $(_TCLDIR)\lib\$(TCLSCRIPTZIPNAME) TCLTOOLSDIR = \must\have\tcl\sources\to\build\this\target TCL_INCLUDES = -I"$(_TCLDIR)\include" @@ -1134,6 +1187,7 @@ TCLIMPLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)t$(SUFX:t=).lib TCL_LIBRARY = $(_TCLDIR)\library TCLREGLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclreg13$(SUFX:t=).lib TCLDDELIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde14$(SUFX:t=).lib +TCLSCRIPTZIP = $(_TCLDIR)\win\$(BUILDDIRTOP)\$(TCLSCRIPTZIPNAME) TCLTOOLSDIR = $(_TCLDIR)\tools TCL_INCLUDES = -I"$(_TCLDIR)\generic" -I"$(_TCLDIR)\win" @@ -1166,7 +1220,8 @@ WISH = $(OUT_DIR)\$(WISHNAME) TKSTUBLIB = $(OUT_DIR)\$(TKSTUBLIBNAME) TKIMPLIB = $(OUT_DIR)\$(TKIMPLIBNAME) TKLIB = $(OUT_DIR)\$(TKLIBNAME) -TK_INCLUDES = -I"$(WIN_DIR)" -I"$(GENERICDIR)" +TK_INCLUDES = -I"$(WIN_DIR)" -I"$(GENERICDIR)" +TKSCRIPTZIP = $(OUT_DIR)\$(TKSCRIPTZIPNAME) !else # effectively NEED_TK @@ -1181,7 +1236,10 @@ TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX:t=).lib TKIMPLIB = $(_TKDIR)\lib\$(TKIMPLIBNAME) !endif TK_INCLUDES = -I"$(_TKDIR)\include" +TKSCRIPTZIP = $(_TKDIR)\lib\$(TKSCRIPTZIPNAME) + !else # Building against Tk sources + WISH = $(_TKDIR)\win\$(BUILDDIRTOP)\$(WISHNAME) TKSTUBLIB = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TKSTUBLIBNAME) TKIMPLIB = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TKIMPLIBNAME) @@ -1192,7 +1250,10 @@ TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX:t=).lib TKIMPLIB = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TKIMPLIBNAME) !endif TK_INCLUDES = -I"$(_TKDIR)\generic" -I"$(_TKDIR)\win" -I"$(_TKDIR)\xlib" +TKSCRIPTZIP = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TKSCRIPTZIPNAME) + !endif # TKINSTALL + tklibs = "$(TKSTUBLIB)" "$(TKIMPLIB)" !endif # $(DOING_TK) @@ -1233,6 +1294,7 @@ BIN_INSTALL_DIR = $(_INSTALLDIR)\bin DOC_INSTALL_DIR = $(_INSTALLDIR)\doc !if $(DOING_TCL) SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\$(PROJECT)$(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) +MODULE_INSTALL_DIR = $(_INSTALLDIR)\lib\tcl$(TCL_MAJOR_VERSION) !else # DOING_TK SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\$(PROJECT)$(TK_MAJOR_VERSION).$(TK_MINOR_VERSION) !endif @@ -1277,7 +1339,15 @@ INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\..\include # baselibs - minimum Windows libraries required. Parent makefile can # define PRJ_LIBS before including rules.rc if additional libs are needed -OPTDEFINES = /DTCL_CFGVAL_ENCODING=$(CFG_ENCODING) /DSTDC_HEADERS +OPTDEFINES = /DSTDC_HEADERS +!if $(VCVERSION) > 1600 +OPTDEFINES = $(OPTDEFINES) /DHAVE_STDINT_H=1 +!else +OPTDEFINES = $(OPTDEFINES) /DMP_NO_STDINT=1 +!endif +!if $(VCVERSION) >= 1800 +OPTDEFINES = $(OPTDEFINES) /DHAVE_INTTYPES_H=1 /DHAVE_STDBOOL_H=1 +!endif !if $(TCL_MEM_DEBUG) OPTDEFINES = $(OPTDEFINES) /DTCL_MEM_DEBUG @@ -1293,6 +1363,11 @@ OPTDEFINES = $(OPTDEFINES) /DUSE_THREAD_ALLOC=1 !endif !if $(STATIC_BUILD) OPTDEFINES = $(OPTDEFINES) /DSTATIC_BUILD +!elseif $(TCL_VERSION) > 86 +OPTDEFINES = $(OPTDEFINES) /DTCL_WITH_EXTERNAL_TOMMATH +!if "$(MACHINE)" == "AMD64" +OPTDEFINES = $(OPTDEFINES) /DMP_64BIT +!endif !endif !if $(TCL_NO_DEPRECATED) OPTDEFINES = $(OPTDEFINES) /DTCL_NO_DEPRECATED @@ -1301,7 +1376,7 @@ OPTDEFINES = $(OPTDEFINES) /DTCL_NO_DEPRECATED !if $(USE_STUBS) # Note we do not define USE_TCL_STUBS even when building tk since some # test targets in tk do not use stubs -!if ! $(DOING_TCL) +!if !$(DOING_TCL) USE_STUBS_DEFS = /DUSE_TCL_STUBS /DUSE_TCLOO_STUBS !if $(NEED_TK) USE_STUBS_DEFS = $(USE_STUBS_DEFS) /DUSE_TK_STUBS @@ -1322,15 +1397,20 @@ OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_PROFILED OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_DO64BIT !endif !if $(VCVERSION) < 1300 -OPTDEFINES = $(OPTDEFINES) /DNO_STRTOI64 +OPTDEFINES = $(OPTDEFINES) /DNO_STRTOI64=1 !endif +!if "$(TCL_MAJOR_VERSION)" == "8" !if "$(_USE_64BIT_TIME_T)" == "1" -OPTDEFINES = $(OPTDEFINES) /D_USE_64BIT_TIME_T +OPTDEFINES = $(OPTDEFINES) /D_USE_64BIT_TIME_T=1 +!endif +!if "$(TCL_UTF_MAX)" == "4" +OPTDEFINES = $(OPTDEFINES) /DTCL_UTF_MAX=4 !endif # _ATL_XP_TARGETING - Newer SDK's need this to build for XP COMPILERFLAGS = /D_ATL_XP_TARGETING +!endif # Like the TEA system only set this non empty for non-Tk extensions # Note: some extensions use PACKAGE_NAME and others use PACKAGE_TCLNAME @@ -1455,18 +1535,6 @@ lflags = -nologo -machine:$(MACHINE) $(LINKERFLAGS) $(ldebug) lflags = $(lflags) -nodefaultlib:libucrt.lib !endif -# Old linkers (Visual C++ 6 in particular) will link for fast loading -# on Win98. Since we do not support Win98 any more, we specify nowin98 -# as recommended for NT and later. However, this is only required by -# IX86 on older compilers and only needed if we are not doing a static build. - -!if "$(MACHINE)" == "IX86" && !$(STATIC_BUILD) -!if [nmakehlp -l -opt:nowin98 $(LINKER_TESTFLAGS)] -# Align sections for PE size savings. -lflags = $(lflags) -opt:nowin98 -!endif -!endif - dlllflags = $(lflags) -dll conlflags = $(lflags) -subsystem:console guilflags = $(lflags) -subsystem:windows @@ -1508,7 +1576,7 @@ GUIEXECMD = $(link32) $(guilflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) RESCMD = $(rc32) -fo $@ -r -i "$(GENERICDIR)" -i "$(TMP_DIR)" \ $(TCL_INCLUDES) \ /DDEBUG=$(DEBUG) -d UNCHECKED=$(UNCHECKED) \ - /DCOMMAVERSION=$(DOTVERSION:.=,),0 \ + /DCOMMAVERSION=$(RCCOMMAVERSION) \ /DDOTVERSION=\"$(DOTVERSION)\" \ /DVERSION=\"$(VERSION)\" \ /DSUFX=\"$(SUFX)\" \ @@ -1524,11 +1592,11 @@ default-target: $(DEFAULT_BUILD_TARGET) !if $(MULTIPLATFORM_INSTALL) default-pkgindex: @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \ - [list load [file join $$dir $(PLATFORM_IDENTIFY) $(PRJLIBNAME)]] > $(OUT_DIR)\pkgIndex.tcl + [list load [file join $$dir $(PLATFORM_IDENTIFY) $(PRJLIBNAME)] [string totitle $(PRJ_PACKAGE_TCLNAME)]] > $(OUT_DIR)\pkgIndex.tcl !else default-pkgindex: @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \ - [list load [file join $$dir $(PRJLIBNAME)]] > $(OUT_DIR)\pkgIndex.tcl + [list load [file join $$dir $(PRJLIBNAME)] [string totitle $(PRJ_PACKAGE_TCLNAME)]] > $(OUT_DIR)\pkgIndex.tcl !endif default-pkgindex-tea: @@ -1574,6 +1642,8 @@ default-install-pdbs: @if not exist "$(LIB_INSTALL_DIR)" mkdir "$(LIB_INSTALL_DIR)" @$(CPY) "$(OUT_DIR)\*.pdb" "$(LIB_INSTALL_DIR)\" +# "emacs font-lock highlighting fix + default-install-docs-html: @echo Installing documentation files to '$(DOC_INSTALL_DIR)' @if not exist "$(DOC_INSTALL_DIR)" mkdir "$(DOC_INSTALL_DIR)" @@ -1636,7 +1706,7 @@ default-shell: default-setup $(PROJECT) !ifdef RCFILE # Note: don't use $** in below rule because there may be other dependencies -# and only the "master" rc must be passed to the resource compiler +# and only the "main" rc must be passed to the resource compiler $(TMP_DIR)\$(PROJECT).res: $(RCDIR)\$(PROJECT).rc $(RESCMD) $(RCDIR)\$(PROJECT).rc @@ -1690,7 +1760,7 @@ DISABLE_IMPLICIT_RULES = 0 !if !$(DISABLE_IMPLICIT_RULES) # Implicit rule definitions - only for building library objects. For stubs and -# main application, the master makefile should define explicit rules. +# main application, the makefile should define explicit rules. {$(ROOT)}.c{$(TMP_DIR)}.obj:: $(CCPKGCMD) @<< @@ -1731,15 +1801,15 @@ $< # When building an extension, certain configuration options should # match the ones used when Tcl was built. Here we check and # warn on a mismatch. -!if ! $(DOING_TCL) +!if !$(DOING_TCL) !if $(TCLINSTALL) # Building against an installed Tcl !if exist("$(_TCLDIR)\lib\nmake\tcl.nmake") TCLNMAKECONFIG = "$(_TCLDIR)\lib\nmake\tcl.nmake" !endif -!else # ! $(TCLINSTALL) - building against Tcl source -!if exist("$(OUT_DIR)\tcl.nmake") -TCLNMAKECONFIG = "$(OUT_DIR)\tcl.nmake" +!else # !$(TCLINSTALL) - building against Tcl source +!if exist("$(_TCLDIR)\win\$(BUILDDIRTOP)\tcl.nmake") +TCLNMAKECONFIG = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcl.nmake" !endif !endif # TCLINSTALL @@ -1760,7 +1830,7 @@ TCLNMAKECONFIG = "$(OUT_DIR)\tcl.nmake" !endif # TCLNMAKECONFIG -!endif # ! $(DOING_TCL) +!endif # !$(DOING_TCL) #---------------------------------------------------------- diff --git a/amd64/lib/nmake/targets.vc b/amd64/lib/nmake/targets.vc index 6bfebc7..077e8f7 100644 --- a/amd64/lib/nmake/targets.vc +++ b/amd64/lib/nmake/targets.vc @@ -4,7 +4,7 @@ # Part of the nmake based build system for Tcl and its extensions. # This file defines some standard targets for the convenience of extensions # and can be optionally included by the extension makefile. -# See TIP 477 (https://core.tcl-lang.org/tips/doc/trunk/tip/477.md) for docs. +# See TIP 477 (https://core.tcl-lang.org/tips/doc/main/tip/477.md) for docs. $(PROJECT): setup pkgindex $(PRJLIB) diff --git a/amd64/lib/reg1.3/pkgIndex.tcl b/amd64/lib/reg1.3/pkgIndex.tcl index 219e41f..6603e3e 100644 --- a/amd64/lib/reg1.3/pkgIndex.tcl +++ b/amd64/lib/reg1.3/pkgIndex.tcl @@ -1,9 +1,9 @@ if {![package vsatisfies [package provide Tcl] 8.5]} return if {[info sharedlibextension] != ".dll"} return if {[::tcl::pkgconfig get debug]} { - package ifneeded registry 1.3.4 \ - [list load [file join $dir tclreg13g.dll] registry] + package ifneeded registry 1.3.5 \ + [list load [file join $dir tclreg13g.dll] Registry] } else { - package ifneeded registry 1.3.4 \ - [list load [file join $dir tclreg13.dll] registry] + package ifneeded registry 1.3.5 \ + [list load [file join $dir tclreg13.dll] Registry] } diff --git a/amd64/lib/reg1.3/tclreg13.dll b/amd64/lib/reg1.3/tclreg13.dll index 490c560..4cbbf82 100644 Binary files a/amd64/lib/reg1.3/tclreg13.dll and b/amd64/lib/reg1.3/tclreg13.dll differ diff --git a/amd64/lib/tcl8.6/auto.tcl b/amd64/lib/tcl8.6/auto.tcl index a7a8979..64c5bc7 100644 --- a/amd64/lib/tcl8.6/auto.tcl +++ b/amd64/lib/tcl8.6/auto.tcl @@ -240,6 +240,7 @@ proc auto_mkindex_old {dir args} { set f "" set error [catch { set f [open $file] + fconfigure $f -eofchar \032 while {[gets $f line] >= 0} { if {[regexp {^proc[ ]+([^ ]*)} $line match procName]} { set procName [lindex [auto_qualify $procName "::"] 0] @@ -350,6 +351,7 @@ proc auto_mkindex_parser::mkindex {file} { set scriptFile $file set fid [open $file] + fconfigure $fid -eofchar \032 set contents [read $fid] close $fid @@ -376,10 +378,10 @@ proc auto_mkindex_parser::mkindex {file} { # auto_mkindex_parser::hook command # -# Registers a Tcl command to evaluate when initializing the slave interpreter -# used by the mkindex parser. The command is evaluated in the master +# Registers a Tcl command to evaluate when initializing the child interpreter +# used by the mkindex parser. The command is evaluated in the parent # interpreter, and can use the variable auto_mkindex_parser::parser to get to -# the slave +# the child proc auto_mkindex_parser::hook {cmd} { variable initCommands @@ -389,14 +391,14 @@ proc auto_mkindex_parser::hook {cmd} { # auto_mkindex_parser::slavehook command # -# Registers a Tcl command to evaluate when initializing the slave interpreter -# used by the mkindex parser. The command is evaluated in the slave +# Registers a Tcl command to evaluate when initializing the child interpreter +# used by the mkindex parser. The command is evaluated in the child # interpreter. proc auto_mkindex_parser::slavehook {cmd} { variable initCommands - # The $parser variable is defined to be the name of the slave interpreter + # The $parser variable is defined to be the name of the child interpreter # when this command is used later. lappend initCommands "\$parser eval [list $cmd]" @@ -550,7 +552,7 @@ auto_mkindex_parser::command proc {name args} { # Conditionally add support for Tcl byte code files. There are some tricky # details here. First, we need to get the tbcload library initialized in the -# current interpreter. We cannot load tbcload into the slave until we have +# current interpreter. We cannot load tbcload into the child until we have # done so because it needs access to the tcl_patchLevel variable. Second, # because the package index file may defer loading the library until we invoke # a command, we need to explicitly invoke auto_load to force it to be loaded. diff --git a/amd64/lib/tcl8.6/clock.tcl b/amd64/lib/tcl8.6/clock.tcl index 8e4b657..273b534 100644 --- a/amd64/lib/tcl8.6/clock.tcl +++ b/amd64/lib/tcl8.6/clock.tcl @@ -9,7 +9,7 @@ # #---------------------------------------------------------------------- # -# Copyright (c) 2004,2005,2006,2007 by Kevin B. Kenny +# Copyright (c) 2004-2007 Kevin B. Kenny # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # @@ -3304,7 +3304,7 @@ proc ::tcl::clock::LoadTimeZoneFile { fileName } { return } - # Since an unsafe interp uses the [clock] command in the master, this code + # Since an unsafe interp uses the [clock] command in the parent, this code # is security sensitive. Make sure that the path name cannot escape the # given directory. @@ -3344,7 +3344,7 @@ proc ::tcl::clock::LoadTimeZoneFile { fileName } { proc ::tcl::clock::LoadZoneinfoFile { fileName } { variable ZoneinfoPaths - # Since an unsafe interp uses the [clock] command in the master, this code + # Since an unsafe interp uses the [clock] command in the parent, this code # is security sensitive. Make sure that the path name cannot escape the # given directory. @@ -3452,7 +3452,7 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { set times [linsert $times 0 $MINWIDE] set codes {} foreach c $tempCodes { - lappend codes [expr { $c & 0xff }] + lappend codes [expr { $c & 0xFF }] } set codes [linsert $codes 0 0] diff --git a/amd64/lib/tcl8.6/encoding/tis-620.enc b/amd64/lib/tcl8.6/encoding/tis-620.enc index c233be5..2e9142a 100644 --- a/amd64/lib/tcl8.6/encoding/tis-620.enc +++ b/amd64/lib/tcl8.6/encoding/tis-620.enc @@ -17,4 +17,4 @@ S 0E200E210E220E230E240E250E260E270E280E290E2A0E2B0E2C0E2D0E2E0E2F 0E300E310E320E330E340E350E360E370E380E390E3A00000000000000000E3F 0E400E410E420E430E440E450E460E470E480E490E4A0E4B0E4C0E4D0E4E0E4F -0E500E510E520E530E540E550E560E570E580E590E5A0E5B0000000000000000 \ No newline at end of file +0E500E510E520E530E540E550E560E570E580E590E5A0E5B0000000000000000 diff --git a/amd64/lib/tcl8.6/init.tcl b/amd64/lib/tcl8.6/init.tcl index 5cda0d9..1bfca4c 100644 --- a/amd64/lib/tcl8.6/init.tcl +++ b/amd64/lib/tcl8.6/init.tcl @@ -6,7 +6,7 @@ # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 Scriptics Corporation. -# Copyright (c) 2004 by Kevin B. Kenny. All rights reserved. +# Copyright (c) 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. @@ -16,7 +16,7 @@ if {[info commands package] == ""} { error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" } -package require -exact Tcl 8.6.10 +package require -exact Tcl 8.6.11 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: @@ -37,41 +37,46 @@ package require -exact Tcl 8.6.10 # tcl_pkgPath, which is set by the platform-specific initialization routines # On UNIX it is compiled in # On Windows, it is not used +# +# (Ticket 41c9857bdd) In a safe interpreter, this file does not set +# ::auto_path (other than to {} if it is undefined). The caller, typically +# a Safe Base command, is responsible for setting ::auto_path. if {![info exists auto_path]} { - if {[info exists env(TCLLIBPATH)]} { + if {[info exists env(TCLLIBPATH)] && (![interp issafe])} { set auto_path $env(TCLLIBPATH) } else { set auto_path "" } } namespace eval tcl { - variable Dir - foreach Dir [list $::tcl_library [file dirname $::tcl_library]] { - if {$Dir ni $::auto_path} { - lappend ::auto_path $Dir - } - } - set Dir [file join [file dirname [file dirname \ - [info nameofexecutable]]] lib] - if {$Dir ni $::auto_path} { - lappend ::auto_path $Dir - } - catch { - foreach Dir $::tcl_pkgPath { + if {![interp issafe]} { + variable Dir + foreach Dir [list $::tcl_library [file dirname $::tcl_library]] { if {$Dir ni $::auto_path} { lappend ::auto_path $Dir } } - } + set Dir [file join [file dirname [file dirname \ + [info nameofexecutable]]] lib] + if {$Dir ni $::auto_path} { + lappend ::auto_path $Dir + } + if {[info exists ::tcl_pkgPath]} { catch { + foreach Dir $::tcl_pkgPath { + if {$Dir ni $::auto_path} { + lappend ::auto_path $Dir + } + } + }} - if {![interp issafe]} { - variable Path [encoding dirs] - set Dir [file join $::tcl_library encoding] - if {$Dir ni $Path} { + variable Path [encoding dirs] + set Dir [file join $::tcl_library encoding] + if {$Dir ni $Path} { lappend Path $Dir encoding dirs $Path - } + } + unset Dir Path } # TIP #255 min and max functions @@ -79,7 +84,7 @@ namespace eval tcl { proc min {args} { if {![llength $args]} { return -code error \ - "too few arguments to math function \"min\"" + "not enough arguments to math function \"min\"" } set val Inf foreach arg $args { @@ -95,7 +100,7 @@ namespace eval tcl { proc max {args} { if {![llength $args]} { return -code error \ - "too few arguments to math function \"max\"" + "not enough arguments to math function \"max\"" } set val -Inf foreach arg $args { @@ -308,7 +313,7 @@ proc unknown args { set errInfo [string range $errInfo 0 $last-1] set tail "\"$cinfo\"" set last [string last $tail $errInfo] - if {$last + [string length $tail] != [string length $errInfo]} { + if {$last < 0 || $last + [string length $tail] != [string length $errInfo]} { return -code error -errorcode $errCode \ -errorinfo $errInfo $msg } @@ -489,6 +494,7 @@ proc auto_load_index {} { continue } else { set error [catch { + fconfigure $f -eofchar \032 set id [gets $f] if {$id eq "# Tcl autoload index file, version 2.0"} { eval [read $f] @@ -792,7 +798,7 @@ proc tcl::CopyDirectory {action src dest} { } } } else { - if {[string first $nsrc $ndest] != -1} { + if {[string first $nsrc $ndest] >= 0} { set srclen [expr {[llength [file split $nsrc]] - 1}] set ndest [lindex [file split $ndest] $srclen] if {$ndest eq [file tail $nsrc]} { diff --git a/amd64/lib/tcl8.6/opt0.4/optparse.tcl b/amd64/lib/tcl8.6/opt0.4/optparse.tcl index 869a2b6..1639379 100644 --- a/amd64/lib/tcl8.6/opt0.4/optparse.tcl +++ b/amd64/lib/tcl8.6/opt0.4/optparse.tcl @@ -8,10 +8,10 @@ # on it. If your code does rely on this package you # may directly incorporate this code into your application. -package require Tcl 8.2 +package require Tcl 8.5- # When this version number changes, update the pkgIndex.tcl file # and the install directory in the Makefiles. -package provide opt 0.4.6 +package provide opt 0.4.8 namespace eval ::tcl { @@ -44,8 +44,8 @@ namespace eval ::tcl { {-intflag 7} {-weirdflag "help string"} {-noStatics "Not ok to load static packages"} - {-nestedloading1 true "OK to load into nested slaves"} - {-nestedloading2 -boolean true "OK to load into nested slaves"} + {-nestedloading1 true "OK to load into nested children"} + {-nestedloading2 -boolean true "OK to load into nested children"} {-libsOK -choice {Tk SybTcl} "List of packages that can be loaded"} {-precision -int 12 "Number of digits of precision"} diff --git a/amd64/lib/tcl8.6/opt0.4/pkgIndex.tcl b/amd64/lib/tcl8.6/opt0.4/pkgIndex.tcl index 107d4c6..23e118c 100644 --- a/amd64/lib/tcl8.6/opt0.4/pkgIndex.tcl +++ b/amd64/lib/tcl8.6/opt0.4/pkgIndex.tcl @@ -8,5 +8,5 @@ # script is sourced, the variable $dir must contain the # full path name of this file's directory. -if {![package vsatisfies [package provide Tcl] 8.2]} {return} -package ifneeded opt 0.4.6 [list source [file join $dir optparse.tcl]] +if {![package vsatisfies [package provide Tcl] 8.5-]} {return} +package ifneeded opt 0.4.8 [list source [file join $dir optparse.tcl]] diff --git a/amd64/lib/tcl8.6/package.tcl b/amd64/lib/tcl8.6/package.tcl index 44e3b28..4a73346 100644 --- a/amd64/lib/tcl8.6/package.tcl +++ b/amd64/lib/tcl8.6/package.tcl @@ -237,7 +237,7 @@ proc pkg_mkIndex {args} { $c eval [list set ::tcl::file $file] $c eval [list set ::tcl::direct $direct] - # Download needed procedures into the slave because we've just deleted + # Download needed procedures into the child because we've just deleted # the unknown procedure. This doesn't handle procedures with default # arguments. @@ -479,9 +479,12 @@ proc tclPkgUnknown {name args} { } set tclSeenPath($dir) 1 - # we can't use glob in safe interps, so enclose the following in a - # catch statement, where we get the pkgIndex files out of the - # subdirectories + # Get the pkgIndex.tcl files in subdirectories of auto_path directories. + # - Safe Base interpreters have a restricted "glob" command that + # works in this case. + # - The "catch" was essential when there was no safe glob and every + # call in a safe interp failed; it is retained only for corner + # cases in which the eventual call to glob returns an error. catch { foreach file [glob -directory $dir -join -nocomplain \ * pkgIndex.tcl] { @@ -585,6 +588,7 @@ proc tcl::MacOSXPkgUnknown {original name args} { set tclSeenPath($dir) 1 # get the pkgIndex files out of the subdirectories + # Safe interpreters do not use tcl::MacOSXPkgUnknown - see init.tcl. foreach file [glob -directory $dir -join -nocomplain \ * Resources Scripts pkgIndex.tcl] { set dir [file dirname $file] diff --git a/amd64/lib/tcl8.6/safe.tcl b/amd64/lib/tcl8.6/safe.tcl index ea6391d..b9dd18d 100644 --- a/amd64/lib/tcl8.6/safe.tcl +++ b/amd64/lib/tcl8.6/safe.tcl @@ -1,9 +1,9 @@ # safe.tcl -- # # This file provide a safe loading/sourcing mechanism for safe interpreters. -# It implements a virtual path mecanism to hide the real pathnames from the -# slave. It runs in a master interpreter and sets up data structure and -# aliases that will be invoked when used from a slave interpreter. +# It implements a virtual path mechanism to hide the real pathnames from the +# child. It runs in a parent interpreter and sets up data structure and +# aliases that will be invoked when used from a child interpreter. # # See the safe.n man page for details. # @@ -20,7 +20,7 @@ # # Needed utilities package -package require opt 0.4.1 +package require opt 0.4.8 # Create the safe namespace namespace eval ::safe { @@ -79,6 +79,7 @@ proc ::safe::InterpNested {} { # Interface/entry point function and front end for "Create" proc ::safe::interpCreate {args} { set Args [::tcl::OptKeyParse ::safe::interpCreate $args] + RejectExcessColons $slave InterpCreate $slave $accessPath \ [InterpStatics] [InterpNested] $deleteHook } @@ -88,16 +89,17 @@ proc ::safe::interpInit {args} { if {![::interp exists $slave]} { return -code error "\"$slave\" is not an interpreter" } + RejectExcessColons $slave InterpInit $slave $accessPath \ [InterpStatics] [InterpNested] $deleteHook } -# Check that the given slave is "one of us" -proc ::safe::CheckInterp {slave} { - namespace upvar ::safe S$slave state - if {![info exists state] || ![::interp exists $slave]} { +# Check that the given child is "one of us" +proc ::safe::CheckInterp {child} { + namespace upvar ::safe [VarName $child] state + if {![info exists state] || ![::interp exists $child]} { return -code error \ - "\"$slave\" is not an interpreter managed by ::safe::" + "\"$child\" is not an interpreter managed by ::safe::" } } @@ -119,11 +121,11 @@ proc ::safe::interpConfigure {args} { 1 { # If we have exactly 1 argument the semantic is to return all # the current configuration. We still call OptKeyParse though - # we know that "slave" is our given argument because it also + # we know that "child" is our given argument because it also # checks for the "-help" option. set Args [::tcl::OptKeyParse ::safe::interpIC $args] CheckInterp $slave - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state return [join [list \ [list -accessPath $state(access_path)] \ @@ -146,7 +148,7 @@ proc ::safe::interpConfigure {args} { return -code error [::tcl::OptFlagUsage $desc $arg] } CheckInterp $slave - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state set item [::tcl::OptCurDesc $desc] set name [::tcl::OptName $item] @@ -187,15 +189,15 @@ proc ::safe::interpConfigure {args} { # create did set Args [::tcl::OptKeyParse ::safe::interpIC $args] CheckInterp $slave - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state # Get the current (and not the default) values of whatever has # not been given: if {![::tcl::OptProcArgGiven -accessPath]} { - set doreset 1 + set doreset 0 set accessPath $state(access_path) } else { - set doreset 0 + set doreset 1 } if { ![::tcl::OptProcArgGiven -statics] @@ -218,14 +220,33 @@ proc ::safe::interpConfigure {args} { } # we can now reconfigure : InterpSetConfig $slave $accessPath $statics $nested $deleteHook - # auto_reset the slave (to completly synch the new access_path) + # auto_reset the child (to completly synch the new access_path) if {$doreset} { if {[catch {::interp eval $slave {auto_reset}} msg]} { Log $slave "auto_reset failed: $msg" } else { Log $slave "successful auto_reset" NOTICE } + + # Sync the paths used to search for Tcl modules. + ::interp eval $slave {tcl::tm::path remove {*}[tcl::tm::list]} + if {[llength $state(tm_path_slave)] > 0} { + ::interp eval $slave [list \ + ::tcl::tm::add {*}[lreverse $state(tm_path_slave)]] + } + + # Remove stale "package ifneeded" data for non-loaded packages. + # - Not for loaded packages, because "package forget" erases + # data from "package provide" as well as "package ifneeded". + # - This is OK because the script cannot reload any version of + # the package unless it first does "package forget". + foreach pkg [::interp eval $slave {package names}] { + if {[::interp eval $slave [list package provide $pkg]] eq ""} { + ::interp eval $slave [list package forget $pkg] + } + } } + return } } } @@ -239,17 +260,17 @@ proc ::safe::interpConfigure {args} { # # safe::InterpCreate : doing the real job # -# This procedure creates a safe slave and initializes it with the safe +# This procedure creates a safe interpreter and initializes it with the safe # base aliases. -# NB: slave name must be simple alphanumeric string, no spaces, no (), no +# NB: child name must be simple alphanumeric string, no spaces, no (), no # {},... {because the state array is stored as part of the name} # -# Returns the slave name. +# Returns the child name. # # Optional Arguments : -# + slave name : if empty, generated name will be used +# + child name : if empty, generated name will be used # + access_path: path list controlling where load/source can occur, -# if empty: the master auto_path will be used. +# if empty: the parent auto_path will be used. # + staticsok : flag, if 0 :no static package can be loaded (load {} Xxx) # if 1 :static packages are ok. # + nestedok: flag, if 0 :no loading to sub-sub interps (load xx xx sub) @@ -257,35 +278,37 @@ proc ::safe::interpConfigure {args} { # use the full name and no indent so auto_mkIndex can find us proc ::safe::InterpCreate { - slave + child access_path staticsok nestedok deletehook } { - # Create the slave. - if {$slave ne ""} { - ::interp create -safe $slave + # Create the child. + # If evaluated in ::safe, the interpreter command for foo is ::foo; + # but for foo::bar is safe::foo::bar. So evaluate in :: instead. + if {$child ne ""} { + namespace eval :: [list ::interp create -safe $child] } else { - # empty argument: generate slave name - set slave [::interp create -safe] + # empty argument: generate child name + set child [::interp create -safe] } - Log $slave "Created" NOTICE + Log $child "Created" NOTICE - # Initialize it. (returns slave name) - InterpInit $slave $access_path $staticsok $nestedok $deletehook + # Initialize it. (returns child name) + InterpInit $child $access_path $staticsok $nestedok $deletehook } # # InterpSetConfig (was setAccessPath) : -# Sets up slave virtual auto_path and corresponding structure within -# the master. Also sets the tcl_library in the slave to be the first +# Sets up child virtual auto_path and corresponding structure within +# the parent. Also sets the tcl_library in the child to be the first # directory in the path. -# NB: If you change the path after the slave has been initialized you -# probably need to call "auto_reset" in the slave in order that it gets +# NB: If you change the path after the child has been initialized you +# probably need to call "auto_reset" in the child in order that it gets # the right auto_index() array values. -proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { +proc ::safe::InterpSetConfig {child access_path staticsok nestedok deletehook} { global auto_path # determine and store the access path if empty @@ -295,36 +318,36 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { # Make sure that tcl_library is in auto_path and at the first # position (needed by setAccessPath) set where [lsearch -exact $access_path [info library]] - if {$where == -1} { + if {$where < 0} { # not found, add it. set access_path [linsert $access_path 0 [info library]] - Log $slave "tcl_library was not in auto_path,\ + Log $child "tcl_library was not in auto_path,\ added it to slave's access_path" NOTICE } elseif {$where != 0} { # not first, move it first set access_path [linsert \ [lreplace $access_path $where $where] \ 0 [info library]] - Log $slave "tcl_libray was not in first in auto_path,\ + Log $child "tcl_libray was not in first in auto_path,\ moved it to front of slave's access_path" NOTICE } # Add 1st level sub dirs (will searched by auto loading from tcl - # code in the slave using glob and thus fail, so we add them here + # code in the child using glob and thus fail, so we add them here # so by default it works the same). set access_path [AddSubDirs $access_path] } - Log $slave "Setting accessPath=($access_path) staticsok=$staticsok\ + Log $child "Setting accessPath=($access_path) staticsok=$staticsok\ nestedok=$nestedok deletehook=($deletehook)" NOTICE - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $child] state # clear old autopath if it existed # build new one # Extend the access list with the paths used to look for Tcl Modules. # We save the virtual form separately as well, as syncing it with the - # slave has to be defered until the necessary commands are present for + # child has to be deferred until the necessary commands are present for # setup. set norm_access_path {} @@ -344,6 +367,7 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { } set morepaths [::tcl::tm::list] + set firstpass 1 while {[llength $morepaths]} { set addpaths $morepaths set morepaths {} @@ -352,6 +376,12 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { # Prevent the addition of dirs on the tm list to the # result if they are already known. if {[dict exists $remap_access_path $dir]} { + if {$firstpass} { + # $dir is in [::tcl::tm::list] and belongs in the slave_tm_path. + # Later passes handle subdirectories, which belong in the + # access path but not in the module path. + lappend slave_tm_path [dict get $remap_access_path $dir] + } continue } @@ -361,7 +391,12 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { lappend map_access_path $token $dir lappend remap_access_path $dir $token lappend norm_access_path [file normalize $dir] - lappend slave_tm_path $token + if {$firstpass} { + # $dir is in [::tcl::tm::list] and belongs in the slave_tm_path. + # Later passes handle subdirectories, which belong in the + # access path but not in the module path. + lappend slave_tm_path $token + } incr i # [Bug 2854929] @@ -372,6 +407,7 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { # subdirectories. lappend morepaths {*}[glob -nocomplain -directory $dir -type d *] } + set firstpass 0 } set state(access_path) $access_path @@ -384,7 +420,8 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { set state(nestedok) $nestedok set state(cleanupHook) $deletehook - SyncAccessPath $slave + SyncAccessPath $child + return } # @@ -392,11 +429,12 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { # FindInAccessPath: # Search for a real directory and returns its virtual Id (including the # "$") -proc ::safe::interpFindInAccessPath {slave path} { - namespace upvar ::safe S$slave state +proc ::safe::interpFindInAccessPath {child path} { + CheckInterp $child + namespace upvar ::safe [VarName $child] state if {![dict exists $state(access_path,remap) $path]} { - return -code error "$path not found in access path $access_path" + return -code error "$path not found in access path" } return [dict get $state(access_path,remap) $path] @@ -406,10 +444,11 @@ proc ::safe::interpFindInAccessPath {slave path} { # addToAccessPath: # add (if needed) a real directory to access path and return its # virtual token (including the "$"). -proc ::safe::interpAddToAccessPath {slave path} { +proc ::safe::interpAddToAccessPath {child path} { # first check if the directory is already in there # (inlined interpFindInAccessPath). - namespace upvar ::safe S$slave state + CheckInterp $child + namespace upvar ::safe [VarName $child] state if {[dict exists $state(access_path,remap) $path]} { return [dict get $state(access_path,remap) $path] @@ -424,7 +463,7 @@ proc ::safe::interpAddToAccessPath {slave path} { lappend state(access_path,remap) $path $token lappend state(access_path,norm) [file normalize $path] - SyncAccessPath $slave + SyncAccessPath $child return $token } @@ -432,25 +471,25 @@ proc ::safe::interpAddToAccessPath {slave path} { # interpreter. It is useful when you want to install the safe base aliases # into a preexisting safe interpreter. proc ::safe::InterpInit { - slave + child access_path staticsok nestedok deletehook } { # Configure will generate an access_path when access_path is empty. - InterpSetConfig $slave $access_path $staticsok $nestedok $deletehook + InterpSetConfig $child $access_path $staticsok $nestedok $deletehook # NB we need to add [namespace current], aliases are always absolute # paths. - # These aliases let the slave load files to define new commands - # This alias lets the slave use the encoding names, convertfrom, + # These aliases let the child load files to define new commands + # This alias lets the child use the encoding names, convertfrom, # convertto, and system, but not "encoding system " to set the # system encoding. # Handling Tcl Modules, we need a restricted form of Glob. # This alias interposes on the 'exit' command and cleanly terminates - # the slave. + # the child. foreach {command alias} { source AliasSource @@ -459,61 +498,61 @@ proc ::safe::InterpInit { exit interpDelete glob AliasGlob } { - ::interp alias $slave $command {} [namespace current]::$alias $slave + ::interp alias $child $command {} [namespace current]::$alias $child } - # This alias lets the slave have access to a subset of the 'file' + # This alias lets the child have access to a subset of the 'file' # command functionality. - ::interp expose $slave file + ::interp expose $child file foreach subcommand {dirname extension rootname tail} { - ::interp alias $slave ::tcl::file::$subcommand {} \ - ::safe::AliasFileSubcommand $slave $subcommand + ::interp alias $child ::tcl::file::$subcommand {} \ + ::safe::AliasFileSubcommand $child $subcommand } foreach subcommand { atime attributes copy delete executable exists isdirectory isfile link lstat mtime mkdir nativename normalize owned readable readlink rename size stat tempfile type volumes writable } { - ::interp alias $slave ::tcl::file::$subcommand {} \ - ::safe::BadSubcommand $slave file $subcommand + ::interp alias $child ::tcl::file::$subcommand {} \ + ::safe::BadSubcommand $child file $subcommand } # Subcommands of info foreach {subcommand alias} { nameofexecutable AliasExeName } { - ::interp alias $slave ::tcl::info::$subcommand \ - {} [namespace current]::$alias $slave + ::interp alias $child ::tcl::info::$subcommand \ + {} [namespace current]::$alias $child } - # The allowed slave variables already have been set by Tcl_MakeSafe(3) + # The allowed child variables already have been set by Tcl_MakeSafe(3) - # Source init.tcl and tm.tcl into the slave, to get auto_load and + # Source init.tcl and tm.tcl into the child, to get auto_load and # other procedures defined: - if {[catch {::interp eval $slave { + if {[catch {::interp eval $child { source [file join $tcl_library init.tcl] }} msg opt]} { - Log $slave "can't source init.tcl ($msg)" - return -options $opt "can't source init.tcl into slave $slave ($msg)" + Log $child "can't source init.tcl ($msg)" + return -options $opt "can't source init.tcl into slave $child ($msg)" } - if {[catch {::interp eval $slave { + if {[catch {::interp eval $child { source [file join $tcl_library tm.tcl] }} msg opt]} { - Log $slave "can't source tm.tcl ($msg)" - return -options $opt "can't source tm.tcl into slave $slave ($msg)" + Log $child "can't source tm.tcl ($msg)" + return -options $opt "can't source tm.tcl into slave $child ($msg)" } # Sync the paths used to search for Tcl modules. This can be done only # now, after tm.tcl was loaded. - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $child] state if {[llength $state(tm_path_slave)] > 0} { - ::interp eval $slave [list \ + ::interp eval $child [list \ ::tcl::tm::add {*}[lreverse $state(tm_path_slave)]] } - return $slave + return $child } # Add (only if needed, avoid duplicates) 1 level of sub directories to an @@ -539,15 +578,30 @@ proc ::safe::AddSubDirs {pathList} { return $res } -# This procedure deletes a safe slave managed by Safe Tcl and cleans up -# associated state: +# This procedure deletes a safe interpreter managed by Safe Tcl and cleans up +# associated state. +# - The command will also delete non-Safe-Base interpreters. +# - This is regrettable, but to avoid breaking existing code this should be +# amended at the next major revision by uncommenting "CheckInterp". -proc ::safe::interpDelete {slave} { - Log $slave "About to delete" NOTICE +proc ::safe::interpDelete {child} { + Log $child "About to delete" NOTICE - namespace upvar ::safe S$slave state + # CheckInterp $child + namespace upvar ::safe [VarName $child] state - # If the slave has a cleanup hook registered, call it. Check the + # When an interpreter is deleted with [interp delete], any sub-interpreters + # are deleted automatically, but this leaves behind their data in the Safe + # Base. To clean up properly, we call safe::interpDelete recursively on each + # Safe Base sub-interpreter, so each one is deleted cleanly and not by + # the automatic mechanism built into [interp delete]. + foreach sub [interp children $child] { + if {[info exists ::safe::[VarName [list $child $sub]]]} { + ::safe::interpDelete [list $child $sub] + } + } + + # If the child has a cleanup hook registered, call it. Check the # existance because we might be called to delete an interp which has # not been registered with us at all @@ -558,14 +612,14 @@ proc ::safe::interpDelete {slave} { # we'll loop unset state(cleanupHook) try { - {*}$hook $slave + {*}$hook $child } on error err { - Log $slave "Delete hook error ($err)" + Log $child "Delete hook error ($err)" } } } - # Discard the global array of state associated with the slave, and + # Discard the global array of state associated with the child, and # delete the interpreter. if {[info exists state]} { @@ -574,9 +628,9 @@ proc ::safe::interpDelete {slave} { # if we have been called twice, the interp might have been deleted # already - if {[::interp exists $slave]} { - ::interp delete $slave - Log $slave "Deleted" NOTICE + if {[::interp exists $child]} { + ::interp delete $child + Log $child "Deleted" NOTICE } return @@ -602,9 +656,9 @@ proc ::safe::setLogCmd {args} { } else { # Activate logging, define proper command. - proc ::safe::Log {slave msg {type ERROR}} { + proc ::safe::Log {child msg {type ERROR}} { variable Log - {*}$Log "$type for slave $slave : $msg" + {*}$Log "$type for slave $child : $msg" return } } @@ -613,23 +667,23 @@ proc ::safe::setLogCmd {args} { # ------------------- END OF PUBLIC METHODS ------------ # -# Sets the slave auto_path to the master recorded value. Also sets +# Sets the child auto_path to the parent recorded value. Also sets # tcl_library to the first token of the virtual path. # -proc ::safe::SyncAccessPath {slave} { - namespace upvar ::safe S$slave state +proc ::safe::SyncAccessPath {child} { + namespace upvar ::safe [VarName $child] state set slave_access_path $state(access_path,slave) - ::interp eval $slave [list set auto_path $slave_access_path] + ::interp eval $child [list set auto_path $slave_access_path] - Log $slave "auto_path in $slave has been set to $slave_access_path"\ + Log $child "auto_path in $child has been set to $slave_access_path"\ NOTICE # This code assumes that info library is the first element in the # list of auto_path's. See -> InterpSetConfig for the code which # ensures this condition. - ::interp eval $slave [list \ + ::interp eval $child [list \ set tcl_library [lindex $slave_access_path 0]] } @@ -643,8 +697,8 @@ proc ::safe::PathToken {n} { # # translate virtual path into real path # -proc ::safe::TranslatePath {slave path} { - namespace upvar ::safe S$slave state +proc ::safe::TranslatePath {child path} { + namespace upvar ::safe [VarName $child] state # somehow strip the namespaces 'functionality' out (the danger is that # we would strip valid macintosh "../" queries... : @@ -659,7 +713,7 @@ proc ::safe::TranslatePath {slave path} { # file name control (limit access to files/resources that should be a # valid tcl source file) -proc ::safe::CheckFileName {slave file} { +proc ::safe::CheckFileName {child file} { # This used to limit what can be sourced to ".tcl" and forbid files # with more than 1 dot and longer than 14 chars, but I changed that # for 8.4 as a safe interp has enough internal protection already to @@ -680,17 +734,17 @@ proc ::safe::CheckFileName {slave file} { # interpreters that are *almost* safe. In particular, it just acts to # prevent discovery of what home directories exist. -proc ::safe::AliasFileSubcommand {slave subcommand name} { +proc ::safe::AliasFileSubcommand {child subcommand name} { if {[string match ~* $name]} { set name ./$name } - tailcall ::interp invokehidden $slave tcl:file:$subcommand $name + tailcall ::interp invokehidden $child tcl:file:$subcommand $name } # AliasGlob is the target of the "glob" alias in safe interpreters. -proc ::safe::AliasGlob {slave args} { - Log $slave "GLOB ! $args" NOTICE +proc ::safe::AliasGlob {child args} { + Log $child "GLOB ! $args" NOTICE set cmd {} set at 0 array set got { @@ -712,11 +766,15 @@ proc ::safe::AliasGlob {slave args} { while {$at < [llength $args]} { switch -glob -- [set opt [lindex $args $at]] { - -nocomplain - -- - -join - -tails { + -nocomplain - -- - -tails { lappend cmd $opt set got($opt) 1 incr at } + -join { + set got($opt) 1 + incr at + } -types - -type { lappend cmd -types [lindex $args [incr at]] incr at @@ -730,15 +788,8 @@ proc ::safe::AliasGlob {slave args} { set virtualdir [lindex $args [incr at]] incr at } - pkgIndex.tcl { - # Oops, this is globbing a subdirectory in regular package - # search. That is not wanted. Abort, handler does catch - # already (because glob was not defined before). See - # package.tcl, lines 484ff in tclPkgUnknown. - return -code error "unknown command glob" - } -* { - Log $slave "Safe base rejecting glob option '$opt'" + Log $child "Safe base rejecting glob option '$opt'" return -code error "Safe base rejecting glob option '$opt'" } default { @@ -749,73 +800,116 @@ proc ::safe::AliasGlob {slave args} { } # Get the real path from the virtual one and check that the path is in the - # access path of that slave. Done after basic argument processing so that + # access path of that child. Done after basic argument processing so that # we know if -nocomplain is set. if {$got(-directory)} { try { - set dir [TranslatePath $slave $virtualdir] - DirInAccessPath $slave $dir + set dir [TranslatePath $child $virtualdir] + DirInAccessPath $child $dir } on error msg { - Log $slave $msg + Log $child $msg if {$got(-nocomplain)} return return -code error "permission denied" } - lappend cmd -directory $dir + if {$got(--)} { + set cmd [linsert $cmd end-1 -directory $dir] + } else { + lappend cmd -directory $dir + } + } else { + # The code after this "if ... else" block would conspire to return with + # no results in this case, if it were allowed to proceed. Instead, + # return now and reduce the number of cases to be considered later. + Log $child {option -directory must be supplied} + if {$got(-nocomplain)} return + return -code error "permission denied" } - # Apply the -join semantics ourselves + # Apply the -join semantics ourselves. if {$got(-join)} { set args [lreplace $args $at end [join [lrange $args $at end] "/"]] } - # Process remaining pattern arguments + # Process the pattern arguments. If we've done a join there is only one + # pattern argument. + set firstPattern [llength $cmd] foreach opt [lrange $args $at end] { if {![regexp $dirPartRE $opt -> thedir thefile]} { set thedir . - } elseif {[string match ~* $thedir]} { - set thedir ./$thedir + # The *.tm search comes here. } - if {$thedir eq "*" && - ($thefile eq "pkgIndex.tcl" || $thefile eq "*.tm")} { + # "Special" treatment for (joined) argument {*/pkgIndex.tcl}. + # Do the expansion of "*" here, and filter out any directories that are + # not in the access path. The outcome is to lappend to cmd a path of + # the form $virtualdir/subdir/pkgIndex.tcl for each subdirectory subdir, + # after removing any subdir that are not in the access path. + if {($thedir eq "*") && ($thefile eq "pkgIndex.tcl")} { set mapped 0 - foreach d [glob -directory [TranslatePath $slave $virtualdir] \ + foreach d [glob -directory [TranslatePath $child $virtualdir] \ -types d -tails *] { catch { - DirInAccessPath $slave \ - [TranslatePath $slave [file join $virtualdir $d]] + DirInAccessPath $child \ + [TranslatePath $child [file join $virtualdir $d]] lappend cmd [file join $d $thefile] set mapped 1 } } if {$mapped} continue + # Don't [continue] if */pkgIndex.tcl has no matches in the access + # path. The pattern will now receive the same treatment as a + # "non-special" pattern (and will fail because it includes a "*" in + # the directory name). } + # Any directory pattern that is not an exact (i.e. non-glob) match to a + # directory in the access path will be rejected here. + # - Rejections include any directory pattern that has glob matching + # patterns "*", "?", backslashes, braces or square brackets, (UNLESS + # it corresponds to a genuine directory name AND that directory is in + # the access path). + # - The only "special matching characters" that remain in patterns for + # processing by glob are in the filename tail. + # - [file join $anything ~${foo}] is ~${foo}, which is not an exact + # match to any directory in the access path. Hence directory patterns + # that begin with "~" are rejected here. Tests safe-16.[5-8] check + # that "file join" remains as required and does not expand ~${foo}. + # - Bug [3529949] relates to unwanted expansion of ~${foo} and this is + # how the present code avoids the bug. All tests safe-16.* relate. try { - DirInAccessPath $slave [TranslatePath $slave \ + DirInAccessPath $child [TranslatePath $child \ [file join $virtualdir $thedir]] } on error msg { - Log $slave $msg + Log $child $msg if {$got(-nocomplain)} continue return -code error "permission denied" } lappend cmd $opt } - Log $slave "GLOB = $cmd" NOTICE + Log $child "GLOB = $cmd" NOTICE if {$got(-nocomplain) && [llength $cmd] eq $firstPattern} { return } try { - set entries [::interp invokehidden $slave glob {*}$cmd] + # >>>>>>>>>> HERE'S THE CALL TO SAFE INTERP GLOB <<<<<<<<<< + # - Pattern arguments added to cmd have NOT been translated from tokens. + # Only the virtualdir is translated (to dir). + # - In the pkgIndex.tcl case, there is no "*" in the pattern arguments, + # which are a list of names each with tail pkgIndex.tcl. The purpose + # of the call to glob is to remove the names for which the file does + # not exist. + set entries [::interp invokehidden $child glob {*}$cmd] } on error msg { - Log $slave $msg + # This is the only place that a call with -nocomplain and no invalid + # "dash-options" can return an error. + Log $child $msg return -code error "script error" } - Log $slave "GLOB < $entries" NOTICE + Log $child "GLOB < $entries" NOTICE - # Translate path back to what the slave should see. + # Translate path back to what the child should see. set res {} set l [string length $dir] foreach p $entries { @@ -825,13 +919,13 @@ proc ::safe::AliasGlob {slave args} { lappend res $p } - Log $slave "GLOB > $res" NOTICE + Log $child "GLOB > $res" NOTICE return $res } # AliasSource is the target of the "source" alias in safe interpreters. -proc ::safe::AliasSource {slave args} { +proc ::safe::AliasSource {child args} { set argc [llength $args] # Extended for handling of Tcl Modules to allow not only "source # filename", but "source -encoding E filename" as well. @@ -840,7 +934,7 @@ proc ::safe::AliasSource {slave args} { set encoding [lindex $args 1] set at 2 if {$encoding eq "identity"} { - Log $slave "attempt to use the identity encoding" + Log $child "attempt to use the identity encoding" return -code error "permission denied" } } else { @@ -849,39 +943,42 @@ proc ::safe::AliasSource {slave args} { } if {$argc != 1} { set msg "wrong # args: should be \"source ?-encoding E? fileName\"" - Log $slave "$msg ($args)" + Log $child "$msg ($args)" return -code error $msg } set file [lindex $args $at] # get the real path from the virtual one. if {[catch { - set realfile [TranslatePath $slave $file] + set realfile [TranslatePath $child $file] } msg]} { - Log $slave $msg + Log $child $msg return -code error "permission denied" } - # check that the path is in the access path of that slave + # check that the path is in the access path of that child if {[catch { - FileInAccessPath $slave $realfile + FileInAccessPath $child $realfile } msg]} { - Log $slave $msg + Log $child $msg return -code error "permission denied" } - # do the checks on the filename : + # Check that the filename exists and is readable. If it is not, deliver + # this -errorcode so that caller in tclPkgUnknown does not write a message + # to tclLog. Has no effect on other callers of ::source, which are in + # "package ifneeded" scripts. if {[catch { - CheckFileName $slave $realfile + CheckFileName $child $realfile } msg]} { - Log $slave "$realfile:$msg" - return -code error $msg + Log $child "$realfile:$msg" + return -code error -errorcode {POSIX EACCES} $msg } # Passed all the tests, lets source it. Note that we do this all manually - # because we want to control [info script] in the slave so information + # because we want to control [info script] in the child so information # doesn't leak so much. [Bug 2913625] - set old [::interp eval $slave {info script}] + set old [::interp eval $child {info script}] set replacementMsg "script error" set code [catch { set f [open $realfile] @@ -891,17 +988,17 @@ proc ::safe::AliasSource {slave args} { } set contents [read $f] close $f - ::interp eval $slave [list info script $file] + ::interp eval $child [list info script $file] } msg opt] if {$code == 0} { - set code [catch {::interp eval $slave $contents} msg opt] + set code [catch {::interp eval $child $contents} msg opt] set replacementMsg $msg } - catch {interp eval $slave [list info script $old]} + catch {interp eval $child [list info script $old]} # Note that all non-errors are fine result codes from [source], so we must # take a little care to do it properly. [Bug 2923613] if {$code == 1} { - Log $slave $msg + Log $child $msg return -code error $replacementMsg } return -code $code -options $opt $msg @@ -909,18 +1006,18 @@ proc ::safe::AliasSource {slave args} { # AliasLoad is the target of the "load" alias in safe interpreters. -proc ::safe::AliasLoad {slave file args} { +proc ::safe::AliasLoad {child file args} { set argc [llength $args] if {$argc > 2} { set msg "load error: too many arguments" - Log $slave "$msg ($argc) {$file $args}" + Log $child "$msg ($argc) {$file $args}" return -code error $msg } # package name (can be empty if file is not). set package [lindex $args 0] - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $child] state # Determine where to load. load use a relative interp path and {} # means self, so we can directly and safely use passed arg. @@ -929,7 +1026,7 @@ proc ::safe::AliasLoad {slave file args} { # we will try to load into a sub sub interp; check that we want to # authorize that. if {!$state(nestedok)} { - Log $slave "loading to a sub interp (nestedok)\ + Log $child "loading to a sub interp (nestedok)\ disabled (trying to load $package to $target)" return -code error "permission denied (nested load)" } @@ -940,11 +1037,11 @@ proc ::safe::AliasLoad {slave file args} { # static package loading if {$package eq ""} { set msg "load error: empty filename and no package name" - Log $slave $msg + Log $child $msg return -code error $msg } if {!$state(staticsok)} { - Log $slave "static packages loading disabled\ + Log $child "static packages loading disabled\ (trying to load $package to $target)" return -code error "permission denied (static package)" } @@ -953,36 +1050,43 @@ proc ::safe::AliasLoad {slave file args} { # get the real path from the virtual one. try { - set file [TranslatePath $slave $file] + set file [TranslatePath $child $file] } on error msg { - Log $slave $msg + Log $child $msg return -code error "permission denied" } # check the translated path try { - FileInAccessPath $slave $file + FileInAccessPath $child $file } on error msg { - Log $slave $msg + Log $child $msg return -code error "permission denied (path)" } } try { - return [::interp invokehidden $slave load $file $package $target] + return [::interp invokehidden $child load $file $package $target] } on error msg { - Log $slave $msg + # Some packages return no error message. + set msg0 "load of binary library for package $package failed" + if {$msg eq {}} { + set msg $msg0 + } else { + set msg "$msg0: $msg" + } + Log $child $msg return -code error $msg } } # FileInAccessPath raises an error if the file is not found in the list of -# directories contained in the (master side recorded) slave's access path. +# directories contained in the (parent side recorded) child's access path. # the security here relies on "file dirname" answering the proper # result... needs checking ? -proc ::safe::FileInAccessPath {slave file} { - namespace upvar ::safe S$slave state +proc ::safe::FileInAccessPath {child file} { + namespace upvar ::safe [VarName $child] state set access_path $state(access_path) if {[file isdirectory $file]} { @@ -994,14 +1098,14 @@ proc ::safe::FileInAccessPath {slave file} { # potential pathname anomalies. set norm_parent [file normalize $parent] - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $child] state if {$norm_parent ni $state(access_path,norm)} { return -code error "\"$file\": not in access_path" } } -proc ::safe::DirInAccessPath {slave dir} { - namespace upvar ::safe S$slave state +proc ::safe::DirInAccessPath {child dir} { + namespace upvar ::safe [VarName $child] state set access_path $state(access_path) if {[file isfile $dir]} { @@ -1012,7 +1116,7 @@ proc ::safe::DirInAccessPath {slave dir} { # potential pathname anomalies. set norm_dir [file normalize $dir] - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $child] state if {$norm_dir ni $state(access_path,norm)} { return -code error "\"$dir\": not in access_path" } @@ -1021,16 +1125,16 @@ proc ::safe::DirInAccessPath {slave dir} { # This procedure is used to report an attempt to use an unsafe member of an # ensemble command. -proc ::safe::BadSubcommand {slave command subcommand args} { +proc ::safe::BadSubcommand {child command subcommand args} { set msg "not allowed to invoke subcommand $subcommand of $command" - Log $slave $msg + Log $child $msg return -code error -errorcode {TCL SAFE SUBCOMMAND} $msg } # AliasEncoding is the target of the "encoding" alias in safe interpreters. -proc ::safe::AliasEncoding {slave option args} { - # Note that [encoding dirs] is not supported in safe slaves at all +proc ::safe::AliasEncoding {child option args} { + # Note that [encoding dirs] is not supported in safe children at all set subcommands {convertfrom convertto names system} try { set option [tcl::prefix match -error [list -level 1 -errorcode \ @@ -1041,18 +1145,70 @@ proc ::safe::AliasEncoding {slave option args} { "wrong # args: should be \"encoding system\"" } } on error {msg options} { - Log $slave $msg + Log $child $msg return -options $options $msg } - tailcall ::interp invokehidden $slave encoding $option {*}$args + tailcall ::interp invokehidden $child encoding $option {*}$args } # Various minor hiding of platform features. [Bug 2913625] -proc ::safe::AliasExeName {slave} { +proc ::safe::AliasExeName {child} { return "" } +# ------------------------------------------------------------------------------ +# Using Interpreter Names with Namespace Qualifiers +# ------------------------------------------------------------------------------ +# (1) We wish to preserve compatibility with existing code, in which Safe Base +# interpreter names have no namespace qualifiers. +# (2) safe::interpCreate and the rest of the Safe Base previously could not +# accept namespace qualifiers in an interpreter name. +# (3) The interp command will accept namespace qualifiers in an interpreter +# name, but accepts distinct interpreters that will have the same command +# name (e.g. foo, ::foo, and :::foo) (bug 66c2e8c974). +# (4) To satisfy these constraints, Safe Base interpreter names will be fully +# qualified namespace names with no excess colons and with the leading "::" +# omitted. +# (5) Trailing "::" implies a namespace tail {}, which interp reads as {{}}. +# Reject such names. +# (6) We could: +# (a) EITHER reject usable but non-compliant names (e.g. excess colons) in +# interpCreate, interpInit; +# (b) OR accept such names and then translate to a compliant name in every +# command. +# The problem with (b) is that the user will expect to use the name with the +# interp command and will find that it is not recognised. +# E.g "interpCreate ::foo" creates interpreter "foo", and the user's name +# "::foo" works with all the Safe Base commands, but "interp eval ::foo" +# fails. +# So we choose (a). +# (7) The command +# namespace upvar ::safe S$child state +# becomes +# namespace upvar ::safe [VarName $child] state +# ------------------------------------------------------------------------------ + +proc ::safe::RejectExcessColons {child} { + set stripped [regsub -all -- {:::*} $child ::] + if {[string range $stripped end-1 end] eq {::}} { + return -code error {interpreter name must not end in "::"} + } + if {$stripped ne $child} { + set msg {interpreter name has excess colons in namespace separators} + return -code error $msg + } + if {[string range $stripped 0 1] eq {::}} { + return -code error {interpreter name must not begin "::"} + } + return +} + +proc ::safe::VarName {child} { + # return S$child + return S[string map {:: @N @ @A} $child] +} + proc ::safe::Setup {} { #### # @@ -1111,20 +1267,20 @@ namespace eval ::safe { # Log command, set via 'setLogCmd'. Logging is disabled when empty. variable Log {} - # The package maintains a state array per slave interp under its + # The package maintains a state array per child interp under its # control. The name of this array is S. This array is # brought into scope where needed, using 'namespace upvar'. The S - # prefix is used to avoid that a slave interp called "Log" smashes + # prefix is used to avoid that a child interp called "Log" smashes # the "Log" variable. # # The array's elements are: # - # access_path : List of paths accessible to the slave. + # access_path : List of paths accessible to the child. # access_path,norm : Ditto, in normalized form. - # access_path,slave : Ditto, as the path tokens as seen by the slave. + # access_path,slave : Ditto, as the path tokens as seen by the child. # access_path,map : dict ( token -> path ) # access_path,remap : dict ( path -> token ) - # tm_path_slave : List of TM root directories, as tokens seen by the slave. + # tm_path_slave : List of TM root directories, as tokens seen by the child. # staticsok : Value of option -statics # nestedok : Value of option -nested # cleanupHook : Value of option -deleteHook diff --git a/amd64/lib/tcl8.6/tm.tcl b/amd64/lib/tcl8.6/tm.tcl index 1802bb9..c60084c 100644 --- a/amd64/lib/tcl8.6/tm.tcl +++ b/amd64/lib/tcl8.6/tm.tcl @@ -212,11 +212,12 @@ proc ::tcl::tm::UnknownHandler {original name args} { } set strip [llength [file split $path]] - # We can't use glob in safe interps, so enclose the following in a - # catch statement, where we get the module files out of the - # subdirectories. In other words, Tcl Modules are not-functional - # in such an interpreter. This is the same as for the command - # "tclPkgUnknown", i.e. the search for regular packages. + # Get the module files out of the subdirectories. + # - Safe Base interpreters have a restricted "glob" command that + # works in this case. + # - The "catch" was essential when there was no safe glob and every + # call in a safe interp failed; it is retained only for corner + # cases in which the eventual call to glob returns an error. catch { # We always look for _all_ possible modules in the current @@ -238,12 +239,16 @@ proc ::tcl::tm::UnknownHandler {original name args} { continue } - if {[package ifneeded $pkgname $pkgversion] ne {}} { + if {([package ifneeded $pkgname $pkgversion] ne {}) + && (![interp issafe]) + } { # There's already a provide script registered for # this version of this package. Since all units of # code claiming to be the same version of the same # package ought to be identical, just stick with # the one we already have. + # This does not apply to Safe Base interpreters because + # the token-to-directory mapping may have changed. continue } diff --git a/amd64/lib/tcl8.6/tzdata/Africa/Accra b/amd64/lib/tcl8.6/tzdata/Africa/Accra index f43f751..3f755f6 100644 --- a/amd64/lib/tcl8.6/tzdata/Africa/Accra +++ b/amd64/lib/tcl8.6/tzdata/Africa/Accra @@ -2,51 +2,65 @@ set TZData(:Africa/Accra) { {-9223372036854775808 -52 0 LMT} - {-1640995148 0 0 GMT} - {-1556841600 1200 1 GMT} - {-1546388400 0 0 GMT} - {-1525305600 1200 1 GMT} - {-1514852400 0 0 GMT} - {-1493769600 1200 1 GMT} - {-1483316400 0 0 GMT} - {-1462233600 1200 1 GMT} - {-1451780400 0 0 GMT} - {-1430611200 1200 1 GMT} - {-1420158000 0 0 GMT} - {-1399075200 1200 1 GMT} - {-1388622000 0 0 GMT} - {-1367539200 1200 1 GMT} - {-1357086000 0 0 GMT} - {-1336003200 1200 1 GMT} - {-1325550000 0 0 GMT} - {-1304380800 1200 1 GMT} - {-1293927600 0 0 GMT} - {-1272844800 1200 1 GMT} - {-1262391600 0 0 GMT} - {-1241308800 1200 1 GMT} - {-1230855600 0 0 GMT} - {-1209772800 1200 1 GMT} - {-1199319600 0 0 GMT} - {-1178150400 1200 1 GMT} - {-1167697200 0 0 GMT} - {-1146614400 1200 1 GMT} - {-1136161200 0 0 GMT} - {-1115078400 1200 1 GMT} - {-1104625200 0 0 GMT} - {-1083542400 1200 1 GMT} - {-1073089200 0 0 GMT} - {-1051920000 1200 1 GMT} - {-1041466800 0 0 GMT} - {-1020384000 1200 1 GMT} - {-1009930800 0 0 GMT} - {-988848000 1200 1 GMT} - {-978394800 0 0 GMT} - {-957312000 1200 1 GMT} - {-946858800 0 0 GMT} - {-925689600 1200 1 GMT} - {-915236400 0 0 GMT} - {-894153600 1200 1 GMT} - {-883700400 0 0 GMT} - {-862617600 1200 1 GMT} - {-852164400 0 0 GMT} + {-1709337548 0 0 GMT} + {-1581206400 1200 1 +0020} + {-1577917200 0 0 GMT} + {-1556834400 1200 1 +0020} + {-1546294800 0 0 GMT} + {-1525298400 1200 1 +0020} + {-1514758800 0 0 GMT} + {-1493762400 1200 1 +0020} + {-1483222800 0 0 GMT} + {-1462226400 1200 1 +0020} + {-1451686800 0 0 GMT} + {-1430604000 1200 1 +0020} + {-1420064400 0 0 GMT} + {-1399068000 1200 1 +0020} + {-1388528400 0 0 GMT} + {-1367532000 1200 1 +0020} + {-1356992400 0 0 GMT} + {-1335996000 1200 1 +0020} + {-1325456400 0 0 GMT} + {-1304373600 1200 1 +0020} + {-1293834000 0 0 GMT} + {-1272837600 1200 1 +0020} + {-1262298000 0 0 GMT} + {-1241301600 1200 1 +0020} + {-1230762000 0 0 GMT} + {-1209765600 1200 1 +0020} + {-1199226000 0 0 GMT} + {-1178143200 1200 1 +0020} + {-1167603600 0 0 GMT} + {-1146607200 1200 1 +0020} + {-1136067600 0 0 GMT} + {-1115071200 1200 1 +0020} + {-1104531600 0 0 GMT} + {-1083535200 1200 1 +0020} + {-1072995600 0 0 GMT} + {-1051912800 1200 1 +0020} + {-1041373200 0 0 GMT} + {-1020376800 1200 1 +0020} + {-1009837200 0 0 GMT} + {-988840800 1200 1 +0020} + {-978301200 0 0 GMT} + {-957304800 1200 1 +0020} + {-946765200 0 0 GMT} + {-936309600 1200 1 +0020} + {-915142800 0 0 GMT} + {-904773600 1200 1 +0020} + {-883606800 0 0 GMT} + {-880329600 1800 0 +0030} + {-756952200 0 0 GMT} + {-610149600 1800 1 +0030} + {-599610600 0 0 GMT} + {-578613600 1800 1 +0030} + {-568074600 0 0 GMT} + {-546991200 1800 1 +0030} + {-536452200 0 0 GMT} + {-515455200 1800 1 +0030} + {-504916200 0 0 GMT} + {-483919200 1800 1 +0030} + {-473380200 0 0 GMT} + {-452383200 1800 1 +0030} + {-441844200 0 0 GMT} } diff --git a/amd64/lib/tcl8.6/tzdata/Africa/Algiers b/amd64/lib/tcl8.6/tzdata/Africa/Algiers index fe4de22..b26d31c 100644 --- a/amd64/lib/tcl8.6/tzdata/Africa/Algiers +++ b/amd64/lib/tcl8.6/tzdata/Africa/Algiers @@ -2,7 +2,7 @@ set TZData(:Africa/Algiers) { {-9223372036854775808 732 0 LMT} - {-2486679072 561 0 PMT} + {-2486592732 561 0 PMT} {-1855958961 0 0 WET} {-1689814800 3600 1 WEST} {-1680397200 0 0 WET} diff --git a/amd64/lib/tcl8.6/tzdata/Africa/Casablanca b/amd64/lib/tcl8.6/tzdata/Africa/Casablanca index 99027c9..cb60740 100644 --- a/amd64/lib/tcl8.6/tzdata/Africa/Casablanca +++ b/amd64/lib/tcl8.6/tzdata/Africa/Casablanca @@ -60,13 +60,13 @@ set TZData(:Africa/Casablanca) { {1557021600 0 1 +01} {1560045600 3600 0 +01} {1587261600 0 1 +01} - {1590285600 3600 0 +01} + {1590890400 3600 0 +01} {1618106400 0 1 +01} {1621130400 3600 0 +01} {1648346400 0 1 +01} {1651975200 3600 0 +01} {1679191200 0 1 +01} - {1682215200 3600 0 +01} + {1682820000 3600 0 +01} {1710036000 0 1 +01} {1713060000 3600 0 +01} {1740276000 0 1 +01} @@ -76,13 +76,13 @@ set TZData(:Africa/Casablanca) { {1801965600 0 1 +01} {1804989600 3600 0 +01} {1832205600 0 1 +01} - {1835229600 3600 0 +01} + {1835834400 3600 0 +01} {1863050400 0 1 +01} {1866074400 3600 0 +01} {1893290400 0 1 +01} {1896919200 3600 0 +01} {1924135200 0 1 +01} - {1927159200 3600 0 +01} + {1927764000 3600 0 +01} {1954980000 0 1 +01} {1958004000 3600 0 +01} {1985220000 0 1 +01} @@ -92,13 +92,13 @@ set TZData(:Africa/Casablanca) { {2046304800 0 1 +01} {2049933600 3600 0 +01} {2077149600 0 1 +01} - {2080173600 3600 0 +01} + {2080778400 3600 0 +01} {2107994400 0 1 +01} {2111018400 3600 0 +01} {2138234400 0 1 +01} {2141863200 3600 0 +01} {2169079200 0 1 +01} - {2172103200 3600 0 +01} + {2172708000 3600 0 +01} {2199924000 0 1 +01} {2202948000 3600 0 +01} {2230164000 0 1 +01} @@ -108,13 +108,13 @@ set TZData(:Africa/Casablanca) { {2291248800 0 1 +01} {2294877600 3600 0 +01} {2322093600 0 1 +01} - {2325117600 3600 0 +01} + {2325722400 3600 0 +01} {2352938400 0 1 +01} {2355962400 3600 0 +01} {2383178400 0 1 +01} {2386807200 3600 0 +01} {2414023200 0 1 +01} - {2417047200 3600 0 +01} + {2417652000 3600 0 +01} {2444868000 0 1 +01} {2447892000 3600 0 +01} {2475108000 0 1 +01} @@ -124,13 +124,13 @@ set TZData(:Africa/Casablanca) { {2536192800 0 1 +01} {2539821600 3600 0 +01} {2567037600 0 1 +01} - {2570061600 3600 0 +01} + {2570666400 3600 0 +01} {2597882400 0 1 +01} {2600906400 3600 0 +01} {2628122400 0 1 +01} {2631751200 3600 0 +01} {2658967200 0 1 +01} - {2661991200 3600 0 +01} + {2662596000 3600 0 +01} {2689812000 0 1 +01} {2692836000 3600 0 +01} {2720052000 0 1 +01} @@ -140,63 +140,63 @@ set TZData(:Africa/Casablanca) { {2781136800 0 1 +01} {2784765600 3600 0 +01} {2811981600 0 1 +01} - {2815005600 3600 0 +01} + {2815610400 3600 0 +01} {2842826400 0 1 +01} {2845850400 3600 0 +01} {2873066400 0 1 +01} {2876695200 3600 0 +01} {2903911200 0 1 +01} - {2906935200 3600 0 +01} + {2907540000 3600 0 +01} {2934756000 0 1 +01} {2937780000 3600 0 +01} {2964996000 0 1 +01} - {2968020000 3600 0 +01} + {2968624800 3600 0 +01} {2995840800 0 1 +01} {2998864800 3600 0 +01} {3026080800 0 1 +01} {3029709600 3600 0 +01} {3056925600 0 1 +01} - {3059949600 3600 0 +01} + {3060554400 3600 0 +01} {3087770400 0 1 +01} {3090794400 3600 0 +01} {3118010400 0 1 +01} {3121639200 3600 0 +01} {3148855200 0 1 +01} - {3151879200 3600 0 +01} + {3152484000 3600 0 +01} {3179700000 0 1 +01} {3182724000 3600 0 +01} {3209940000 0 1 +01} - {3212964000 3600 0 +01} + {3213568800 3600 0 +01} {3240784800 0 1 +01} {3243808800 3600 0 +01} {3271024800 0 1 +01} {3274653600 3600 0 +01} {3301869600 0 1 +01} - {3304893600 3600 0 +01} + {3305498400 3600 0 +01} {3332714400 0 1 +01} {3335738400 3600 0 +01} {3362954400 0 1 +01} {3366583200 3600 0 +01} {3393799200 0 1 +01} - {3396823200 3600 0 +01} + {3397428000 3600 0 +01} {3424644000 0 1 +01} {3427668000 3600 0 +01} {3454884000 0 1 +01} - {3457908000 3600 0 +01} + {3458512800 3600 0 +01} {3485728800 0 1 +01} {3488752800 3600 0 +01} {3515968800 0 1 +01} {3519597600 3600 0 +01} {3546813600 0 1 +01} - {3549837600 3600 0 +01} + {3550442400 3600 0 +01} {3577658400 0 1 +01} {3580682400 3600 0 +01} {3607898400 0 1 +01} {3611527200 3600 0 +01} {3638743200 0 1 +01} - {3641767200 3600 0 +01} + {3642372000 3600 0 +01} {3669588000 0 1 +01} {3672612000 3600 0 +01} {3699828000 0 1 +01} - {3702852000 3600 0 +01} + {3703456800 3600 0 +01} } diff --git a/amd64/lib/tcl8.6/tzdata/Africa/El_Aaiun b/amd64/lib/tcl8.6/tzdata/Africa/El_Aaiun index 9f021a4..fd3e88f 100644 --- a/amd64/lib/tcl8.6/tzdata/Africa/El_Aaiun +++ b/amd64/lib/tcl8.6/tzdata/Africa/El_Aaiun @@ -49,13 +49,13 @@ set TZData(:Africa/El_Aaiun) { {1557021600 0 1 +01} {1560045600 3600 0 +01} {1587261600 0 1 +01} - {1590285600 3600 0 +01} + {1590890400 3600 0 +01} {1618106400 0 1 +01} {1621130400 3600 0 +01} {1648346400 0 1 +01} {1651975200 3600 0 +01} {1679191200 0 1 +01} - {1682215200 3600 0 +01} + {1682820000 3600 0 +01} {1710036000 0 1 +01} {1713060000 3600 0 +01} {1740276000 0 1 +01} @@ -65,13 +65,13 @@ set TZData(:Africa/El_Aaiun) { {1801965600 0 1 +01} {1804989600 3600 0 +01} {1832205600 0 1 +01} - {1835229600 3600 0 +01} + {1835834400 3600 0 +01} {1863050400 0 1 +01} {1866074400 3600 0 +01} {1893290400 0 1 +01} {1896919200 3600 0 +01} {1924135200 0 1 +01} - {1927159200 3600 0 +01} + {1927764000 3600 0 +01} {1954980000 0 1 +01} {1958004000 3600 0 +01} {1985220000 0 1 +01} @@ -81,13 +81,13 @@ set TZData(:Africa/El_Aaiun) { {2046304800 0 1 +01} {2049933600 3600 0 +01} {2077149600 0 1 +01} - {2080173600 3600 0 +01} + {2080778400 3600 0 +01} {2107994400 0 1 +01} {2111018400 3600 0 +01} {2138234400 0 1 +01} {2141863200 3600 0 +01} {2169079200 0 1 +01} - {2172103200 3600 0 +01} + {2172708000 3600 0 +01} {2199924000 0 1 +01} {2202948000 3600 0 +01} {2230164000 0 1 +01} @@ -97,13 +97,13 @@ set TZData(:Africa/El_Aaiun) { {2291248800 0 1 +01} {2294877600 3600 0 +01} {2322093600 0 1 +01} - {2325117600 3600 0 +01} + {2325722400 3600 0 +01} {2352938400 0 1 +01} {2355962400 3600 0 +01} {2383178400 0 1 +01} {2386807200 3600 0 +01} {2414023200 0 1 +01} - {2417047200 3600 0 +01} + {2417652000 3600 0 +01} {2444868000 0 1 +01} {2447892000 3600 0 +01} {2475108000 0 1 +01} @@ -113,13 +113,13 @@ set TZData(:Africa/El_Aaiun) { {2536192800 0 1 +01} {2539821600 3600 0 +01} {2567037600 0 1 +01} - {2570061600 3600 0 +01} + {2570666400 3600 0 +01} {2597882400 0 1 +01} {2600906400 3600 0 +01} {2628122400 0 1 +01} {2631751200 3600 0 +01} {2658967200 0 1 +01} - {2661991200 3600 0 +01} + {2662596000 3600 0 +01} {2689812000 0 1 +01} {2692836000 3600 0 +01} {2720052000 0 1 +01} @@ -129,63 +129,63 @@ set TZData(:Africa/El_Aaiun) { {2781136800 0 1 +01} {2784765600 3600 0 +01} {2811981600 0 1 +01} - {2815005600 3600 0 +01} + {2815610400 3600 0 +01} {2842826400 0 1 +01} {2845850400 3600 0 +01} {2873066400 0 1 +01} {2876695200 3600 0 +01} {2903911200 0 1 +01} - {2906935200 3600 0 +01} + {2907540000 3600 0 +01} {2934756000 0 1 +01} {2937780000 3600 0 +01} {2964996000 0 1 +01} - {2968020000 3600 0 +01} + {2968624800 3600 0 +01} {2995840800 0 1 +01} {2998864800 3600 0 +01} {3026080800 0 1 +01} {3029709600 3600 0 +01} {3056925600 0 1 +01} - {3059949600 3600 0 +01} + {3060554400 3600 0 +01} {3087770400 0 1 +01} {3090794400 3600 0 +01} {3118010400 0 1 +01} {3121639200 3600 0 +01} {3148855200 0 1 +01} - {3151879200 3600 0 +01} + {3152484000 3600 0 +01} {3179700000 0 1 +01} {3182724000 3600 0 +01} {3209940000 0 1 +01} - {3212964000 3600 0 +01} + {3213568800 3600 0 +01} {3240784800 0 1 +01} {3243808800 3600 0 +01} {3271024800 0 1 +01} {3274653600 3600 0 +01} {3301869600 0 1 +01} - {3304893600 3600 0 +01} + {3305498400 3600 0 +01} {3332714400 0 1 +01} {3335738400 3600 0 +01} {3362954400 0 1 +01} {3366583200 3600 0 +01} {3393799200 0 1 +01} - {3396823200 3600 0 +01} + {3397428000 3600 0 +01} {3424644000 0 1 +01} {3427668000 3600 0 +01} {3454884000 0 1 +01} - {3457908000 3600 0 +01} + {3458512800 3600 0 +01} {3485728800 0 1 +01} {3488752800 3600 0 +01} {3515968800 0 1 +01} {3519597600 3600 0 +01} {3546813600 0 1 +01} - {3549837600 3600 0 +01} + {3550442400 3600 0 +01} {3577658400 0 1 +01} {3580682400 3600 0 +01} {3607898400 0 1 +01} {3611527200 3600 0 +01} {3638743200 0 1 +01} - {3641767200 3600 0 +01} + {3642372000 3600 0 +01} {3669588000 0 1 +01} {3672612000 3600 0 +01} {3699828000 0 1 +01} - {3702852000 3600 0 +01} + {3703456800 3600 0 +01} } diff --git a/amd64/lib/tcl8.6/tzdata/Africa/Lagos b/amd64/lib/tcl8.6/tzdata/Africa/Lagos index 079572f..8750661 100644 --- a/amd64/lib/tcl8.6/tzdata/Africa/Lagos +++ b/amd64/lib/tcl8.6/tzdata/Africa/Lagos @@ -1,6 +1,9 @@ # created by tools/tclZIC.tcl - do not edit set TZData(:Africa/Lagos) { - {-9223372036854775808 816 0 LMT} - {-1588464816 3600 0 WAT} + {-9223372036854775808 815 0 LMT} + {-2035584815 0 0 GMT} + {-1940889600 815 0 LMT} + {-1767226415 1800 0 +0030} + {-1588465800 3600 0 WAT} } diff --git a/amd64/lib/tcl8.6/tzdata/Africa/Nairobi b/amd64/lib/tcl8.6/tzdata/Africa/Nairobi index 715dc45..b4c3b97 100644 --- a/amd64/lib/tcl8.6/tzdata/Africa/Nairobi +++ b/amd64/lib/tcl8.6/tzdata/Africa/Nairobi @@ -2,8 +2,9 @@ set TZData(:Africa/Nairobi) { {-9223372036854775808 8836 0 LMT} - {-1309746436 10800 0 EAT} - {-1262314800 9000 0 +0230} - {-946780200 9900 0 +0245} - {-315629100 10800 0 EAT} + {-1946168836 9000 0 +0230} + {-1309746600 10800 0 EAT} + {-1261969200 9000 0 +0230} + {-1041388200 9900 0 +0245} + {-865305900 10800 0 EAT} } diff --git a/amd64/lib/tcl8.6/tzdata/America/Belize b/amd64/lib/tcl8.6/tzdata/America/Belize index 5b46388..3b3f9e4 100644 --- a/amd64/lib/tcl8.6/tzdata/America/Belize +++ b/amd64/lib/tcl8.6/tzdata/America/Belize @@ -51,8 +51,51 @@ set TZData(:America/Belize) { {-911759400 -21600 0 CST} {-891194400 -19800 1 -0530} {-879705000 -21600 0 CST} - {-859744800 -19800 1 -0530} - {-848255400 -21600 0 CST} + {-868212000 -18000 1 CWT} + {-769395600 -18000 1 CPT} + {-758746800 -21600 0 CST} + {-701892000 -19800 1 -0530} + {-690402600 -21600 0 CST} + {-670442400 -19800 1 -0530} + {-658953000 -21600 0 CST} + {-638992800 -19800 1 -0530} + {-627503400 -21600 0 CST} + {-606938400 -19800 1 -0530} + {-596053800 -21600 0 CST} + {-575488800 -19800 1 -0530} + {-564604200 -21600 0 CST} + {-544039200 -19800 1 -0530} + {-532549800 -21600 0 CST} + {-512589600 -19800 1 -0530} + {-501100200 -21600 0 CST} + {-481140000 -19800 1 -0530} + {-469650600 -21600 0 CST} + {-449690400 -19800 1 -0530} + {-438201000 -21600 0 CST} + {-417636000 -19800 1 -0530} + {-406751400 -21600 0 CST} + {-386186400 -19800 1 -0530} + {-375301800 -21600 0 CST} + {-354736800 -19800 1 -0530} + {-343247400 -21600 0 CST} + {-323287200 -19800 1 -0530} + {-311797800 -21600 0 CST} + {-291837600 -19800 1 -0530} + {-280348200 -21600 0 CST} + {-259783200 -19800 1 -0530} + {-248898600 -21600 0 CST} + {-228333600 -19800 1 -0530} + {-217449000 -21600 0 CST} + {-196884000 -19800 1 -0530} + {-185999400 -21600 0 CST} + {-165434400 -19800 1 -0530} + {-153945000 -21600 0 CST} + {-133984800 -19800 1 -0530} + {-122495400 -21600 0 CST} + {-102535200 -19800 1 -0530} + {-91045800 -21600 0 CST} + {-70480800 -19800 1 -0530} + {-59596200 -21600 0 CST} {123919200 -18000 1 CDT} {129618000 -21600 0 CST} {409039200 -18000 1 CDT} diff --git a/amd64/lib/tcl8.6/tzdata/America/Dawson b/amd64/lib/tcl8.6/tzdata/America/Dawson index 8d2b641..c8e3f26 100644 --- a/amd64/lib/tcl8.6/tzdata/America/Dawson +++ b/amd64/lib/tcl8.6/tzdata/America/Dawson @@ -94,163 +94,5 @@ set TZData(:America/Dawson) { {1552212000 -25200 1 PDT} {1572771600 -28800 0 PST} {1583661600 -25200 1 PDT} - {1604221200 -28800 0 PST} - {1615716000 -25200 1 PDT} - {1636275600 -28800 0 PST} - {1647165600 -25200 1 PDT} - {1667725200 -28800 0 PST} - {1678615200 -25200 1 PDT} - {1699174800 -28800 0 PST} - {1710064800 -25200 1 PDT} - {1730624400 -28800 0 PST} - {1741514400 -25200 1 PDT} - {1762074000 -28800 0 PST} - {1772964000 -25200 1 PDT} - {1793523600 -28800 0 PST} - {1805018400 -25200 1 PDT} - {1825578000 -28800 0 PST} - {1836468000 -25200 1 PDT} - {1857027600 -28800 0 PST} - {1867917600 -25200 1 PDT} - {1888477200 -28800 0 PST} - {1899367200 -25200 1 PDT} - {1919926800 -28800 0 PST} - {1930816800 -25200 1 PDT} - {1951376400 -28800 0 PST} - {1962871200 -25200 1 PDT} - {1983430800 -28800 0 PST} - {1994320800 -25200 1 PDT} - {2014880400 -28800 0 PST} - {2025770400 -25200 1 PDT} - {2046330000 -28800 0 PST} - {2057220000 -25200 1 PDT} - {2077779600 -28800 0 PST} - {2088669600 -25200 1 PDT} - {2109229200 -28800 0 PST} - {2120119200 -25200 1 PDT} - {2140678800 -28800 0 PST} - {2152173600 -25200 1 PDT} - {2172733200 -28800 0 PST} - {2183623200 -25200 1 PDT} - {2204182800 -28800 0 PST} - {2215072800 -25200 1 PDT} - {2235632400 -28800 0 PST} - {2246522400 -25200 1 PDT} - {2267082000 -28800 0 PST} - {2277972000 -25200 1 PDT} - {2298531600 -28800 0 PST} - {2309421600 -25200 1 PDT} - {2329981200 -28800 0 PST} - {2341476000 -25200 1 PDT} - {2362035600 -28800 0 PST} - {2372925600 -25200 1 PDT} - {2393485200 -28800 0 PST} - {2404375200 -25200 1 PDT} - {2424934800 -28800 0 PST} - {2435824800 -25200 1 PDT} - {2456384400 -28800 0 PST} - {2467274400 -25200 1 PDT} - {2487834000 -28800 0 PST} - {2499328800 -25200 1 PDT} - {2519888400 -28800 0 PST} - {2530778400 -25200 1 PDT} - {2551338000 -28800 0 PST} - {2562228000 -25200 1 PDT} - {2582787600 -28800 0 PST} - {2593677600 -25200 1 PDT} - {2614237200 -28800 0 PST} - {2625127200 -25200 1 PDT} - {2645686800 -28800 0 PST} - {2656576800 -25200 1 PDT} - {2677136400 -28800 0 PST} - {2688631200 -25200 1 PDT} - {2709190800 -28800 0 PST} - {2720080800 -25200 1 PDT} - {2740640400 -28800 0 PST} - {2751530400 -25200 1 PDT} - {2772090000 -28800 0 PST} - {2782980000 -25200 1 PDT} - {2803539600 -28800 0 PST} - {2814429600 -25200 1 PDT} - {2834989200 -28800 0 PST} - {2846484000 -25200 1 PDT} - {2867043600 -28800 0 PST} - {2877933600 -25200 1 PDT} - {2898493200 -28800 0 PST} - {2909383200 -25200 1 PDT} - {2929942800 -28800 0 PST} - {2940832800 -25200 1 PDT} - {2961392400 -28800 0 PST} - {2972282400 -25200 1 PDT} - {2992842000 -28800 0 PST} - {3003732000 -25200 1 PDT} - {3024291600 -28800 0 PST} - {3035786400 -25200 1 PDT} - {3056346000 -28800 0 PST} - {3067236000 -25200 1 PDT} - {3087795600 -28800 0 PST} - {3098685600 -25200 1 PDT} - {3119245200 -28800 0 PST} - {3130135200 -25200 1 PDT} - {3150694800 -28800 0 PST} - {3161584800 -25200 1 PDT} - {3182144400 -28800 0 PST} - {3193034400 -25200 1 PDT} - {3213594000 -28800 0 PST} - {3225088800 -25200 1 PDT} - {3245648400 -28800 0 PST} - {3256538400 -25200 1 PDT} - {3277098000 -28800 0 PST} - {3287988000 -25200 1 PDT} - {3308547600 -28800 0 PST} - {3319437600 -25200 1 PDT} - {3339997200 -28800 0 PST} - {3350887200 -25200 1 PDT} - {3371446800 -28800 0 PST} - {3382941600 -25200 1 PDT} - {3403501200 -28800 0 PST} - {3414391200 -25200 1 PDT} - {3434950800 -28800 0 PST} - {3445840800 -25200 1 PDT} - {3466400400 -28800 0 PST} - {3477290400 -25200 1 PDT} - {3497850000 -28800 0 PST} - {3508740000 -25200 1 PDT} - {3529299600 -28800 0 PST} - {3540189600 -25200 1 PDT} - {3560749200 -28800 0 PST} - {3572244000 -25200 1 PDT} - {3592803600 -28800 0 PST} - {3603693600 -25200 1 PDT} - {3624253200 -28800 0 PST} - {3635143200 -25200 1 PDT} - {3655702800 -28800 0 PST} - {3666592800 -25200 1 PDT} - {3687152400 -28800 0 PST} - {3698042400 -25200 1 PDT} - {3718602000 -28800 0 PST} - {3730096800 -25200 1 PDT} - {3750656400 -28800 0 PST} - {3761546400 -25200 1 PDT} - {3782106000 -28800 0 PST} - {3792996000 -25200 1 PDT} - {3813555600 -28800 0 PST} - {3824445600 -25200 1 PDT} - {3845005200 -28800 0 PST} - {3855895200 -25200 1 PDT} - {3876454800 -28800 0 PST} - {3887344800 -25200 1 PDT} - {3907904400 -28800 0 PST} - {3919399200 -25200 1 PDT} - {3939958800 -28800 0 PST} - {3950848800 -25200 1 PDT} - {3971408400 -28800 0 PST} - {3982298400 -25200 1 PDT} - {4002858000 -28800 0 PST} - {4013748000 -25200 1 PDT} - {4034307600 -28800 0 PST} - {4045197600 -25200 1 PDT} - {4065757200 -28800 0 PST} - {4076647200 -25200 1 PDT} - {4097206800 -28800 0 PST} + {1604217600 -25200 0 MST} } diff --git a/amd64/lib/tcl8.6/tzdata/America/Godthab b/amd64/lib/tcl8.6/tzdata/America/Godthab index 3e45f87..8bb7b73 100644 --- a/amd64/lib/tcl8.6/tzdata/America/Godthab +++ b/amd64/lib/tcl8.6/tzdata/America/Godthab @@ -1,246 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Godthab) { - {-9223372036854775808 -12416 0 LMT} - {-1686083584 -10800 0 -03} - {323845200 -7200 0 -02} - {338950800 -10800 0 -03} - {354675600 -7200 1 -02} - {370400400 -10800 0 -03} - {386125200 -7200 1 -02} - {401850000 -10800 0 -03} - {417574800 -7200 1 -02} - {433299600 -10800 0 -03} - {449024400 -7200 1 -02} - {465354000 -10800 0 -03} - {481078800 -7200 1 -02} - {496803600 -10800 0 -03} - {512528400 -7200 1 -02} - {528253200 -10800 0 -03} - {543978000 -7200 1 -02} - {559702800 -10800 0 -03} - {575427600 -7200 1 -02} - {591152400 -10800 0 -03} - {606877200 -7200 1 -02} - {622602000 -10800 0 -03} - {638326800 -7200 1 -02} - {654656400 -10800 0 -03} - {670381200 -7200 1 -02} - {686106000 -10800 0 -03} - {701830800 -7200 1 -02} - {717555600 -10800 0 -03} - {733280400 -7200 1 -02} - {749005200 -10800 0 -03} - {764730000 -7200 1 -02} - {780454800 -10800 0 -03} - {796179600 -7200 1 -02} - {811904400 -10800 0 -03} - {828234000 -7200 1 -02} - {846378000 -10800 0 -03} - {859683600 -7200 1 -02} - {877827600 -10800 0 -03} - {891133200 -7200 1 -02} - {909277200 -10800 0 -03} - {922582800 -7200 1 -02} - {941331600 -10800 0 -03} - {954032400 -7200 1 -02} - {972781200 -10800 0 -03} - {985482000 -7200 1 -02} - {1004230800 -10800 0 -03} - {1017536400 -7200 1 -02} - {1035680400 -10800 0 -03} - {1048986000 -7200 1 -02} - {1067130000 -10800 0 -03} - {1080435600 -7200 1 -02} - {1099184400 -10800 0 -03} - {1111885200 -7200 1 -02} - {1130634000 -10800 0 -03} - {1143334800 -7200 1 -02} - {1162083600 -10800 0 -03} - {1174784400 -7200 1 -02} - {1193533200 -10800 0 -03} - {1206838800 -7200 1 -02} - {1224982800 -10800 0 -03} - {1238288400 -7200 1 -02} - {1256432400 -10800 0 -03} - {1269738000 -7200 1 -02} - {1288486800 -10800 0 -03} - {1301187600 -7200 1 -02} - {1319936400 -10800 0 -03} - {1332637200 -7200 1 -02} - {1351386000 -10800 0 -03} - {1364691600 -7200 1 -02} - {1382835600 -10800 0 -03} - {1396141200 -7200 1 -02} - {1414285200 -10800 0 -03} - {1427590800 -7200 1 -02} - {1445734800 -10800 0 -03} - {1459040400 -7200 1 -02} - {1477789200 -10800 0 -03} - {1490490000 -7200 1 -02} - {1509238800 -10800 0 -03} - {1521939600 -7200 1 -02} - {1540688400 -10800 0 -03} - {1553994000 -7200 1 -02} - {1572138000 -10800 0 -03} - {1585443600 -7200 1 -02} - {1603587600 -10800 0 -03} - {1616893200 -7200 1 -02} - {1635642000 -10800 0 -03} - {1648342800 -7200 1 -02} - {1667091600 -10800 0 -03} - {1679792400 -7200 1 -02} - {1698541200 -10800 0 -03} - {1711846800 -7200 1 -02} - {1729990800 -10800 0 -03} - {1743296400 -7200 1 -02} - {1761440400 -10800 0 -03} - {1774746000 -7200 1 -02} - {1792890000 -10800 0 -03} - {1806195600 -7200 1 -02} - {1824944400 -10800 0 -03} - {1837645200 -7200 1 -02} - {1856394000 -10800 0 -03} - {1869094800 -7200 1 -02} - {1887843600 -10800 0 -03} - {1901149200 -7200 1 -02} - {1919293200 -10800 0 -03} - {1932598800 -7200 1 -02} - {1950742800 -10800 0 -03} - {1964048400 -7200 1 -02} - {1982797200 -10800 0 -03} - {1995498000 -7200 1 -02} - {2014246800 -10800 0 -03} - {2026947600 -7200 1 -02} - {2045696400 -10800 0 -03} - {2058397200 -7200 1 -02} - {2077146000 -10800 0 -03} - {2090451600 -7200 1 -02} - {2108595600 -10800 0 -03} - {2121901200 -7200 1 -02} - {2140045200 -10800 0 -03} - {2153350800 -7200 1 -02} - {2172099600 -10800 0 -03} - {2184800400 -7200 1 -02} - {2203549200 -10800 0 -03} - {2216250000 -7200 1 -02} - {2234998800 -10800 0 -03} - {2248304400 -7200 1 -02} - {2266448400 -10800 0 -03} - {2279754000 -7200 1 -02} - {2297898000 -10800 0 -03} - {2311203600 -7200 1 -02} - {2329347600 -10800 0 -03} - {2342653200 -7200 1 -02} - {2361402000 -10800 0 -03} - {2374102800 -7200 1 -02} - {2392851600 -10800 0 -03} - {2405552400 -7200 1 -02} - {2424301200 -10800 0 -03} - {2437606800 -7200 1 -02} - {2455750800 -10800 0 -03} - {2469056400 -7200 1 -02} - {2487200400 -10800 0 -03} - {2500506000 -7200 1 -02} - {2519254800 -10800 0 -03} - {2531955600 -7200 1 -02} - {2550704400 -10800 0 -03} - {2563405200 -7200 1 -02} - {2582154000 -10800 0 -03} - {2595459600 -7200 1 -02} - {2613603600 -10800 0 -03} - {2626909200 -7200 1 -02} - {2645053200 -10800 0 -03} - {2658358800 -7200 1 -02} - {2676502800 -10800 0 -03} - {2689808400 -7200 1 -02} - {2708557200 -10800 0 -03} - {2721258000 -7200 1 -02} - {2740006800 -10800 0 -03} - {2752707600 -7200 1 -02} - {2771456400 -10800 0 -03} - {2784762000 -7200 1 -02} - {2802906000 -10800 0 -03} - {2816211600 -7200 1 -02} - {2834355600 -10800 0 -03} - {2847661200 -7200 1 -02} - {2866410000 -10800 0 -03} - {2879110800 -7200 1 -02} - {2897859600 -10800 0 -03} - {2910560400 -7200 1 -02} - {2929309200 -10800 0 -03} - {2942010000 -7200 1 -02} - {2960758800 -10800 0 -03} - {2974064400 -7200 1 -02} - {2992208400 -10800 0 -03} - {3005514000 -7200 1 -02} - {3023658000 -10800 0 -03} - {3036963600 -7200 1 -02} - {3055712400 -10800 0 -03} - {3068413200 -7200 1 -02} - {3087162000 -10800 0 -03} - {3099862800 -7200 1 -02} - {3118611600 -10800 0 -03} - {3131917200 -7200 1 -02} - {3150061200 -10800 0 -03} - {3163366800 -7200 1 -02} - {3181510800 -10800 0 -03} - {3194816400 -7200 1 -02} - {3212960400 -10800 0 -03} - {3226266000 -7200 1 -02} - {3245014800 -10800 0 -03} - {3257715600 -7200 1 -02} - {3276464400 -10800 0 -03} - {3289165200 -7200 1 -02} - {3307914000 -10800 0 -03} - {3321219600 -7200 1 -02} - {3339363600 -10800 0 -03} - {3352669200 -7200 1 -02} - {3370813200 -10800 0 -03} - {3384118800 -7200 1 -02} - {3402867600 -10800 0 -03} - {3415568400 -7200 1 -02} - {3434317200 -10800 0 -03} - {3447018000 -7200 1 -02} - {3465766800 -10800 0 -03} - {3479072400 -7200 1 -02} - {3497216400 -10800 0 -03} - {3510522000 -7200 1 -02} - {3528666000 -10800 0 -03} - {3541971600 -7200 1 -02} - {3560115600 -10800 0 -03} - {3573421200 -7200 1 -02} - {3592170000 -10800 0 -03} - {3604870800 -7200 1 -02} - {3623619600 -10800 0 -03} - {3636320400 -7200 1 -02} - {3655069200 -10800 0 -03} - {3668374800 -7200 1 -02} - {3686518800 -10800 0 -03} - {3699824400 -7200 1 -02} - {3717968400 -10800 0 -03} - {3731274000 -7200 1 -02} - {3750022800 -10800 0 -03} - {3762723600 -7200 1 -02} - {3781472400 -10800 0 -03} - {3794173200 -7200 1 -02} - {3812922000 -10800 0 -03} - {3825622800 -7200 1 -02} - {3844371600 -10800 0 -03} - {3857677200 -7200 1 -02} - {3875821200 -10800 0 -03} - {3889126800 -7200 1 -02} - {3907270800 -10800 0 -03} - {3920576400 -7200 1 -02} - {3939325200 -10800 0 -03} - {3952026000 -7200 1 -02} - {3970774800 -10800 0 -03} - {3983475600 -7200 1 -02} - {4002224400 -10800 0 -03} - {4015530000 -7200 1 -02} - {4033674000 -10800 0 -03} - {4046979600 -7200 1 -02} - {4065123600 -10800 0 -03} - {4078429200 -7200 1 -02} - {4096573200 -10800 0 -03} +if {![info exists TZData(America/Nuuk)]} { + LoadTimeZoneFile America/Nuuk } +set TZData(:America/Godthab) $TZData(:America/Nuuk) diff --git a/amd64/lib/tcl8.6/tzdata/America/Grand_Turk b/amd64/lib/tcl8.6/tzdata/America/Grand_Turk index da5f09b..414b0f9 100644 --- a/amd64/lib/tcl8.6/tzdata/America/Grand_Turk +++ b/amd64/lib/tcl8.6/tzdata/America/Grand_Turk @@ -77,8 +77,7 @@ set TZData(:America/Grand_Turk) { {1383458400 -18000 0 EST} {1394348400 -14400 1 EDT} {1414908000 -18000 0 EST} - {1425798000 -14400 1 EDT} - {1446361200 -14400 0 AST} + {1425798000 -14400 0 AST} {1520751600 -14400 0 EDT} {1541311200 -18000 0 EST} {1552201200 -14400 1 EDT} diff --git a/amd64/lib/tcl8.6/tzdata/America/Nassau b/amd64/lib/tcl8.6/tzdata/America/Nassau index 1c35e93..292c56d 100644 --- a/amd64/lib/tcl8.6/tzdata/America/Nassau +++ b/amd64/lib/tcl8.6/tzdata/America/Nassau @@ -3,6 +3,11 @@ set TZData(:America/Nassau) { {-9223372036854775808 -18570 0 LMT} {-1825095030 -18000 0 EST} + {-873140400 -14400 1 EWT} + {-788904000 -18000 0 EST} + {-786222000 -14400 1 EWT} + {-769395600 -14400 1 EPT} + {-763848000 -18000 0 EST} {-179341200 -14400 1 EDT} {-163620000 -18000 0 EST} {-147891600 -14400 1 EDT} diff --git a/amd64/lib/tcl8.6/tzdata/America/Nuuk b/amd64/lib/tcl8.6/tzdata/America/Nuuk new file mode 100644 index 0000000..8d85a81 --- /dev/null +++ b/amd64/lib/tcl8.6/tzdata/America/Nuuk @@ -0,0 +1,246 @@ +# created by tools/tclZIC.tcl - do not edit + +set TZData(:America/Nuuk) { + {-9223372036854775808 -12416 0 LMT} + {-1686083584 -10800 0 -03} + {323845200 -7200 0 -02} + {338950800 -10800 0 -03} + {354675600 -7200 1 -02} + {370400400 -10800 0 -03} + {386125200 -7200 1 -02} + {401850000 -10800 0 -03} + {417574800 -7200 1 -02} + {433299600 -10800 0 -03} + {449024400 -7200 1 -02} + {465354000 -10800 0 -03} + {481078800 -7200 1 -02} + {496803600 -10800 0 -03} + {512528400 -7200 1 -02} + {528253200 -10800 0 -03} + {543978000 -7200 1 -02} + {559702800 -10800 0 -03} + {575427600 -7200 1 -02} + {591152400 -10800 0 -03} + {606877200 -7200 1 -02} + {622602000 -10800 0 -03} + {638326800 -7200 1 -02} + {654656400 -10800 0 -03} + {670381200 -7200 1 -02} + {686106000 -10800 0 -03} + {701830800 -7200 1 -02} + {717555600 -10800 0 -03} + {733280400 -7200 1 -02} + {749005200 -10800 0 -03} + {764730000 -7200 1 -02} + {780454800 -10800 0 -03} + {796179600 -7200 1 -02} + {811904400 -10800 0 -03} + {828234000 -7200 1 -02} + {846378000 -10800 0 -03} + {859683600 -7200 1 -02} + {877827600 -10800 0 -03} + {891133200 -7200 1 -02} + {909277200 -10800 0 -03} + {922582800 -7200 1 -02} + {941331600 -10800 0 -03} + {954032400 -7200 1 -02} + {972781200 -10800 0 -03} + {985482000 -7200 1 -02} + {1004230800 -10800 0 -03} + {1017536400 -7200 1 -02} + {1035680400 -10800 0 -03} + {1048986000 -7200 1 -02} + {1067130000 -10800 0 -03} + {1080435600 -7200 1 -02} + {1099184400 -10800 0 -03} + {1111885200 -7200 1 -02} + {1130634000 -10800 0 -03} + {1143334800 -7200 1 -02} + {1162083600 -10800 0 -03} + {1174784400 -7200 1 -02} + {1193533200 -10800 0 -03} + {1206838800 -7200 1 -02} + {1224982800 -10800 0 -03} + {1238288400 -7200 1 -02} + {1256432400 -10800 0 -03} + {1269738000 -7200 1 -02} + {1288486800 -10800 0 -03} + {1301187600 -7200 1 -02} + {1319936400 -10800 0 -03} + {1332637200 -7200 1 -02} + {1351386000 -10800 0 -03} + {1364691600 -7200 1 -02} + {1382835600 -10800 0 -03} + {1396141200 -7200 1 -02} + {1414285200 -10800 0 -03} + {1427590800 -7200 1 -02} + {1445734800 -10800 0 -03} + {1459040400 -7200 1 -02} + {1477789200 -10800 0 -03} + {1490490000 -7200 1 -02} + {1509238800 -10800 0 -03} + {1521939600 -7200 1 -02} + {1540688400 -10800 0 -03} + {1553994000 -7200 1 -02} + {1572138000 -10800 0 -03} + {1585443600 -7200 1 -02} + {1603587600 -10800 0 -03} + {1616893200 -7200 1 -02} + {1635642000 -10800 0 -03} + {1648342800 -7200 1 -02} + {1667091600 -10800 0 -03} + {1679792400 -7200 1 -02} + {1698541200 -10800 0 -03} + {1711846800 -7200 1 -02} + {1729990800 -10800 0 -03} + {1743296400 -7200 1 -02} + {1761440400 -10800 0 -03} + {1774746000 -7200 1 -02} + {1792890000 -10800 0 -03} + {1806195600 -7200 1 -02} + {1824944400 -10800 0 -03} + {1837645200 -7200 1 -02} + {1856394000 -10800 0 -03} + {1869094800 -7200 1 -02} + {1887843600 -10800 0 -03} + {1901149200 -7200 1 -02} + {1919293200 -10800 0 -03} + {1932598800 -7200 1 -02} + {1950742800 -10800 0 -03} + {1964048400 -7200 1 -02} + {1982797200 -10800 0 -03} + {1995498000 -7200 1 -02} + {2014246800 -10800 0 -03} + {2026947600 -7200 1 -02} + {2045696400 -10800 0 -03} + {2058397200 -7200 1 -02} + {2077146000 -10800 0 -03} + {2090451600 -7200 1 -02} + {2108595600 -10800 0 -03} + {2121901200 -7200 1 -02} + {2140045200 -10800 0 -03} + {2153350800 -7200 1 -02} + {2172099600 -10800 0 -03} + {2184800400 -7200 1 -02} + {2203549200 -10800 0 -03} + {2216250000 -7200 1 -02} + {2234998800 -10800 0 -03} + {2248304400 -7200 1 -02} + {2266448400 -10800 0 -03} + {2279754000 -7200 1 -02} + {2297898000 -10800 0 -03} + {2311203600 -7200 1 -02} + {2329347600 -10800 0 -03} + {2342653200 -7200 1 -02} + {2361402000 -10800 0 -03} + {2374102800 -7200 1 -02} + {2392851600 -10800 0 -03} + {2405552400 -7200 1 -02} + {2424301200 -10800 0 -03} + {2437606800 -7200 1 -02} + {2455750800 -10800 0 -03} + {2469056400 -7200 1 -02} + {2487200400 -10800 0 -03} + {2500506000 -7200 1 -02} + {2519254800 -10800 0 -03} + {2531955600 -7200 1 -02} + {2550704400 -10800 0 -03} + {2563405200 -7200 1 -02} + {2582154000 -10800 0 -03} + {2595459600 -7200 1 -02} + {2613603600 -10800 0 -03} + {2626909200 -7200 1 -02} + {2645053200 -10800 0 -03} + {2658358800 -7200 1 -02} + {2676502800 -10800 0 -03} + {2689808400 -7200 1 -02} + {2708557200 -10800 0 -03} + {2721258000 -7200 1 -02} + {2740006800 -10800 0 -03} + {2752707600 -7200 1 -02} + {2771456400 -10800 0 -03} + {2784762000 -7200 1 -02} + {2802906000 -10800 0 -03} + {2816211600 -7200 1 -02} + {2834355600 -10800 0 -03} + {2847661200 -7200 1 -02} + {2866410000 -10800 0 -03} + {2879110800 -7200 1 -02} + {2897859600 -10800 0 -03} + {2910560400 -7200 1 -02} + {2929309200 -10800 0 -03} + {2942010000 -7200 1 -02} + {2960758800 -10800 0 -03} + {2974064400 -7200 1 -02} + {2992208400 -10800 0 -03} + {3005514000 -7200 1 -02} + {3023658000 -10800 0 -03} + {3036963600 -7200 1 -02} + {3055712400 -10800 0 -03} + {3068413200 -7200 1 -02} + {3087162000 -10800 0 -03} + {3099862800 -7200 1 -02} + {3118611600 -10800 0 -03} + {3131917200 -7200 1 -02} + {3150061200 -10800 0 -03} + {3163366800 -7200 1 -02} + {3181510800 -10800 0 -03} + {3194816400 -7200 1 -02} + {3212960400 -10800 0 -03} + {3226266000 -7200 1 -02} + {3245014800 -10800 0 -03} + {3257715600 -7200 1 -02} + {3276464400 -10800 0 -03} + {3289165200 -7200 1 -02} + {3307914000 -10800 0 -03} + {3321219600 -7200 1 -02} + {3339363600 -10800 0 -03} + {3352669200 -7200 1 -02} + {3370813200 -10800 0 -03} + {3384118800 -7200 1 -02} + {3402867600 -10800 0 -03} + {3415568400 -7200 1 -02} + {3434317200 -10800 0 -03} + {3447018000 -7200 1 -02} + {3465766800 -10800 0 -03} + {3479072400 -7200 1 -02} + {3497216400 -10800 0 -03} + {3510522000 -7200 1 -02} + {3528666000 -10800 0 -03} + {3541971600 -7200 1 -02} + {3560115600 -10800 0 -03} + {3573421200 -7200 1 -02} + {3592170000 -10800 0 -03} + {3604870800 -7200 1 -02} + {3623619600 -10800 0 -03} + {3636320400 -7200 1 -02} + {3655069200 -10800 0 -03} + {3668374800 -7200 1 -02} + {3686518800 -10800 0 -03} + {3699824400 -7200 1 -02} + {3717968400 -10800 0 -03} + {3731274000 -7200 1 -02} + {3750022800 -10800 0 -03} + {3762723600 -7200 1 -02} + {3781472400 -10800 0 -03} + {3794173200 -7200 1 -02} + {3812922000 -10800 0 -03} + {3825622800 -7200 1 -02} + {3844371600 -10800 0 -03} + {3857677200 -7200 1 -02} + {3875821200 -10800 0 -03} + {3889126800 -7200 1 -02} + {3907270800 -10800 0 -03} + {3920576400 -7200 1 -02} + {3939325200 -10800 0 -03} + {3952026000 -7200 1 -02} + {3970774800 -10800 0 -03} + {3983475600 -7200 1 -02} + {4002224400 -10800 0 -03} + {4015530000 -7200 1 -02} + {4033674000 -10800 0 -03} + {4046979600 -7200 1 -02} + {4065123600 -10800 0 -03} + {4078429200 -7200 1 -02} + {4096573200 -10800 0 -03} +} diff --git a/amd64/lib/tcl8.6/tzdata/America/Whitehorse b/amd64/lib/tcl8.6/tzdata/America/Whitehorse index 1d61093..498a203 100644 --- a/amd64/lib/tcl8.6/tzdata/America/Whitehorse +++ b/amd64/lib/tcl8.6/tzdata/America/Whitehorse @@ -94,163 +94,5 @@ set TZData(:America/Whitehorse) { {1552212000 -25200 1 PDT} {1572771600 -28800 0 PST} {1583661600 -25200 1 PDT} - {1604221200 -28800 0 PST} - {1615716000 -25200 1 PDT} - {1636275600 -28800 0 PST} - {1647165600 -25200 1 PDT} - {1667725200 -28800 0 PST} - {1678615200 -25200 1 PDT} - {1699174800 -28800 0 PST} - {1710064800 -25200 1 PDT} - {1730624400 -28800 0 PST} - {1741514400 -25200 1 PDT} - {1762074000 -28800 0 PST} - {1772964000 -25200 1 PDT} - {1793523600 -28800 0 PST} - {1805018400 -25200 1 PDT} - {1825578000 -28800 0 PST} - {1836468000 -25200 1 PDT} - {1857027600 -28800 0 PST} - {1867917600 -25200 1 PDT} - {1888477200 -28800 0 PST} - {1899367200 -25200 1 PDT} - {1919926800 -28800 0 PST} - {1930816800 -25200 1 PDT} - {1951376400 -28800 0 PST} - {1962871200 -25200 1 PDT} - {1983430800 -28800 0 PST} - {1994320800 -25200 1 PDT} - {2014880400 -28800 0 PST} - {2025770400 -25200 1 PDT} - {2046330000 -28800 0 PST} - {2057220000 -25200 1 PDT} - {2077779600 -28800 0 PST} - {2088669600 -25200 1 PDT} - {2109229200 -28800 0 PST} - {2120119200 -25200 1 PDT} - {2140678800 -28800 0 PST} - {2152173600 -25200 1 PDT} - {2172733200 -28800 0 PST} - {2183623200 -25200 1 PDT} - {2204182800 -28800 0 PST} - {2215072800 -25200 1 PDT} - {2235632400 -28800 0 PST} - {2246522400 -25200 1 PDT} - {2267082000 -28800 0 PST} - {2277972000 -25200 1 PDT} - {2298531600 -28800 0 PST} - {2309421600 -25200 1 PDT} - {2329981200 -28800 0 PST} - {2341476000 -25200 1 PDT} - {2362035600 -28800 0 PST} - {2372925600 -25200 1 PDT} - {2393485200 -28800 0 PST} - {2404375200 -25200 1 PDT} - {2424934800 -28800 0 PST} - {2435824800 -25200 1 PDT} - {2456384400 -28800 0 PST} - {2467274400 -25200 1 PDT} - {2487834000 -28800 0 PST} - {2499328800 -25200 1 PDT} - {2519888400 -28800 0 PST} - {2530778400 -25200 1 PDT} - {2551338000 -28800 0 PST} - {2562228000 -25200 1 PDT} - {2582787600 -28800 0 PST} - {2593677600 -25200 1 PDT} - {2614237200 -28800 0 PST} - {2625127200 -25200 1 PDT} - {2645686800 -28800 0 PST} - {2656576800 -25200 1 PDT} - {2677136400 -28800 0 PST} - {2688631200 -25200 1 PDT} - {2709190800 -28800 0 PST} - {2720080800 -25200 1 PDT} - {2740640400 -28800 0 PST} - {2751530400 -25200 1 PDT} - {2772090000 -28800 0 PST} - {2782980000 -25200 1 PDT} - {2803539600 -28800 0 PST} - {2814429600 -25200 1 PDT} - {2834989200 -28800 0 PST} - {2846484000 -25200 1 PDT} - {2867043600 -28800 0 PST} - {2877933600 -25200 1 PDT} - {2898493200 -28800 0 PST} - {2909383200 -25200 1 PDT} - {2929942800 -28800 0 PST} - {2940832800 -25200 1 PDT} - {2961392400 -28800 0 PST} - {2972282400 -25200 1 PDT} - {2992842000 -28800 0 PST} - {3003732000 -25200 1 PDT} - {3024291600 -28800 0 PST} - {3035786400 -25200 1 PDT} - {3056346000 -28800 0 PST} - {3067236000 -25200 1 PDT} - {3087795600 -28800 0 PST} - {3098685600 -25200 1 PDT} - {3119245200 -28800 0 PST} - {3130135200 -25200 1 PDT} - {3150694800 -28800 0 PST} - {3161584800 -25200 1 PDT} - {3182144400 -28800 0 PST} - {3193034400 -25200 1 PDT} - {3213594000 -28800 0 PST} - {3225088800 -25200 1 PDT} - {3245648400 -28800 0 PST} - {3256538400 -25200 1 PDT} - {3277098000 -28800 0 PST} - {3287988000 -25200 1 PDT} - {3308547600 -28800 0 PST} - {3319437600 -25200 1 PDT} - {3339997200 -28800 0 PST} - {3350887200 -25200 1 PDT} - {3371446800 -28800 0 PST} - {3382941600 -25200 1 PDT} - {3403501200 -28800 0 PST} - {3414391200 -25200 1 PDT} - {3434950800 -28800 0 PST} - {3445840800 -25200 1 PDT} - {3466400400 -28800 0 PST} - {3477290400 -25200 1 PDT} - {3497850000 -28800 0 PST} - {3508740000 -25200 1 PDT} - {3529299600 -28800 0 PST} - {3540189600 -25200 1 PDT} - {3560749200 -28800 0 PST} - {3572244000 -25200 1 PDT} - {3592803600 -28800 0 PST} - {3603693600 -25200 1 PDT} - {3624253200 -28800 0 PST} - {3635143200 -25200 1 PDT} - {3655702800 -28800 0 PST} - {3666592800 -25200 1 PDT} - {3687152400 -28800 0 PST} - {3698042400 -25200 1 PDT} - {3718602000 -28800 0 PST} - {3730096800 -25200 1 PDT} - {3750656400 -28800 0 PST} - {3761546400 -25200 1 PDT} - {3782106000 -28800 0 PST} - {3792996000 -25200 1 PDT} - {3813555600 -28800 0 PST} - {3824445600 -25200 1 PDT} - {3845005200 -28800 0 PST} - {3855895200 -25200 1 PDT} - {3876454800 -28800 0 PST} - {3887344800 -25200 1 PDT} - {3907904400 -28800 0 PST} - {3919399200 -25200 1 PDT} - {3939958800 -28800 0 PST} - {3950848800 -25200 1 PDT} - {3971408400 -28800 0 PST} - {3982298400 -25200 1 PDT} - {4002858000 -28800 0 PST} - {4013748000 -25200 1 PDT} - {4034307600 -28800 0 PST} - {4045197600 -25200 1 PDT} - {4065757200 -28800 0 PST} - {4076647200 -25200 1 PDT} - {4097206800 -28800 0 PST} + {1604217600 -25200 0 MST} } diff --git a/amd64/lib/tcl8.6/tzdata/Antarctica/Casey b/amd64/lib/tcl8.6/tzdata/Antarctica/Casey index aa37480..56935e3 100644 --- a/amd64/lib/tcl8.6/tzdata/Antarctica/Casey +++ b/amd64/lib/tcl8.6/tzdata/Antarctica/Casey @@ -9,4 +9,9 @@ set TZData(:Antarctica/Casey) { {1329843600 28800 0 +08} {1477065600 39600 0 +11} {1520701200 28800 0 +08} + {1538856000 39600 0 +11} + {1552752000 28800 0 +08} + {1570129200 39600 0 +11} + {1583596800 28800 0 +08} + {1601740860 39600 0 +11} } diff --git a/amd64/lib/tcl8.6/tzdata/Antarctica/Macquarie b/amd64/lib/tcl8.6/tzdata/Antarctica/Macquarie index 60bf7a6..82b2b9f 100644 --- a/amd64/lib/tcl8.6/tzdata/Antarctica/Macquarie +++ b/amd64/lib/tcl8.6/tzdata/Antarctica/Macquarie @@ -5,7 +5,7 @@ set TZData(:Antarctica/Macquarie) { {-2214259200 36000 0 AEST} {-1680508800 39600 1 AEDT} {-1669892400 39600 0 AEDT} - {-1665392400 36000 0 AEST} + {-1665388800 36000 0 AEST} {-1601719200 0 0 -00} {-94730400 36000 0 AEST} {-71136000 39600 1 AEDT} @@ -93,5 +93,184 @@ set TZData(:Antarctica/Macquarie) { {1223136000 39600 1 AEDT} {1238860800 36000 0 AEST} {1254585600 39600 1 AEDT} - {1270310400 39600 0 +11} + {1262264400 39600 1 AEDT} + {1293800400 39600 0 AEST} + {1301760000 36000 0 AEST} + {1317484800 39600 1 AEDT} + {1333209600 36000 0 AEST} + {1349539200 39600 1 AEDT} + {1365264000 36000 0 AEST} + {1380988800 39600 1 AEDT} + {1396713600 36000 0 AEST} + {1412438400 39600 1 AEDT} + {1428163200 36000 0 AEST} + {1443888000 39600 1 AEDT} + {1459612800 36000 0 AEST} + {1475337600 39600 1 AEDT} + {1491062400 36000 0 AEST} + {1506787200 39600 1 AEDT} + {1522512000 36000 0 AEST} + {1538841600 39600 1 AEDT} + {1554566400 36000 0 AEST} + {1570291200 39600 1 AEDT} + {1586016000 36000 0 AEST} + {1601740800 39600 1 AEDT} + {1617465600 36000 0 AEST} + {1633190400 39600 1 AEDT} + {1648915200 36000 0 AEST} + {1664640000 39600 1 AEDT} + {1680364800 36000 0 AEST} + {1696089600 39600 1 AEDT} + {1712419200 36000 0 AEST} + {1728144000 39600 1 AEDT} + {1743868800 36000 0 AEST} + {1759593600 39600 1 AEDT} + {1775318400 36000 0 AEST} + {1791043200 39600 1 AEDT} + {1806768000 36000 0 AEST} + {1822492800 39600 1 AEDT} + {1838217600 36000 0 AEST} + {1853942400 39600 1 AEDT} + {1869667200 36000 0 AEST} + {1885996800 39600 1 AEDT} + {1901721600 36000 0 AEST} + {1917446400 39600 1 AEDT} + {1933171200 36000 0 AEST} + {1948896000 39600 1 AEDT} + {1964620800 36000 0 AEST} + {1980345600 39600 1 AEDT} + {1996070400 36000 0 AEST} + {2011795200 39600 1 AEDT} + {2027520000 36000 0 AEST} + {2043244800 39600 1 AEDT} + {2058969600 36000 0 AEST} + {2075299200 39600 1 AEDT} + {2091024000 36000 0 AEST} + {2106748800 39600 1 AEDT} + {2122473600 36000 0 AEST} + {2138198400 39600 1 AEDT} + {2153923200 36000 0 AEST} + {2169648000 39600 1 AEDT} + {2185372800 36000 0 AEST} + {2201097600 39600 1 AEDT} + {2216822400 36000 0 AEST} + {2233152000 39600 1 AEDT} + {2248876800 36000 0 AEST} + {2264601600 39600 1 AEDT} + {2280326400 36000 0 AEST} + {2296051200 39600 1 AEDT} + {2311776000 36000 0 AEST} + {2327500800 39600 1 AEDT} + {2343225600 36000 0 AEST} + {2358950400 39600 1 AEDT} + {2374675200 36000 0 AEST} + {2390400000 39600 1 AEDT} + {2406124800 36000 0 AEST} + {2422454400 39600 1 AEDT} + {2438179200 36000 0 AEST} + {2453904000 39600 1 AEDT} + {2469628800 36000 0 AEST} + {2485353600 39600 1 AEDT} + {2501078400 36000 0 AEST} + {2516803200 39600 1 AEDT} + {2532528000 36000 0 AEST} + {2548252800 39600 1 AEDT} + {2563977600 36000 0 AEST} + {2579702400 39600 1 AEDT} + {2596032000 36000 0 AEST} + {2611756800 39600 1 AEDT} + {2627481600 36000 0 AEST} + {2643206400 39600 1 AEDT} + {2658931200 36000 0 AEST} + {2674656000 39600 1 AEDT} + {2690380800 36000 0 AEST} + {2706105600 39600 1 AEDT} + {2721830400 36000 0 AEST} + {2737555200 39600 1 AEDT} + {2753280000 36000 0 AEST} + {2769609600 39600 1 AEDT} + {2785334400 36000 0 AEST} + {2801059200 39600 1 AEDT} + {2816784000 36000 0 AEST} + {2832508800 39600 1 AEDT} + {2848233600 36000 0 AEST} + {2863958400 39600 1 AEDT} + {2879683200 36000 0 AEST} + {2895408000 39600 1 AEDT} + {2911132800 36000 0 AEST} + {2926857600 39600 1 AEDT} + {2942582400 36000 0 AEST} + {2958912000 39600 1 AEDT} + {2974636800 36000 0 AEST} + {2990361600 39600 1 AEDT} + {3006086400 36000 0 AEST} + {3021811200 39600 1 AEDT} + {3037536000 36000 0 AEST} + {3053260800 39600 1 AEDT} + {3068985600 36000 0 AEST} + {3084710400 39600 1 AEDT} + {3100435200 36000 0 AEST} + {3116764800 39600 1 AEDT} + {3132489600 36000 0 AEST} + {3148214400 39600 1 AEDT} + {3163939200 36000 0 AEST} + {3179664000 39600 1 AEDT} + {3195388800 36000 0 AEST} + {3211113600 39600 1 AEDT} + {3226838400 36000 0 AEST} + {3242563200 39600 1 AEDT} + {3258288000 36000 0 AEST} + {3274012800 39600 1 AEDT} + {3289737600 36000 0 AEST} + {3306067200 39600 1 AEDT} + {3321792000 36000 0 AEST} + {3337516800 39600 1 AEDT} + {3353241600 36000 0 AEST} + {3368966400 39600 1 AEDT} + {3384691200 36000 0 AEST} + {3400416000 39600 1 AEDT} + {3416140800 36000 0 AEST} + {3431865600 39600 1 AEDT} + {3447590400 36000 0 AEST} + {3463315200 39600 1 AEDT} + {3479644800 36000 0 AEST} + {3495369600 39600 1 AEDT} + {3511094400 36000 0 AEST} + {3526819200 39600 1 AEDT} + {3542544000 36000 0 AEST} + {3558268800 39600 1 AEDT} + {3573993600 36000 0 AEST} + {3589718400 39600 1 AEDT} + {3605443200 36000 0 AEST} + {3621168000 39600 1 AEDT} + {3636892800 36000 0 AEST} + {3653222400 39600 1 AEDT} + {3668947200 36000 0 AEST} + {3684672000 39600 1 AEDT} + {3700396800 36000 0 AEST} + {3716121600 39600 1 AEDT} + {3731846400 36000 0 AEST} + {3747571200 39600 1 AEDT} + {3763296000 36000 0 AEST} + {3779020800 39600 1 AEDT} + {3794745600 36000 0 AEST} + {3810470400 39600 1 AEDT} + {3826195200 36000 0 AEST} + {3842524800 39600 1 AEDT} + {3858249600 36000 0 AEST} + {3873974400 39600 1 AEDT} + {3889699200 36000 0 AEST} + {3905424000 39600 1 AEDT} + {3921148800 36000 0 AEST} + {3936873600 39600 1 AEDT} + {3952598400 36000 0 AEST} + {3968323200 39600 1 AEDT} + {3984048000 36000 0 AEST} + {4000377600 39600 1 AEDT} + {4016102400 36000 0 AEST} + {4031827200 39600 1 AEDT} + {4047552000 36000 0 AEST} + {4063276800 39600 1 AEDT} + {4079001600 36000 0 AEST} + {4094726400 39600 1 AEDT} } diff --git a/amd64/lib/tcl8.6/tzdata/Asia/Gaza b/amd64/lib/tcl8.6/tzdata/Asia/Gaza index 9b73dcc..95523c9 100644 --- a/amd64/lib/tcl8.6/tzdata/Asia/Gaza +++ b/amd64/lib/tcl8.6/tzdata/Asia/Gaza @@ -3,16 +3,18 @@ set TZData(:Asia/Gaza) { {-9223372036854775808 8272 0 LMT} {-2185409872 7200 0 EEST} - {-933645600 10800 1 EEST} - {-857358000 7200 0 EEST} + {-933638400 10800 1 EEST} + {-923097600 7200 0 EEST} + {-919036800 10800 1 EEST} + {-857347200 7200 0 EEST} {-844300800 10800 1 EEST} - {-825822000 7200 0 EEST} - {-812685600 10800 1 EEST} - {-794199600 7200 0 EEST} - {-779853600 10800 1 EEST} - {-762656400 7200 0 EEST} + {-825811200 7200 0 EEST} + {-812678400 10800 1 EEST} + {-794188800 7200 0 EEST} + {-779846400 10800 1 EEST} + {-762652800 7200 0 EEST} {-748310400 10800 1 EEST} - {-731127600 7200 0 EEST} + {-731116800 7200 0 EEST} {-682653600 7200 0 EET} {-399088800 10800 1 EEST} {-386650800 7200 0 EET} @@ -40,12 +42,12 @@ set TZData(:Asia/Gaza) { {150843600 7200 0 IST} {167176800 10800 1 IDT} {178664400 7200 0 IST} - {334015200 10800 1 IDT} - {337644000 7200 0 IST} - {452556000 10800 1 IDT} - {462232800 7200 0 IST} + {334101600 10800 1 IDT} + {337730400 7200 0 IST} + {452642400 10800 1 IDT} + {462319200 7200 0 IST} {482277600 10800 1 IDT} - {495579600 7200 0 IST} + {494370000 7200 0 IST} {516751200 10800 1 IDT} {526424400 7200 0 IST} {545436000 10800 1 IDT} @@ -110,7 +112,7 @@ set TZData(:Asia/Gaza) { {1395957600 10800 1 EEST} {1414098000 7200 0 EET} {1427493600 10800 1 EEST} - {1445547600 7200 0 EET} + {1445551200 7200 0 EET} {1458946800 10800 1 EEST} {1477692000 7200 0 EET} {1490396400 10800 1 EEST} @@ -118,165 +120,165 @@ set TZData(:Asia/Gaza) { {1521846000 10800 1 EEST} {1540591200 7200 0 EET} {1553810400 10800 1 EEST} - {1572040800 7200 0 EET} - {1585260000 10800 1 EEST} - {1604095200 7200 0 EET} - {1616709600 10800 1 EEST} + {1572037200 7200 0 EET} + {1585346400 10800 1 EEST} + {1603490400 7200 0 EET} + {1616796000 10800 1 EEST} {1635544800 7200 0 EET} - {1648159200 10800 1 EEST} + {1648245600 10800 1 EEST} {1666994400 7200 0 EET} - {1680213600 10800 1 EEST} + {1679695200 10800 1 EEST} {1698444000 7200 0 EET} - {1711663200 10800 1 EEST} + {1711749600 10800 1 EEST} {1729893600 7200 0 EET} - {1743112800 10800 1 EEST} + {1743199200 10800 1 EEST} {1761343200 7200 0 EET} - {1774562400 10800 1 EEST} - {1793397600 7200 0 EET} - {1806012000 10800 1 EEST} + {1774648800 10800 1 EEST} + {1792792800 7200 0 EET} + {1806098400 10800 1 EEST} {1824847200 7200 0 EET} - {1838066400 10800 1 EEST} + {1837548000 10800 1 EEST} {1856296800 7200 0 EET} - {1869516000 10800 1 EEST} + {1868997600 10800 1 EEST} {1887746400 7200 0 EET} - {1900965600 10800 1 EEST} + {1901052000 10800 1 EEST} {1919196000 7200 0 EET} - {1932415200 10800 1 EEST} + {1932501600 10800 1 EEST} {1950645600 7200 0 EET} - {1963864800 10800 1 EEST} + {1963951200 10800 1 EEST} {1982700000 7200 0 EET} - {1995314400 10800 1 EEST} + {1995400800 10800 1 EEST} {2014149600 7200 0 EET} - {2027368800 10800 1 EEST} + {2026850400 10800 1 EEST} {2045599200 7200 0 EET} - {2058818400 10800 1 EEST} + {2058300000 10800 1 EEST} {2077048800 7200 0 EET} - {2090268000 10800 1 EEST} + {2090354400 10800 1 EEST} {2108498400 7200 0 EET} - {2121717600 10800 1 EEST} - {2140552800 7200 0 EET} - {2153167200 10800 1 EEST} + {2121804000 10800 1 EEST} + {2139948000 7200 0 EET} + {2153253600 10800 1 EEST} {2172002400 7200 0 EET} - {2184616800 10800 1 EEST} + {2184703200 10800 1 EEST} {2203452000 7200 0 EET} - {2216671200 10800 1 EEST} + {2216152800 10800 1 EEST} {2234901600 7200 0 EET} - {2248120800 10800 1 EEST} + {2248207200 10800 1 EEST} {2266351200 7200 0 EET} - {2279570400 10800 1 EEST} + {2279656800 10800 1 EEST} {2297800800 7200 0 EET} - {2311020000 10800 1 EEST} - {2329855200 7200 0 EET} - {2342469600 10800 1 EEST} + {2311106400 10800 1 EEST} + {2329250400 7200 0 EET} + {2342556000 10800 1 EEST} {2361304800 7200 0 EET} - {2374524000 10800 1 EEST} + {2374005600 10800 1 EEST} {2392754400 7200 0 EET} - {2405973600 10800 1 EEST} + {2405455200 10800 1 EEST} {2424204000 7200 0 EET} - {2437423200 10800 1 EEST} + {2437509600 10800 1 EEST} {2455653600 7200 0 EET} - {2468872800 10800 1 EEST} - {2487708000 7200 0 EET} - {2500322400 10800 1 EEST} + {2468959200 10800 1 EEST} + {2487103200 7200 0 EET} + {2500408800 10800 1 EEST} {2519157600 7200 0 EET} - {2531772000 10800 1 EEST} + {2531858400 10800 1 EEST} {2550607200 7200 0 EET} - {2563826400 10800 1 EEST} + {2563308000 10800 1 EEST} {2582056800 7200 0 EET} - {2595276000 10800 1 EEST} + {2595362400 10800 1 EEST} {2613506400 7200 0 EET} - {2626725600 10800 1 EEST} + {2626812000 10800 1 EEST} {2644956000 7200 0 EET} - {2658175200 10800 1 EEST} - {2677010400 7200 0 EET} - {2689624800 10800 1 EEST} + {2658261600 10800 1 EEST} + {2676405600 7200 0 EET} + {2689711200 10800 1 EEST} {2708460000 7200 0 EET} - {2721679200 10800 1 EEST} + {2721160800 10800 1 EEST} {2739909600 7200 0 EET} - {2753128800 10800 1 EEST} + {2752610400 10800 1 EEST} {2771359200 7200 0 EET} - {2784578400 10800 1 EEST} + {2784664800 10800 1 EEST} {2802808800 7200 0 EET} - {2816028000 10800 1 EEST} + {2816114400 10800 1 EEST} {2834258400 7200 0 EET} - {2847477600 10800 1 EEST} + {2847564000 10800 1 EEST} {2866312800 7200 0 EET} - {2878927200 10800 1 EEST} + {2879013600 10800 1 EEST} {2897762400 7200 0 EET} - {2910981600 10800 1 EEST} + {2910463200 10800 1 EEST} {2929212000 7200 0 EET} - {2942431200 10800 1 EEST} + {2941912800 10800 1 EEST} {2960661600 7200 0 EET} - {2973880800 10800 1 EEST} + {2973967200 10800 1 EEST} {2992111200 7200 0 EET} - {3005330400 10800 1 EEST} - {3024165600 7200 0 EET} - {3036780000 10800 1 EEST} + {3005416800 10800 1 EEST} + {3023560800 7200 0 EET} + {3036866400 10800 1 EEST} {3055615200 7200 0 EET} - {3068229600 10800 1 EEST} + {3068316000 10800 1 EEST} {3087064800 7200 0 EET} - {3100284000 10800 1 EEST} + {3099765600 10800 1 EEST} {3118514400 7200 0 EET} - {3131733600 10800 1 EEST} + {3131820000 10800 1 EEST} {3149964000 7200 0 EET} - {3163183200 10800 1 EEST} + {3163269600 10800 1 EEST} {3181413600 7200 0 EET} - {3194632800 10800 1 EEST} - {3213468000 7200 0 EET} - {3226082400 10800 1 EEST} + {3194719200 10800 1 EEST} + {3212863200 7200 0 EET} + {3226168800 10800 1 EEST} {3244917600 7200 0 EET} - {3258136800 10800 1 EEST} + {3257618400 10800 1 EEST} {3276367200 7200 0 EET} - {3289586400 10800 1 EEST} + {3289068000 10800 1 EEST} {3307816800 7200 0 EET} - {3321036000 10800 1 EEST} + {3321122400 10800 1 EEST} {3339266400 7200 0 EET} - {3352485600 10800 1 EEST} - {3371320800 7200 0 EET} - {3383935200 10800 1 EEST} + {3352572000 10800 1 EEST} + {3370716000 7200 0 EET} + {3384021600 10800 1 EEST} {3402770400 7200 0 EET} - {3415384800 10800 1 EEST} + {3415471200 10800 1 EEST} {3434220000 7200 0 EET} - {3447439200 10800 1 EEST} + {3446920800 10800 1 EEST} {3465669600 7200 0 EET} - {3478888800 10800 1 EEST} + {3478975200 10800 1 EEST} {3497119200 7200 0 EET} - {3510338400 10800 1 EEST} + {3510424800 10800 1 EEST} {3528568800 7200 0 EET} - {3541788000 10800 1 EEST} - {3560623200 7200 0 EET} - {3573237600 10800 1 EEST} + {3541874400 10800 1 EEST} + {3560018400 7200 0 EET} + {3573324000 10800 1 EEST} {3592072800 7200 0 EET} - {3605292000 10800 1 EEST} + {3604773600 10800 1 EEST} {3623522400 7200 0 EET} - {3636741600 10800 1 EEST} + {3636223200 10800 1 EEST} {3654972000 7200 0 EET} - {3668191200 10800 1 EEST} + {3668277600 10800 1 EEST} {3686421600 7200 0 EET} - {3699640800 10800 1 EEST} + {3699727200 10800 1 EEST} {3717871200 7200 0 EET} - {3731090400 10800 1 EEST} + {3731176800 10800 1 EEST} {3749925600 7200 0 EET} - {3762540000 10800 1 EEST} + {3762626400 10800 1 EEST} {3781375200 7200 0 EET} - {3794594400 10800 1 EEST} + {3794076000 10800 1 EEST} {3812824800 7200 0 EET} - {3826044000 10800 1 EEST} + {3825525600 10800 1 EEST} {3844274400 7200 0 EET} - {3857493600 10800 1 EEST} + {3857580000 10800 1 EEST} {3875724000 7200 0 EET} - {3888943200 10800 1 EEST} - {3907778400 7200 0 EET} - {3920392800 10800 1 EEST} + {3889029600 10800 1 EEST} + {3907173600 7200 0 EET} + {3920479200 10800 1 EEST} {3939228000 7200 0 EET} - {3951842400 10800 1 EEST} + {3951928800 10800 1 EEST} {3970677600 7200 0 EET} - {3983896800 10800 1 EEST} + {3983378400 10800 1 EEST} {4002127200 7200 0 EET} - {4015346400 10800 1 EEST} + {4015432800 10800 1 EEST} {4033576800 7200 0 EET} - {4046796000 10800 1 EEST} + {4046882400 10800 1 EEST} {4065026400 7200 0 EET} - {4078245600 10800 1 EEST} - {4097080800 7200 0 EET} + {4078332000 10800 1 EEST} + {4096476000 7200 0 EET} } diff --git a/amd64/lib/tcl8.6/tzdata/Asia/Hebron b/amd64/lib/tcl8.6/tzdata/Asia/Hebron index fe8f7e1..3fdcd65 100644 --- a/amd64/lib/tcl8.6/tzdata/Asia/Hebron +++ b/amd64/lib/tcl8.6/tzdata/Asia/Hebron @@ -3,16 +3,18 @@ set TZData(:Asia/Hebron) { {-9223372036854775808 8423 0 LMT} {-2185410023 7200 0 EEST} - {-933645600 10800 1 EEST} - {-857358000 7200 0 EEST} + {-933638400 10800 1 EEST} + {-923097600 7200 0 EEST} + {-919036800 10800 1 EEST} + {-857347200 7200 0 EEST} {-844300800 10800 1 EEST} - {-825822000 7200 0 EEST} - {-812685600 10800 1 EEST} - {-794199600 7200 0 EEST} - {-779853600 10800 1 EEST} - {-762656400 7200 0 EEST} + {-825811200 7200 0 EEST} + {-812678400 10800 1 EEST} + {-794188800 7200 0 EEST} + {-779846400 10800 1 EEST} + {-762652800 7200 0 EEST} {-748310400 10800 1 EEST} - {-731127600 7200 0 EEST} + {-731116800 7200 0 EEST} {-682653600 7200 0 EET} {-399088800 10800 1 EEST} {-386650800 7200 0 EET} @@ -40,12 +42,12 @@ set TZData(:Asia/Hebron) { {150843600 7200 0 IST} {167176800 10800 1 IDT} {178664400 7200 0 IST} - {334015200 10800 1 IDT} - {337644000 7200 0 IST} - {452556000 10800 1 IDT} - {462232800 7200 0 IST} + {334101600 10800 1 IDT} + {337730400 7200 0 IST} + {452642400 10800 1 IDT} + {462319200 7200 0 IST} {482277600 10800 1 IDT} - {495579600 7200 0 IST} + {494370000 7200 0 IST} {516751200 10800 1 IDT} {526424400 7200 0 IST} {545436000 10800 1 IDT} @@ -109,7 +111,7 @@ set TZData(:Asia/Hebron) { {1395957600 10800 1 EEST} {1414098000 7200 0 EET} {1427493600 10800 1 EEST} - {1445547600 7200 0 EET} + {1445551200 7200 0 EET} {1458946800 10800 1 EEST} {1477692000 7200 0 EET} {1490396400 10800 1 EEST} @@ -117,165 +119,165 @@ set TZData(:Asia/Hebron) { {1521846000 10800 1 EEST} {1540591200 7200 0 EET} {1553810400 10800 1 EEST} - {1572040800 7200 0 EET} - {1585260000 10800 1 EEST} - {1604095200 7200 0 EET} - {1616709600 10800 1 EEST} + {1572037200 7200 0 EET} + {1585346400 10800 1 EEST} + {1603490400 7200 0 EET} + {1616796000 10800 1 EEST} {1635544800 7200 0 EET} - {1648159200 10800 1 EEST} + {1648245600 10800 1 EEST} {1666994400 7200 0 EET} - {1680213600 10800 1 EEST} + {1679695200 10800 1 EEST} {1698444000 7200 0 EET} - {1711663200 10800 1 EEST} + {1711749600 10800 1 EEST} {1729893600 7200 0 EET} - {1743112800 10800 1 EEST} + {1743199200 10800 1 EEST} {1761343200 7200 0 EET} - {1774562400 10800 1 EEST} - {1793397600 7200 0 EET} - {1806012000 10800 1 EEST} + {1774648800 10800 1 EEST} + {1792792800 7200 0 EET} + {1806098400 10800 1 EEST} {1824847200 7200 0 EET} - {1838066400 10800 1 EEST} + {1837548000 10800 1 EEST} {1856296800 7200 0 EET} - {1869516000 10800 1 EEST} + {1868997600 10800 1 EEST} {1887746400 7200 0 EET} - {1900965600 10800 1 EEST} + {1901052000 10800 1 EEST} {1919196000 7200 0 EET} - {1932415200 10800 1 EEST} + {1932501600 10800 1 EEST} {1950645600 7200 0 EET} - {1963864800 10800 1 EEST} + {1963951200 10800 1 EEST} {1982700000 7200 0 EET} - {1995314400 10800 1 EEST} + {1995400800 10800 1 EEST} {2014149600 7200 0 EET} - {2027368800 10800 1 EEST} + {2026850400 10800 1 EEST} {2045599200 7200 0 EET} - {2058818400 10800 1 EEST} + {2058300000 10800 1 EEST} {2077048800 7200 0 EET} - {2090268000 10800 1 EEST} + {2090354400 10800 1 EEST} {2108498400 7200 0 EET} - {2121717600 10800 1 EEST} - {2140552800 7200 0 EET} - {2153167200 10800 1 EEST} + {2121804000 10800 1 EEST} + {2139948000 7200 0 EET} + {2153253600 10800 1 EEST} {2172002400 7200 0 EET} - {2184616800 10800 1 EEST} + {2184703200 10800 1 EEST} {2203452000 7200 0 EET} - {2216671200 10800 1 EEST} + {2216152800 10800 1 EEST} {2234901600 7200 0 EET} - {2248120800 10800 1 EEST} + {2248207200 10800 1 EEST} {2266351200 7200 0 EET} - {2279570400 10800 1 EEST} + {2279656800 10800 1 EEST} {2297800800 7200 0 EET} - {2311020000 10800 1 EEST} - {2329855200 7200 0 EET} - {2342469600 10800 1 EEST} + {2311106400 10800 1 EEST} + {2329250400 7200 0 EET} + {2342556000 10800 1 EEST} {2361304800 7200 0 EET} - {2374524000 10800 1 EEST} + {2374005600 10800 1 EEST} {2392754400 7200 0 EET} - {2405973600 10800 1 EEST} + {2405455200 10800 1 EEST} {2424204000 7200 0 EET} - {2437423200 10800 1 EEST} + {2437509600 10800 1 EEST} {2455653600 7200 0 EET} - {2468872800 10800 1 EEST} - {2487708000 7200 0 EET} - {2500322400 10800 1 EEST} + {2468959200 10800 1 EEST} + {2487103200 7200 0 EET} + {2500408800 10800 1 EEST} {2519157600 7200 0 EET} - {2531772000 10800 1 EEST} + {2531858400 10800 1 EEST} {2550607200 7200 0 EET} - {2563826400 10800 1 EEST} + {2563308000 10800 1 EEST} {2582056800 7200 0 EET} - {2595276000 10800 1 EEST} + {2595362400 10800 1 EEST} {2613506400 7200 0 EET} - {2626725600 10800 1 EEST} + {2626812000 10800 1 EEST} {2644956000 7200 0 EET} - {2658175200 10800 1 EEST} - {2677010400 7200 0 EET} - {2689624800 10800 1 EEST} + {2658261600 10800 1 EEST} + {2676405600 7200 0 EET} + {2689711200 10800 1 EEST} {2708460000 7200 0 EET} - {2721679200 10800 1 EEST} + {2721160800 10800 1 EEST} {2739909600 7200 0 EET} - {2753128800 10800 1 EEST} + {2752610400 10800 1 EEST} {2771359200 7200 0 EET} - {2784578400 10800 1 EEST} + {2784664800 10800 1 EEST} {2802808800 7200 0 EET} - {2816028000 10800 1 EEST} + {2816114400 10800 1 EEST} {2834258400 7200 0 EET} - {2847477600 10800 1 EEST} + {2847564000 10800 1 EEST} {2866312800 7200 0 EET} - {2878927200 10800 1 EEST} + {2879013600 10800 1 EEST} {2897762400 7200 0 EET} - {2910981600 10800 1 EEST} + {2910463200 10800 1 EEST} {2929212000 7200 0 EET} - {2942431200 10800 1 EEST} + {2941912800 10800 1 EEST} {2960661600 7200 0 EET} - {2973880800 10800 1 EEST} + {2973967200 10800 1 EEST} {2992111200 7200 0 EET} - {3005330400 10800 1 EEST} - {3024165600 7200 0 EET} - {3036780000 10800 1 EEST} + {3005416800 10800 1 EEST} + {3023560800 7200 0 EET} + {3036866400 10800 1 EEST} {3055615200 7200 0 EET} - {3068229600 10800 1 EEST} + {3068316000 10800 1 EEST} {3087064800 7200 0 EET} - {3100284000 10800 1 EEST} + {3099765600 10800 1 EEST} {3118514400 7200 0 EET} - {3131733600 10800 1 EEST} + {3131820000 10800 1 EEST} {3149964000 7200 0 EET} - {3163183200 10800 1 EEST} + {3163269600 10800 1 EEST} {3181413600 7200 0 EET} - {3194632800 10800 1 EEST} - {3213468000 7200 0 EET} - {3226082400 10800 1 EEST} + {3194719200 10800 1 EEST} + {3212863200 7200 0 EET} + {3226168800 10800 1 EEST} {3244917600 7200 0 EET} - {3258136800 10800 1 EEST} + {3257618400 10800 1 EEST} {3276367200 7200 0 EET} - {3289586400 10800 1 EEST} + {3289068000 10800 1 EEST} {3307816800 7200 0 EET} - {3321036000 10800 1 EEST} + {3321122400 10800 1 EEST} {3339266400 7200 0 EET} - {3352485600 10800 1 EEST} - {3371320800 7200 0 EET} - {3383935200 10800 1 EEST} + {3352572000 10800 1 EEST} + {3370716000 7200 0 EET} + {3384021600 10800 1 EEST} {3402770400 7200 0 EET} - {3415384800 10800 1 EEST} + {3415471200 10800 1 EEST} {3434220000 7200 0 EET} - {3447439200 10800 1 EEST} + {3446920800 10800 1 EEST} {3465669600 7200 0 EET} - {3478888800 10800 1 EEST} + {3478975200 10800 1 EEST} {3497119200 7200 0 EET} - {3510338400 10800 1 EEST} + {3510424800 10800 1 EEST} {3528568800 7200 0 EET} - {3541788000 10800 1 EEST} - {3560623200 7200 0 EET} - {3573237600 10800 1 EEST} + {3541874400 10800 1 EEST} + {3560018400 7200 0 EET} + {3573324000 10800 1 EEST} {3592072800 7200 0 EET} - {3605292000 10800 1 EEST} + {3604773600 10800 1 EEST} {3623522400 7200 0 EET} - {3636741600 10800 1 EEST} + {3636223200 10800 1 EEST} {3654972000 7200 0 EET} - {3668191200 10800 1 EEST} + {3668277600 10800 1 EEST} {3686421600 7200 0 EET} - {3699640800 10800 1 EEST} + {3699727200 10800 1 EEST} {3717871200 7200 0 EET} - {3731090400 10800 1 EEST} + {3731176800 10800 1 EEST} {3749925600 7200 0 EET} - {3762540000 10800 1 EEST} + {3762626400 10800 1 EEST} {3781375200 7200 0 EET} - {3794594400 10800 1 EEST} + {3794076000 10800 1 EEST} {3812824800 7200 0 EET} - {3826044000 10800 1 EEST} + {3825525600 10800 1 EEST} {3844274400 7200 0 EET} - {3857493600 10800 1 EEST} + {3857580000 10800 1 EEST} {3875724000 7200 0 EET} - {3888943200 10800 1 EEST} - {3907778400 7200 0 EET} - {3920392800 10800 1 EEST} + {3889029600 10800 1 EEST} + {3907173600 7200 0 EET} + {3920479200 10800 1 EEST} {3939228000 7200 0 EET} - {3951842400 10800 1 EEST} + {3951928800 10800 1 EEST} {3970677600 7200 0 EET} - {3983896800 10800 1 EEST} + {3983378400 10800 1 EEST} {4002127200 7200 0 EET} - {4015346400 10800 1 EEST} + {4015432800 10800 1 EEST} {4033576800 7200 0 EET} - {4046796000 10800 1 EEST} + {4046882400 10800 1 EEST} {4065026400 7200 0 EET} - {4078245600 10800 1 EEST} - {4097080800 7200 0 EET} + {4078332000 10800 1 EEST} + {4096476000 7200 0 EET} } diff --git a/amd64/lib/tcl8.6/tzdata/Asia/Jerusalem b/amd64/lib/tcl8.6/tzdata/Asia/Jerusalem index e1e84f4..596deb3 100644 --- a/amd64/lib/tcl8.6/tzdata/Asia/Jerusalem +++ b/amd64/lib/tcl8.6/tzdata/Asia/Jerusalem @@ -4,47 +4,49 @@ set TZData(:Asia/Jerusalem) { {-9223372036854775808 8454 0 LMT} {-2840149254 8440 0 JMT} {-1641003640 7200 0 IST} - {-933645600 10800 1 IDT} - {-857358000 7200 0 IST} + {-933638400 10800 1 IDT} + {-923097600 7200 0 IST} + {-919036800 10800 1 IDT} + {-857347200 7200 0 IST} {-844300800 10800 1 IDT} - {-825822000 7200 0 IST} - {-812685600 10800 1 IDT} - {-794199600 7200 0 IST} - {-779853600 10800 1 IDT} - {-762656400 7200 0 IST} + {-825811200 7200 0 IST} + {-812678400 10800 1 IDT} + {-794188800 7200 0 IST} + {-779846400 10800 1 IDT} + {-762652800 7200 0 IST} {-748310400 10800 1 IDT} - {-731127600 7200 0 IST} - {-681962400 14400 1 IDDT} - {-673243200 10800 1 IDT} - {-667962000 7200 0 IST} - {-652327200 10800 1 IDT} - {-636426000 7200 0 IST} - {-622087200 10800 1 IDT} + {-731116800 7200 0 IST} + {-681955200 14400 1 IDDT} + {-673228800 10800 1 IDT} + {-667958400 7200 0 IST} + {-652320000 10800 1 IDT} + {-636422400 7200 0 IST} + {-622080000 10800 1 IDT} {-608947200 7200 0 IST} - {-591847200 10800 1 IDT} + {-591840000 10800 1 IDT} {-572486400 7200 0 IST} {-558576000 10800 1 IDT} {-542851200 7200 0 IST} {-527731200 10800 1 IDT} {-514425600 7200 0 IST} - {-490845600 10800 1 IDT} - {-482986800 7200 0 IST} - {-459475200 10800 1 IDT} - {-451537200 7200 0 IST} - {-428551200 10800 1 IDT} + {-490838400 10800 1 IDT} + {-482976000 7200 0 IST} + {-459388800 10800 1 IDT} + {-451526400 7200 0 IST} + {-428544000 10800 1 IDT} {-418262400 7200 0 IST} - {-400032000 10800 1 IDT} - {-387428400 7200 0 IST} + {-400118400 10800 1 IDT} + {-387417600 7200 0 IST} {142380000 10800 1 IDT} {150843600 7200 0 IST} {167176800 10800 1 IDT} {178664400 7200 0 IST} - {334015200 10800 1 IDT} - {337644000 7200 0 IST} - {452556000 10800 1 IDT} - {462232800 7200 0 IST} + {334101600 10800 1 IDT} + {337730400 7200 0 IST} + {452642400 10800 1 IDT} + {462319200 7200 0 IST} {482277600 10800 1 IDT} - {495579600 7200 0 IST} + {494370000 7200 0 IST} {516751200 10800 1 IDT} {526424400 7200 0 IST} {545436000 10800 1 IDT} diff --git a/amd64/lib/tcl8.6/tzdata/Asia/Shanghai b/amd64/lib/tcl8.6/tzdata/Asia/Shanghai index 66bc433..0fcf802 100644 --- a/amd64/lib/tcl8.6/tzdata/Asia/Shanghai +++ b/amd64/lib/tcl8.6/tzdata/Asia/Shanghai @@ -3,6 +3,8 @@ set TZData(:Asia/Shanghai) { {-9223372036854775808 29143 0 LMT} {-2177481943 28800 0 CST} + {-1600675200 32400 1 CDT} + {-1585904400 28800 0 CST} {-933667200 32400 1 CDT} {-922093200 28800 0 CST} {-908870400 32400 1 CDT} diff --git a/amd64/lib/tcl8.6/tzdata/Atlantic/Bermuda b/amd64/lib/tcl8.6/tzdata/Atlantic/Bermuda index 2d4d983..40ab5d7 100644 --- a/amd64/lib/tcl8.6/tzdata/Atlantic/Bermuda +++ b/amd64/lib/tcl8.6/tzdata/Atlantic/Bermuda @@ -2,7 +2,34 @@ set TZData(:Atlantic/Bermuda) { {-9223372036854775808 -15558 0 LMT} - {-1262281242 -14400 0 AST} + {-2524506042 -15558 0 BMT} + {-1664307642 -11958 1 BMT} + {-1648932042 -15558 0 BMT} + {-1632080442 -11958 1 BMT} + {-1618692042 -15558 0 BST} + {-1262281242 -14400 0 AT} + {-882727200 -10800 1 ADT} + {-858538800 -14400 0 AST} + {-845229600 -10800 1 ADT} + {-825879600 -14400 0 AST} + {-814384800 -10800 1 ADT} + {-793825200 -14400 0 AST} + {-782935200 -10800 1 ADT} + {-762375600 -14400 0 AST} + {-713988000 -10800 1 ADT} + {-703710000 -14400 0 AST} + {-681933600 -10800 1 ADT} + {-672865200 -14400 0 AST} + {-650484000 -10800 1 ADT} + {-641415600 -14400 0 AST} + {-618429600 -10800 1 ADT} + {-609966000 -14400 0 AST} + {-586980000 -10800 1 ADT} + {-578516400 -14400 0 AST} + {-555530400 -10800 1 ADT} + {-546462000 -14400 0 AST} + {-429127200 -10800 1 ADT} + {-415825200 -14400 0 AST} {136360800 -10800 0 ADT} {152082000 -14400 0 AST} {167810400 -10800 1 ADT} diff --git a/amd64/lib/tcl8.6/tzdata/Australia/Adelaide b/amd64/lib/tcl8.6/tzdata/Australia/Adelaide index 7e1b04e..5f7c1a4 100644 --- a/amd64/lib/tcl8.6/tzdata/Australia/Adelaide +++ b/amd64/lib/tcl8.6/tzdata/Australia/Adelaide @@ -4,14 +4,14 @@ set TZData(:Australia/Adelaide) { {-9223372036854775808 33260 0 LMT} {-2364110060 32400 0 ACST} {-2230189200 34200 0 ACST} - {-1672565340 37800 1 ACDT} - {-1665390600 34200 0 ACST} + {-1672558200 37800 1 ACDT} + {-1665387000 34200 0 ACST} {-883639800 37800 1 ACDT} - {-876126600 34200 0 ACST} + {-876123000 34200 0 ACST} {-860398200 37800 1 ACDT} - {-844677000 34200 0 ACST} + {-844673400 34200 0 ACST} {-828343800 37800 1 ACDT} - {-813227400 34200 0 ACST} + {-813223800 34200 0 ACST} {31501800 34200 0 ACST} {57688200 37800 1 ACDT} {67969800 34200 0 ACST} diff --git a/amd64/lib/tcl8.6/tzdata/Australia/Brisbane b/amd64/lib/tcl8.6/tzdata/Australia/Brisbane index 8422ae6..325313a 100644 --- a/amd64/lib/tcl8.6/tzdata/Australia/Brisbane +++ b/amd64/lib/tcl8.6/tzdata/Australia/Brisbane @@ -3,14 +3,14 @@ set TZData(:Australia/Brisbane) { {-9223372036854775808 36728 0 LMT} {-2366791928 36000 0 AEST} - {-1672567140 39600 1 AEDT} - {-1665392400 36000 0 AEST} + {-1672560000 39600 1 AEDT} + {-1665388800 36000 0 AEST} {-883641600 39600 1 AEDT} - {-876128400 36000 0 AEST} + {-876124800 36000 0 AEST} {-860400000 39600 1 AEDT} - {-844678800 36000 0 AEST} + {-844675200 36000 0 AEST} {-828345600 39600 1 AEDT} - {-813229200 36000 0 AEST} + {-813225600 36000 0 AEST} {31500000 36000 0 AEST} {57686400 39600 1 AEDT} {67968000 36000 0 AEST} diff --git a/amd64/lib/tcl8.6/tzdata/Australia/Broken_Hill b/amd64/lib/tcl8.6/tzdata/Australia/Broken_Hill index c428061..2534b70 100644 --- a/amd64/lib/tcl8.6/tzdata/Australia/Broken_Hill +++ b/amd64/lib/tcl8.6/tzdata/Australia/Broken_Hill @@ -5,14 +5,14 @@ set TZData(:Australia/Broken_Hill) { {-2364110748 36000 0 AEST} {-2314951200 32400 0 ACST} {-2230189200 34200 0 ACST} - {-1672565340 37800 1 ACDT} - {-1665390600 34200 0 ACST} + {-1672558200 37800 1 ACDT} + {-1665387000 34200 0 ACST} {-883639800 37800 1 ACDT} - {-876126600 34200 0 ACST} + {-876123000 34200 0 ACST} {-860398200 37800 1 ACDT} - {-844677000 34200 0 ACST} + {-844673400 34200 0 ACST} {-828343800 37800 1 ACDT} - {-813227400 34200 0 ACST} + {-813223800 34200 0 ACST} {31501800 34200 0 ACST} {57688200 37800 1 ACDT} {67969800 34200 0 ACST} diff --git a/amd64/lib/tcl8.6/tzdata/Australia/Currie b/amd64/lib/tcl8.6/tzdata/Australia/Currie index 936327b..3315aa3 100644 --- a/amd64/lib/tcl8.6/tzdata/Australia/Currie +++ b/amd64/lib/tcl8.6/tzdata/Australia/Currie @@ -1,273 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Australia/Currie) { - {-9223372036854775808 34528 0 LMT} - {-2345794528 36000 0 AEST} - {-1680508800 39600 1 AEDT} - {-1669892400 39600 0 AEDT} - {-1665392400 36000 0 AEST} - {-883641600 39600 1 AEDT} - {-876128400 36000 0 AEST} - {-860400000 39600 1 AEDT} - {-844678800 36000 0 AEST} - {-828345600 39600 1 AEDT} - {-813229200 36000 0 AEST} - {47138400 36000 0 AEST} - {57686400 39600 1 AEDT} - {67968000 36000 0 AEST} - {89136000 39600 1 AEDT} - {100022400 36000 0 AEST} - {120585600 39600 1 AEDT} - {131472000 36000 0 AEST} - {152035200 39600 1 AEDT} - {162921600 36000 0 AEST} - {183484800 39600 1 AEDT} - {194976000 36000 0 AEST} - {215539200 39600 1 AEDT} - {226425600 36000 0 AEST} - {246988800 39600 1 AEDT} - {257875200 36000 0 AEST} - {278438400 39600 1 AEDT} - {289324800 36000 0 AEST} - {309888000 39600 1 AEDT} - {320774400 36000 0 AEST} - {341337600 39600 1 AEDT} - {352224000 36000 0 AEST} - {372787200 39600 1 AEDT} - {386092800 36000 0 AEST} - {404841600 39600 1 AEDT} - {417542400 36000 0 AEST} - {436291200 39600 1 AEDT} - {447177600 36000 0 AEST} - {467740800 39600 1 AEDT} - {478627200 36000 0 AEST} - {499190400 39600 1 AEDT} - {510076800 36000 0 AEST} - {530035200 39600 1 AEDT} - {542736000 36000 0 AEST} - {562089600 39600 1 AEDT} - {574790400 36000 0 AEST} - {594144000 39600 1 AEDT} - {606240000 36000 0 AEST} - {625593600 39600 1 AEDT} - {637689600 36000 0 AEST} - {657043200 39600 1 AEDT} - {670348800 36000 0 AEST} - {686678400 39600 1 AEDT} - {701798400 36000 0 AEST} - {718128000 39600 1 AEDT} - {733248000 36000 0 AEST} - {749577600 39600 1 AEDT} - {764697600 36000 0 AEST} - {781027200 39600 1 AEDT} - {796147200 36000 0 AEST} - {812476800 39600 1 AEDT} - {828201600 36000 0 AEST} - {844531200 39600 1 AEDT} - {859651200 36000 0 AEST} - {875980800 39600 1 AEDT} - {891100800 36000 0 AEST} - {907430400 39600 1 AEDT} - {922550400 36000 0 AEST} - {938880000 39600 1 AEDT} - {954000000 36000 0 AEST} - {967305600 39600 1 AEDT} - {985449600 36000 0 AEST} - {1002384000 39600 1 AEDT} - {1017504000 36000 0 AEST} - {1033833600 39600 1 AEDT} - {1048953600 36000 0 AEST} - {1065283200 39600 1 AEDT} - {1080403200 36000 0 AEST} - {1096732800 39600 1 AEDT} - {1111852800 36000 0 AEST} - {1128182400 39600 1 AEDT} - {1143907200 36000 0 AEST} - {1159632000 39600 1 AEDT} - {1174752000 36000 0 AEST} - {1191686400 39600 1 AEDT} - {1207411200 36000 0 AEST} - {1223136000 39600 1 AEDT} - {1238860800 36000 0 AEST} - {1254585600 39600 1 AEDT} - {1270310400 36000 0 AEST} - {1286035200 39600 1 AEDT} - {1301760000 36000 0 AEST} - {1317484800 39600 1 AEDT} - {1333209600 36000 0 AEST} - {1349539200 39600 1 AEDT} - {1365264000 36000 0 AEST} - {1380988800 39600 1 AEDT} - {1396713600 36000 0 AEST} - {1412438400 39600 1 AEDT} - {1428163200 36000 0 AEST} - {1443888000 39600 1 AEDT} - {1459612800 36000 0 AEST} - {1475337600 39600 1 AEDT} - {1491062400 36000 0 AEST} - {1506787200 39600 1 AEDT} - {1522512000 36000 0 AEST} - {1538841600 39600 1 AEDT} - {1554566400 36000 0 AEST} - {1570291200 39600 1 AEDT} - {1586016000 36000 0 AEST} - {1601740800 39600 1 AEDT} - {1617465600 36000 0 AEST} - {1633190400 39600 1 AEDT} - {1648915200 36000 0 AEST} - {1664640000 39600 1 AEDT} - {1680364800 36000 0 AEST} - {1696089600 39600 1 AEDT} - {1712419200 36000 0 AEST} - {1728144000 39600 1 AEDT} - {1743868800 36000 0 AEST} - {1759593600 39600 1 AEDT} - {1775318400 36000 0 AEST} - {1791043200 39600 1 AEDT} - {1806768000 36000 0 AEST} - {1822492800 39600 1 AEDT} - {1838217600 36000 0 AEST} - {1853942400 39600 1 AEDT} - {1869667200 36000 0 AEST} - {1885996800 39600 1 AEDT} - {1901721600 36000 0 AEST} - {1917446400 39600 1 AEDT} - {1933171200 36000 0 AEST} - {1948896000 39600 1 AEDT} - {1964620800 36000 0 AEST} - {1980345600 39600 1 AEDT} - {1996070400 36000 0 AEST} - {2011795200 39600 1 AEDT} - {2027520000 36000 0 AEST} - {2043244800 39600 1 AEDT} - {2058969600 36000 0 AEST} - {2075299200 39600 1 AEDT} - {2091024000 36000 0 AEST} - {2106748800 39600 1 AEDT} - {2122473600 36000 0 AEST} - {2138198400 39600 1 AEDT} - {2153923200 36000 0 AEST} - {2169648000 39600 1 AEDT} - {2185372800 36000 0 AEST} - {2201097600 39600 1 AEDT} - {2216822400 36000 0 AEST} - {2233152000 39600 1 AEDT} - {2248876800 36000 0 AEST} - {2264601600 39600 1 AEDT} - {2280326400 36000 0 AEST} - {2296051200 39600 1 AEDT} - {2311776000 36000 0 AEST} - {2327500800 39600 1 AEDT} - {2343225600 36000 0 AEST} - {2358950400 39600 1 AEDT} - {2374675200 36000 0 AEST} - {2390400000 39600 1 AEDT} - {2406124800 36000 0 AEST} - {2422454400 39600 1 AEDT} - {2438179200 36000 0 AEST} - {2453904000 39600 1 AEDT} - {2469628800 36000 0 AEST} - {2485353600 39600 1 AEDT} - {2501078400 36000 0 AEST} - {2516803200 39600 1 AEDT} - {2532528000 36000 0 AEST} - {2548252800 39600 1 AEDT} - {2563977600 36000 0 AEST} - {2579702400 39600 1 AEDT} - {2596032000 36000 0 AEST} - {2611756800 39600 1 AEDT} - {2627481600 36000 0 AEST} - {2643206400 39600 1 AEDT} - {2658931200 36000 0 AEST} - {2674656000 39600 1 AEDT} - {2690380800 36000 0 AEST} - {2706105600 39600 1 AEDT} - {2721830400 36000 0 AEST} - {2737555200 39600 1 AEDT} - {2753280000 36000 0 AEST} - {2769609600 39600 1 AEDT} - {2785334400 36000 0 AEST} - {2801059200 39600 1 AEDT} - {2816784000 36000 0 AEST} - {2832508800 39600 1 AEDT} - {2848233600 36000 0 AEST} - {2863958400 39600 1 AEDT} - {2879683200 36000 0 AEST} - {2895408000 39600 1 AEDT} - {2911132800 36000 0 AEST} - {2926857600 39600 1 AEDT} - {2942582400 36000 0 AEST} - {2958912000 39600 1 AEDT} - {2974636800 36000 0 AEST} - {2990361600 39600 1 AEDT} - {3006086400 36000 0 AEST} - {3021811200 39600 1 AEDT} - {3037536000 36000 0 AEST} - {3053260800 39600 1 AEDT} - {3068985600 36000 0 AEST} - {3084710400 39600 1 AEDT} - {3100435200 36000 0 AEST} - {3116764800 39600 1 AEDT} - {3132489600 36000 0 AEST} - {3148214400 39600 1 AEDT} - {3163939200 36000 0 AEST} - {3179664000 39600 1 AEDT} - {3195388800 36000 0 AEST} - {3211113600 39600 1 AEDT} - {3226838400 36000 0 AEST} - {3242563200 39600 1 AEDT} - {3258288000 36000 0 AEST} - {3274012800 39600 1 AEDT} - {3289737600 36000 0 AEST} - {3306067200 39600 1 AEDT} - {3321792000 36000 0 AEST} - {3337516800 39600 1 AEDT} - {3353241600 36000 0 AEST} - {3368966400 39600 1 AEDT} - {3384691200 36000 0 AEST} - {3400416000 39600 1 AEDT} - {3416140800 36000 0 AEST} - {3431865600 39600 1 AEDT} - {3447590400 36000 0 AEST} - {3463315200 39600 1 AEDT} - {3479644800 36000 0 AEST} - {3495369600 39600 1 AEDT} - {3511094400 36000 0 AEST} - {3526819200 39600 1 AEDT} - {3542544000 36000 0 AEST} - {3558268800 39600 1 AEDT} - {3573993600 36000 0 AEST} - {3589718400 39600 1 AEDT} - {3605443200 36000 0 AEST} - {3621168000 39600 1 AEDT} - {3636892800 36000 0 AEST} - {3653222400 39600 1 AEDT} - {3668947200 36000 0 AEST} - {3684672000 39600 1 AEDT} - {3700396800 36000 0 AEST} - {3716121600 39600 1 AEDT} - {3731846400 36000 0 AEST} - {3747571200 39600 1 AEDT} - {3763296000 36000 0 AEST} - {3779020800 39600 1 AEDT} - {3794745600 36000 0 AEST} - {3810470400 39600 1 AEDT} - {3826195200 36000 0 AEST} - {3842524800 39600 1 AEDT} - {3858249600 36000 0 AEST} - {3873974400 39600 1 AEDT} - {3889699200 36000 0 AEST} - {3905424000 39600 1 AEDT} - {3921148800 36000 0 AEST} - {3936873600 39600 1 AEDT} - {3952598400 36000 0 AEST} - {3968323200 39600 1 AEDT} - {3984048000 36000 0 AEST} - {4000377600 39600 1 AEDT} - {4016102400 36000 0 AEST} - {4031827200 39600 1 AEDT} - {4047552000 36000 0 AEST} - {4063276800 39600 1 AEDT} - {4079001600 36000 0 AEST} - {4094726400 39600 1 AEDT} +if {![info exists TZData(Australia/Hobart)]} { + LoadTimeZoneFile Australia/Hobart } +set TZData(:Australia/Currie) $TZData(:Australia/Hobart) diff --git a/amd64/lib/tcl8.6/tzdata/Australia/Darwin b/amd64/lib/tcl8.6/tzdata/Australia/Darwin index e77605d..13f13ee 100644 --- a/amd64/lib/tcl8.6/tzdata/Australia/Darwin +++ b/amd64/lib/tcl8.6/tzdata/Australia/Darwin @@ -4,12 +4,12 @@ set TZData(:Australia/Darwin) { {-9223372036854775808 31400 0 LMT} {-2364108200 32400 0 ACST} {-2230189200 34200 0 ACST} - {-1672565340 37800 1 ACDT} - {-1665390600 34200 0 ACST} + {-1672558200 37800 1 ACDT} + {-1665387000 34200 0 ACST} {-883639800 37800 1 ACDT} - {-876126600 34200 0 ACST} + {-876123000 34200 0 ACST} {-860398200 37800 1 ACDT} - {-844677000 34200 0 ACST} + {-844673400 34200 0 ACST} {-828343800 37800 1 ACDT} - {-813227400 34200 0 ACST} + {-813223800 34200 0 ACST} } diff --git a/amd64/lib/tcl8.6/tzdata/Australia/Eucla b/amd64/lib/tcl8.6/tzdata/Australia/Eucla index 8008980..1d81a3d 100644 --- a/amd64/lib/tcl8.6/tzdata/Australia/Eucla +++ b/amd64/lib/tcl8.6/tzdata/Australia/Eucla @@ -3,12 +3,12 @@ set TZData(:Australia/Eucla) { {-9223372036854775808 30928 0 LMT} {-2337928528 31500 0 +0945} - {-1672562640 35100 1 +0945} - {-1665387900 31500 0 +0945} + {-1672555500 35100 1 +0945} + {-1665384300 31500 0 +0945} {-883637100 35100 1 +0945} - {-876123900 31500 0 +0945} + {-876120300 31500 0 +0945} {-860395500 35100 1 +0945} - {-844674300 31500 0 +0945} + {-844670700 31500 0 +0945} {-836473500 35100 0 +0945} {152039700 35100 1 +0945} {162926100 31500 0 +0945} diff --git a/amd64/lib/tcl8.6/tzdata/Australia/Hobart b/amd64/lib/tcl8.6/tzdata/Australia/Hobart index bf5adf0..5ff675e 100644 --- a/amd64/lib/tcl8.6/tzdata/Australia/Hobart +++ b/amd64/lib/tcl8.6/tzdata/Australia/Hobart @@ -4,14 +4,18 @@ set TZData(:Australia/Hobart) { {-9223372036854775808 35356 0 LMT} {-2345795356 36000 0 AEST} {-1680508800 39600 1 AEDT} - {-1669892400 39600 0 AEDT} - {-1665392400 36000 0 AEST} + {-1665388800 36000 0 AEST} + {-1646640000 39600 1 AEDT} + {-1635753600 36000 0 AEST} + {-1615190400 39600 1 AEDT} + {-1604304000 36000 0 AEST} + {-1583920800 36000 0 AEST} {-883641600 39600 1 AEDT} - {-876128400 36000 0 AEST} + {-876124800 36000 0 AEST} {-860400000 39600 1 AEDT} - {-844678800 36000 0 AEST} + {-844675200 36000 0 AEST} {-828345600 39600 1 AEDT} - {-813229200 36000 0 AEST} + {-813225600 36000 0 AEST} {-94730400 36000 0 AEST} {-71136000 39600 1 AEDT} {-55411200 36000 0 AEST} diff --git a/amd64/lib/tcl8.6/tzdata/Australia/Lindeman b/amd64/lib/tcl8.6/tzdata/Australia/Lindeman index 91ad0a6..1be6962 100644 --- a/amd64/lib/tcl8.6/tzdata/Australia/Lindeman +++ b/amd64/lib/tcl8.6/tzdata/Australia/Lindeman @@ -3,14 +3,14 @@ set TZData(:Australia/Lindeman) { {-9223372036854775808 35756 0 LMT} {-2366790956 36000 0 AEST} - {-1672567140 39600 1 AEDT} - {-1665392400 36000 0 AEST} + {-1672560000 39600 1 AEDT} + {-1665388800 36000 0 AEST} {-883641600 39600 1 AEDT} - {-876128400 36000 0 AEST} + {-876124800 36000 0 AEST} {-860400000 39600 1 AEDT} - {-844678800 36000 0 AEST} + {-844675200 36000 0 AEST} {-828345600 39600 1 AEDT} - {-813229200 36000 0 AEST} + {-813225600 36000 0 AEST} {31500000 36000 0 AEST} {57686400 39600 1 AEDT} {67968000 36000 0 AEST} diff --git a/amd64/lib/tcl8.6/tzdata/Australia/Melbourne b/amd64/lib/tcl8.6/tzdata/Australia/Melbourne index 81777df..77e9067 100644 --- a/amd64/lib/tcl8.6/tzdata/Australia/Melbourne +++ b/amd64/lib/tcl8.6/tzdata/Australia/Melbourne @@ -3,14 +3,14 @@ set TZData(:Australia/Melbourne) { {-9223372036854775808 34792 0 LMT} {-2364111592 36000 0 AEST} - {-1672567140 39600 1 AEDT} - {-1665392400 36000 0 AEST} + {-1672560000 39600 1 AEDT} + {-1665388800 36000 0 AEST} {-883641600 39600 1 AEDT} - {-876128400 36000 0 AEST} + {-876124800 36000 0 AEST} {-860400000 39600 1 AEDT} - {-844678800 36000 0 AEST} + {-844675200 36000 0 AEST} {-828345600 39600 1 AEDT} - {-813229200 36000 0 AEST} + {-813225600 36000 0 AEST} {31500000 36000 0 AEST} {57686400 39600 1 AEDT} {67968000 36000 0 AEST} diff --git a/amd64/lib/tcl8.6/tzdata/Australia/Perth b/amd64/lib/tcl8.6/tzdata/Australia/Perth index 6ccbca8..4ed3cba 100644 --- a/amd64/lib/tcl8.6/tzdata/Australia/Perth +++ b/amd64/lib/tcl8.6/tzdata/Australia/Perth @@ -3,12 +3,12 @@ set TZData(:Australia/Perth) { {-9223372036854775808 27804 0 LMT} {-2337925404 28800 0 AWST} - {-1672559940 32400 1 AWDT} - {-1665385200 28800 0 AWST} + {-1672552800 32400 1 AWDT} + {-1665381600 28800 0 AWST} {-883634400 32400 1 AWDT} - {-876121200 28800 0 AWST} + {-876117600 28800 0 AWST} {-860392800 32400 1 AWDT} - {-844671600 28800 0 AWST} + {-844668000 28800 0 AWST} {-836470800 32400 0 AWST} {152042400 32400 1 AWDT} {162928800 28800 0 AWST} diff --git a/amd64/lib/tcl8.6/tzdata/Australia/Sydney b/amd64/lib/tcl8.6/tzdata/Australia/Sydney index b1c4411..fd01af6 100644 --- a/amd64/lib/tcl8.6/tzdata/Australia/Sydney +++ b/amd64/lib/tcl8.6/tzdata/Australia/Sydney @@ -3,14 +3,14 @@ set TZData(:Australia/Sydney) { {-9223372036854775808 36292 0 LMT} {-2364113092 36000 0 AEST} - {-1672567140 39600 1 AEDT} - {-1665392400 36000 0 AEST} + {-1672560000 39600 1 AEDT} + {-1665388800 36000 0 AEST} {-883641600 39600 1 AEDT} - {-876128400 36000 0 AEST} + {-876124800 36000 0 AEST} {-860400000 39600 1 AEDT} - {-844678800 36000 0 AEST} + {-844675200 36000 0 AEST} {-828345600 39600 1 AEDT} - {-813229200 36000 0 AEST} + {-813225600 36000 0 AEST} {31500000 36000 0 AEST} {57686400 39600 1 AEDT} {67968000 36000 0 AEST} diff --git a/amd64/lib/tcl8.6/tzdata/Europe/Budapest b/amd64/lib/tcl8.6/tzdata/Europe/Budapest index e660ad1..4b92c5f 100644 --- a/amd64/lib/tcl8.6/tzdata/Europe/Budapest +++ b/amd64/lib/tcl8.6/tzdata/Europe/Budapest @@ -2,17 +2,19 @@ set TZData(:Europe/Budapest) { {-9223372036854775808 4580 0 LMT} - {-2500938980 3600 0 CET} + {-2498260580 3600 0 CET} {-1693706400 7200 1 CEST} {-1680483600 3600 0 CET} {-1663455600 7200 1 CEST} {-1650150000 3600 0 CET} {-1640998800 3600 0 CET} - {-1633212000 7200 1 CEST} + {-1632006000 7200 1 CEST} {-1618700400 3600 0 CET} - {-1600466400 7200 1 CEST} - {-1581202800 3600 0 CET} - {-906771600 3600 0 CET} + {-1600470000 7200 1 CEST} + {-1587250800 3600 0 CET} + {-1569711600 7200 1 CEST} + {-1555196400 3600 0 CET} + {-906775200 3600 0 CET} {-857257200 3600 0 CET} {-844556400 7200 1 CEST} {-828226800 3600 0 CET} @@ -20,33 +22,32 @@ set TZData(:Europe/Budapest) { {-796777200 3600 0 CET} {-788922000 3600 0 CET} {-778471200 7200 1 CEST} - {-762660000 3600 0 CET} + {-762656400 3600 0 CET} {-749689200 7200 1 CEST} - {-733359600 3600 0 CET} + {-733276800 3600 0 CET} {-717634800 7200 1 CEST} {-701910000 3600 0 CET} {-686185200 7200 1 CEST} {-670460400 3600 0 CET} {-654130800 7200 1 CEST} {-639010800 3600 0 CET} - {-621990000 7200 1 CEST} - {-605660400 3600 0 CET} {-492656400 7200 1 CEST} {-481168800 3600 0 CET} - {-461120400 7200 1 CEST} - {-449632800 3600 0 CET} - {-428547600 7200 1 CEST} - {-418269600 3600 0 CET} - {-397094400 7200 1 CEST} + {-461199600 7200 1 CEST} + {-449708400 3600 0 CET} + {-428540400 7200 1 CEST} + {-418258800 3600 0 CET} + {-397090800 7200 1 CEST} {-386809200 3600 0 CET} - {323827200 7200 1 CEST} - {338950800 3600 0 CET} - {354675600 7200 1 CEST} - {370400400 3600 0 CET} - {386125200 7200 1 CEST} - {401850000 3600 0 CET} - {417574800 7200 1 CEST} - {433299600 3600 0 CET} + {323823600 7200 1 CEST} + {338943600 3600 0 CET} + {354668400 7200 1 CEST} + {370393200 3600 0 CET} + {386118000 7200 1 CEST} + {401842800 3600 0 CET} + {417567600 7200 1 CEST} + {433292400 3600 0 CET} + {441759600 3600 0 CET} {449024400 7200 1 CEST} {465354000 3600 0 CET} {481078800 7200 1 CEST} diff --git a/amd64/lib/tcl8.6/tzdata/Europe/Monaco b/amd64/lib/tcl8.6/tzdata/Europe/Monaco index f887b0b..7428b2f 100644 --- a/amd64/lib/tcl8.6/tzdata/Europe/Monaco +++ b/amd64/lib/tcl8.6/tzdata/Europe/Monaco @@ -2,8 +2,8 @@ set TZData(:Europe/Monaco) { {-9223372036854775808 1772 0 LMT} - {-2486680172 561 0 PMT} - {-1855958961 0 0 WET} + {-2448318572 561 0 PMT} + {-1854403761 0 0 WET} {-1689814800 3600 1 WEST} {-1680397200 0 0 WET} {-1665363600 3600 1 WEST} diff --git a/amd64/lib/tcl8.6/tzdata/Europe/Paris b/amd64/lib/tcl8.6/tzdata/Europe/Paris index 4b22a09..7208e55 100644 --- a/amd64/lib/tcl8.6/tzdata/Europe/Paris +++ b/amd64/lib/tcl8.6/tzdata/Europe/Paris @@ -2,8 +2,8 @@ set TZData(:Europe/Paris) { {-9223372036854775808 561 0 LMT} - {-2486678901 561 0 PMT} - {-1855958901 0 0 WET} + {-2486592561 561 0 PMT} + {-1855958961 0 0 WET} {-1689814800 3600 1 WEST} {-1680397200 0 0 WET} {-1665363600 3600 1 WEST} diff --git a/amd64/lib/tcl8.6/tzdata/Europe/Volgograd b/amd64/lib/tcl8.6/tzdata/Europe/Volgograd index 3938683..2ce2dfe 100644 --- a/amd64/lib/tcl8.6/tzdata/Europe/Volgograd +++ b/amd64/lib/tcl8.6/tzdata/Europe/Volgograd @@ -69,4 +69,5 @@ set TZData(:Europe/Volgograd) { {1301180400 14400 0 +04} {1414274400 10800 0 +03} {1540681200 14400 0 +04} + {1609020000 10800 0 +03} } diff --git a/amd64/lib/tcl8.6/tzdata/Indian/Mahe b/amd64/lib/tcl8.6/tzdata/Indian/Mahe index 3dd5b40..dcafc36 100644 --- a/amd64/lib/tcl8.6/tzdata/Indian/Mahe +++ b/amd64/lib/tcl8.6/tzdata/Indian/Mahe @@ -2,5 +2,5 @@ set TZData(:Indian/Mahe) { {-9223372036854775808 13308 0 LMT} - {-2006653308 14400 0 +04} + {-1988163708 14400 0 +04} } diff --git a/amd64/lib/tcl8.6/tzdata/Pacific/Efate b/amd64/lib/tcl8.6/tzdata/Pacific/Efate index a026ee1..5a22546 100644 --- a/amd64/lib/tcl8.6/tzdata/Pacific/Efate +++ b/amd64/lib/tcl8.6/tzdata/Pacific/Efate @@ -3,9 +3,11 @@ set TZData(:Pacific/Efate) { {-9223372036854775808 40396 0 LMT} {-1829387596 39600 0 +11} + {125409600 43200 1 +11} + {133876800 39600 0 +11} {433256400 43200 1 +11} {448977600 39600 0 +11} - {467298000 43200 1 +11} + {464706000 43200 1 +11} {480427200 39600 0 +11} {496760400 43200 1 +11} {511876800 39600 0 +11} diff --git a/amd64/lib/tcl8.6/tzdata/Pacific/Fiji b/amd64/lib/tcl8.6/tzdata/Pacific/Fiji index e316b93..a062913 100644 --- a/amd64/lib/tcl8.6/tzdata/Pacific/Fiji +++ b/amd64/lib/tcl8.6/tzdata/Pacific/Fiji @@ -29,7 +29,7 @@ set TZData(:Pacific/Fiji) { {1547301600 43200 0 +12} {1573308000 46800 1 +12} {1578751200 43200 0 +12} - {1604757600 46800 1 +12} + {1608386400 46800 1 +12} {1610805600 43200 0 +12} {1636812000 46800 1 +12} {1642255200 43200 0 +12} diff --git a/amd64/lib/tcl8.6/word.tcl b/amd64/lib/tcl8.6/word.tcl index 3e4bc3a..828f13a 100644 --- a/amd64/lib/tcl8.6/word.tcl +++ b/amd64/lib/tcl8.6/word.tcl @@ -4,8 +4,8 @@ # strings. This file is primarily needed so Tk text and entry widgets behave # properly for different platforms. # -# Copyright (c) 1996 by Sun Microsystems, Inc. -# Copyright (c) 1998 by Scritpics Corporation. +# Copyright (c) 1996 Sun Microsystems, Inc. +# Copyright (c) 1998 Scritpics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -146,7 +146,9 @@ proc tcl_startOfNextWord {str start} { proc tcl_startOfPreviousWord {str start} { variable ::tcl::WordBreakRE set word {-1 -1} - regexp -indices -- $WordBreakRE(previous) [string range $str 0 $start-1] \ - result word + if {$start > 0} { + regexp -indices -- $WordBreakRE(previous) [string range $str 0 $start-1] \ + result word + } return [lindex $word 0] } diff --git a/amd64/lib/tcl8/8.4/platform-1.0.15.tm b/amd64/lib/tcl8/8.4/platform-1.0.15.tm new file mode 100644 index 0000000..6c01142 --- /dev/null +++ b/amd64/lib/tcl8/8.4/platform-1.0.15.tm @@ -0,0 +1,423 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Overview + +# Heuristics to assemble a platform identifier from publicly available +# information. The identifier describes the platform of the currently +# running tcl shell. This is a mixture of the runtime environment and +# of build-time properties of the executable itself. +# +# Examples: +# <1> A tcl shell executing on a x86_64 processor, but having a +# wordsize of 4 was compiled for the x86 environment, i.e. 32 +# bit, and loaded packages have to match that, and not the +# actual cpu. +# +# <2> The hp/solaris 32/64 bit builds of the core cannot be +# distinguished by looking at tcl_platform. As packages have to +# match the 32/64 information we have to look in more places. In +# this case we inspect the executable itself (magic numbers, +# i.e. fileutil::magic::filetype). +# +# The basic information used comes out of the 'os' and 'machine' +# entries of the 'tcl_platform' array. A number of general and +# os/machine specific transformation are applied to get a canonical +# result. +# +# General +# Only the first element of 'os' is used - we don't care whether we +# are on "Windows NT" or "Windows XP" or whatever. +# +# Machine specific +# % arm* -> arm +# % sun4* -> sparc +# % intel -> ix86 +# % i*86* -> ix86 +# % Power* -> powerpc +# % x86_64 + wordSize 4 => x86 code +# +# OS specific +# % AIX are always powerpc machines +# % HP-UX 9000/800 etc means parisc +# % linux has to take glibc version into account +# % sunos -> solaris, and keep version number +# +# NOTE: A platform like linux glibc 2.3, which can use glibc 2.2 stuff +# has to provide all possible allowed platform identifiers when +# searching search. Ditto a solaris 2.8 platform can use solaris 2.6 +# packages. Etc. This is handled by the other procedure, see below. + +# ### ### ### ######### ######### ######### +## Requirements + +namespace eval ::platform {} + +# ### ### ### ######### ######### ######### +## Implementation + +# -- platform::generic +# +# Assembles an identifier for the generic platform. It leaves out +# details like kernel version, libc version, etc. + +proc ::platform::generic {} { + global tcl_platform + + set plat [string tolower [lindex $tcl_platform(os) 0]] + set cpu $tcl_platform(machine) + + switch -glob -- $cpu { + sun4* { + set cpu sparc + } + intel - + i*86* { + set cpu ix86 + } + x86_64 { + if {$tcl_platform(wordSize) == 4} { + # See Example <1> at the top of this file. + set cpu ix86 + } + } + "Power*" { + set cpu powerpc + } + "arm*" { + set cpu arm + } + ia64 { + if {$tcl_platform(wordSize) == 4} { + append cpu _32 + } + } + } + + switch -glob -- $plat { + windows { + if {$tcl_platform(platform) == "unix"} { + set plat cygwin + } else { + set plat win32 + } + if {$cpu eq "amd64"} { + # Do not check wordSize, win32-x64 is an IL32P64 platform. + set cpu x86_64 + } + } + sunos { + set plat solaris + if {[string match "ix86" $cpu]} { + if {$tcl_platform(wordSize) == 8} { + set cpu x86_64 + } + } elseif {![string match "ia64*" $cpu]} { + # sparc + if {$tcl_platform(wordSize) == 8} { + append cpu 64 + } + } + } + darwin { + set plat macosx + # Correctly identify the cpu when running as a 64bit + # process on a machine with a 32bit kernel + if {$cpu eq "ix86"} { + if {$tcl_platform(wordSize) == 8} { + set cpu x86_64 + } + } + } + aix { + set cpu powerpc + if {$tcl_platform(wordSize) == 8} { + append cpu 64 + } + } + hp-ux { + set plat hpux + if {![string match "ia64*" $cpu]} { + set cpu parisc + if {$tcl_platform(wordSize) == 8} { + append cpu 64 + } + } + } + osf1 { + set plat tru64 + } + default { + set plat [lindex [split $plat _-] 0] + } + } + + return "${plat}-${cpu}" +} + +# -- platform::identify +# +# Assembles an identifier for the exact platform, by extending the +# generic identifier. I.e. it adds in details like kernel version, +# libc version, etc., if they are relevant for the loading of +# packages on the platform. + +proc ::platform::identify {} { + global tcl_platform + + set id [generic] + regexp {^([^-]+)-([^-]+)$} $id -> plat cpu + + switch -- $plat { + solaris { + regsub {^5} $tcl_platform(osVersion) 2 text + append plat $text + return "${plat}-${cpu}" + } + macosx { + set major [lindex [split $tcl_platform(osVersion) .] 0] + if {$major > 19} { + incr major -20 + append plat 11.$major + } else { + incr major -4 + append plat 10.$major + return "${plat}-${cpu}" + } + return "${plat}-${cpu}" + } + linux { + # Look for the libc*.so and determine its version + # (libc5/6, libc6 further glibc 2.X) + + set v unknown + + # Determine in which directory to look. /lib, or /lib64. + # For that we use the tcl_platform(wordSize). + # + # We could use the 'cpu' info, per the equivalence below, + # that however would be restricted to intel. And this may + # be a arm, mips, etc. system. The wordsize is more + # fundamental. + # + # ix86 <=> (wordSize == 4) <=> 32 bit ==> /lib + # x86_64 <=> (wordSize == 8) <=> 64 bit ==> /lib64 + # + # Do not look into /lib64 even if present, if the cpu + # doesn't fit. + + # TODO: Determine the prefixes (i386, x86_64, ...) for + # other cpus. The path after the generic one is utterly + # specific to intel right now. Ok, on Ubuntu, possibly + # other Debian systems we may apparently be able to query + # the necessary CPU code. If we can't we simply use the + # hardwired fallback. + + switch -exact -- $tcl_platform(wordSize) { + 4 { + lappend bases /lib + if {[catch { + exec dpkg-architecture -qDEB_HOST_MULTIARCH + } res]} { + lappend bases /lib/i386-linux-gnu + } else { + # dpkg-arch returns the full tripled, not just cpu. + lappend bases /lib/$res + } + } + 8 { + lappend bases /lib64 + if {[catch { + exec dpkg-architecture -qDEB_HOST_MULTIARCH + } res]} { + lappend bases /lib/x86_64-linux-gnu + } else { + # dpkg-arch returns the full tripled, not just cpu. + lappend bases /lib/$res + } + } + default { + return -code error "Bad wordSize $tcl_platform(wordSize), expected 4 or 8" + } + } + + foreach base $bases { + if {[LibcVersion $base -> v]} break + } + + append plat -$v + return "${plat}-${cpu}" + } + } + + return $id +} + +proc ::platform::LibcVersion {base _->_ vv} { + upvar 1 $vv v + set libclist [lsort [glob -nocomplain -directory $base libc*]] + + if {![llength $libclist]} { return 0 } + + set libc [lindex $libclist 0] + + # Try executing the library first. This should suceed + # for a glibc library, and return the version + # information. + + if {![catch { + set vdata [lindex [split [exec $libc] \n] 0] + }]} { + regexp {version ([0-9]+(\.[0-9]+)*)} $vdata -> v + foreach {major minor} [split $v .] break + set v glibc${major}.${minor} + return 1 + } else { + # We had trouble executing the library. We are now + # inspecting its name to determine the version + # number. This code by Larry McVoy. + + if {[regexp -- {libc-([0-9]+)\.([0-9]+)} $libc -> major minor]} { + set v glibc${major}.${minor} + return 1 + } + } + return 0 +} + +# -- platform::patterns +# +# Given an exact platform identifier, i.e. _not_ the generic +# identifier it assembles a list of exact platform identifier +# describing platform which should be compatible with the +# input. +# +# I.e. packages for all platforms in the result list should be +# loadable on the specified platform. + +# << Should we add the generic identifier to the list as well ? In +# general it is not compatible I believe. So better not. In many +# cases the exact identifier is identical to the generic one +# anyway. +# >> + +proc ::platform::patterns {id} { + set res [list $id] + if {$id eq "tcl"} {return $res} + + switch -glob -- $id { + solaris*-* { + if {[regexp {solaris([^-]*)-(.*)} $id -> v cpu]} { + if {$v eq ""} {return $id} + foreach {major minor} [split $v .] break + incr minor -1 + for {set j $minor} {$j >= 6} {incr j -1} { + lappend res solaris${major}.${j}-${cpu} + } + } + } + linux*-* { + if {[regexp {linux-glibc([^-]*)-(.*)} $id -> v cpu]} { + foreach {major minor} [split $v .] break + incr minor -1 + for {set j $minor} {$j >= 0} {incr j -1} { + lappend res linux-glibc${major}.${j}-${cpu} + } + } + } + macosx-powerpc { + lappend res macosx-universal + } + macosx-x86_64 { + lappend res macosx-i386-x86_64 + } + macosx-ix86 { + lappend res macosx-universal macosx-i386-x86_64 + } + macosx*-* { + # 10.5+,11.0+ + if {[regexp {macosx([^-]*)-(.*)} $id -> v cpu]} { + + switch -exact -- $cpu { + ix86 { + lappend alt i386-x86_64 + lappend alt universal + } + x86_64 { + if {[lindex [split $::tcl_platform(osVersion) .] 0] < 19} { + set alt i386-x86_64 + } else { + set alt {} + } + } + arm { + lappend alt x86_64 + } + default { set alt {} } + } + + if {$v ne ""} { + foreach {major minor} [split $v .] break + + set res {} + if {$major eq 11} { + # Add 11.0 to 11.minor to patterns. + for {set j $minor} {$j >= 0} {incr j -1} { + lappend res macosx${major}.${j}-${cpu} + foreach a $alt { + lappend res macosx${major}.${j}-$a + } + } + set major 10 + set minor 15 + } + # Add 10.5 to 10.minor to patterns. + for {set j $minor} {$j >= 5} {incr j -1} { + if {$cpu ne "arm"} { + lappend res macosx${major}.${j}-${cpu} + } + foreach a $alt { + lappend res macosx${major}.${j}-$a + } + } + + # Add unversioned patterns for 10.3/10.4 builds. + lappend res macosx-${cpu} + foreach a $alt { + lappend res macosx-$a + } + } else { + # No version, just do unversioned patterns. + foreach a $alt { + lappend res macosx-$a + } + } + } else { + # no v, no cpu ... nothing + } + } + } + lappend res tcl ; # Pure tcl packages are always compatible. + return $res +} + + +# ### ### ### ######### ######### ######### +## Ready + +package provide platform 1.0.15 + +# ### ### ### ######### ######### ######### +## Demo application + +if {[info exists argv0] && ($argv0 eq [info script])} { + puts ==================================== + parray tcl_platform + puts ==================================== + puts Generic\ identification:\ [::platform::generic] + puts Exact\ identification:\ \ \ [::platform::identify] + puts ==================================== + puts Search\ patterns: + puts *\ [join [::platform::patterns [::platform::identify]] \n*\ ] + puts ==================================== + exit 0 +} diff --git a/amd64/lib/tcl8/8.5/msgcat-1.6.1.tm b/amd64/lib/tcl8/8.5/msgcat-1.6.1.tm index 646bc17..fa91a37 100644 --- a/amd64/lib/tcl8/8.5/msgcat-1.6.1.tm +++ b/amd64/lib/tcl8/8.5/msgcat-1.6.1.tm @@ -4,9 +4,9 @@ # message catalog facility for Tcl programs. It should be # loaded with the command "package require msgcat". # -# Copyright (c) 2010-2015 by Harald Oehlmann. -# Copyright (c) 1998-2000 by Ajuba Solutions. -# Copyright (c) 1998 by Mark Harrison. +# Copyright (c) 2010-2015 Harald Oehlmann. +# Copyright (c) 1998-2000 Ajuba Solutions. +# Copyright (c) 1998 Mark Harrison. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/amd64/lib/tcl8/8.5/tcltest-2.5.3.tm b/amd64/lib/tcl8/8.5/tcltest-2.5.3.tm new file mode 100644 index 0000000..7dc75d7 --- /dev/null +++ b/amd64/lib/tcl8/8.5/tcltest-2.5.3.tm @@ -0,0 +1,3515 @@ +# tcltest.tcl -- +# +# This file contains support code for the Tcl test suite. It +# defines the tcltest namespace and finds and defines the output +# directory, constraints available, output and error channels, +# etc. used by Tcl tests. See the tcltest man page for more +# details. +# +# This design was based on the Tcl testing approach designed and +# initially implemented by Mary Ann May-Pumphrey of Sun +# Microsystems. +# +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 Scriptics Corporation. +# Copyright (c) 2000 Ajuba Solutions +# Contributions from Don Porter, NIST, 2002. (not subject to US copyright) +# All rights reserved. + +package require Tcl 8.5- ;# -verbose line uses [info frame] +namespace eval tcltest { + + # When the version number changes, be sure to update the pkgIndex.tcl file, + # and the install directory in the Makefiles. When the minor version + # changes (new feature) be sure to update the man page as well. + variable Version 2.5.3 + + # Compatibility support for dumb variables defined in tcltest 1 + # Do not use these. Call [package provide Tcl] and [info patchlevel] + # yourself. You don't need tcltest to wrap it for you. + variable version [package provide Tcl] + variable patchLevel [info patchlevel] + +##### Export the public tcltest procs; several categories + # + # Export the main functional commands that do useful things + namespace export cleanupTests loadTestedCommands makeDirectory \ + makeFile removeDirectory removeFile runAllTests test + + # Export configuration commands that control the functional commands + namespace export configure customMatch errorChannel interpreter \ + outputChannel testConstraint + + # Export commands that are duplication (candidates for deprecation) + if {![package vsatisfies [package provide Tcl] 8.7-]} { + namespace export bytestring ;# dups [encoding convertfrom identity] + } + namespace export debug ;# [configure -debug] + namespace export errorFile ;# [configure -errfile] + namespace export limitConstraints ;# [configure -limitconstraints] + namespace export loadFile ;# [configure -loadfile] + namespace export loadScript ;# [configure -load] + namespace export match ;# [configure -match] + namespace export matchFiles ;# [configure -file] + namespace export matchDirectories ;# [configure -relateddir] + namespace export normalizeMsg ;# application of [customMatch] + namespace export normalizePath ;# [file normalize] (8.4) + namespace export outputFile ;# [configure -outfile] + namespace export preserveCore ;# [configure -preservecore] + namespace export singleProcess ;# [configure -singleproc] + namespace export skip ;# [configure -skip] + namespace export skipFiles ;# [configure -notfile] + namespace export skipDirectories ;# [configure -asidefromdir] + namespace export temporaryDirectory ;# [configure -tmpdir] + namespace export testsDirectory ;# [configure -testdir] + namespace export verbose ;# [configure -verbose] + namespace export viewFile ;# binary encoding [read] + namespace export workingDirectory ;# [cd] [pwd] + + # Export deprecated commands for tcltest 1 compatibility + namespace export getMatchingFiles mainThread restoreState saveState \ + threadReap + + # tcltest::normalizePath -- + # + # This procedure resolves any symlinks in the path thus creating + # a path without internal redirection. It assumes that the + # incoming path is absolute. + # + # Arguments + # pathVar - name of variable containing path to modify. + # + # Results + # The path is modified in place. + # + # Side Effects: + # None. + # + proc normalizePath {pathVar} { + upvar 1 $pathVar path + set oldpwd [pwd] + catch {cd $path} + set path [pwd] + cd $oldpwd + return $path + } + +##### Verification commands used to test values of variables and options + # + # Verification command that accepts everything + proc AcceptAll {value} { + return $value + } + + # Verification command that accepts valid Tcl lists + proc AcceptList { list } { + return [lrange $list 0 end] + } + + # Verification command that accepts a glob pattern + proc AcceptPattern { pattern } { + return [AcceptAll $pattern] + } + + # Verification command that accepts integers + proc AcceptInteger { level } { + return [incr level 0] + } + + # Verification command that accepts boolean values + proc AcceptBoolean { boolean } { + return [expr {$boolean && $boolean}] + } + + # Verification command that accepts (syntactically) valid Tcl scripts + proc AcceptScript { script } { + if {![info complete $script]} { + return -code error "invalid Tcl script: $script" + } + return $script + } + + # Verification command that accepts (converts to) absolute pathnames + proc AcceptAbsolutePath { path } { + return [file join [pwd] $path] + } + + # Verification command that accepts existing readable directories + proc AcceptReadable { path } { + if {![file readable $path]} { + return -code error "\"$path\" is not readable" + } + return $path + } + proc AcceptDirectory { directory } { + set directory [AcceptAbsolutePath $directory] + if {![file exists $directory]} { + return -code error "\"$directory\" does not exist" + } + if {![file isdir $directory]} { + return -code error "\"$directory\" is not a directory" + } + return [AcceptReadable $directory] + } + +##### Initialize internal arrays of tcltest, but only if the caller + # has not already pre-initialized them. This is done to support + # compatibility with older tests that directly access internals + # rather than go through command interfaces. + # + proc ArrayDefault {varName value} { + variable $varName + if {[array exists $varName]} { + return + } + if {[info exists $varName]} { + # Pre-initialized value is a scalar: destroy it! + unset $varName + } + array set $varName $value + } + + # save the original environment so that it can be restored later + ArrayDefault originalEnv [array get ::env] + + # initialize numTests array to keep track of the number of tests + # that pass, fail, and are skipped. + ArrayDefault numTests [list Total 0 Passed 0 Skipped 0 Failed 0] + + # createdNewFiles will store test files as indices and the list of + # files (that should not have been) left behind by the test files + # as values. + ArrayDefault createdNewFiles {} + + # initialize skippedBecause array to keep track of constraints that + # kept tests from running; a constraint name of "userSpecifiedSkip" + # means that the test appeared on the list of tests that matched the + # -skip value given to the flag; "userSpecifiedNonMatch" means that + # the test didn't match the argument given to the -match flag; both + # of these constraints are counted only if tcltest::debug is set to + # true. + ArrayDefault skippedBecause {} + + # initialize the testConstraints array to keep track of valid + # predefined constraints (see the explanation for the + # InitConstraints proc for more details). + ArrayDefault testConstraints {} + +##### Initialize internal variables of tcltest, but only if the caller + # has not already pre-initialized them. This is done to support + # compatibility with older tests that directly access internals + # rather than go through command interfaces. + # + proc Default {varName value {verify AcceptAll}} { + variable $varName + if {![info exists $varName]} { + variable $varName [$verify $value] + } else { + variable $varName [$verify [set $varName]] + } + } + + # Save any arguments that we might want to pass through to other + # programs. This is used by the -args flag. + # FINDUSER + Default parameters {} + + # Count the number of files tested (0 if runAllTests wasn't called). + # runAllTests will set testSingleFile to false, so stats will + # not be printed until runAllTests calls the cleanupTests proc. + # The currentFailure var stores the boolean value of whether the + # current test file has had any failures. The failFiles list + # stores the names of test files that had failures. + Default numTestFiles 0 AcceptInteger + Default testSingleFile true AcceptBoolean + Default currentFailure false AcceptBoolean + Default failFiles {} AcceptList + + # Tests should remove all files they create. The test suite will + # check the current working dir for files created by the tests. + # filesMade keeps track of such files created using the makeFile and + # makeDirectory procedures. filesExisted stores the names of + # pre-existing files. + # + # Note that $filesExisted lists only those files that exist in + # the original [temporaryDirectory]. + Default filesMade {} AcceptList + Default filesExisted {} AcceptList + proc FillFilesExisted {} { + variable filesExisted + + # Save the names of files that already exist in the scratch directory. + foreach file [glob -nocomplain -directory [temporaryDirectory] *] { + lappend filesExisted [file tail $file] + } + + # After successful filling, turn this into a no-op. + proc FillFilesExisted args {} + } + + # Kept only for compatibility + Default constraintsSpecified {} AcceptList + trace add variable constraintsSpecified read [namespace code { + set constraintsSpecified [array names testConstraints] ;#}] + + # tests that use threads need to know which is the main thread + Default mainThread 1 + variable mainThread + if {[info commands thread::id] ne {}} { + set mainThread [thread::id] + } elseif {[info commands testthread] ne {}} { + set mainThread [testthread id] + } + + # Set workingDirectory to [pwd]. The default output directory for + # Tcl tests is the working directory. Whenever this value changes + # change to that directory. + variable workingDirectory + trace add variable workingDirectory write \ + [namespace code {cd $workingDirectory ;#}] + + Default workingDirectory [pwd] AcceptAbsolutePath + proc workingDirectory { {dir ""} } { + variable workingDirectory + if {[llength [info level 0]] == 1} { + return $workingDirectory + } + set workingDirectory [AcceptAbsolutePath $dir] + } + + # Set the location of the execuatble + Default tcltest [info nameofexecutable] + trace add variable tcltest write [namespace code {testConstraint stdio \ + [eval [ConstraintInitializer stdio]] ;#}] + + # save the platform information so it can be restored later + Default originalTclPlatform [array get ::tcl_platform] + + # If a core file exists, save its modification time. + if {[file exists [file join [workingDirectory] core]]} { + Default coreModTime \ + [file mtime [file join [workingDirectory] core]] + } + + # stdout and stderr buffers for use when we want to store them + Default outData {} + Default errData {} + + # keep track of test level for nested test commands + variable testLevel 0 + + # the variables and procs that existed when saveState was called are + # stored in a variable of the same name + Default saveState {} + + # Internationalization support -- used in [SetIso8859_1_Locale] and + # [RestoreLocale]. Those commands are used in cmdIL.test. + + if {![info exists [namespace current]::isoLocale]} { + variable isoLocale fr + switch -- $::tcl_platform(platform) { + "unix" { + + # Try some 'known' values for some platforms: + + switch -exact -- $::tcl_platform(os) { + "FreeBSD" { + set isoLocale fr_FR.ISO_8859-1 + } + HP-UX { + set isoLocale fr_FR.iso88591 + } + Linux - + IRIX { + set isoLocale fr + } + default { + + # Works on SunOS 4 and Solaris, and maybe + # others... Define it to something else on your + # system if you want to test those. + + set isoLocale iso_8859_1 + } + } + } + "windows" { + set isoLocale French + } + } + } + + variable ChannelsWeOpened; array set ChannelsWeOpened {} + # output goes to stdout by default + Default outputChannel stdout + proc outputChannel { {filename ""} } { + variable outputChannel + variable ChannelsWeOpened + + # This is very subtle and tricky, so let me try to explain. + # (Hopefully this longer comment will be clear when I come + # back in a few months, unlike its predecessor :) ) + # + # The [outputChannel] command (and underlying variable) have to + # be kept in sync with the [configure -outfile] configuration + # option ( and underlying variable Option(-outfile) ). This is + # accomplished with a write trace on Option(-outfile) that will + # update [outputChannel] whenver a new value is written. That + # much is easy. + # + # The trick is that in order to maintain compatibility with + # version 1 of tcltest, we must allow every configuration option + # to get its inital value from command line arguments. This is + # accomplished by setting initial read traces on all the + # configuration options to parse the command line option the first + # time they are read. These traces are cancelled whenever the + # program itself calls [configure]. + # + # OK, then so to support tcltest 1 compatibility, it seems we want + # to get the return from [outputFile] to trigger the read traces, + # just in case. + # + # BUT! A little known feature of Tcl variable traces is that + # traces are disabled during the handling of other traces. So, + # if we trigger read traces on Option(-outfile) and that triggers + # command line parsing which turns around and sets an initial + # value for Option(-outfile) -- -- the write trace that + # would keep [outputChannel] in sync with that new initial value + # would not fire! + # + # SO, finally, as a workaround, instead of triggering read traces + # by invoking [outputFile], we instead trigger the same set of + # read traces by invoking [debug]. Any command that reads a + # configuration option would do. [debug] is just a handy one. + # The end result is that we support tcltest 1 compatibility and + # keep outputChannel and -outfile in sync in all cases. + debug + + if {[llength [info level 0]] == 1} { + return $outputChannel + } + if {[info exists ChannelsWeOpened($outputChannel)]} { + close $outputChannel + unset ChannelsWeOpened($outputChannel) + } + switch -exact -- $filename { + stderr - + stdout { + set outputChannel $filename + } + default { + set outputChannel [open $filename a] + set ChannelsWeOpened($outputChannel) 1 + + # If we created the file in [temporaryDirectory], then + # [cleanupTests] will delete it, unless we claim it was + # already there. + set outdir [normalizePath [file dirname \ + [file join [pwd] $filename]]] + if {$outdir eq [temporaryDirectory]} { + variable filesExisted + FillFilesExisted + set filename [file tail $filename] + if {$filename ni $filesExisted} { + lappend filesExisted $filename + } + } + } + } + return $outputChannel + } + + # errors go to stderr by default + Default errorChannel stderr + proc errorChannel { {filename ""} } { + variable errorChannel + variable ChannelsWeOpened + + # This is subtle and tricky. See the comment above in + # [outputChannel] for a detailed explanation. + debug + + if {[llength [info level 0]] == 1} { + return $errorChannel + } + if {[info exists ChannelsWeOpened($errorChannel)]} { + close $errorChannel + unset ChannelsWeOpened($errorChannel) + } + switch -exact -- $filename { + stderr - + stdout { + set errorChannel $filename + } + default { + set errorChannel [open $filename a] + set ChannelsWeOpened($errorChannel) 1 + + # If we created the file in [temporaryDirectory], then + # [cleanupTests] will delete it, unless we claim it was + # already there. + set outdir [normalizePath [file dirname \ + [file join [pwd] $filename]]] + if {$outdir eq [temporaryDirectory]} { + variable filesExisted + FillFilesExisted + set filename [file tail $filename] + if {$filename ni $filesExisted} { + lappend filesExisted $filename + } + } + } + } + return $errorChannel + } + +##### Set up the configurable options + # + # The configurable options of the package + variable Option; array set Option {} + + # Usage strings for those options + variable Usage; array set Usage {} + + # Verification commands for those options + variable Verify; array set Verify {} + + # Initialize the default values of the configurable options that are + # historically associated with an exported variable. If that variable + # is already set, support compatibility by accepting its pre-set value. + # Use [trace] to establish ongoing connection between the deprecated + # exported variable and the modern option kept as a true internal var. + # Also set up usage string and value testing for the option. + proc Option {option value usage {verify AcceptAll} {varName {}}} { + variable Option + variable Verify + variable Usage + variable OptionControlledVariables + variable DefaultValue + set Usage($option) $usage + set Verify($option) $verify + set DefaultValue($option) $value + if {[catch {$verify $value} msg]} { + return -code error $msg + } else { + set Option($option) $msg + } + if {[string length $varName]} { + variable $varName + if {[info exists $varName]} { + if {[catch {$verify [set $varName]} msg]} { + return -code error $msg + } else { + set Option($option) $msg + } + unset $varName + } + namespace eval [namespace current] \ + [list upvar 0 Option($option) $varName] + # Workaround for Bug (now Feature Request) 572889. Grrrr.... + # Track all the variables tied to options + lappend OptionControlledVariables $varName + # Later, set auto-configure read traces on all + # of them, since a single trace on Option does not work. + proc $varName {{value {}}} [subst -nocommands { + if {[llength [info level 0]] == 2} { + Configure $option [set value] + } + return [Configure $option] + }] + } + } + + proc MatchingOption {option} { + variable Option + set match [array names Option $option*] + switch -- [llength $match] { + 0 { + set sorted [lsort [array names Option]] + set values [join [lrange $sorted 0 end-1] ", "] + append values ", or [lindex $sorted end]" + return -code error "unknown option $option: should be\ + one of $values" + } + 1 { + return [lindex $match 0] + } + default { + # Exact match trumps ambiguity + if {$option in $match} { + return $option + } + set values [join [lrange $match 0 end-1] ", "] + append values ", or [lindex $match end]" + return -code error "ambiguous option $option:\ + could match $values" + } + } + } + + proc EstablishAutoConfigureTraces {} { + variable OptionControlledVariables + foreach varName [concat $OptionControlledVariables Option] { + variable $varName + trace add variable $varName read [namespace code { + ProcessCmdLineArgs ;#}] + } + } + + proc RemoveAutoConfigureTraces {} { + variable OptionControlledVariables + foreach varName [concat $OptionControlledVariables Option] { + variable $varName + foreach pair [trace info variable $varName] { + lassign $pair op cmd + if {($op eq "read") && + [string match *ProcessCmdLineArgs* $cmd]} { + trace remove variable $varName $op $cmd + } + } + } + # Once the traces are removed, this can become a no-op + proc RemoveAutoConfigureTraces {} {} + } + + proc Configure args { + variable Option + variable Verify + set n [llength $args] + if {$n == 0} { + return [lsort [array names Option]] + } + if {$n == 1} { + if {[catch {MatchingOption [lindex $args 0]} option]} { + return -code error $option + } + return $Option($option) + } + while {[llength $args] > 1} { + if {[catch {MatchingOption [lindex $args 0]} option]} { + return -code error $option + } + if {[catch {$Verify($option) [lindex $args 1]} value]} { + return -code error "invalid $option\ + value \"[lindex $args 1]\": $value" + } + set Option($option) $value + set args [lrange $args 2 end] + } + if {[llength $args]} { + if {[catch {MatchingOption [lindex $args 0]} option]} { + return -code error $option + } + return -code error "missing value for option $option" + } + } + proc configure args { + if {[llength $args] > 1} { + RemoveAutoConfigureTraces + } + set code [catch {Configure {*}$args} msg] + return -code $code $msg + } + + proc AcceptVerbose { level } { + set level [AcceptList $level] + set levelMap { + l list + p pass + b body + s skip + t start + e error + l line + m msec + u usec + } + set levelRegexp "^([join [dict values $levelMap] |])\$" + if {[llength $level] == 1} { + if {![regexp $levelRegexp $level]} { + # translate single characters abbreviations to expanded list + set level [string map $levelMap [split $level {}]] + } + } + set valid [list] + foreach v $level { + if {[regexp $levelRegexp $v]} { + lappend valid $v + } + } + return $valid + } + + proc IsVerbose {level} { + variable Option + return [expr {[lsearch -exact $Option(-verbose) $level] >= 0}] + } + + # Default verbosity is to show bodies of failed tests + Option -verbose {body error} { + Takes any combination of the values 'p', 's', 'b', 't', 'e' and 'l'. + Test suite will display all passed tests if 'p' is specified, all + skipped tests if 's' is specified, the bodies of failed tests if + 'b' is specified, and when tests start if 't' is specified. + ErrorInfo is displayed if 'e' is specified. Source file line + information of failed tests is displayed if 'l' is specified. + } AcceptVerbose verbose + + # Match and skip patterns default to the empty list, except for + # matchFiles, which defaults to all .test files in the + # testsDirectory and matchDirectories, which defaults to all + # directories. + Option -match * { + Run all tests within the specified files that match one of the + list of glob patterns given. + } AcceptList match + + Option -skip {} { + Skip all tests within the specified tests (via -match) and files + that match one of the list of glob patterns given. + } AcceptList skip + + Option -file *.test { + Run tests in all test files that match the glob pattern given. + } AcceptPattern matchFiles + + # By default, skip files that appear to be SCCS lock files. + Option -notfile l.*.test { + Skip all test files that match the glob pattern given. + } AcceptPattern skipFiles + + Option -relateddir * { + Run tests in directories that match the glob pattern given. + } AcceptPattern matchDirectories + + Option -asidefromdir {} { + Skip tests in directories that match the glob pattern given. + } AcceptPattern skipDirectories + + # By default, don't save core files + Option -preservecore 0 { + If 2, save any core files produced during testing in the directory + specified by -tmpdir. If 1, notify the user if core files are + created. + } AcceptInteger preserveCore + + # debug output doesn't get printed by default; debug level 1 spits + # up only the tests that were skipped because they didn't match or + # were specifically skipped. A debug level of 2 would spit up the + # tcltest variables and flags provided; a debug level of 3 causes + # some additional output regarding operations of the test harness. + # The tcltest package currently implements only up to debug level 3. + Option -debug 0 { + Internal debug level + } AcceptInteger debug + + proc SetSelectedConstraints args { + variable Option + foreach c $Option(-constraints) { + testConstraint $c 1 + } + } + Option -constraints {} { + Do not skip the listed constraints listed in -constraints. + } AcceptList + trace add variable Option(-constraints) write \ + [namespace code {SetSelectedConstraints ;#}] + + # Don't run only the "-constraint" specified tests by default + proc ClearUnselectedConstraints args { + variable Option + variable testConstraints + if {!$Option(-limitconstraints)} {return} + foreach c [array names testConstraints] { + if {$c ni $Option(-constraints)} { + testConstraint $c 0 + } + } + } + Option -limitconstraints 0 { + whether to run only tests with the constraints + } AcceptBoolean limitConstraints + trace add variable Option(-limitconstraints) write \ + [namespace code {ClearUnselectedConstraints ;#}] + + # A test application has to know how to load the tested commands + # into the interpreter. + Option -load {} { + Specifies the script to load the tested commands. + } AcceptScript loadScript + + # Default is to run each test file in a separate process + Option -singleproc 0 { + whether to run all tests in one process + } AcceptBoolean singleProcess + + proc AcceptTemporaryDirectory { directory } { + set directory [AcceptAbsolutePath $directory] + if {![file exists $directory]} { + file mkdir $directory + } + set directory [AcceptDirectory $directory] + if {![file writable $directory]} { + if {[workingDirectory] eq $directory} { + # Special exception: accept the default value + # even if the directory is not writable + return $directory + } + return -code error "\"$directory\" is not writeable" + } + return $directory + } + + # Directory where files should be created + Option -tmpdir [workingDirectory] { + Save temporary files in the specified directory. + } AcceptTemporaryDirectory temporaryDirectory + trace add variable Option(-tmpdir) write \ + [namespace code {normalizePath Option(-tmpdir) ;#}] + + # Tests should not rely on the current working directory. + # Files that are part of the test suite should be accessed relative + # to [testsDirectory] + Option -testdir [workingDirectory] { + Search tests in the specified directory. + } AcceptDirectory testsDirectory + trace add variable Option(-testdir) write \ + [namespace code {normalizePath Option(-testdir) ;#}] + + proc AcceptLoadFile { file } { + if {$file eq {}} {return $file} + set file [file join [temporaryDirectory] $file] + return [AcceptReadable $file] + } + proc ReadLoadScript {args} { + variable Option + if {$Option(-loadfile) eq {}} {return} + set tmp [open $Option(-loadfile) r] + loadScript [read $tmp] + close $tmp + } + Option -loadfile {} { + Read the script to load the tested commands from the specified file. + } AcceptLoadFile loadFile + trace add variable Option(-loadfile) write [namespace code ReadLoadScript] + + proc AcceptOutFile { file } { + if {[string equal stderr $file]} {return $file} + if {[string equal stdout $file]} {return $file} + return [file join [temporaryDirectory] $file] + } + + # output goes to stdout by default + Option -outfile stdout { + Send output from test runs to the specified file. + } AcceptOutFile outputFile + trace add variable Option(-outfile) write \ + [namespace code {outputChannel $Option(-outfile) ;#}] + + # errors go to stderr by default + Option -errfile stderr { + Send errors from test runs to the specified file. + } AcceptOutFile errorFile + trace add variable Option(-errfile) write \ + [namespace code {errorChannel $Option(-errfile) ;#}] + + proc loadIntoChildInterpreter {child args} { + variable Version + interp eval $child [package ifneeded tcltest $Version] + interp eval $child "tcltest::configure {*}{$args}" + interp alias $child ::tcltest::ReportToParent \ + {} ::tcltest::ReportedFromChild + } + proc ReportedFromChild {total passed skipped failed because newfiles} { + variable numTests + variable skippedBecause + variable createdNewFiles + incr numTests(Total) $total + incr numTests(Passed) $passed + incr numTests(Skipped) $skipped + incr numTests(Failed) $failed + foreach {constraint count} $because { + incr skippedBecause($constraint) $count + } + foreach {testfile created} $newfiles { + lappend createdNewFiles($testfile) {*}$created + } + return + } +} + +##################################################################### + +# tcltest::Debug* -- +# +# Internal helper procedures to write out debug information +# dependent on the chosen level. A test shell may overide +# them, f.e. to redirect the output into a different +# channel, or even into a GUI. + +# tcltest::DebugPuts -- +# +# Prints the specified string if the current debug level is +# higher than the provided level argument. +# +# Arguments: +# level The lowest debug level triggering the output +# string The string to print out. +# +# Results: +# Prints the string. Nothing else is allowed. +# +# Side Effects: +# None. +# + +proc tcltest::DebugPuts {level string} { + variable debug + if {$debug >= $level} { + puts $string + } + return +} + +# tcltest::DebugPArray -- +# +# Prints the contents of the specified array if the current +# debug level is higher than the provided level argument +# +# Arguments: +# level The lowest debug level triggering the output +# arrayvar The name of the array to print out. +# +# Results: +# Prints the contents of the array. Nothing else is allowed. +# +# Side Effects: +# None. +# + +proc tcltest::DebugPArray {level arrayvar} { + variable debug + + if {$debug >= $level} { + catch {upvar 1 $arrayvar $arrayvar} + parray $arrayvar + } + return +} + +# Define our own [parray] in ::tcltest that will inherit use of the [puts] +# defined in ::tcltest. NOTE: Ought to construct with [info args] and +# [info default], but can't be bothered now. If [parray] changes, then +# this will need changing too. +auto_load ::parray +proc tcltest::parray {a {pattern *}} [info body ::parray] + +# tcltest::DebugDo -- +# +# Executes the script if the current debug level is greater than +# the provided level argument +# +# Arguments: +# level The lowest debug level triggering the execution. +# script The tcl script executed upon a debug level high enough. +# +# Results: +# Arbitrary side effects, dependent on the executed script. +# +# Side Effects: +# None. +# + +proc tcltest::DebugDo {level script} { + variable debug + + if {$debug >= $level} { + uplevel 1 $script + } + return +} + +##################################################################### + +proc tcltest::Warn {msg} { + puts [outputChannel] "WARNING: $msg" +} + +# tcltest::mainThread +# +# Accessor command for tcltest variable mainThread. +# +proc tcltest::mainThread { {new ""} } { + variable mainThread + if {[llength [info level 0]] == 1} { + return $mainThread + } + set mainThread $new +} + +# tcltest::testConstraint -- +# +# sets a test constraint to a value; to do multiple constraints, +# call this proc multiple times. also returns the value of the +# named constraint if no value was supplied. +# +# Arguments: +# constraint - name of the constraint +# value - new value for constraint (should be boolean) - if not +# supplied, this is a query +# +# Results: +# content of tcltest::testConstraints($constraint) +# +# Side effects: +# none + +proc tcltest::testConstraint {constraint {value ""}} { + variable testConstraints + variable Option + DebugPuts 3 "entering testConstraint $constraint $value" + if {[llength [info level 0]] == 2} { + return $testConstraints($constraint) + } + # Check for boolean values + if {[catch {expr {$value && 1}} msg]} { + return -code error $msg + } + if {[limitConstraints] && ($constraint ni $Option(-constraints))} { + set value 0 + } + set testConstraints($constraint) $value +} + +# tcltest::interpreter -- +# +# the interpreter name stored in tcltest::tcltest +# +# Arguments: +# executable name +# +# Results: +# content of tcltest::tcltest +# +# Side effects: +# None. + +proc tcltest::interpreter { {interp ""} } { + variable tcltest + if {[llength [info level 0]] == 1} { + return $tcltest + } + set tcltest $interp +} + +##################################################################### + +# tcltest::AddToSkippedBecause -- +# +# Increments the variable used to track how many tests were +# skipped because of a particular constraint. +# +# Arguments: +# constraint The name of the constraint to be modified +# +# Results: +# Modifies tcltest::skippedBecause; sets the variable to 1 if +# didn't previously exist - otherwise, it just increments it. +# +# Side effects: +# None. + +proc tcltest::AddToSkippedBecause { constraint {value 1}} { + # add the constraint to the list of constraints that kept tests + # from running + variable skippedBecause + + if {[info exists skippedBecause($constraint)]} { + incr skippedBecause($constraint) $value + } else { + set skippedBecause($constraint) $value + } + return +} + +# tcltest::PrintError -- +# +# Prints errors to tcltest::errorChannel and then flushes that +# channel, making sure that all messages are < 80 characters per +# line. +# +# Arguments: +# errorMsg String containing the error to be printed +# +# Results: +# None. +# +# Side effects: +# None. + +proc tcltest::PrintError {errorMsg} { + set InitialMessage "Error: " + set InitialMsgLen [string length $InitialMessage] + puts -nonewline [errorChannel] $InitialMessage + + # Keep track of where the end of the string is. + set endingIndex [string length $errorMsg] + + if {$endingIndex < (80 - $InitialMsgLen)} { + puts [errorChannel] $errorMsg + } else { + # Print up to 80 characters on the first line, including the + # InitialMessage. + set beginningIndex [string last " " [string range $errorMsg 0 \ + [expr {80 - $InitialMsgLen}]]] + puts [errorChannel] [string range $errorMsg 0 $beginningIndex] + + while {$beginningIndex ne "end"} { + puts -nonewline [errorChannel] \ + [string repeat " " $InitialMsgLen] + if {($endingIndex - $beginningIndex) + < (80 - $InitialMsgLen)} { + puts [errorChannel] [string trim \ + [string range $errorMsg $beginningIndex end]] + break + } else { + set newEndingIndex [expr {[string last " " \ + [string range $errorMsg $beginningIndex \ + [expr {$beginningIndex + + (80 - $InitialMsgLen)}] + ]] + $beginningIndex}] + if {($newEndingIndex <= 0) + || ($newEndingIndex <= $beginningIndex)} { + set newEndingIndex end + } + puts [errorChannel] [string trim \ + [string range $errorMsg \ + $beginningIndex $newEndingIndex]] + set beginningIndex $newEndingIndex + } + } + } + flush [errorChannel] + return +} + +# tcltest::SafeFetch -- +# +# The following trace procedure makes it so that we can safely +# refer to non-existent members of the testConstraints array +# without causing an error. Instead, reading a non-existent +# member will return 0. This is necessary because tests are +# allowed to use constraint "X" without ensuring that +# testConstraints("X") is defined. +# +# Arguments: +# n1 - name of the array (testConstraints) +# n2 - array key value (constraint name) +# op - operation performed on testConstraints (generally r) +# +# Results: +# none +# +# Side effects: +# sets testConstraints($n2) to 0 if it's referenced but never +# before used + +proc tcltest::SafeFetch {n1 n2 op} { + variable testConstraints + DebugPuts 3 "entering SafeFetch $n1 $n2 $op" + if {$n2 eq {}} {return} + if {![info exists testConstraints($n2)]} { + if {[catch {testConstraint $n2 [eval [ConstraintInitializer $n2]]}]} { + testConstraint $n2 0 + } + } +} + +# tcltest::ConstraintInitializer -- +# +# Get or set a script that when evaluated in the tcltest namespace +# will return a boolean value with which to initialize the +# associated constraint. +# +# Arguments: +# constraint - name of the constraint initialized by the script +# script - the initializer script +# +# Results +# boolean value of the constraint - enabled or disabled +# +# Side effects: +# Constraint is initialized for future reference by [test] +proc tcltest::ConstraintInitializer {constraint {script ""}} { + variable ConstraintInitializer + DebugPuts 3 "entering ConstraintInitializer $constraint $script" + if {[llength [info level 0]] == 2} { + return $ConstraintInitializer($constraint) + } + # Check for boolean values + if {![info complete $script]} { + return -code error "ConstraintInitializer must be complete script" + } + set ConstraintInitializer($constraint) $script +} + +# tcltest::InitConstraints -- +# +# Call all registered constraint initializers to force initialization +# of all known constraints. +# See the tcltest man page for the list of built-in constraints defined +# in this procedure. +# +# Arguments: +# none +# +# Results: +# The testConstraints array is reset to have an index for each +# built-in test constraint. +# +# Side Effects: +# None. +# + +proc tcltest::InitConstraints {} { + variable ConstraintInitializer + initConstraintsHook + foreach constraint [array names ConstraintInitializer] { + testConstraint $constraint + } +} + +proc tcltest::DefineConstraintInitializers {} { + ConstraintInitializer singleTestInterp {singleProcess} + + # All the 'pc' constraints are here for backward compatibility and + # are not documented. They have been replaced with equivalent 'win' + # constraints. + + ConstraintInitializer unixOnly \ + {string equal $::tcl_platform(platform) unix} + ConstraintInitializer macOnly \ + {string equal $::tcl_platform(platform) macintosh} + ConstraintInitializer pcOnly \ + {string equal $::tcl_platform(platform) windows} + ConstraintInitializer winOnly \ + {string equal $::tcl_platform(platform) windows} + + ConstraintInitializer unix {testConstraint unixOnly} + ConstraintInitializer mac {testConstraint macOnly} + ConstraintInitializer pc {testConstraint pcOnly} + ConstraintInitializer win {testConstraint winOnly} + + ConstraintInitializer unixOrPc \ + {expr {[testConstraint unix] || [testConstraint pc]}} + ConstraintInitializer macOrPc \ + {expr {[testConstraint mac] || [testConstraint pc]}} + ConstraintInitializer unixOrWin \ + {expr {[testConstraint unix] || [testConstraint win]}} + ConstraintInitializer macOrWin \ + {expr {[testConstraint mac] || [testConstraint win]}} + ConstraintInitializer macOrUnix \ + {expr {[testConstraint mac] || [testConstraint unix]}} + + ConstraintInitializer nt {string equal $::tcl_platform(os) "Windows NT"} + ConstraintInitializer 95 {string equal $::tcl_platform(os) "Windows 95"} + ConstraintInitializer 98 {string equal $::tcl_platform(os) "Windows 98"} + + # The following Constraints switches are used to mark tests that + # should work, but have been temporarily disabled on certain + # platforms because they don't and we haven't gotten around to + # fixing the underlying problem. + + ConstraintInitializer tempNotPc {expr {![testConstraint pc]}} + ConstraintInitializer tempNotWin {expr {![testConstraint win]}} + ConstraintInitializer tempNotMac {expr {![testConstraint mac]}} + ConstraintInitializer tempNotUnix {expr {![testConstraint unix]}} + + # The following Constraints switches are used to mark tests that + # crash on certain platforms, so that they can be reactivated again + # when the underlying problem is fixed. + + ConstraintInitializer pcCrash {expr {![testConstraint pc]}} + ConstraintInitializer winCrash {expr {![testConstraint win]}} + ConstraintInitializer macCrash {expr {![testConstraint mac]}} + ConstraintInitializer unixCrash {expr {![testConstraint unix]}} + + # Skip empty tests + + ConstraintInitializer emptyTest {format 0} + + # By default, tests that expose known bugs are skipped. + + ConstraintInitializer knownBug {format 0} + + # By default, non-portable tests are skipped. + + ConstraintInitializer nonPortable {format 0} + + # Some tests require user interaction. + + ConstraintInitializer userInteraction {format 0} + + # Some tests must be skipped if the interpreter is not in + # interactive mode + + ConstraintInitializer interactive \ + {expr {[info exists ::tcl_interactive] && $::tcl_interactive}} + + # Some tests can only be run if the installation came from a CD + # image instead of a web image. Some tests must be skipped if you + # are running as root on Unix. Other tests can only be run if you + # are running as root on Unix. + + ConstraintInitializer root {expr \ + {($::tcl_platform(platform) eq "unix") && + ($::tcl_platform(user) in {root {}})}} + ConstraintInitializer notRoot {expr {![testConstraint root]}} + + # Set nonBlockFiles constraint: 1 means this platform supports + # setting files into nonblocking mode. + + ConstraintInitializer nonBlockFiles { + set code [expr {[catch {set f [open defs r]}] + || [catch {fconfigure $f -blocking off}]}] + catch {close $f} + set code + } + + # Set asyncPipeClose constraint: 1 means this platform supports + # async flush and async close on a pipe. + # + # Test for SCO Unix - cannot run async flushing tests because a + # potential problem with select is apparently interfering. + # (Mark Diekhans). + + ConstraintInitializer asyncPipeClose {expr { + !([string equal unix $::tcl_platform(platform)] + && ([catch {exec uname -X | fgrep {Release = 3.2v}}] == 0))}} + + # Test to see if we have a broken version of sprintf with respect + # to the "e" format of floating-point numbers. + + ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05} + + # Test to see if execed commands such as cat, echo, rm and so forth + # are present on this machine. + + ConstraintInitializer unixExecs { + set code 1 + if {$::tcl_platform(platform) eq "macintosh"} { + set code 0 + } + if {$::tcl_platform(platform) eq "windows"} { + if {[catch { + set file _tcl_test_remove_me.txt + makeFile {hello} $file + }]} { + set code 0 + } elseif { + [catch {exec cat $file}] || + [catch {exec echo hello}] || + [catch {exec sh -c echo hello}] || + [catch {exec wc $file}] || + [catch {exec sleep 1}] || + [catch {exec echo abc > $file}] || + [catch {exec chmod 644 $file}] || + [catch {exec rm $file}] || + [llength [auto_execok mkdir]] == 0 || + [llength [auto_execok fgrep]] == 0 || + [llength [auto_execok grep]] == 0 || + [llength [auto_execok ps]] == 0 + } { + set code 0 + } + removeFile $file + } + set code + } + + ConstraintInitializer stdio { + set code 0 + if {![catch {set f [open "|[list [interpreter]]" w]}]} { + if {![catch {puts $f exit}]} { + if {![catch {close $f}]} { + set code 1 + } + } + } + set code + } + + # Deliberately call socket with the wrong number of arguments. The + # error message you get will indicate whether sockets are available + # on this system. + + ConstraintInitializer socket { + catch {socket} msg + string compare $msg "sockets are not available on this system" + } + + # Check for internationalization + ConstraintInitializer hasIsoLocale { + if {[llength [info commands testlocale]] == 0} { + set code 0 + } else { + set code [string length [SetIso8859_1_Locale]] + RestoreLocale + } + set code + } + +} +##################################################################### + +# Usage and command line arguments processing. + +# tcltest::PrintUsageInfo +# +# Prints out the usage information for package tcltest. This can +# be customized with the redefinition of [PrintUsageInfoHook]. +# +# Arguments: +# none +# +# Results: +# none +# +# Side Effects: +# none +proc tcltest::PrintUsageInfo {} { + puts [Usage] + PrintUsageInfoHook +} + +proc tcltest::Usage { {option ""} } { + variable Usage + variable Verify + if {[llength [info level 0]] == 1} { + set msg "Usage: [file tail [info nameofexecutable]] script " + append msg "?-help? ?flag value? ... \n" + append msg "Available flags (and valid input values) are:" + + set max 0 + set allOpts [concat -help [Configure]] + foreach opt $allOpts { + set foo [Usage $opt] + lassign $foo x type($opt) usage($opt) + set line($opt) " $opt $type($opt) " + set length($opt) [string length $line($opt)] + if {$length($opt) > $max} {set max $length($opt)} + } + set rest [expr {72 - $max}] + foreach opt $allOpts { + append msg \n$line($opt) + append msg [string repeat " " [expr {$max - $length($opt)}]] + set u [string trim $usage($opt)] + catch {append u " (default: \[[Configure $opt]])"} + regsub -all {\s*\n\s*} $u " " u + while {[string length $u] > $rest} { + set break [string wordstart $u $rest] + if {$break == 0} { + set break [string wordend $u 0] + } + append msg [string range $u 0 [expr {$break - 1}]] + set u [string trim [string range $u $break end]] + append msg \n[string repeat " " $max] + } + append msg $u + } + return $msg\n + } elseif {$option eq "-help"} { + return [list -help "" "Display this usage information."] + } else { + set type [lindex [info args $Verify($option)] 0] + return [list $option $type $Usage($option)] + } +} + +# tcltest::ProcessFlags -- +# +# process command line arguments supplied in the flagArray - this +# is called by processCmdLineArgs. Modifies tcltest variables +# according to the content of the flagArray. +# +# Arguments: +# flagArray - array containing name/value pairs of flags +# +# Results: +# sets tcltest variables according to their values as defined by +# flagArray +# +# Side effects: +# None. + +proc tcltest::ProcessFlags {flagArray} { + # Process -help first + if {"-help" in $flagArray} { + PrintUsageInfo + exit 1 + } + + if {[llength $flagArray] == 0} { + RemoveAutoConfigureTraces + } else { + set args $flagArray + while {[llength $args] > 1 && [catch {configure {*}$args} msg]} { + + # Something went wrong parsing $args for tcltest options + # Check whether the problem is "unknown option" + if {[regexp {^unknown option (\S+):} $msg -> option]} { + # Could be this is an option the Hook knows about + set moreOptions [processCmdLineArgsAddFlagsHook] + if {$option ni $moreOptions} { + # Nope. Report the error, including additional options, + # but keep going + if {[llength $moreOptions]} { + append msg ", " + append msg [join [lrange $moreOptions 0 end-1] ", "] + append msg "or [lindex $moreOptions end]" + } + Warn $msg + } + } else { + # error is something other than "unknown option" + # notify user of the error; and exit + puts [errorChannel] $msg + exit 1 + } + + # To recover, find that unknown option and remove up to it. + # then retry + while {[lindex $args 0] ne $option} { + set args [lrange $args 2 end] + } + set args [lrange $args 2 end] + } + if {[llength $args] == 1} { + puts [errorChannel] \ + "missing value for option [lindex $args 0]" + exit 1 + } + } + + # Call the hook + catch { + array set flag $flagArray + processCmdLineArgsHook [array get flag] + } + return +} + +# tcltest::ProcessCmdLineArgs -- +# +# This procedure must be run after constraint initialization is +# set up (by [DefineConstraintInitializers]) because some constraints +# can be overridden. +# +# Perform configuration according to the command-line options. +# +# Arguments: +# none +# +# Results: +# Sets the above-named variables in the tcltest namespace. +# +# Side Effects: +# None. +# + +proc tcltest::ProcessCmdLineArgs {} { + variable originalEnv + variable testConstraints + + # The "argv" var doesn't exist in some cases, so use {}. + if {![info exists ::argv]} { + ProcessFlags {} + } else { + ProcessFlags $::argv + } + + # Spit out everything you know if we're at a debug level 2 or + # greater + DebugPuts 2 "Flags passed into tcltest:" + if {[info exists ::env(TCLTEST_OPTIONS)]} { + DebugPuts 2 \ + " ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)" + } + if {[info exists ::argv]} { + DebugPuts 2 " argv: $::argv" + } + DebugPuts 2 "tcltest::debug = [debug]" + DebugPuts 2 "tcltest::testsDirectory = [testsDirectory]" + DebugPuts 2 "tcltest::workingDirectory = [workingDirectory]" + DebugPuts 2 "tcltest::temporaryDirectory = [temporaryDirectory]" + DebugPuts 2 "tcltest::outputChannel = [outputChannel]" + DebugPuts 2 "tcltest::errorChannel = [errorChannel]" + DebugPuts 2 "Original environment (tcltest::originalEnv):" + DebugPArray 2 originalEnv + DebugPuts 2 "Constraints:" + DebugPArray 2 testConstraints +} + +##################################################################### + +# Code to run the tests goes here. + +# tcltest::TestPuts -- +# +# Used to redefine puts in test environment. Stores whatever goes +# out on stdout in tcltest::outData and stderr in errData before +# sending it on to the regular puts. +# +# Arguments: +# same as standard puts +# +# Results: +# none +# +# Side effects: +# Intercepts puts; data that would otherwise go to stdout, stderr, +# or file channels specified in outputChannel and errorChannel +# does not get sent to the normal puts function. +namespace eval tcltest::Replace { + namespace export puts +} +proc tcltest::Replace::puts {args} { + variable [namespace parent]::outData + variable [namespace parent]::errData + switch [llength $args] { + 1 { + # Only the string to be printed is specified + append outData [lindex $args 0]\n + return + # return [Puts [lindex $args 0]] + } + 2 { + # Either -nonewline or channelId has been specified + if {[lindex $args 0] eq "-nonewline"} { + append outData [lindex $args end] + return + # return [Puts -nonewline [lindex $args end]] + } else { + set channel [lindex $args 0] + set newline \n + } + } + 3 { + if {[lindex $args 0] eq "-nonewline"} { + # Both -nonewline and channelId are specified, unless + # it's an error. -nonewline is supposed to be argv[0]. + set channel [lindex $args 1] + set newline "" + } + } + } + + if {[info exists channel]} { + if {$channel in [list [[namespace parent]::outputChannel] stdout]} { + append outData [lindex $args end]$newline + return + } elseif {$channel in [list [[namespace parent]::errorChannel] stderr]} { + append errData [lindex $args end]$newline + return + } + } + + # If we haven't returned by now, we don't know how to handle the + # input. Let puts handle it. + return [Puts {*}$args] +} + +# tcltest::Eval -- +# +# Evaluate the script in the test environment. If ignoreOutput is +# false, store data sent to stderr and stdout in outData and +# errData. Otherwise, ignore this output altogether. +# +# Arguments: +# script Script to evaluate +# ?ignoreOutput? Indicates whether or not to ignore output +# sent to stdout & stderr +# +# Results: +# result from running the script +# +# Side effects: +# Empties the contents of outData and errData before running a +# test if ignoreOutput is set to 0. + +proc tcltest::Eval {script {ignoreOutput 1}} { + variable outData + variable errData + DebugPuts 3 "[lindex [info level 0] 0] called" + if {!$ignoreOutput} { + set outData {} + set errData {} + rename ::puts [namespace current]::Replace::Puts + namespace eval :: [list namespace import [namespace origin Replace::puts]] + namespace import Replace::puts + } + set result [uplevel 1 $script] + if {!$ignoreOutput} { + namespace forget puts + namespace eval :: namespace forget puts + rename [namespace current]::Replace::Puts ::puts + } + return $result +} + +# tcltest::CompareStrings -- +# +# compares the expected answer to the actual answer, depending on +# the mode provided. Mode determines whether a regexp, exact, +# glob or custom comparison is done. +# +# Arguments: +# actual - string containing the actual result +# expected - pattern to be matched against +# mode - type of comparison to be done +# +# Results: +# result of the match +# +# Side effects: +# None. + +proc tcltest::CompareStrings {actual expected mode} { + variable CustomMatch + if {![info exists CustomMatch($mode)]} { + return -code error "No matching command registered for `-match $mode'" + } + set match [namespace eval :: $CustomMatch($mode) [list $expected $actual]] + if {[catch {expr {$match && $match}} result]} { + return -code error "Invalid result from `-match $mode' command: $result" + } + return $match +} + +# tcltest::customMatch -- +# +# registers a command to be called when a particular type of +# matching is required. +# +# Arguments: +# nickname - Keyword for the type of matching +# cmd - Incomplete command that implements that type of matching +# when completed with expected string and actual string +# and then evaluated. +# +# Results: +# None. +# +# Side effects: +# Sets the variable tcltest::CustomMatch + +proc tcltest::customMatch {mode script} { + variable CustomMatch + if {![info complete $script]} { + return -code error \ + "invalid customMatch script; can't evaluate after completion" + } + set CustomMatch($mode) $script +} + +# tcltest::SubstArguments list +# +# This helper function takes in a list of words, then perform a +# substitution on the list as though each word in the list is a separate +# argument to the Tcl function. For example, if this function is +# invoked as: +# +# SubstArguments {$a {$a}} +# +# Then it is as though the function is invoked as: +# +# SubstArguments $a {$a} +# +# This code is adapted from Paul Duffin's function "SplitIntoWords". +# The original function can be found on: +# +# http://purl.org/thecliff/tcl/wiki/858.html +# +# Results: +# a list containing the result of the substitution +# +# Exceptions: +# An error may occur if the list containing unbalanced quote or +# unknown variable. +# +# Side Effects: +# None. +# + +proc tcltest::SubstArguments {argList} { + + # We need to split the argList up into tokens but cannot use list + # operations as they throw away some significant quoting, and + # [split] ignores braces as it should. Therefore what we do is + # gradually build up a string out of whitespace seperated strings. + # We cannot use [split] to split the argList into whitespace + # separated strings as it throws away the whitespace which maybe + # important so we have to do it all by hand. + + set result {} + set token "" + + while {[string length $argList]} { + # Look for the next word containing a quote: " { } + if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \ + $argList all]} { + # Get the text leading up to this word, but not including + # this word, from the argList. + set text [string range $argList 0 \ + [expr {[lindex $all 0] - 1}]] + # Get the word with the quote + set word [string range $argList \ + [lindex $all 0] [lindex $all 1]] + + # Remove all text up to and including the word from the + # argList. + set argList [string range $argList \ + [expr {[lindex $all 1] + 1}] end] + } else { + # Take everything up to the end of the argList. + set text $argList + set word {} + set argList {} + } + + if {$token ne {}} { + # If we saw a word with quote before, then there is a + # multi-word token starting with that word. In this case, + # add the text and the current word to this token. + append token $text $word + } else { + # Add the text to the result. There is no need to parse + # the text because it couldn't be a part of any multi-word + # token. Then start a new multi-word token with the word + # because we need to pass this token to the Tcl parser to + # check for balancing quotes + append result $text + set token $word + } + + if { [catch {llength $token} length] == 0 && $length == 1} { + # The token is a valid list so add it to the result. + # lappend result [string trim $token] + append result \{$token\} + set token {} + } + } + + # If the last token has not been added to the list then there + # is a problem. + if { [string length $token] } { + error "incomplete token \"$token\"" + } + + return $result +} + + +# tcltest::test -- +# +# This procedure runs a test and prints an error message if the test +# fails. If verbose has been set, it also prints a message even if the +# test succeeds. The test will be skipped if it doesn't match the +# match variable, if it matches an element in skip, or if one of the +# elements of "constraints" turns out not to be true. +# +# If testLevel is 1, then this is a top level test, and we record +# pass/fail information; otherwise, this information is not logged and +# is not added to running totals. +# +# Attributes: +# Only description is a required attribute. All others are optional. +# Default values are indicated. +# +# constraints - A list of one or more keywords, each of which +# must be the name of an element in the array +# "testConstraints". If any of these elements is +# zero, the test is skipped. This attribute is +# optional; default is {} +# body - Script to run to carry out the test. It must +# return a result that can be checked for +# correctness. This attribute is optional; +# default is {} +# result - Expected result from script. This attribute is +# optional; default is {}. +# output - Expected output sent to stdout. This attribute +# is optional; default is {}. +# errorOutput - Expected output sent to stderr. This attribute +# is optional; default is {}. +# returnCodes - Expected return codes. This attribute is +# optional; default is {0 2}. +# errorCode - Expected error code. This attribute is +# optional; default is {*}. It is a glob pattern. +# If given, returnCodes defaults to {1}. +# setup - Code to run before $script (above). This +# attribute is optional; default is {}. +# cleanup - Code to run after $script (above). This +# attribute is optional; default is {}. +# match - specifies type of matching to do on result, +# output, errorOutput; this must be a string +# previously registered by a call to [customMatch]. +# The strings exact, glob, and regexp are pre-registered +# by the tcltest package. Default value is exact. +# +# Arguments: +# name - Name of test, in the form foo-1.2. +# description - Short textual description of the test, to +# help humans understand what it does. +# +# Results: +# None. +# +# Side effects: +# Just about anything is possible depending on the test. +# + +proc tcltest::test {name description args} { + global tcl_platform + variable testLevel + variable coreModTime + DebugPuts 3 "test $name $args" + DebugDo 1 { + variable TestNames + catch { + puts "test name '$name' re-used; prior use in $TestNames($name)" + } + set TestNames($name) [info script] + } + + FillFilesExisted + incr testLevel + + # Pre-define everything to null except output and errorOutput. We + # determine whether or not to trap output based on whether or not + # these variables (output & errorOutput) are defined. + lassign {} constraints setup cleanup body result returnCodes errorCode match + + # Set the default match mode + set match exact + + # Set the default match values for return codes (0 is the standard + # expected return value if everything went well; 2 represents + # 'return' being used in the test script). + set returnCodes [list 0 2] + + # Set the default error code pattern + set errorCode "*" + + # The old test format can't have a 3rd argument (constraints or + # script) that starts with '-'. + if {[string match -* [lindex $args 0]] || ([llength $args] <= 1)} { + if {[llength $args] == 1} { + set list [SubstArguments [lindex $args 0]] + foreach {element value} $list { + set testAttributes($element) $value + } + foreach item {constraints match setup body cleanup \ + result returnCodes errorCode output errorOutput} { + if {[info exists testAttributes(-$item)]} { + set testAttributes(-$item) [uplevel 1 \ + ::concat $testAttributes(-$item)] + } + } + } else { + array set testAttributes $args + } + + set validFlags {-setup -cleanup -body -result -returnCodes \ + -errorCode -match -output -errorOutput -constraints} + + foreach flag [array names testAttributes] { + if {$flag ni $validFlags} { + incr testLevel -1 + set sorted [lsort $validFlags] + set options [join [lrange $sorted 0 end-1] ", "] + append options ", or [lindex $sorted end]" + return -code error "bad option \"$flag\": must be $options" + } + } + + # store whatever the user gave us + foreach item [array names testAttributes] { + set [string trimleft $item "-"] $testAttributes($item) + } + + # Check the values supplied for -match + variable CustomMatch + if {$match ni [array names CustomMatch]} { + incr testLevel -1 + set sorted [lsort [array names CustomMatch]] + set values [join [lrange $sorted 0 end-1] ", "] + append values ", or [lindex $sorted end]" + return -code error "bad -match value \"$match\":\ + must be $values" + } + + # Replace symbolic valies supplied for -returnCodes + foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} { + set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes] + } + # errorCode without returnCode 1 is meaningless + if {$errorCode ne "*" && 1 ni $returnCodes} { + set returnCodes 1 + } + } else { + # This is parsing for the old test command format; it is here + # for backward compatibility. + set result [lindex $args end] + if {[llength $args] == 2} { + set body [lindex $args 0] + } elseif {[llength $args] == 3} { + set constraints [lindex $args 0] + set body [lindex $args 1] + } else { + incr testLevel -1 + return -code error "wrong # args:\ + should be \"test name desc ?options?\"" + } + } + + if {[Skipped $name $constraints]} { + incr testLevel -1 + return + } + + # Save information about the core file. + if {[preserveCore]} { + if {[file exists [file join [workingDirectory] core]]} { + set coreModTime [file mtime [file join [workingDirectory] core]] + } + } + + # First, run the setup script (or a hook if it presents): + if {[set cmd [namespace which -command [namespace current]::SetupTest]] ne ""} { + set setup [list $cmd $setup] + } + set processTest 1 + set code [catch {uplevel 1 $setup} setupMsg] + if {$code == 1} { + set errorInfo(setup) $::errorInfo + set errorCodeRes(setup) $::errorCode + if {$errorCodeRes(setup) eq "BYPASS-SKIPPED-TEST"} { + _noticeSkipped $name $setupMsg + set processTest [set code 0] + } + } + set setupFailure [expr {$code != 0}] + + # Only run the test body if the setup was successful + if {$processTest && !$setupFailure} { + + # Register startup time + if {[IsVerbose msec] || [IsVerbose usec]} { + set timeStart [clock microseconds] + } + + # Verbose notification of $body start + if {[IsVerbose start]} { + puts [outputChannel] "---- $name start" + flush [outputChannel] + } + + set command [list [namespace origin RunTest] $name $body] + if {[info exists output] || [info exists errorOutput]} { + set testResult [uplevel 1 [list [namespace origin Eval] $command 0]] + } else { + set testResult [uplevel 1 [list [namespace origin Eval] $command 1]] + } + lassign $testResult actualAnswer returnCode + if {$returnCode == 1} { + set errorInfo(body) $::errorInfo + set errorCodeRes(body) $::errorCode + if {$errorCodeRes(body) eq "BYPASS-SKIPPED-TEST"} { + _noticeSkipped $name $actualAnswer + set processTest [set returnCode 0] + } + } + } + + # check if the return code matched the expected return code + set codeFailure 0 + if {$processTest && !$setupFailure && ($returnCode ni $returnCodes)} { + set codeFailure 1 + } + set errorCodeFailure 0 + if {$processTest && !$setupFailure && !$codeFailure && $returnCode == 1 && \ + ![string match $errorCode $errorCodeRes(body)]} { + set errorCodeFailure 1 + } + + # If expected output/error strings exist, we have to compare + # them. If the comparison fails, then so did the test. + set outputFailure 0 + variable outData + if {$processTest && [info exists output] && !$codeFailure} { + if {[set outputCompare [catch { + CompareStrings $outData $output $match + } outputMatch]] == 0} { + set outputFailure [expr {!$outputMatch}] + } else { + set outputFailure 1 + } + } + + set errorFailure 0 + variable errData + if {$processTest && [info exists errorOutput] && !$codeFailure} { + if {[set errorCompare [catch { + CompareStrings $errData $errorOutput $match + } errorMatch]] == 0} { + set errorFailure [expr {!$errorMatch}] + } else { + set errorFailure 1 + } + } + + # check if the answer matched the expected answer + # Only check if we ran the body of the test (no setup failure) + if {!$processTest} { + set scriptFailure 0 + } elseif {$setupFailure || $codeFailure} { + set scriptFailure 0 + } elseif {[set scriptCompare [catch { + CompareStrings $actualAnswer $result $match + } scriptMatch]] == 0} { + set scriptFailure [expr {!$scriptMatch}] + } else { + set scriptFailure 1 + } + + # Always run the cleanup script (or a hook if it presents): + if {[set cmd [namespace which -command [namespace current]::CleanupTest]] ne ""} { + set cleanup [list $cmd $cleanup] + } + set code [catch {uplevel 1 $cleanup} cleanupMsg] + if {$code == 1} { + set errorInfo(cleanup) $::errorInfo + set errorCodeRes(cleanup) $::errorCode + } + set cleanupFailure [expr {$code != 0}] + + set coreFailure 0 + set coreMsg "" + # check for a core file first - if one was created by the test, + # then the test failed + if {[preserveCore]} { + if {[file exists [file join [workingDirectory] core]]} { + # There's only a test failure if there is a core file + # and (1) there previously wasn't one or (2) the new + # one is different from the old one. + if {[info exists coreModTime]} { + if {$coreModTime != [file mtime \ + [file join [workingDirectory] core]]} { + set coreFailure 1 + } + } else { + set coreFailure 1 + } + + if {([preserveCore] > 1) && ($coreFailure)} { + append coreMsg "\nMoving file to:\ + [file join [temporaryDirectory] core-$name]" + catch {file rename -force -- \ + [file join [workingDirectory] core] \ + [file join [temporaryDirectory] core-$name] + } msg + if {$msg ne {}} { + append coreMsg "\nError:\ + Problem renaming core file: $msg" + } + } + } + } + + if {[IsVerbose msec] || [IsVerbose usec]} { + set t [expr {[clock microseconds] - $timeStart}] + if {[IsVerbose usec]} { + puts [outputChannel] "++++ $name took $t μs" + } + if {[IsVerbose msec]} { + puts [outputChannel] "++++ $name took [expr {round($t/1000.)}] ms" + } + } + + # if skipped, it is safe to return here + if {!$processTest} { + incr testLevel -1 + return + } + + # if we didn't experience any failures, then we passed + variable numTests + if {!($setupFailure || $cleanupFailure || $coreFailure + || $outputFailure || $errorFailure || $codeFailure + || $errorCodeFailure || $scriptFailure)} { + if {$testLevel == 1} { + incr numTests(Passed) + if {[IsVerbose pass]} { + puts [outputChannel] "++++ $name PASSED" + } + } + incr testLevel -1 + return + } + + # We know the test failed, tally it... + if {$testLevel == 1} { + incr numTests(Failed) + } + + # ... then report according to the type of failure + variable currentFailure true + if {![IsVerbose body]} { + set body "" + } + puts [outputChannel] "\n" + if {[IsVerbose line]} { + if {![catch {set testFrame [info frame -1]}] && + [dict get $testFrame type] eq "source"} { + set testFile [dict get $testFrame file] + set testLine [dict get $testFrame line] + } else { + set testFile [file normalize [uplevel 1 {info script}]] + if {[file readable $testFile]} { + set testFd [open $testFile r] + set testLine [expr {[lsearch -regexp \ + [split [read $testFd] "\n"] \ + "^\[ \t\]*test [string map {. \\.} $name] "] + 1}] + close $testFd + } + } + if {[info exists testLine]} { + puts [outputChannel] "$testFile:$testLine: error: test failed:\ + $name [string trim $description]" + } + } + puts [outputChannel] "==== $name\ + [string trim $description] FAILED" + if {[string length $body]} { + puts [outputChannel] "==== Contents of test case:" + puts [outputChannel] $body + } + if {$setupFailure} { + puts [outputChannel] "---- Test setup\ + failed:\n$setupMsg" + if {[info exists errorInfo(setup)]} { + puts [outputChannel] "---- errorInfo(setup): $errorInfo(setup)" + puts [outputChannel] "---- errorCode(setup): $errorCodeRes(setup)" + } + } + if {$processTest && $scriptFailure} { + if {$scriptCompare} { + puts [outputChannel] "---- Error testing result: $scriptMatch" + } else { + puts [outputChannel] "---- Result was:\n$actualAnswer" + puts [outputChannel] "---- Result should have been\ + ($match matching):\n$result" + } + } + if {$errorCodeFailure} { + puts [outputChannel] "---- Error code was: '$errorCodeRes(body)'" + puts [outputChannel] "---- Error code should have been: '$errorCode'" + } + if {$codeFailure} { + switch -- $returnCode { + 0 { set msg "Test completed normally" } + 1 { set msg "Test generated error" } + 2 { set msg "Test generated return exception" } + 3 { set msg "Test generated break exception" } + 4 { set msg "Test generated continue exception" } + default { set msg "Test generated exception" } + } + puts [outputChannel] "---- $msg; Return code was: $returnCode" + puts [outputChannel] "---- Return code should have been\ + one of: $returnCodes" + if {[IsVerbose error]} { + if {[info exists errorInfo(body)] && (1 ni $returnCodes)} { + puts [outputChannel] "---- errorInfo: $errorInfo(body)" + puts [outputChannel] "---- errorCode: $errorCodeRes(body)" + } + } + } + if {$outputFailure} { + if {$outputCompare} { + puts [outputChannel] "---- Error testing output: $outputMatch" + } else { + puts [outputChannel] "---- Output was:\n$outData" + puts [outputChannel] "---- Output should have been\ + ($match matching):\n$output" + } + } + if {$errorFailure} { + if {$errorCompare} { + puts [outputChannel] "---- Error testing errorOutput: $errorMatch" + } else { + puts [outputChannel] "---- Error output was:\n$errData" + puts [outputChannel] "---- Error output should have\ + been ($match matching):\n$errorOutput" + } + } + if {$cleanupFailure} { + puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg" + if {[info exists errorInfo(cleanup)]} { + puts [outputChannel] "---- errorInfo(cleanup): $errorInfo(cleanup)" + puts [outputChannel] "---- errorCode(cleanup): $errorCodeRes(cleanup)" + } + } + if {$coreFailure} { + puts [outputChannel] "---- Core file produced while running\ + test! $coreMsg" + } + puts [outputChannel] "==== $name FAILED\n" + + incr testLevel -1 + return +} + +# Skip -- +# +# Skips a running test and add a reason to skipped "constraints". Can be used +# to conditional intended abort of the test. +# +# Side Effects: Maintains tally of total tests seen and tests skipped. +# +proc tcltest::Skip {reason} { + return -code error -errorcode BYPASS-SKIPPED-TEST $reason +} + +proc tcltest::_noticeSkipped {name reason} { + variable testLevel + variable numTests + + if {[IsVerbose skip]} { + puts [outputChannel] "++++ $name SKIPPED: $reason" + } + + if {$testLevel == 1} { + incr numTests(Skipped) + AddToSkippedBecause $reason + } +} + + +# Skipped -- +# +# Given a test name and it constraints, returns a boolean indicating +# whether the current configuration says the test should be skipped. +# +# Side Effects: Maintains tally of total tests seen and tests skipped. +# +proc tcltest::Skipped {name constraints} { + variable testLevel + variable numTests + variable testConstraints + + if {$testLevel == 1} { + incr numTests(Total) + } + # skip the test if it's name matches an element of skip + foreach pattern [skip] { + if {[string match $pattern $name]} { + if {$testLevel == 1} { + incr numTests(Skipped) + DebugDo 1 {AddToSkippedBecause userSpecifiedSkip} + } + return 1 + } + } + # skip the test if it's name doesn't match any element of match + set ok 0 + foreach pattern [match] { + if {[string match $pattern $name]} { + set ok 1 + break + } + } + if {!$ok} { + if {$testLevel == 1} { + incr numTests(Skipped) + DebugDo 1 {AddToSkippedBecause userSpecifiedNonMatch} + } + return 1 + } + if {$constraints eq {}} { + # If we're limited to the listed constraints and there aren't + # any listed, then we shouldn't run the test. + if {[limitConstraints]} { + AddToSkippedBecause userSpecifiedLimitConstraint + if {$testLevel == 1} { + incr numTests(Skipped) + } + return 1 + } + } else { + # "constraints" argument exists; + # make sure that the constraints are satisfied. + + set doTest 0 + if {[string match {*[$\[]*} $constraints] != 0} { + # full expression, e.g. {$foo > [info tclversion]} + catch {set doTest [uplevel #0 [list expr $constraints]]} + } elseif {[regexp {[^.:_a-zA-Z0-9 \n\r\t]+} $constraints] != 0} { + # something like {a || b} should be turned into + # $testConstraints(a) || $testConstraints(b). + regsub -all {[.\w]+} $constraints {$testConstraints(&)} c + catch {set doTest [eval [list expr $c]]} + } elseif {![catch {llength $constraints}]} { + # just simple constraints such as {unixOnly fonts}. + set doTest 1 + foreach constraint $constraints { + if {(![info exists testConstraints($constraint)]) \ + || (!$testConstraints($constraint))} { + set doTest 0 + + # store the constraint that kept the test from + # running + set constraints $constraint + break + } + } + } + + if {!$doTest} { + _noticeSkipped $name $constraints + return 1 + } + } + return 0 +} + +# RunTest -- +# +# This is where the body of a test is evaluated. The combination of +# [RunTest] and [Eval] allows the output and error output of the test +# body to be captured for comparison against the expected values. + +proc tcltest::RunTest {name script} { + DebugPuts 3 "Running $name {$script}" + + # If there is no "memory" command (because memory debugging isn't + # enabled), then don't attempt to use the command. + + if {[llength [info commands memory]] == 1} { + memory tag $name + } + + # run the test script (or a hook if it presents): + if {[set cmd [namespace which -command [namespace current]::EvalTest]] ne ""} { + set script [list $cmd $script] + } + set code [catch {uplevel 1 $script} actualAnswer] + + return [list $actualAnswer $code] +} + +##################################################################### + +# tcltest::cleanupTestsHook -- +# +# This hook allows a harness that builds upon tcltest to specify +# additional things that should be done at cleanup. +# + +if {[llength [info commands tcltest::cleanupTestsHook]] == 0} { + proc tcltest::cleanupTestsHook {} {} +} + +# tcltest::cleanupTests -- +# +# Remove files and dirs created using the makeFile and makeDirectory +# commands since the last time this proc was invoked. +# +# Print the names of the files created without the makeFile command +# since the tests were invoked. +# +# Print the number tests (total, passed, failed, and skipped) since the +# tests were invoked. +# +# Restore original environment (as reported by special variable env). +# +# Arguments: +# calledFromAllFile - if 0, behave as if we are running a single +# test file within an entire suite of tests. if we aren't running +# a single test file, then don't report status. check for new +# files created during the test run and report on them. if 1, +# report collated status from all the test file runs. +# +# Results: +# None. +# +# Side Effects: +# None +# + +proc tcltest::cleanupTests {{calledFromAllFile 0}} { + variable filesMade + variable filesExisted + variable createdNewFiles + variable testSingleFile + variable numTests + variable numTestFiles + variable failFiles + variable skippedBecause + variable currentFailure + variable originalEnv + variable originalTclPlatform + variable coreModTime + + FillFilesExisted + set testFileName [file tail [info script]] + + # Hook to handle reporting to a parent interpreter + if {[llength [info commands [namespace current]::ReportToParent]]} { + ReportToParent $numTests(Total) $numTests(Passed) $numTests(Skipped) \ + $numTests(Failed) [array get skippedBecause] \ + [array get createdNewFiles] + set testSingleFile false + } + + # Call the cleanup hook + cleanupTestsHook + + # Remove files and directories created by the makeFile and + # makeDirectory procedures. Record the names of files in + # workingDirectory that were not pre-existing, and associate them + # with the test file that created them. + + if {!$calledFromAllFile} { + foreach file $filesMade { + if {[file exists $file]} { + DebugDo 1 {Warn "cleanupTests deleting $file..."} + catch {file delete -force -- $file} + } + } + set currentFiles {} + foreach file [glob -nocomplain \ + -directory [temporaryDirectory] *] { + lappend currentFiles [file tail $file] + } + set newFiles {} + foreach file $currentFiles { + if {$file ni $filesExisted} { + lappend newFiles $file + } + } + set filesExisted $currentFiles + if {[llength $newFiles] > 0} { + set createdNewFiles($testFileName) $newFiles + } + } + + if {$calledFromAllFile || $testSingleFile} { + + # print stats + + puts -nonewline [outputChannel] "$testFileName:" + foreach index [list "Total" "Passed" "Skipped" "Failed"] { + puts -nonewline [outputChannel] \ + "\t$index\t$numTests($index)" + } + puts [outputChannel] "" + + # print number test files sourced + # print names of files that ran tests which failed + + if {$calledFromAllFile} { + puts [outputChannel] \ + "Sourced $numTestFiles Test Files." + set numTestFiles 0 + if {[llength $failFiles] > 0} { + puts [outputChannel] \ + "Files with failing tests: $failFiles" + set failFiles {} + } + } + + # if any tests were skipped, print the constraints that kept + # them from running. + + set constraintList [array names skippedBecause] + if {[llength $constraintList] > 0} { + puts [outputChannel] \ + "Number of tests skipped for each constraint:" + foreach constraint [lsort $constraintList] { + puts [outputChannel] \ + "\t$skippedBecause($constraint)\t$constraint" + unset skippedBecause($constraint) + } + } + + # report the names of test files in createdNewFiles, and reset + # the array to be empty. + + set testFilesThatTurded [lsort [array names createdNewFiles]] + if {[llength $testFilesThatTurded] > 0} { + puts [outputChannel] "Warning: files left behind:" + foreach testFile $testFilesThatTurded { + puts [outputChannel] \ + "\t$testFile:\t$createdNewFiles($testFile)" + unset createdNewFiles($testFile) + } + } + + # reset filesMade, filesExisted, and numTests + + set filesMade {} + foreach index [list "Total" "Passed" "Skipped" "Failed"] { + set numTests($index) 0 + } + + # exit only if running Tk in non-interactive mode + # This should be changed to determine if an event + # loop is running, which is the real issue. + # Actually, this doesn't belong here at all. A package + # really has no business [exit]-ing an application. + if {![catch {package present Tk}] && ![testConstraint interactive]} { + exit + } + } else { + + # if we're deferring stat-reporting until all files are sourced, + # then add current file to failFile list if any tests in this + # file failed + + if {$currentFailure && ($testFileName ni $failFiles)} { + lappend failFiles $testFileName + } + set currentFailure false + + # restore the environment to the state it was in before this package + # was loaded + + set newEnv {} + set changedEnv {} + set removedEnv {} + foreach index [array names ::env] { + if {![info exists originalEnv($index)]} { + lappend newEnv $index + unset ::env($index) + } + } + foreach index [array names originalEnv] { + if {![info exists ::env($index)]} { + lappend removedEnv $index + set ::env($index) $originalEnv($index) + } elseif {$::env($index) ne $originalEnv($index)} { + lappend changedEnv $index + set ::env($index) $originalEnv($index) + } + } + if {[llength $newEnv] > 0} { + puts [outputChannel] \ + "env array elements created:\t$newEnv" + } + if {[llength $changedEnv] > 0} { + puts [outputChannel] \ + "env array elements changed:\t$changedEnv" + } + if {[llength $removedEnv] > 0} { + puts [outputChannel] \ + "env array elements removed:\t$removedEnv" + } + + set changedTclPlatform {} + foreach index [array names originalTclPlatform] { + if {$::tcl_platform($index) \ + != $originalTclPlatform($index)} { + lappend changedTclPlatform $index + set ::tcl_platform($index) $originalTclPlatform($index) + } + } + if {[llength $changedTclPlatform] > 0} { + puts [outputChannel] "tcl_platform array elements\ + changed:\t$changedTclPlatform" + } + + if {[file exists [file join [workingDirectory] core]]} { + if {[preserveCore] > 1} { + puts "rename core file (> 1)" + puts [outputChannel] "produced core file! \ + Moving file to: \ + [file join [temporaryDirectory] core-$testFileName]" + catch {file rename -force -- \ + [file join [workingDirectory] core] \ + [file join [temporaryDirectory] core-$testFileName] + } msg + if {$msg ne {}} { + PrintError "Problem renaming file: $msg" + } + } else { + # Print a message if there is a core file and (1) there + # previously wasn't one or (2) the new one is different + # from the old one. + + if {[info exists coreModTime]} { + if {$coreModTime != [file mtime \ + [file join [workingDirectory] core]]} { + puts [outputChannel] "A core file was created!" + } + } else { + puts [outputChannel] "A core file was created!" + } + } + } + } + flush [outputChannel] + flush [errorChannel] + return +} + +##################################################################### + +# Procs that determine which tests/test files to run + +# tcltest::GetMatchingFiles +# +# Looks at the patterns given to match and skip files and uses +# them to put together a list of the tests that will be run. +# +# Arguments: +# directory to search +# +# Results: +# The constructed list is returned to the user. This will +# primarily be used in 'all.tcl' files. It is used in +# runAllTests. +# +# Side Effects: +# None + +# a lower case version is needed for compatibility with tcltest 1.0 +proc tcltest::getMatchingFiles args {GetMatchingFiles {*}$args} + +proc tcltest::GetMatchingFiles { args } { + if {[llength $args]} { + set dirList $args + } else { + # Finding tests only in [testsDirectory] is normal operation. + # This procedure is written to accept multiple directory arguments + # only to satisfy version 1 compatibility. + set dirList [list [testsDirectory]] + } + + set matchingFiles [list] + foreach directory $dirList { + + # List files in $directory that match patterns to run. + set matchFileList [list] + foreach match [matchFiles] { + set matchFileList [concat $matchFileList \ + [glob -directory $directory -types {b c f p s} \ + -nocomplain -- $match]] + } + + # List files in $directory that match patterns to skip. + set skipFileList [list] + foreach skip [skipFiles] { + set skipFileList [concat $skipFileList \ + [glob -directory $directory -types {b c f p s} \ + -nocomplain -- $skip]] + } + + # Add to result list all files in match list and not in skip list + foreach file $matchFileList { + if {$file ni $skipFileList} { + lappend matchingFiles $file + } + } + } + + if {[llength $matchingFiles] == 0} { + PrintError "No test files remain after applying your match and\ + skip patterns!" + } + return $matchingFiles +} + +# tcltest::GetMatchingDirectories -- +# +# Looks at the patterns given to match and skip directories and +# uses them to put together a list of the test directories that we +# should attempt to run. (Only subdirectories containing an +# "all.tcl" file are put into the list.) +# +# Arguments: +# root directory from which to search +# +# Results: +# The constructed list is returned to the user. This is used in +# the primary all.tcl file. +# +# Side Effects: +# None. + +proc tcltest::GetMatchingDirectories {rootdir} { + + # Determine the skip list first, to avoid [glob]-ing over subdirectories + # we're going to throw away anyway. Be sure we skip the $rootdir if it + # comes up to avoid infinite loops. + set skipDirs [list $rootdir] + foreach pattern [skipDirectories] { + set skipDirs [concat $skipDirs [glob -directory $rootdir -types d \ + -nocomplain -- $pattern]] + } + + # Now step through the matching directories, prune out the skipped ones + # as you go. + set matchDirs [list] + foreach pattern [matchDirectories] { + foreach path [glob -directory $rootdir -types d -nocomplain -- \ + $pattern] { + if {$path ni $skipDirs} { + set matchDirs [concat $matchDirs [GetMatchingDirectories $path]] + if {[file exists [file join $path all.tcl]]} { + lappend matchDirs $path + } + } + } + } + + if {[llength $matchDirs] == 0} { + DebugPuts 1 "No test directories remain after applying match\ + and skip patterns!" + } + return [lsort $matchDirs] +} + +# tcltest::runAllTests -- +# +# prints output and sources test files according to the match and +# skip patterns provided. after sourcing test files, it goes on +# to source all.tcl files in matching test subdirectories. +# +# Arguments: +# shell being tested +# +# Results: +# Whether there were any failures. +# +# Side effects: +# None. + +proc tcltest::runAllTests { {shell ""} } { + variable testSingleFile + variable numTestFiles + variable numTests + variable failFiles + variable DefaultValue + + FillFilesExisted + if {[llength [info level 0]] == 1} { + set shell [interpreter] + } + + set testSingleFile false + + puts [outputChannel] "Tests running in interp: $shell" + puts [outputChannel] "Tests located in: [testsDirectory]" + puts [outputChannel] "Tests running in: [workingDirectory]" + puts [outputChannel] "Temporary files stored in\ + [temporaryDirectory]" + + # [file system] first available in Tcl 8.4 + if {![catch {file system [testsDirectory]} result] + && ([lindex $result 0] ne "native")} { + # If we aren't running in the native filesystem, then we must + # run the tests in a single process (via 'source'), because + # trying to run then via a pipe will fail since the files don't + # really exist. + singleProcess 1 + } + + if {[singleProcess]} { + puts [outputChannel] \ + "Test files sourced into current interpreter" + } else { + puts [outputChannel] \ + "Test files run in separate interpreters" + } + if {[llength [skip]] > 0} { + puts [outputChannel] "Skipping tests that match: [skip]" + } + puts [outputChannel] "Running tests that match: [match]" + + if {[llength [skipFiles]] > 0} { + puts [outputChannel] \ + "Skipping test files that match: [skipFiles]" + } + if {[llength [matchFiles]] > 0} { + puts [outputChannel] \ + "Only running test files that match: [matchFiles]" + } + + set timeCmd {clock format [clock seconds]} + puts [outputChannel] "Tests began at [eval $timeCmd]" + + # Run each of the specified tests + foreach file [lsort [GetMatchingFiles]] { + set tail [file tail $file] + puts [outputChannel] $tail + flush [outputChannel] + + if {[singleProcess]} { + if {[catch { + incr numTestFiles + uplevel 1 [list ::source $file] + } msg]} { + puts [outputChannel] "Test file error: $msg" + # append the name of the test to a list to be reported + # later + lappend testFileFailures $file + } + if {$numTests(Failed) > 0} { + set failFilesSet 1 + } + } else { + # Pass along our configuration to the child processes. + # EXCEPT for the -outfile, because the parent process + # needs to read and process output of children. + set childargv [list] + foreach opt [Configure] { + if {$opt eq "-outfile"} {continue} + set value [Configure $opt] + # Don't bother passing default configuration options + if {$value eq $DefaultValue($opt)} { + continue + } + lappend childargv $opt $value + } + set cmd [linsert $childargv 0 | $shell $file] + if {[catch { + incr numTestFiles + set pipeFd [open $cmd "r"] + while {[gets $pipeFd line] >= 0} { + if {[regexp [join { + {^([^:]+):\t} + {Total\t([0-9]+)\t} + {Passed\t([0-9]+)\t} + {Skipped\t([0-9]+)\t} + {Failed\t([0-9]+)} + } ""] $line null testFile \ + Total Passed Skipped Failed]} { + foreach index {Total Passed Skipped Failed} { + incr numTests($index) [set $index] + } + if {$Failed > 0} { + lappend failFiles $testFile + set failFilesSet 1 + } + } elseif {[regexp [join { + {^Number of tests skipped } + {for each constraint:} + {|^\t(\d+)\t(.+)$} + } ""] $line match skipped constraint]} { + if {[string match \t* $match]} { + AddToSkippedBecause $constraint $skipped + } + } else { + puts [outputChannel] $line + } + } + close $pipeFd + } msg]} { + puts [outputChannel] "Test file error: $msg" + # append the name of the test to a list to be reported + # later + lappend testFileFailures $file + } + } + } + + # cleanup + puts [outputChannel] "\nTests ended at [eval $timeCmd]" + cleanupTests 1 + if {[info exists testFileFailures]} { + puts [outputChannel] "\nTest files exiting with errors: \n" + foreach file $testFileFailures { + puts [outputChannel] " [file tail $file]\n" + } + } + + # Checking for subdirectories in which to run tests + foreach directory [GetMatchingDirectories [testsDirectory]] { + set dir [file tail $directory] + puts [outputChannel] [string repeat ~ 44] + puts [outputChannel] "$dir test began at [eval $timeCmd]\n" + + uplevel 1 [list ::source [file join $directory all.tcl]] + + set endTime [eval $timeCmd] + puts [outputChannel] "\n$dir test ended at $endTime" + puts [outputChannel] "" + puts [outputChannel] [string repeat ~ 44] + } + return [expr {[info exists testFileFailures] || [info exists failFilesSet]}] +} + +##################################################################### + +# Test utility procs - not used in tcltest, but may be useful for +# testing. + +# tcltest::loadTestedCommands -- +# +# Uses the specified script to load the commands to test. Allowed to +# be empty, as the tested commands could have been compiled into the +# interpreter. +# +# Arguments +# none +# +# Results +# none +# +# Side Effects: +# none. + +proc tcltest::loadTestedCommands {} { + return [uplevel 1 [loadScript]] +} + +# tcltest::saveState -- +# +# Save information regarding what procs and variables exist. +# +# Arguments: +# none +# +# Results: +# Modifies the variable saveState +# +# Side effects: +# None. + +proc tcltest::saveState {} { + variable saveState + uplevel 1 [list ::set [namespace which -variable saveState]] \ + {[::list [::info procs] [::info vars]]} + DebugPuts 2 "[lindex [info level 0] 0]: $saveState" + return +} + +# tcltest::restoreState -- +# +# Remove procs and variables that didn't exist before the call to +# [saveState]. +# +# Arguments: +# none +# +# Results: +# Removes procs and variables from your environment if they don't +# exist in the saveState variable. +# +# Side effects: +# None. + +proc tcltest::restoreState {} { + variable saveState + foreach p [uplevel 1 {::info procs}] { + if {($p ni [lindex $saveState 0]) && ("[namespace current]::$p" ne + [uplevel 1 [list ::namespace origin $p]])} { + + DebugPuts 2 "[lindex [info level 0] 0]: Removing proc $p" + uplevel 1 [list ::catch [list ::rename $p {}]] + } + } + foreach p [uplevel 1 {::info vars}] { + if {$p ni [lindex $saveState 1]} { + DebugPuts 2 "[lindex [info level 0] 0]:\ + Removing variable $p" + uplevel 1 [list ::catch [list ::unset $p]] + } + } + return +} + +# tcltest::normalizeMsg -- +# +# Removes "extra" newlines from a string. +# +# Arguments: +# msg String to be modified +# +# Results: +# string with extra newlines removed +# +# Side effects: +# None. + +proc tcltest::normalizeMsg {msg} { + regsub "\n$" [string tolower $msg] "" msg + set msg [string map [list "\n\n" "\n"] $msg] + return [string map [list "\n\}" "\}"] $msg] +} + +# tcltest::makeFile -- +# +# Create a new file with the name , and write to it. +# +# If this file hasn't been created via makeFile since the last time +# cleanupTests was called, add it to the $filesMade list, so it will be +# removed by the next call to cleanupTests. +# +# Arguments: +# contents content of the new file +# name name of the new file +# directory directory name for new file +# +# Results: +# absolute path to the file created +# +# Side effects: +# None. + +proc tcltest::makeFile {contents name {directory ""}} { + variable filesMade + FillFilesExisted + + if {[llength [info level 0]] == 3} { + set directory [temporaryDirectory] + } + + set fullName [file join $directory $name] + + DebugPuts 3 "[lindex [info level 0] 0]:\ + putting ``$contents'' into $fullName" + + set fd [open $fullName w] + fconfigure $fd -translation lf + if {[package vsatisfies [package provide Tcl] 8.7-]} { + fconfigure $fd -encoding utf-8 + } + if {[string index $contents end] eq "\n"} { + puts -nonewline $fd $contents + } else { + puts $fd $contents + } + close $fd + + if {$fullName ni $filesMade} { + lappend filesMade $fullName + } + return $fullName +} + +# tcltest::removeFile -- +# +# Removes the named file from the filesystem +# +# Arguments: +# name file to be removed +# directory directory from which to remove file +# +# Results: +# return value from [file delete] +# +# Side effects: +# None. + +proc tcltest::removeFile {name {directory ""}} { + variable filesMade + FillFilesExisted + if {[llength [info level 0]] == 2} { + set directory [temporaryDirectory] + } + set fullName [file join $directory $name] + DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName" + set idx [lsearch -exact $filesMade $fullName] + if {$idx < 0} { + DebugDo 1 { + Warn "removeFile removing \"$fullName\":\n not created by makeFile" + } + } else { + set filesMade [lreplace $filesMade $idx $idx] + } + if {![file isfile $fullName]} { + DebugDo 1 { + Warn "removeFile removing \"$fullName\":\n not a file" + } + } + if {[catch {file delete -- $fullName} msg ]} { + DebugDo 1 { + Warn "removeFile removing \"$fullName\":\n failed: $msg" + } + } + return +} + +# tcltest::makeDirectory -- +# +# Create a new dir with the name . +# +# If this dir hasn't been created via makeDirectory since the last time +# cleanupTests was called, add it to the $directoriesMade list, so it +# will be removed by the next call to cleanupTests. +# +# Arguments: +# name name of the new directory +# directory directory in which to create new dir +# +# Results: +# absolute path to the directory created +# +# Side effects: +# None. + +proc tcltest::makeDirectory {name {directory ""}} { + variable filesMade + FillFilesExisted + if {[llength [info level 0]] == 2} { + set directory [temporaryDirectory] + } + set fullName [file join $directory $name] + DebugPuts 3 "[lindex [info level 0] 0]: creating $fullName" + file mkdir $fullName + if {$fullName ni $filesMade} { + lappend filesMade $fullName + } + return $fullName +} + +# tcltest::removeDirectory -- +# +# Removes a named directory from the file system. +# +# Arguments: +# name Name of the directory to remove +# directory Directory from which to remove +# +# Results: +# return value from [file delete] +# +# Side effects: +# None + +proc tcltest::removeDirectory {name {directory ""}} { + variable filesMade + FillFilesExisted + if {[llength [info level 0]] == 2} { + set directory [temporaryDirectory] + } + set fullName [file join $directory $name] + DebugPuts 3 "[lindex [info level 0] 0]: deleting $fullName" + set idx [lsearch -exact $filesMade $fullName] + set filesMade [lreplace $filesMade $idx $idx] + if {$idx < 0} { + DebugDo 1 { + Warn "removeDirectory removing \"$fullName\":\n not created\ + by makeDirectory" + } + } + if {![file isdirectory $fullName]} { + DebugDo 1 { + Warn "removeDirectory removing \"$fullName\":\n not a directory" + } + } + return [file delete -force -- $fullName] +} + +# tcltest::viewFile -- +# +# reads the content of a file and returns it +# +# Arguments: +# name of the file to read +# directory in which file is located +# +# Results: +# content of the named file +# +# Side effects: +# None. + +proc tcltest::viewFile {name {directory ""}} { + FillFilesExisted + if {[llength [info level 0]] == 2} { + set directory [temporaryDirectory] + } + set fullName [file join $directory $name] + set f [open $fullName] + if {[package vsatisfies [package provide Tcl] 8.7-]} { + fconfigure $f -encoding utf-8 + } + set data [read -nonewline $f] + close $f + return $data +} + +# tcltest::bytestring -- +# +# Construct a string that consists of the requested sequence of bytes, +# as opposed to a string of properly formed UTF-8 characters. +# This allows the tester to +# 1. Create denormalized or improperly formed strings to pass to C +# procedures that are supposed to accept strings with embedded NULL +# bytes. +# 2. Confirm that a string result has a certain pattern of bytes, for +# instance to confirm that "\xE0\0" in a Tcl script is stored +# internally in UTF-8 as the sequence of bytes "\xC3\xA0\xC0\x80". +# +# Generally, it's a bad idea to examine the bytes in a Tcl string or to +# construct improperly formed strings in this manner, because it involves +# exposing that Tcl uses UTF-8 internally. +# +# This function doesn't work any more in Tcl 8.7, since the 'identity' +# is gone (TIP #345) +# +# Arguments: +# string being converted +# +# Results: +# result fom encoding +# +# Side effects: +# None + +if {![package vsatisfies [package provide Tcl] 8.7-]} { + proc tcltest::bytestring {string} { + return [encoding convertfrom identity $string] + } +} + +# tcltest::OpenFiles -- +# +# used in io tests, uses testchannel +# +# Arguments: +# None. +# +# Results: +# ??? +# +# Side effects: +# None. + +proc tcltest::OpenFiles {} { + if {[catch {testchannel open} result]} { + return {} + } + return $result +} + +# tcltest::LeakFiles -- +# +# used in io tests, uses testchannel +# +# Arguments: +# None. +# +# Results: +# ??? +# +# Side effects: +# None. + +proc tcltest::LeakFiles {old} { + if {[catch {testchannel open} new]} { + return {} + } + set leak {} + foreach p $new { + if {$p ni $old} { + lappend leak $p + } + } + return $leak +} + +# +# Internationalization / ISO support procs -- dl +# + +# tcltest::SetIso8859_1_Locale -- +# +# used in cmdIL.test, uses testlocale +# +# Arguments: +# None. +# +# Results: +# None. +# +# Side effects: +# None. + +proc tcltest::SetIso8859_1_Locale {} { + variable previousLocale + variable isoLocale + if {[info commands testlocale] != ""} { + set previousLocale [testlocale ctype] + testlocale ctype $isoLocale + } + return +} + +# tcltest::RestoreLocale -- +# +# used in cmdIL.test, uses testlocale +# +# Arguments: +# None. +# +# Results: +# None. +# +# Side effects: +# None. + +proc tcltest::RestoreLocale {} { + variable previousLocale + if {[info commands testlocale] != ""} { + testlocale ctype $previousLocale + } + return +} + +# tcltest::threadReap -- +# +# Kill all threads except for the main thread. +# Do nothing if testthread is not defined. +# +# Arguments: +# none. +# +# Results: +# Returns the number of existing threads. +# +# Side Effects: +# none. +# + +proc tcltest::threadReap {} { + if {[info commands testthread] ne {}} { + + # testthread built into tcltest + + testthread errorproc ThreadNullError + while {[llength [testthread names]] > 1} { + foreach tid [testthread names] { + if {$tid != [mainThread]} { + catch { + testthread send -async $tid {testthread exit} + } + } + } + ## Enter a bit a sleep to give the threads enough breathing + ## room to kill themselves off, otherwise the end up with a + ## massive queue of repeated events + after 1 + } + testthread errorproc ThreadError + return [llength [testthread names]] + } elseif {[info commands thread::id] ne {}} { + + # Thread extension + + thread::errorproc ThreadNullError + while {[llength [thread::names]] > 1} { + foreach tid [thread::names] { + if {$tid != [mainThread]} { + catch {thread::send -async $tid {thread::exit}} + } + } + ## Enter a bit a sleep to give the threads enough breathing + ## room to kill themselves off, otherwise the end up with a + ## massive queue of repeated events + after 1 + } + thread::errorproc ThreadError + return [llength [thread::names]] + } else { + return 1 + } + return 0 +} + +# Initialize the constraints and set up command line arguments +namespace eval tcltest { + # Define initializers for all the built-in contraint definitions + DefineConstraintInitializers + + # Set up the constraints in the testConstraints array to be lazily + # initialized by a registered initializer, or by "false" if no + # initializer is registered. + trace add variable testConstraints read [namespace code SafeFetch] + + # Only initialize constraints at package load time if an + # [initConstraintsHook] has been pre-defined. This is only + # for compatibility support. The modern way to add a custom + # test constraint is to just call the [testConstraint] command + # straight away, without all this "hook" nonsense. + if {[namespace current] eq + [namespace qualifiers [namespace which initConstraintsHook]]} { + InitConstraints + } else { + proc initConstraintsHook {} {} + } + + # Define the standard match commands + customMatch exact [list string equal] + customMatch glob [list string match] + customMatch regexp [list regexp --] + + # If the TCLTEST_OPTIONS environment variable exists, configure + # tcltest according to the option values it specifies. This has + # the effect of resetting tcltest's default configuration. + proc ConfigureFromEnvironment {} { + upvar #0 env(TCLTEST_OPTIONS) options + if {[catch {llength $options} msg]} { + Warn "invalid TCLTEST_OPTIONS \"$options\":\n invalid\ + Tcl list: $msg" + return + } + if {[llength $options] % 2} { + Warn "invalid TCLTEST_OPTIONS: \"$options\":\n should be\ + -option value ?-option value ...?" + return + } + if {[catch {Configure {*}$options} msg]} { + Warn "invalid TCLTEST_OPTIONS: \"$options\":\n $msg" + return + } + } + if {[info exists ::env(TCLTEST_OPTIONS)]} { + ConfigureFromEnvironment + } + + proc LoadTimeCmdLineArgParsingRequired {} { + set required false + if {[info exists ::argv] && ("-help" in $::argv)} { + # The command line asks for -help, so give it (and exit) + # right now. ([configure] does not process -help) + set required true + } + foreach hook { PrintUsageInfoHook processCmdLineArgsHook + processCmdLineArgsAddFlagsHook } { + if {[namespace current] eq + [namespace qualifiers [namespace which $hook]]} { + set required true + } else { + proc $hook args {} + } + } + return $required + } + + # Only initialize configurable options from the command line arguments + # at package load time if necessary for backward compatibility. This + # lets the tcltest user call [configure] for themselves if they wish. + # Traces are established for auto-configuration from the command line + # if any configurable options are accessed before the user calls + # [configure]. + if {[LoadTimeCmdLineArgParsingRequired]} { + ProcessCmdLineArgs + } else { + EstablishAutoConfigureTraces + } + + package provide [namespace tail [namespace current]] $Version +} diff --git a/amd64/lib/tcl8/8.6/http-2.9.5.tm b/amd64/lib/tcl8/8.6/http-2.9.5.tm new file mode 100644 index 0000000..b0f87de --- /dev/null +++ b/amd64/lib/tcl8/8.6/http-2.9.5.tm @@ -0,0 +1,3506 @@ +# http.tcl -- +# +# Client-side HTTP for GET, POST, and HEAD commands. These routines can +# be used in untrusted code that uses the Safesock security policy. +# These procedures use a callback interface to avoid using vwait, which +# is not defined in the safe base. +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require Tcl 8.6- +# Keep this in sync with pkgIndex.tcl and with the install directories in +# Makefiles +package provide http 2.9.5 + +namespace eval http { + # Allow resourcing to not clobber existing data + + variable http + if {![info exists http]} { + array set http { + -accept */* + -pipeline 1 + -postfresh 0 + -proxyhost {} + -proxyport {} + -proxyfilter http::ProxyRequired + -repost 0 + -urlencoding utf-8 + -zip 1 + } + # We need a useragent string of this style or various servers will + # refuse to send us compressed content even when we ask for it. This + # follows the de-facto layout of user-agent strings in current browsers. + # Safe interpreters do not have ::tcl_platform(os) or + # ::tcl_platform(osVersion). + if {[interp issafe]} { + set http(-useragent) "Mozilla/5.0\ + (Windows; U;\ + Windows NT 10.0)\ + http/[package provide http] Tcl/[package provide Tcl]" + } else { + set http(-useragent) "Mozilla/5.0\ + ([string totitle $::tcl_platform(platform)]; U;\ + $::tcl_platform(os) $::tcl_platform(osVersion))\ + http/[package provide http] Tcl/[package provide Tcl]" + } + } + + proc init {} { + # Set up the map for quoting chars. RFC3986 Section 2.3 say percent + # encode all except: "... percent-encoded octets in the ranges of + # ALPHA (%41-%5A and %61-%7A), DIGIT (%30-%39), hyphen (%2D), period + # (%2E), underscore (%5F), or tilde (%7E) should not be created by URI + # producers ..." + for {set i 0} {$i <= 256} {incr i} { + set c [format %c $i] + if {![string match {[-._~a-zA-Z0-9]} $c]} { + set map($c) %[format %.2X $i] + } + } + # These are handled specially + set map(\n) %0D%0A + variable formMap [array get map] + + # Create a map for HTTP/1.1 open sockets + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketClosing + variable socketPlayCmd + if {[info exists socketMapping]} { + # Close open sockets on re-init. Do not permit retries. + foreach {url sock} [array get socketMapping] { + unset -nocomplain socketClosing($url) + unset -nocomplain socketPlayCmd($url) + CloseSocket $sock + } + } + + # CloseSocket should have unset the socket* arrays, one element at + # a time. Now unset anything that was overlooked. + # Traces on "unset socketRdState(*)" will call CancelReadPipeline and + # cancel any queued responses. + # Traces on "unset socketWrState(*)" will call CancelWritePipeline and + # cancel any queued requests. + array unset socketMapping + array unset socketRdState + array unset socketWrState + array unset socketRdQueue + array unset socketWrQueue + array unset socketClosing + array unset socketPlayCmd + array set socketMapping {} + array set socketRdState {} + array set socketWrState {} + array set socketRdQueue {} + array set socketWrQueue {} + array set socketClosing {} + array set socketPlayCmd {} + } + init + + variable urlTypes + if {![info exists urlTypes]} { + set urlTypes(http) [list 80 ::socket] + } + + variable encodings [string tolower [encoding names]] + # This can be changed, but iso8859-1 is the RFC standard. + variable defaultCharset + if {![info exists defaultCharset]} { + set defaultCharset "iso8859-1" + } + + # Force RFC 3986 strictness in geturl url verification? + variable strict + if {![info exists strict]} { + set strict 1 + } + + # Let user control default keepalive for compatibility + variable defaultKeepalive + if {![info exists defaultKeepalive]} { + set defaultKeepalive 0 + } + + namespace export geturl config reset wait formatQuery quoteString + namespace export register unregister registerError + # - Useful, but not exported: data, size, status, code, cleanup, error, + # meta, ncode, mapReply, init. Comments suggest that "init" can be used + # for re-initialisation, although the command is undocumented. + # - Not exported, probably should be upper-case initial letter as part + # of the internals: getTextLine, make-transformation-chunked. +} + +# http::Log -- +# +# Debugging output -- define this to observe HTTP/1.1 socket usage. +# Should echo any args received. +# +# Arguments: +# msg Message to output +# +if {[info command http::Log] eq {}} {proc http::Log {args} {}} + +# http::register -- +# +# See documentation for details. +# +# Arguments: +# proto URL protocol prefix, e.g. https +# port Default port for protocol +# command Command to use to create socket +# Results: +# list of port and command that was registered. + +proc http::register {proto port command} { + variable urlTypes + set urlTypes([string tolower $proto]) [list $port $command] +} + +# http::unregister -- +# +# Unregisters URL protocol handler +# +# Arguments: +# proto URL protocol prefix, e.g. https +# Results: +# list of port and command that was unregistered. + +proc http::unregister {proto} { + variable urlTypes + set lower [string tolower $proto] + if {![info exists urlTypes($lower)]} { + return -code error "unsupported url type \"$proto\"" + } + set old $urlTypes($lower) + unset urlTypes($lower) + return $old +} + +# http::config -- +# +# See documentation for details. +# +# Arguments: +# args Options parsed by the procedure. +# Results: +# TODO + +proc http::config {args} { + variable http + set options [lsort [array names http -*]] + set usage [join $options ", "] + if {[llength $args] == 0} { + set result {} + foreach name $options { + lappend result $name $http($name) + } + return $result + } + set options [string map {- ""} $options] + set pat ^-(?:[join $options |])$ + if {[llength $args] == 1} { + set flag [lindex $args 0] + if {![regexp -- $pat $flag]} { + return -code error "Unknown option $flag, must be: $usage" + } + return $http($flag) + } else { + foreach {flag value} $args { + if {![regexp -- $pat $flag]} { + return -code error "Unknown option $flag, must be: $usage" + } + set http($flag) $value + } + } +} + +# http::Finish -- +# +# Clean up the socket and eval close time callbacks +# +# Arguments: +# token Connection token. +# errormsg (optional) If set, forces status to error. +# skipCB (optional) If set, don't call the -command callback. This +# is useful when geturl wants to throw an exception instead +# of calling the callback. That way, the same error isn't +# reported to two places. +# +# Side Effects: +# May close the socket. + +proc http::Finish {token {errormsg ""} {skipCB 0}} { + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketClosing + variable socketPlayCmd + + variable $token + upvar 0 $token state + global errorInfo errorCode + set closeQueue 0 + if {$errormsg ne ""} { + set state(error) [list $errormsg $errorInfo $errorCode] + set state(status) "error" + } + if {[info commands ${token}EventCoroutine] ne {}} { + rename ${token}EventCoroutine {} + } + if { ($state(status) eq "timeout") + || ($state(status) eq "error") + || ($state(status) eq "eof") + || ([info exists state(-keepalive)] && !$state(-keepalive)) + || ([info exists state(connection)] && ($state(connection) eq "close")) + } { + set closeQueue 1 + set connId $state(socketinfo) + set sock $state(sock) + CloseSocket $state(sock) $token + } elseif { + ([info exists state(-keepalive)] && $state(-keepalive)) + && ([info exists state(connection)] && ($state(connection) ne "close")) + } { + KeepSocket $token + } + if {[info exists state(after)]} { + after cancel $state(after) + unset state(after) + } + if {[info exists state(-command)] && (!$skipCB) + && (![info exists state(done-command-cb)])} { + set state(done-command-cb) yes + if {[catch {eval $state(-command) {$token}} err] && $errormsg eq ""} { + set state(error) [list $err $errorInfo $errorCode] + set state(status) error + } + } + + if { $closeQueue + && [info exists socketMapping($connId)] + && ($socketMapping($connId) eq $sock) + } { + http::CloseQueuedQueries $connId $token + } +} + +# http::KeepSocket - +# +# Keep a socket in the persistent sockets table and connect it to its next +# queued task if possible. Otherwise leave it idle and ready for its next +# use. +# +# If $socketClosing(*), then ($state(connection) eq "close") and therefore +# this command will not be called by Finish. +# +# Arguments: +# token Connection token. + +proc http::KeepSocket {token} { + variable http + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketClosing + variable socketPlayCmd + + variable $token + upvar 0 $token state + set tk [namespace tail $token] + + # Keep this socket open for another request ("Keep-Alive"). + # React if the server half-closes the socket. + # Discussion is in http::geturl. + catch {fileevent $state(sock) readable [list http::CheckEof $state(sock)]} + + # The line below should not be changed in production code. + # It is edited by the test suite. + set TEST_EOF 0 + if {$TEST_EOF} { + # ONLY for testing reaction to server eof. + # No server timeouts will be caught. + catch {fileevent $state(sock) readable {}} + } + + if { [info exists state(socketinfo)] + && [info exists socketMapping($state(socketinfo))] + } { + set connId $state(socketinfo) + # The value "Rready" is set only here. + set socketRdState($connId) Rready + + if { $state(-pipeline) + && [info exists socketRdQueue($connId)] + && [llength $socketRdQueue($connId)] + } { + # The usual case for pipelined responses - if another response is + # queued, arrange to read it. + set token3 [lindex $socketRdQueue($connId) 0] + set socketRdQueue($connId) [lrange $socketRdQueue($connId) 1 end] + variable $token3 + upvar 0 $token3 state3 + set tk2 [namespace tail $token3] + + #Log pipelined, GRANT read access to $token3 in KeepSocket + set socketRdState($connId) $token3 + ReceiveResponse $token3 + + # Other pipelined cases. + # - The test above ensures that, for the pipelined cases in the two + # tests below, the read queue is empty. + # - In those two tests, check whether the next write will be + # nonpipeline. + } elseif { + $state(-pipeline) + && [info exists socketWrState($connId)] + && ($socketWrState($connId) eq "peNding") + + && [info exists socketWrQueue($connId)] + && [llength $socketWrQueue($connId)] + && (![set token3 [lindex $socketWrQueue($connId) 0] + set ${token3}(-pipeline) + ] + ) + } { + # This case: + # - Now it the time to run the "pending" request. + # - The next token in the write queue is nonpipeline, and + # socketWrState has been marked "pending" (in + # http::NextPipelinedWrite or http::geturl) so a new pipelined + # request cannot jump the queue. + # + # Tests: + # - In this case the read queue (tested above) is empty and this + # "pending" write token is in front of the rest of the write + # queue. + # - The write state is not Wready and therefore appears to be busy, + # but because it is "pending" we know that it is reserved for the + # first item in the write queue, a non-pipelined request that is + # waiting for the read queue to empty. That has now happened: so + # give that request read and write access. + variable $token3 + set conn [set ${token3}(tmpConnArgs)] + #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket + set socketRdState($connId) $token3 + set socketWrState($connId) $token3 + set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end] + # Connect does its own fconfigure. + fileevent $state(sock) writable [list http::Connect $token3 {*}$conn] + #Log ---- $state(sock) << conn to $token3 for HTTP request (c) + + } elseif { + $state(-pipeline) + && [info exists socketWrState($connId)] + && ($socketWrState($connId) eq "peNding") + + } { + # Should not come here. The second block in the previous "elseif" + # test should be tautologous (but was needed in an earlier + # implementation) and will be removed after testing. + # If we get here, the value "pending" was assigned in error. + # This error would block the queue for ever. + Log ^X$tk <<<<< Error in queueing of requests >>>>> - token $token + + } elseif { + $state(-pipeline) + && [info exists socketWrState($connId)] + && ($socketWrState($connId) eq "Wready") + + && [info exists socketWrQueue($connId)] + && [llength $socketWrQueue($connId)] + && (![set token3 [lindex $socketWrQueue($connId) 0] + set ${token3}(-pipeline) + ] + ) + } { + # This case: + # - The next token in the write queue is nonpipeline, and + # socketWrState is Wready. Get the next event from socketWrQueue. + # Tests: + # - In this case the read state (tested above) is Rready and the + # write state (tested here) is Wready - there is no "pending" + # request. + # Code: + # - The code is the same as the code below for the nonpipelined + # case with a queued request. + variable $token3 + set conn [set ${token3}(tmpConnArgs)] + #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket + set socketRdState($connId) $token3 + set socketWrState($connId) $token3 + set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end] + # Connect does its own fconfigure. + fileevent $state(sock) writable [list http::Connect $token3 {*}$conn] + #Log ---- $state(sock) << conn to $token3 for HTTP request (c) + + } elseif { + (!$state(-pipeline)) + && [info exists socketWrQueue($connId)] + && [llength $socketWrQueue($connId)] + && ($state(connection) ne "close") + } { + # If not pipelined, (socketRdState eq Rready) tells us that we are + # ready for the next write - there is no need to check + # socketWrState. Write the next request, if one is waiting. + # If the next request is pipelined, it receives premature read + # access to the socket. This is not a problem. + set token3 [lindex $socketWrQueue($connId) 0] + variable $token3 + set conn [set ${token3}(tmpConnArgs)] + #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket + set socketRdState($connId) $token3 + set socketWrState($connId) $token3 + set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end] + # Connect does its own fconfigure. + fileevent $state(sock) writable [list http::Connect $token3 {*}$conn] + #Log ---- $state(sock) << conn to $token3 for HTTP request (d) + + } elseif {(!$state(-pipeline))} { + set socketWrState($connId) Wready + # Rready and Wready and idle: nothing to do. + } + + } else { + CloseSocket $state(sock) $token + # There is no socketMapping($state(socketinfo)), so it does not matter + # that CloseQueuedQueries is not called. + } +} + +# http::CheckEof - +# +# Read from a socket and close it if eof. +# The command is bound to "fileevent readable" on an idle socket, and +# "eof" is the only event that should trigger the binding, occurring when +# the server times out and half-closes the socket. +# +# A read is necessary so that [eof] gives a meaningful result. +# Any bytes sent are junk (or a bug). + +proc http::CheckEof {sock} { + set junk [read $sock] + set n [string length $junk] + if {$n} { + Log "WARNING: $n bytes received but no HTTP request sent" + } + + if {[catch {eof $sock} res] || $res} { + # The server has half-closed the socket. + # If a new write has started, its transaction will fail and + # will then be error-handled. + CloseSocket $sock + } +} + +# http::CloseSocket - +# +# Close a socket and remove it from the persistent sockets table. If +# possible an http token is included here but when we are called from a +# fileevent on remote closure we need to find the correct entry - hence +# the "else" block of the first "if" command. + +proc http::CloseSocket {s {token {}}} { + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketClosing + variable socketPlayCmd + + set tk [namespace tail $token] + + catch {fileevent $s readable {}} + set connId {} + if {$token ne ""} { + variable $token + upvar 0 $token state + if {[info exists state(socketinfo)]} { + set connId $state(socketinfo) + } + } else { + set map [array get socketMapping] + set ndx [lsearch -exact $map $s] + if {$ndx >= 0} { + incr ndx -1 + set connId [lindex $map $ndx] + } + } + if { ($connId ne {}) + && [info exists socketMapping($connId)] + && ($socketMapping($connId) eq $s) + } { + Log "Closing connection $connId (sock $socketMapping($connId))" + if {[catch {close $socketMapping($connId)} err]} { + Log "Error closing connection: $err" + } + if {$token eq {}} { + # Cases with a non-empty token are handled by Finish, so the tokens + # are finished in connection order. + http::CloseQueuedQueries $connId + } + } else { + Log "Closing socket $s (no connection info)" + if {[catch {close $s} err]} { + Log "Error closing socket: $err" + } + } +} + +# http::CloseQueuedQueries +# +# connId - identifier "domain:port" for the connection +# token - (optional) used only for logging +# +# Called from http::CloseSocket and http::Finish, after a connection is closed, +# to clear the read and write queues if this has not already been done. + +proc http::CloseQueuedQueries {connId {token {}}} { + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketClosing + variable socketPlayCmd + + if {![info exists socketMapping($connId)]} { + # Command has already been called. + # Don't come here again - especially recursively. + return + } + + # Used only for logging. + if {$token eq {}} { + set tk {} + } else { + set tk [namespace tail $token] + } + + if { [info exists socketPlayCmd($connId)] + && ($socketPlayCmd($connId) ne {ReplayIfClose Wready {} {}}) + } { + # Before unsetting, there is some unfinished business. + # - If the server sent "Connection: close", we have stored the command + # for retrying any queued requests in socketPlayCmd, so copy that + # value for execution below. socketClosing(*) was also set. + # - Also clear the queues to prevent calls to Finish that would set the + # state for the requests that will be retried to "finished with error + # status". + set unfinished $socketPlayCmd($connId) + set socketRdQueue($connId) {} + set socketWrQueue($connId) {} + } else { + set unfinished {} + } + + Unset $connId + + if {$unfinished ne {}} { + Log ^R$tk Any unfinished transactions (excluding $token) failed \ + - token $token + {*}$unfinished + } +} + +# http::Unset +# +# The trace on "unset socketRdState(*)" will call CancelReadPipeline +# and cancel any queued responses. +# The trace on "unset socketWrState(*)" will call CancelWritePipeline +# and cancel any queued requests. + +proc http::Unset {connId} { + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketClosing + variable socketPlayCmd + + unset socketMapping($connId) + unset socketRdState($connId) + unset socketWrState($connId) + unset -nocomplain socketRdQueue($connId) + unset -nocomplain socketWrQueue($connId) + unset -nocomplain socketClosing($connId) + unset -nocomplain socketPlayCmd($connId) +} + +# http::reset -- +# +# See documentation for details. +# +# Arguments: +# token Connection token. +# why Status info. +# +# Side Effects: +# See Finish + +proc http::reset {token {why reset}} { + variable $token + upvar 0 $token state + set state(status) $why + catch {fileevent $state(sock) readable {}} + catch {fileevent $state(sock) writable {}} + Finish $token + if {[info exists state(error)]} { + set errorlist $state(error) + unset state + eval ::error $errorlist + } +} + +# http::geturl -- +# +# Establishes a connection to a remote url via http. +# +# Arguments: +# url The http URL to goget. +# args Option value pairs. Valid options include: +# -blocksize, -validate, -headers, -timeout +# Results: +# Returns a token for this connection. This token is the name of an +# array that the caller should unset to garbage collect the state. + +proc http::geturl {url args} { + variable http + variable urlTypes + variable defaultCharset + variable defaultKeepalive + variable strict + + # Initialize the state variable, an array. We'll return the name of this + # array as the token for the transaction. + + if {![info exists http(uid)]} { + set http(uid) 0 + } + set token [namespace current]::[incr http(uid)] + ##Log Starting http::geturl - token $token + variable $token + upvar 0 $token state + set tk [namespace tail $token] + reset $token + Log ^A$tk URL $url - token $token + + # Process command options. + + array set state { + -binary false + -blocksize 8192 + -queryblocksize 8192 + -validate 0 + -headers {} + -timeout 0 + -type application/x-www-form-urlencoded + -queryprogress {} + -protocol 1.1 + binary 0 + state created + meta {} + method {} + coding {} + currentsize 0 + totalsize 0 + querylength 0 + queryoffset 0 + type text/html + body {} + status "" + http "" + connection keep-alive + } + set state(-keepalive) $defaultKeepalive + set state(-strict) $strict + # These flags have their types verified [Bug 811170] + array set type { + -binary boolean + -blocksize integer + -queryblocksize integer + -strict boolean + -timeout integer + -validate boolean + -headers dict + } + set state(charset) $defaultCharset + set options { + -binary -blocksize -channel -command -handler -headers -keepalive + -method -myaddr -progress -protocol -query -queryblocksize + -querychannel -queryprogress -strict -timeout -type -validate + } + set usage [join [lsort $options] ", "] + set options [string map {- ""} $options] + set pat ^-(?:[join $options |])$ + foreach {flag value} $args { + if {[regexp -- $pat $flag]} { + # Validate numbers + if {($flag eq "-headers") ? [catch {dict size $value}] : + ([info exists type($flag)] && ![string is $type($flag) -strict $value]) + } { + unset $token + return -code error \ + "Bad value for $flag ($value), must be $type($flag)" + } + set state($flag) $value + } else { + unset $token + return -code error "Unknown option $flag, can be: $usage" + } + } + + # Make sure -query and -querychannel aren't both specified + + set isQueryChannel [info exists state(-querychannel)] + set isQuery [info exists state(-query)] + if {$isQuery && $isQueryChannel} { + unset $token + return -code error "Can't combine -query and -querychannel options!" + } + + # Validate URL, determine the server host and port, and check proxy case + # Recognize user:pass@host URLs also, although we do not do anything with + # that info yet. + + # URLs have basically four parts. + # First, before the colon, is the protocol scheme (e.g. http) + # Second, for HTTP-like protocols, is the authority + # The authority is preceded by // and lasts up to (but not including) + # the following / or ? and it identifies up to four parts, of which + # only one, the host, is required (if an authority is present at all). + # All other parts of the authority (user name, password, port number) + # are optional. + # Third is the resource name, which is split into two parts at a ? + # The first part (from the single "/" up to "?") is the path, and the + # second part (from that "?" up to "#") is the query. *HOWEVER*, we do + # not need to separate them; we send the whole lot to the server. + # Both, path and query are allowed to be missing, including their + # delimiting character. + # Fourth is the fragment identifier, which is everything after the first + # "#" in the URL. The fragment identifier MUST NOT be sent to the server + # and indeed, we don't bother to validate it (it could be an error to + # pass it in here, but it's cheap to strip). + # + # An example of a URL that has all the parts: + # + # http://jschmoe:xyzzy@www.bogus.net:8000/foo/bar.tml?q=foo#changes + # + # The "http" is the protocol, the user is "jschmoe", the password is + # "xyzzy", the host is "www.bogus.net", the port is "8000", the path is + # "/foo/bar.tml", the query is "q=foo", and the fragment is "changes". + # + # Note that the RE actually combines the user and password parts, as + # recommended in RFC 3986. Indeed, that RFC states that putting passwords + # in URLs is a Really Bad Idea, something with which I would agree utterly. + # + # From a validation perspective, we need to ensure that the parts of the + # URL that are going to the server are correctly encoded. This is only + # done if $state(-strict) is true (inherited from $::http::strict). + + set URLmatcher {(?x) # this is _expanded_ syntax + ^ + (?: (\w+) : ) ? # + (?: // + (?: + ( + [^@/\#?]+ # + ) @ + )? + ( # + [^/:\#?]+ | # host name or IPv4 address + \[ [^/\#?]+ \] # IPv6 address in square brackets + ) + (?: : (\d+) )? # + )? + ( [/\?] [^\#]*)? # (including query) + (?: \# (.*) )? # + $ + } + + # Phase one: parse + if {![regexp -- $URLmatcher $url -> proto user host port srvurl]} { + unset $token + return -code error "Unsupported URL: $url" + } + # Phase two: validate + set host [string trim $host {[]}]; # strip square brackets from IPv6 address + if {$host eq ""} { + # Caller has to provide a host name; we do not have a "default host" + # that would enable us to handle relative URLs. + unset $token + return -code error "Missing host part: $url" + # Note that we don't check the hostname for validity here; if it's + # invalid, we'll simply fail to resolve it later on. + } + if {$port ne "" && $port > 65535} { + unset $token + return -code error "Invalid port number: $port" + } + # The user identification and resource identification parts of the URL can + # have encoded characters in them; take care! + if {$user ne ""} { + # Check for validity according to RFC 3986, Appendix A + set validityRE {(?xi) + ^ + (?: [-\w.~!$&'()*+,;=:] | %[0-9a-f][0-9a-f] )+ + $ + } + if {$state(-strict) && ![regexp -- $validityRE $user]} { + unset $token + # Provide a better error message in this error case + if {[regexp {(?i)%(?![0-9a-f][0-9a-f]).?.?} $user bad]} { + return -code error \ + "Illegal encoding character usage \"$bad\" in URL user" + } + return -code error "Illegal characters in URL user" + } + } + if {$srvurl ne ""} { + # RFC 3986 allows empty paths (not even a /), but servers + # return 400 if the path in the HTTP request doesn't start + # with / , so add it here if needed. + if {[string index $srvurl 0] ne "/"} { + set srvurl /$srvurl + } + # Check for validity according to RFC 3986, Appendix A + set validityRE {(?xi) + ^ + # Path part (already must start with / character) + (?: [-\w.~!$&'()*+,;=:@/] | %[0-9a-f][0-9a-f] )* + # Query part (optional, permits ? characters) + (?: \? (?: [-\w.~!$&'()*+,;=:@/?] | %[0-9a-f][0-9a-f] )* )? + $ + } + if {$state(-strict) && ![regexp -- $validityRE $srvurl]} { + unset $token + # Provide a better error message in this error case + if {[regexp {(?i)%(?![0-9a-f][0-9a-f])..} $srvurl bad]} { + return -code error \ + "Illegal encoding character usage \"$bad\" in URL path" + } + return -code error "Illegal characters in URL path" + } + } else { + set srvurl / + } + if {$proto eq ""} { + set proto http + } + set lower [string tolower $proto] + if {![info exists urlTypes($lower)]} { + unset $token + return -code error "Unsupported URL type \"$proto\"" + } + set defport [lindex $urlTypes($lower) 0] + set defcmd [lindex $urlTypes($lower) 1] + + if {$port eq ""} { + set port $defport + } + if {![catch {$http(-proxyfilter) $host} proxy]} { + set phost [lindex $proxy 0] + set pport [lindex $proxy 1] + } + + # OK, now reassemble into a full URL + set url ${proto}:// + if {$user ne ""} { + append url $user + append url @ + } + append url $host + if {$port != $defport} { + append url : $port + } + append url $srvurl + # Don't append the fragment! + set state(url) $url + + set sockopts [list -async] + + # If we are using the proxy, we must pass in the full URL that includes + # the server name. + + if {[info exists phost] && ($phost ne "")} { + set srvurl $url + set targetAddr [list $phost $pport] + } else { + set targetAddr [list $host $port] + } + # Proxy connections aren't shared among different hosts. + set state(socketinfo) $host:$port + + # Save the accept types at this point to prevent a race condition. [Bug + # c11a51c482] + set state(accept-types) $http(-accept) + + if {$isQuery || $isQueryChannel} { + # It's a POST. + # A client wishing to send a non-idempotent request SHOULD wait to send + # that request until it has received the response status for the + # previous request. + if {$http(-postfresh)} { + # Override -keepalive for a POST. Use a new connection, and thus + # avoid the small risk of a race against server timeout. + set state(-keepalive) 0 + } else { + # Allow -keepalive but do not -pipeline - wait for the previous + # transaction to finish. + # There is a small risk of a race against server timeout. + set state(-pipeline) 0 + } + } else { + # It's a GET or HEAD. + set state(-pipeline) $http(-pipeline) + } + + # We cannot handle chunked encodings with -handler, so force HTTP/1.0 + # until we can manage this. + if {[info exists state(-handler)]} { + set state(-protocol) 1.0 + } + + # RFC 7320 A.1 - HTTP/1.0 Keep-Alive is problematic. We do not support it. + if {$state(-protocol) eq "1.0"} { + set state(connection) close + set state(-keepalive) 0 + } + + # See if we are supposed to use a previously opened channel. + # - In principle, ANY call to http::geturl could use a previously opened + # channel if it is available - the "Connection: keep-alive" header is a + # request to leave the channel open AFTER completion of this call. + # - In fact, we try to use an existing channel only if -keepalive 1 -- this + # means that at most one channel is left open for each value of + # $state(socketinfo). This property simplifies the mapping of open + # channels. + set reusing 0 + set alreadyQueued 0 + if {$state(-keepalive)} { + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketClosing + variable socketPlayCmd + + if {[info exists socketMapping($state(socketinfo))]} { + # - If the connection is idle, it has a "fileevent readable" binding + # to http::CheckEof, in case the server times out and half-closes + # the socket (http::CheckEof closes the other half). + # - We leave this binding in place until just before the last + # puts+flush in http::Connected (GET/HEAD) or http::Write (POST), + # after which the HTTP response might be generated. + + if { [info exists socketClosing($state(socketinfo))] + && $socketClosing($state(socketinfo)) + } { + # socketClosing(*) is set because the server has sent a + # "Connection: close" header. + # Do not use the persistent socket again. + # Since we have only one persistent socket per server, and the + # old socket is not yet dead, add the request to the write queue + # of the dying socket, which will be replayed by ReplayIfClose. + # Also add it to socketWrQueue(*) which is used only if an error + # causes a call to Finish. + set reusing 1 + set sock $socketMapping($state(socketinfo)) + Log "reusing socket $sock for $state(socketinfo) - token $token" + + set alreadyQueued 1 + lassign $socketPlayCmd($state(socketinfo)) com0 com1 com2 com3 + lappend com3 $token + set socketPlayCmd($state(socketinfo)) [list $com0 $com1 $com2 $com3] + lappend socketWrQueue($state(socketinfo)) $token + } elseif {[catch {fconfigure $socketMapping($state(socketinfo))}]} { + # FIXME Is it still possible for this code to be executed? If + # so, this could be another place to call TestForReplay, + # rather than discarding the queued transactions. + Log "WARNING: socket for $state(socketinfo) was closed\ + - token $token" + Log "WARNING - if testing, pay special attention to this\ + case (GH) which is seldom executed - token $token" + + # This will call CancelReadPipeline, CancelWritePipeline, and + # cancel any queued requests, responses. + Unset $state(socketinfo) + } else { + # Use the persistent socket. + # The socket may not be ready to write: an earlier request might + # still be still writing (in the pipelined case) or + # writing/reading (in the nonpipeline case). This possibility + # is handled by socketWrQueue later in this command. + set reusing 1 + set sock $socketMapping($state(socketinfo)) + Log "reusing socket $sock for $state(socketinfo) - token $token" + + } + # Do not automatically close the connection socket. + set state(connection) keep-alive + } + } + + if {$reusing} { + # Define state(tmpState) and state(tmpOpenCmd) for use + # by http::ReplayIfDead if the persistent connection has died. + set state(tmpState) [array get state] + + # Pass -myaddr directly to the socket command + if {[info exists state(-myaddr)]} { + lappend sockopts -myaddr $state(-myaddr) + } + + set state(tmpOpenCmd) [list {*}$defcmd {*}$sockopts {*}$targetAddr] + } + + set state(reusing) $reusing + # Excluding ReplayIfDead and the decision whether to call it, there are four + # places outside http::geturl where state(reusing) is used: + # - Connected - if reusing and not pipelined, start the state(-timeout) + # timeout (when writing). + # - DoneRequest - if reusing and pipelined, send the next pipelined write + # - Event - if reusing and pipelined, start the state(-timeout) + # timeout (when reading). + # - Event - if (not reusing) and pipelined, send the next pipelined + # write + + # See comments above re the start of this timeout in other cases. + if {(!$state(reusing)) && ($state(-timeout) > 0)} { + set state(after) [after $state(-timeout) \ + [list http::reset $token timeout]] + } + + if {![info exists sock]} { + # Pass -myaddr directly to the socket command + if {[info exists state(-myaddr)]} { + lappend sockopts -myaddr $state(-myaddr) + } + set pre [clock milliseconds] + ##Log pre socket opened, - token $token + ##Log [concat $defcmd $sockopts $targetAddr] - token $token + if {[catch {eval $defcmd $sockopts $targetAddr} sock errdict]} { + # Something went wrong while trying to establish the connection. + # Clean up after events and such, but DON'T call the command + # callback (if available) because we're going to throw an + # exception from here instead. + + set state(sock) NONE + Finish $token $sock 1 + cleanup $token + dict unset errdict -level + return -options $errdict $sock + } else { + # Initialisation of a new socket. + ##Log post socket opened, - token $token + ##Log socket opened, now fconfigure - token $token + set delay [expr {[clock milliseconds] - $pre}] + if {$delay > 3000} { + Log socket delay $delay - token $token + } + fconfigure $sock -translation {auto crlf} \ + -buffersize $state(-blocksize) + ##Log socket opened, DONE fconfigure - token $token + } + } + # Command [socket] is called with -async, but takes 5s to 5.1s to return, + # with probability of order 1 in 10,000. This may be a bizarre scheduling + # issue with my (KJN's) system (Fedora Linux). + # This does not cause a problem (unless the request times out when this + # command returns). + + set state(sock) $sock + Log "Using $sock for $state(socketinfo) - token $token" \ + [expr {$state(-keepalive)?"keepalive":""}] + + if { $state(-keepalive) + && (![info exists socketMapping($state(socketinfo))]) + } { + # Freshly-opened socket that we would like to become persistent. + set socketMapping($state(socketinfo)) $sock + + if {![info exists socketRdState($state(socketinfo))]} { + set socketRdState($state(socketinfo)) {} + set varName ::http::socketRdState($state(socketinfo)) + trace add variable $varName unset ::http::CancelReadPipeline + } + if {![info exists socketWrState($state(socketinfo))]} { + set socketWrState($state(socketinfo)) {} + set varName ::http::socketWrState($state(socketinfo)) + trace add variable $varName unset ::http::CancelWritePipeline + } + + if {$state(-pipeline)} { + #Log new, init for pipelined, GRANT write access to $token in geturl + # Also grant premature read access to the socket. This is OK. + set socketRdState($state(socketinfo)) $token + set socketWrState($state(socketinfo)) $token + } else { + # socketWrState is not used by this non-pipelined transaction. + # We cannot leave it as "Wready" because the next call to + # http::geturl with a pipelined transaction would conclude that the + # socket is available for writing. + #Log new, init for nonpipeline, GRANT r/w access to $token in geturl + set socketRdState($state(socketinfo)) $token + set socketWrState($state(socketinfo)) $token + } + + set socketRdQueue($state(socketinfo)) {} + set socketWrQueue($state(socketinfo)) {} + set socketClosing($state(socketinfo)) 0 + set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}} + } + + if {![info exists phost]} { + set phost "" + } + if {$reusing} { + # For use by http::ReplayIfDead if the persistent connection has died. + # Also used by NextPipelinedWrite. + set state(tmpConnArgs) [list $proto $phost $srvurl] + } + + # The element socketWrState($connId) has a value which is either the name of + # the token that is permitted to write to the socket, or "Wready" if no + # token is permitted to write. + # + # The code that sets the value to Wready immediately calls + # http::NextPipelinedWrite, which examines socketWrQueue($connId) and + # processes the next request in the queue, if there is one. The value + # Wready is not found when the interpreter is in the event loop unless the + # socket is idle. + # + # The element socketRdState($connId) has a value which is either the name of + # the token that is permitted to read from the socket, or "Rready" if no + # token is permitted to read. + # + # The code that sets the value to Rready then examines + # socketRdQueue($connId) and processes the next request in the queue, if + # there is one. The value Rready is not found when the interpreter is in + # the event loop unless the socket is idle. + + if {$alreadyQueued} { + # A write may or may not be in progress. There is no need to set + # socketWrState to prevent another call stealing write access - all + # subsequent calls on this socket will come here because the socket + # will close after the current read, and its + # socketClosing($connId) is 1. + ##Log "HTTP request for token $token is queued" + + } elseif { $reusing + && $state(-pipeline) + && ($socketWrState($state(socketinfo)) ne "Wready") + } { + ##Log "HTTP request for token $token is queued for pipelined use" + lappend socketWrQueue($state(socketinfo)) $token + + } elseif { $reusing + && (!$state(-pipeline)) + && ($socketWrState($state(socketinfo)) ne "Wready") + } { + # A write is queued or in progress. Lappend to the write queue. + ##Log "HTTP request for token $token is queued for nonpipeline use" + lappend socketWrQueue($state(socketinfo)) $token + + } elseif { $reusing + && (!$state(-pipeline)) + && ($socketWrState($state(socketinfo)) eq "Wready") + && ($socketRdState($state(socketinfo)) ne "Rready") + } { + # A read is queued or in progress, but not a write. Cannot start the + # nonpipeline transaction, but must set socketWrState to prevent a + # pipelined request jumping the queue. + ##Log "HTTP request for token $token is queued for nonpipeline use" + #Log re-use nonpipeline, GRANT delayed write access to $token in geturl + + set socketWrState($state(socketinfo)) peNding + lappend socketWrQueue($state(socketinfo)) $token + + } else { + if {$reusing && $state(-pipeline)} { + #Log re-use pipelined, GRANT write access to $token in geturl + set socketWrState($state(socketinfo)) $token + + } elseif {$reusing} { + # Cf tests above - both are ready. + #Log re-use nonpipeline, GRANT r/w access to $token in geturl + set socketRdState($state(socketinfo)) $token + set socketWrState($state(socketinfo)) $token + } + + # All (!$reusing) cases come here, and also some $reusing cases if the + # connection is ready. + #Log ---- $state(socketinfo) << conn to $token for HTTP request (a) + # Connect does its own fconfigure. + fileevent $sock writable \ + [list http::Connect $token $proto $phost $srvurl] + } + + # Wait for the connection to complete. + if {![info exists state(-command)]} { + # geturl does EVERYTHING asynchronously, so if the user + # calls it synchronously, we just do a wait here. + http::wait $token + + if {![info exists state]} { + # If we timed out then Finish has been called and the users + # command callback may have cleaned up the token. If so we end up + # here with nothing left to do. + return $token + } elseif {$state(status) eq "error"} { + # Something went wrong while trying to establish the connection. + # Clean up after events and such, but DON'T call the command + # callback (if available) because we're going to throw an + # exception from here instead. + set err [lindex $state(error) 0] + cleanup $token + return -code error $err + } + } + ##Log Leaving http::geturl - token $token + return $token +} + +# http::Connected -- +# +# Callback used when the connection to the HTTP server is actually +# established. +# +# Arguments: +# token State token. +# proto What protocol (http, https, etc.) was used to connect. +# phost Are we using keep-alive? Non-empty if yes. +# srvurl Service-local URL that we're requesting +# Results: +# None. + +proc http::Connected {token proto phost srvurl} { + variable http + variable urlTypes + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketClosing + variable socketPlayCmd + + variable $token + upvar 0 $token state + set tk [namespace tail $token] + + if {$state(reusing) && (!$state(-pipeline)) && ($state(-timeout) > 0)} { + set state(after) [after $state(-timeout) \ + [list http::reset $token timeout]] + } + + # Set back the variables needed here. + set sock $state(sock) + set isQueryChannel [info exists state(-querychannel)] + set isQuery [info exists state(-query)] + set host [lindex [split $state(socketinfo) :] 0] + set port [lindex [split $state(socketinfo) :] 1] + + set lower [string tolower $proto] + set defport [lindex $urlTypes($lower) 0] + + # Send data in cr-lf format, but accept any line terminators. + # Initialisation to {auto *} now done in geturl, KeepSocket and DoneRequest. + # We are concerned here with the request (write) not the response (read). + lassign [fconfigure $sock -translation] trRead trWrite + fconfigure $sock -translation [list $trRead crlf] \ + -buffersize $state(-blocksize) + + # The following is disallowed in safe interpreters, but the socket is + # already in non-blocking mode in that case. + + catch {fconfigure $sock -blocking off} + set how GET + if {$isQuery} { + set state(querylength) [string length $state(-query)] + if {$state(querylength) > 0} { + set how POST + set contDone 0 + } else { + # There's no query data. + unset state(-query) + set isQuery 0 + } + } elseif {$state(-validate)} { + set how HEAD + } elseif {$isQueryChannel} { + set how POST + # The query channel must be blocking for the async Write to + # work properly. + fconfigure $state(-querychannel) -blocking 1 -translation binary + set contDone 0 + } + if {[info exists state(-method)] && ($state(-method) ne "")} { + set how $state(-method) + } + set accept_types_seen 0 + + Log ^B$tk begin sending request - token $token + + if {[catch { + set state(method) $how + puts $sock "$how $srvurl HTTP/$state(-protocol)" + if {[dict exists $state(-headers) Host]} { + # Allow Host spoofing. [Bug 928154] + puts $sock "Host: [dict get $state(-headers) Host]" + } elseif {$port == $defport} { + # Don't add port in this case, to handle broken servers. [Bug + # #504508] + puts $sock "Host: $host" + } else { + puts $sock "Host: $host:$port" + } + puts $sock "User-Agent: $http(-useragent)" + if {($state(-protocol) > 1.0) && $state(-keepalive)} { + # Send this header, because a 1.1 server is not compelled to treat + # this as the default. + puts $sock "Connection: keep-alive" + } + if {($state(-protocol) > 1.0) && !$state(-keepalive)} { + puts $sock "Connection: close" ;# RFC2616 sec 8.1.2.1 + } + if {($state(-protocol) < 1.1)} { + # RFC7230 A.1 + # Some server implementations of HTTP/1.0 have a faulty + # implementation of RFC 2068 Keep-Alive. + # Don't leave this to chance. + # For HTTP/1.0 we have already "set state(connection) close" + # and "state(-keepalive) 0". + puts $sock "Connection: close" + } + # RFC7230 A.1 - "clients are encouraged not to send the + # Proxy-Connection header field in any requests" + set accept_encoding_seen 0 + set content_type_seen 0 + dict for {key value} $state(-headers) { + set value [string map [list \n "" \r ""] $value] + set key [string map {" " -} [string trim $key]] + if {[string equal -nocase $key "host"]} { + continue + } + if {[string equal -nocase $key "accept-encoding"]} { + set accept_encoding_seen 1 + } + if {[string equal -nocase $key "accept"]} { + set accept_types_seen 1 + } + if {[string equal -nocase $key "content-type"]} { + set content_type_seen 1 + } + if {[string equal -nocase $key "content-length"]} { + set contDone 1 + set state(querylength) $value + } + if {[string length $key]} { + puts $sock "$key: $value" + } + } + # Allow overriding the Accept header on a per-connection basis. Useful + # for working with REST services. [Bug c11a51c482] + if {!$accept_types_seen} { + puts $sock "Accept: $state(accept-types)" + } + if { (!$accept_encoding_seen) + && (![info exists state(-handler)]) + && $http(-zip) + } { + puts $sock "Accept-Encoding: gzip,deflate,compress" + } + if {$isQueryChannel && ($state(querylength) == 0)} { + # Try to determine size of data in channel. If we cannot seek, the + # surrounding catch will trap us + + set start [tell $state(-querychannel)] + seek $state(-querychannel) 0 end + set state(querylength) \ + [expr {[tell $state(-querychannel)] - $start}] + seek $state(-querychannel) $start + } + + # Flush the request header and set up the fileevent that will either + # push the POST data or read the response. + # + # fileevent note: + # + # It is possible to have both the read and write fileevents active at + # this point. The only scenario it seems to affect is a server that + # closes the connection without reading the POST data. (e.g., early + # versions TclHttpd in various error cases). Depending on the + # platform, the client may or may not be able to get the response from + # the server because of the error it will get trying to write the post + # data. Having both fileevents active changes the timing and the + # behavior, but no two platforms (among Solaris, Linux, and NT) behave + # the same, and none behave all that well in any case. Servers should + # always read their POST data if they expect the client to read their + # response. + + if {$isQuery || $isQueryChannel} { + # POST method. + if {!$content_type_seen} { + puts $sock "Content-Type: $state(-type)" + } + if {!$contDone} { + puts $sock "Content-Length: $state(querylength)" + } + puts $sock "" + flush $sock + # Flush flushes the error in the https case with a bad handshake: + # else the socket never becomes writable again, and hangs until + # timeout (if any). + + lassign [fconfigure $sock -translation] trRead trWrite + fconfigure $sock -translation [list $trRead binary] + fileevent $sock writable [list http::Write $token] + # The http::Write command decides when to make the socket readable, + # using the same test as the GET/HEAD case below. + } else { + # GET or HEAD method. + if { (![catch {fileevent $sock readable} binding]) + && ($binding eq [list http::CheckEof $sock]) + } { + # Remove the "fileevent readable" binding of an idle persistent + # socket to http::CheckEof. We can no longer treat bytes + # received as junk. The server might still time out and + # half-close the socket if it has not yet received the first + # "puts". + fileevent $sock readable {} + } + puts $sock "" + flush $sock + Log ^C$tk end sending request - token $token + # End of writing (GET/HEAD methods). The request has been sent. + + DoneRequest $token + } + + } err]} { + # The socket probably was never connected, OR the connection dropped + # later, OR https handshake error, which may be discovered as late as + # the "flush" command above... + Log "WARNING - if testing, pay special attention to this\ + case (GI) which is seldom executed - token $token" + if {[info exists state(reusing)] && $state(reusing)} { + # The socket was closed at the server end, and closed at + # this end by http::CheckEof. + if {[TestForReplay $token write $err a]} { + return + } else { + Finish $token {failed to re-use socket} + } + + # else: + # This is NOT a persistent socket that has been closed since its + # last use. + # If any other requests are in flight or pipelined/queued, they will + # be discarded. + } elseif {$state(status) eq ""} { + # ...https handshake errors come here. + set msg [registerError $sock] + registerError $sock {} + if {$msg eq {}} { + set msg {failed to use socket} + } + Finish $token $msg + } elseif {$state(status) ne "error"} { + Finish $token $err + } + } +} + +# http::registerError +# +# Called (for example when processing TclTLS activity) to register +# an error for a connection on a specific socket. This helps +# http::Connected to deliver meaningful error messages, e.g. when a TLS +# certificate fails verification. +# +# Usage: http::registerError socket ?newValue? +# +# "set" semantics, except that a "get" (a call without a new value) for a +# non-existent socket returns {}, not an error. + +proc http::registerError {sock args} { + variable registeredErrors + + if { ([llength $args] == 0) + && (![info exists registeredErrors($sock)]) + } { + return + } elseif { ([llength $args] == 1) + && ([lindex $args 0] eq {}) + } { + unset -nocomplain registeredErrors($sock) + return + } + set registeredErrors($sock) {*}$args +} + +# http::DoneRequest -- +# +# Command called when a request has been sent. It will arrange the +# next request and/or response as appropriate. +# +# If this command is called when $socketClosing(*), the request $token +# that calls it must be pipelined and destined to fail. + +proc http::DoneRequest {token} { + variable http + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketClosing + variable socketPlayCmd + + variable $token + upvar 0 $token state + set tk [namespace tail $token] + set sock $state(sock) + + # If pipelined, connect the next HTTP request to the socket. + if {$state(reusing) && $state(-pipeline)} { + # Enable next token (if any) to write. + # The value "Wready" is set only here, and + # in http::Event after reading the response-headers of a + # non-reusing transaction. + # Previous value is $token. It cannot be pending. + set socketWrState($state(socketinfo)) Wready + + # Now ready to write the next pipelined request (if any). + http::NextPipelinedWrite $token + } else { + # If pipelined, this is the first transaction on this socket. We wait + # for the response headers to discover whether the connection is + # persistent. (If this is not done and the connection is not + # persistent, we SHOULD retry and then MUST NOT pipeline before knowing + # that we have a persistent connection + # (rfc2616 8.1.2.2)). + } + + # Connect to receive the response, unless the socket is pipelined + # and another response is being sent. + # This code block is separate from the code below because there are + # cases where socketRdState already has the value $token. + if { $state(-keepalive) + && $state(-pipeline) + && [info exists socketRdState($state(socketinfo))] + && ($socketRdState($state(socketinfo)) eq "Rready") + } { + #Log pipelined, GRANT read access to $token in Connected + set socketRdState($state(socketinfo)) $token + } + + if { $state(-keepalive) + && $state(-pipeline) + && [info exists socketRdState($state(socketinfo))] + && ($socketRdState($state(socketinfo)) ne $token) + } { + # Do not read from the socket until it is ready. + ##Log "HTTP response for token $token is queued for pipelined use" + # If $socketClosing(*), then the caller will be a pipelined write and + # execution will come here. + # This token has already been recorded as "in flight" for writing. + # When the socket is closed, the read queue will be cleared in + # CloseQueuedQueries and so the "lappend" here has no effect. + lappend socketRdQueue($state(socketinfo)) $token + } else { + # In the pipelined case, connection for reading depends on the + # value of socketRdState. + # In the nonpipeline case, connection for reading always occurs. + ReceiveResponse $token + } +} + +# http::ReceiveResponse +# +# Connects token to its socket for reading. + +proc http::ReceiveResponse {token} { + variable $token + upvar 0 $token state + set tk [namespace tail $token] + set sock $state(sock) + + #Log ---- $state(socketinfo) >> conn to $token for HTTP response + lassign [fconfigure $sock -translation] trRead trWrite + fconfigure $sock -translation [list auto $trWrite] \ + -buffersize $state(-blocksize) + Log ^D$tk begin receiving response - token $token + + coroutine ${token}EventCoroutine http::Event $sock $token + if {[info exists state(-handler)] || [info exists state(-progress)]} { + fileevent $sock readable [list http::EventGateway $sock $token] + } else { + fileevent $sock readable ${token}EventCoroutine + } + return +} + + +# http::EventGateway +# +# Bug [c2dc1da315]. +# - Recursive launch of the coroutine can occur if a -handler or -progress +# callback is used, and the callback command enters the event loop. +# - To prevent this, the fileevent "binding" is disabled while the +# coroutine is in flight. +# - If a recursive call occurs despite these precautions, it is not +# trapped and discarded here, because it is better to report it as a +# bug. +# - Although this solution is believed to be sufficiently general, it is +# used only if -handler or -progress is specified. In other cases, +# the coroutine is called directly. + +proc http::EventGateway {sock token} { + variable $token + upvar 0 $token state + fileevent $sock readable {} + catch {${token}EventCoroutine} res opts + if {[info commands ${token}EventCoroutine] ne {}} { + # The coroutine can be deleted by completion (a non-yield return), by + # http::Finish (when there is a premature end to the transaction), by + # http::reset or http::cleanup, or if the caller set option -channel + # but not option -handler: in the last case reading from the socket is + # now managed by commands ::http::Copy*, http::ReceiveChunked, and + # http::make-transformation-chunked. + # + # Catch in case the coroutine has closed the socket. + catch {fileevent $sock readable [list http::EventGateway $sock $token]} + } + + # If there was an error, re-throw it. + return -options $opts $res +} + + +# http::NextPipelinedWrite +# +# - Connecting a socket to a token for writing is done by this command and by +# command KeepSocket. +# - If another request has a pipelined write scheduled for $token's socket, +# and if the socket is ready to accept it, connect the write and update +# the queue accordingly. +# - This command is called from http::DoneRequest and http::Event, +# IF $state(-pipeline) AND (the current transfer has reached the point at +# which the socket is ready for the next request to be written). +# - This command is called when a token has write access and is pipelined and +# keep-alive, and sets socketWrState to Wready. +# - The command need not consider the case where socketWrState is set to a token +# that does not yet have write access. Such a token is waiting for Rready, +# and the assignment of the connection to the token will be done elsewhere (in +# http::KeepSocket). +# - This command cannot be called after socketWrState has been set to a +# "pending" token value (that is then overwritten by the caller), because that +# value is set by this command when it is called by an earlier token when it +# relinquishes its write access, and the pending token is always the next in +# line to write. + +proc http::NextPipelinedWrite {token} { + variable http + variable socketRdState + variable socketWrState + variable socketWrQueue + variable socketClosing + variable $token + upvar 0 $token state + set connId $state(socketinfo) + + if { [info exists socketClosing($connId)] + && $socketClosing($connId) + } { + # socketClosing(*) is set because the server has sent a + # "Connection: close" header. + # Behave as if the queues are empty - so do nothing. + } elseif { $state(-pipeline) + && [info exists socketWrState($connId)] + && ($socketWrState($connId) eq "Wready") + + && [info exists socketWrQueue($connId)] + && [llength $socketWrQueue($connId)] + && ([set token2 [lindex $socketWrQueue($connId) 0] + set ${token2}(-pipeline) + ] + ) + } { + # - The usual case for a pipelined connection, ready for a new request. + #Log pipelined, GRANT write access to $token2 in NextPipelinedWrite + set conn [set ${token2}(tmpConnArgs)] + set socketWrState($connId) $token2 + set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end] + # Connect does its own fconfigure. + fileevent $state(sock) writable [list http::Connect $token2 {*}$conn] + #Log ---- $connId << conn to $token2 for HTTP request (b) + + # In the tests below, the next request will be nonpipeline. + } elseif { $state(-pipeline) + && [info exists socketWrState($connId)] + && ($socketWrState($connId) eq "Wready") + + && [info exists socketWrQueue($connId)] + && [llength $socketWrQueue($connId)] + && (![ set token3 [lindex $socketWrQueue($connId) 0] + set ${token3}(-pipeline) + ] + ) + + && [info exists socketRdState($connId)] + && ($socketRdState($connId) eq "Rready") + } { + # The case in which the next request will be non-pipelined, and the read + # and write queues is ready: which is the condition for a non-pipelined + # write. + variable $token3 + upvar 0 $token3 state3 + set conn [set ${token3}(tmpConnArgs)] + #Log nonpipeline, GRANT r/w access to $token3 in NextPipelinedWrite + set socketRdState($connId) $token3 + set socketWrState($connId) $token3 + set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end] + # Connect does its own fconfigure. + fileevent $state(sock) writable [list http::Connect $token3 {*}$conn] + #Log ---- $state(sock) << conn to $token3 for HTTP request (c) + + } elseif { $state(-pipeline) + && [info exists socketWrState($connId)] + && ($socketWrState($connId) eq "Wready") + + && [info exists socketWrQueue($connId)] + && [llength $socketWrQueue($connId)] + && (![set token2 [lindex $socketWrQueue($connId) 0] + set ${token2}(-pipeline) + ] + ) + } { + # - The case in which the next request will be non-pipelined, but the + # read queue is NOT ready. + # - A read is queued or in progress, but not a write. Cannot start the + # nonpipeline transaction, but must set socketWrState to prevent a new + # pipelined request (in http::geturl) jumping the queue. + # - Because socketWrState($connId) is not set to Wready, the assignment + # of the connection to $token2 will be done elsewhere - by command + # http::KeepSocket when $socketRdState($connId) is set to "Rready". + + #Log re-use nonpipeline, GRANT delayed write access to $token in NextP.. + set socketWrState($connId) peNding + } +} + +# http::CancelReadPipeline +# +# Cancel pipelined responses on a closing "Keep-Alive" socket. +# +# - Called by a variable trace on "unset socketRdState($connId)". +# - The variable relates to a Keep-Alive socket, which has been closed. +# - Cancels all pipelined responses. The requests have been sent, +# the responses have not yet been received. +# - This is a hard cancel that ends each transaction with error status, +# and closes the connection. Do not use it if you want to replay failed +# transactions. +# - N.B. Always delete ::http::socketRdState($connId) before deleting +# ::http::socketRdQueue($connId), or this command will do nothing. +# +# Arguments +# As for a trace command on a variable. + +proc http::CancelReadPipeline {name1 connId op} { + variable socketRdQueue + ##Log CancelReadPipeline $name1 $connId $op + if {[info exists socketRdQueue($connId)]} { + set msg {the connection was closed by CancelReadPipeline} + foreach token $socketRdQueue($connId) { + set tk [namespace tail $token] + Log ^X$tk end of response "($msg)" - token $token + set ${token}(status) eof + Finish $token ;#$msg + } + set socketRdQueue($connId) {} + } +} + +# http::CancelWritePipeline +# +# Cancel queued events on a closing "Keep-Alive" socket. +# +# - Called by a variable trace on "unset socketWrState($connId)". +# - The variable relates to a Keep-Alive socket, which has been closed. +# - In pipelined or nonpipeline case: cancels all queued requests. The +# requests have not yet been sent, the responses are not due. +# - This is a hard cancel that ends each transaction with error status, +# and closes the connection. Do not use it if you want to replay failed +# transactions. +# - N.B. Always delete ::http::socketWrState($connId) before deleting +# ::http::socketWrQueue($connId), or this command will do nothing. +# +# Arguments +# As for a trace command on a variable. + +proc http::CancelWritePipeline {name1 connId op} { + variable socketWrQueue + + ##Log CancelWritePipeline $name1 $connId $op + if {[info exists socketWrQueue($connId)]} { + set msg {the connection was closed by CancelWritePipeline} + foreach token $socketWrQueue($connId) { + set tk [namespace tail $token] + Log ^X$tk end of response "($msg)" - token $token + set ${token}(status) eof + Finish $token ;#$msg + } + set socketWrQueue($connId) {} + } +} + +# http::ReplayIfDead -- +# +# - A query on a re-used persistent socket failed at the earliest opportunity, +# because the socket had been closed by the server. Keep the token, tidy up, +# and try to connect on a fresh socket. +# - The connection is monitored for eof by the command http::CheckEof. Thus +# http::ReplayIfDead is needed only when a server event (half-closing an +# apparently idle connection), and a client event (sending a request) occur at +# almost the same time, and neither client nor server detects the other's +# action before performing its own (an "asynchronous close event"). +# - To simplify testing of http::ReplayIfDead, set TEST_EOF 1 in +# http::KeepSocket, and then http::ReplayIfDead will be called if http::geturl +# is called at any time after the server timeout. +# +# Arguments: +# token Connection token. +# +# Side Effects: +# Use the same token, but try to open a new socket. + +proc http::ReplayIfDead {tokenArg doing} { + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketClosing + variable socketPlayCmd + + variable $tokenArg + upvar 0 $tokenArg stateArg + + Log running http::ReplayIfDead for $tokenArg $doing + + # 1. Merge the tokens for transactions in flight, the read (response) queue, + # and the write (request) queue. + + set InFlightR {} + set InFlightW {} + + # Obtain the tokens for transactions in flight. + if {$stateArg(-pipeline)} { + # Two transactions may be in flight. The "read" transaction was first. + # It is unlikely that the server would close the socket if a response + # was pending; however, an earlier request (as well as the present + # request) may have been sent and ignored if the socket was half-closed + # by the server. + + if { [info exists socketRdState($stateArg(socketinfo))] + && ($socketRdState($stateArg(socketinfo)) ne "Rready") + } { + lappend InFlightR $socketRdState($stateArg(socketinfo)) + } elseif {($doing eq "read")} { + lappend InFlightR $tokenArg + } + + if { [info exists socketWrState($stateArg(socketinfo))] + && $socketWrState($stateArg(socketinfo)) ni {Wready peNding} + } { + lappend InFlightW $socketWrState($stateArg(socketinfo)) + } elseif {($doing eq "write")} { + lappend InFlightW $tokenArg + } + + # Report any inconsistency of $tokenArg with socket*state. + if { ($doing eq "read") + && [info exists socketRdState($stateArg(socketinfo))] + && ($tokenArg ne $socketRdState($stateArg(socketinfo))) + } { + Log WARNING - ReplayIfDead pipelined tokenArg $tokenArg $doing \ + ne socketRdState($stateArg(socketinfo)) \ + $socketRdState($stateArg(socketinfo)) + + } elseif { + ($doing eq "write") + && [info exists socketWrState($stateArg(socketinfo))] + && ($tokenArg ne $socketWrState($stateArg(socketinfo))) + } { + Log WARNING - ReplayIfDead pipelined tokenArg $tokenArg $doing \ + ne socketWrState($stateArg(socketinfo)) \ + $socketWrState($stateArg(socketinfo)) + } + } else { + # One transaction should be in flight. + # socketRdState, socketWrQueue are used. + # socketRdQueue should be empty. + + # Report any inconsistency of $tokenArg with socket*state. + if {$tokenArg ne $socketRdState($stateArg(socketinfo))} { + Log WARNING - ReplayIfDead nonpipeline tokenArg $tokenArg $doing \ + ne socketRdState($stateArg(socketinfo)) \ + $socketRdState($stateArg(socketinfo)) + } + + # Report the inconsistency that socketRdQueue is non-empty. + if { [info exists socketRdQueue($stateArg(socketinfo))] + && ($socketRdQueue($stateArg(socketinfo)) ne {}) + } { + Log WARNING - ReplayIfDead nonpipeline tokenArg $tokenArg $doing \ + has read queue socketRdQueue($stateArg(socketinfo)) \ + $socketRdQueue($stateArg(socketinfo)) ne {} + } + + lappend InFlightW $socketRdState($stateArg(socketinfo)) + set socketRdQueue($stateArg(socketinfo)) {} + } + + set newQueue {} + lappend newQueue {*}$InFlightR + lappend newQueue {*}$socketRdQueue($stateArg(socketinfo)) + lappend newQueue {*}$InFlightW + lappend newQueue {*}$socketWrQueue($stateArg(socketinfo)) + + + # 2. Tidy up tokenArg. This is a cut-down form of Finish/CloseSocket. + # Do not change state(status). + # No need to after cancel stateArg(after) - either this is done in + # ReplayCore/ReInit, or Finish is called. + + catch {close $stateArg(sock)} + + # 2a. Tidy the tokens in the queues - this is done in ReplayCore/ReInit. + # - Transactions, if any, that are awaiting responses cannot be completed. + # They are listed for re-sending in newQueue. + # - All tokens are preserved for re-use by ReplayCore, and their variables + # will be re-initialised by calls to ReInit. + # - The relevant element of socketMapping, socketRdState, socketWrState, + # socketRdQueue, socketWrQueue, socketClosing, socketPlayCmd will be set + # to new values in ReplayCore. + + ReplayCore $newQueue +} + +# http::ReplayIfClose -- +# +# A request on a socket that was previously "Connection: keep-alive" has +# received a "Connection: close" response header. The server supplies +# that response correctly, but any later requests already queued on this +# connection will be lost when the socket closes. +# +# This command takes arguments that represent the socketWrState, +# socketRdQueue and socketWrQueue for this connection. The socketRdState +# is not needed because the server responds in full to the request that +# received the "Connection: close" response header. +# +# Existing request tokens $token (::http::$n) are preserved. The caller +# will be unaware that the request was processed this way. + +proc http::ReplayIfClose {Wstate Rqueue Wqueue} { + Log running http::ReplayIfClose for $Wstate $Rqueue $Wqueue + + if {$Wstate in $Rqueue || $Wstate in $Wqueue} { + Log WARNING duplicate token in http::ReplayIfClose - token $Wstate + set Wstate Wready + } + + # 1. Create newQueue + set InFlightW {} + if {$Wstate ni {Wready peNding}} { + lappend InFlightW $Wstate + } + + set newQueue {} + lappend newQueue {*}$Rqueue + lappend newQueue {*}$InFlightW + lappend newQueue {*}$Wqueue + + # 2. Cleanup - none needed, done by the caller. + + ReplayCore $newQueue +} + +# http::ReInit -- +# +# Command to restore a token's state to a condition that +# makes it ready to replay a request. +# +# Command http::geturl stores extra state in state(tmp*) so +# we don't need to do the argument processing again. +# +# The caller must: +# - Set state(reusing) and state(sock) to their new values after calling +# this command. +# - Unset state(tmpState), state(tmpOpenCmd) if future calls to ReplayCore +# or ReInit are inappropriate for this token. Typically only one retry +# is allowed. +# The caller may also unset state(tmpConnArgs) if this value (and the +# token) will be used immediately. The value is needed by tokens that +# will be stored in a queue. +# +# Arguments: +# token Connection token. +# +# Return Value: (boolean) true iff the re-initialisation was successful. + +proc http::ReInit {token} { + variable $token + upvar 0 $token state + + if {!( + [info exists state(tmpState)] + && [info exists state(tmpOpenCmd)] + && [info exists state(tmpConnArgs)] + ) + } { + Log FAILED in http::ReInit via ReplayCore - NO tmp vars for $token + return 0 + } + + if {[info exists state(after)]} { + after cancel $state(after) + unset state(after) + } + + # Don't alter state(status) - this would trigger http::wait if it is in use. + set tmpState $state(tmpState) + set tmpOpenCmd $state(tmpOpenCmd) + set tmpConnArgs $state(tmpConnArgs) + foreach name [array names state] { + if {$name ne "status"} { + unset state($name) + } + } + + # Don't alter state(status). + # Restore state(tmp*) - the caller may decide to unset them. + # Restore state(tmpConnArgs) which is needed for connection. + # state(tmpState), state(tmpOpenCmd) are needed only for retries. + + dict unset tmpState status + array set state $tmpState + set state(tmpState) $tmpState + set state(tmpOpenCmd) $tmpOpenCmd + set state(tmpConnArgs) $tmpConnArgs + + return 1 +} + +# http::ReplayCore -- +# +# Command to replay a list of requests, using existing connection tokens. +# +# Abstracted from http::geturl which stores extra state in state(tmp*) so +# we don't need to do the argument processing again. +# +# Arguments: +# newQueue List of connection tokens. +# +# Side Effects: +# Use existing tokens, but try to open a new socket. + +proc http::ReplayCore {newQueue} { + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketClosing + variable socketPlayCmd + + if {[llength $newQueue] == 0} { + # Nothing to do. + return + } + + ##Log running ReplayCore for {*}$newQueue + set newToken [lindex $newQueue 0] + set newQueue [lrange $newQueue 1 end] + + # 3. Use newToken, and restore its values of state(*). Do not restore + # elements tmp* - we try again only once. + + set token $newToken + variable $token + upvar 0 $token state + + if {![ReInit $token]} { + Log FAILED in http::ReplayCore - NO tmp vars + Finish $token {cannot send this request again} + return + } + + set tmpState $state(tmpState) + set tmpOpenCmd $state(tmpOpenCmd) + set tmpConnArgs $state(tmpConnArgs) + unset state(tmpState) + unset state(tmpOpenCmd) + unset state(tmpConnArgs) + + set state(reusing) 0 + + if {$state(-timeout) > 0} { + set resetCmd [list http::reset $token timeout] + set state(after) [after $state(-timeout) $resetCmd] + } + + set pre [clock milliseconds] + ##Log pre socket opened, - token $token + ##Log $tmpOpenCmd - token $token + # 4. Open a socket. + if {[catch {eval $tmpOpenCmd} sock]} { + # Something went wrong while trying to establish the connection. + Log FAILED - $sock + set state(sock) NONE + Finish $token $sock + return + } + ##Log post socket opened, - token $token + set delay [expr {[clock milliseconds] - $pre}] + if {$delay > 3000} { + Log socket delay $delay - token $token + } + # Command [socket] is called with -async, but takes 5s to 5.1s to return, + # with probability of order 1 in 10,000. This may be a bizarre scheduling + # issue with my (KJN's) system (Fedora Linux). + # This does not cause a problem (unless the request times out when this + # command returns). + + # 5. Configure the persistent socket data. + if {$state(-keepalive)} { + set socketMapping($state(socketinfo)) $sock + + if {![info exists socketRdState($state(socketinfo))]} { + set socketRdState($state(socketinfo)) {} + set varName ::http::socketRdState($state(socketinfo)) + trace add variable $varName unset ::http::CancelReadPipeline + } + + if {![info exists socketWrState($state(socketinfo))]} { + set socketWrState($state(socketinfo)) {} + set varName ::http::socketWrState($state(socketinfo)) + trace add variable $varName unset ::http::CancelWritePipeline + } + + if {$state(-pipeline)} { + #Log new, init for pipelined, GRANT write acc to $token ReplayCore + set socketRdState($state(socketinfo)) $token + set socketWrState($state(socketinfo)) $token + } else { + #Log new, init for nonpipeline, GRANT r/w acc to $token ReplayCore + set socketRdState($state(socketinfo)) $token + set socketWrState($state(socketinfo)) $token + } + + set socketRdQueue($state(socketinfo)) {} + set socketWrQueue($state(socketinfo)) $newQueue + set socketClosing($state(socketinfo)) 0 + set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}} + } + + ##Log pre newQueue ReInit, - token $token + # 6. Configure sockets in the queue. + foreach tok $newQueue { + if {[ReInit $tok]} { + set ${tok}(reusing) 1 + set ${tok}(sock) $sock + } else { + set ${tok}(reusing) 1 + set ${tok}(sock) NONE + Finish $token {cannot send this request again} + } + } + + # 7. Configure the socket for newToken to send a request. + set state(sock) $sock + Log "Using $sock for $state(socketinfo) - token $token" \ + [expr {$state(-keepalive)?"keepalive":""}] + + # Initialisation of a new socket. + ##Log socket opened, now fconfigure - token $token + fconfigure $sock -translation {auto crlf} -buffersize $state(-blocksize) + ##Log socket opened, DONE fconfigure - token $token + + # Connect does its own fconfigure. + fileevent $sock writable [list http::Connect $token {*}$tmpConnArgs] + #Log ---- $sock << conn to $token for HTTP request (e) +} + +# Data access functions: +# Data - the URL data +# Status - the transaction status: ok, reset, eof, timeout, error +# Code - the HTTP transaction code, e.g., 200 +# Size - the size of the URL data + +proc http::data {token} { + variable $token + upvar 0 $token state + return $state(body) +} +proc http::status {token} { + if {![info exists $token]} { + return "error" + } + variable $token + upvar 0 $token state + return $state(status) +} +proc http::code {token} { + variable $token + upvar 0 $token state + return $state(http) +} +proc http::ncode {token} { + variable $token + upvar 0 $token state + if {[regexp {[0-9]{3}} $state(http) numeric_code]} { + return $numeric_code + } else { + return $state(http) + } +} +proc http::size {token} { + variable $token + upvar 0 $token state + return $state(currentsize) +} +proc http::meta {token} { + variable $token + upvar 0 $token state + return $state(meta) +} +proc http::error {token} { + variable $token + upvar 0 $token state + if {[info exists state(error)]} { + return $state(error) + } + return "" +} + +# http::cleanup +# +# Garbage collect the state associated with a transaction +# +# Arguments +# token The token returned from http::geturl +# +# Side Effects +# unsets the state array + +proc http::cleanup {token} { + variable $token + upvar 0 $token state + if {[info commands ${token}EventCoroutine] ne {}} { + rename ${token}EventCoroutine {} + } + if {[info exists state(after)]} { + after cancel $state(after) + unset state(after) + } + if {[info exists state]} { + unset state + } +} + +# http::Connect +# +# This callback is made when an asyncronous connection completes. +# +# Arguments +# token The token returned from http::geturl +# +# Side Effects +# Sets the status of the connection, which unblocks +# the waiting geturl call + +proc http::Connect {token proto phost srvurl} { + variable $token + upvar 0 $token state + set tk [namespace tail $token] + set err "due to unexpected EOF" + if { + [eof $state(sock)] || + [set err [fconfigure $state(sock) -error]] ne "" + } { + Log "WARNING - if testing, pay special attention to this\ + case (GJ) which is seldom executed - token $token" + if {[info exists state(reusing)] && $state(reusing)} { + # The socket was closed at the server end, and closed at + # this end by http::CheckEof. + if {[TestForReplay $token write $err b]} { + return + } + + # else: + # This is NOT a persistent socket that has been closed since its + # last use. + # If any other requests are in flight or pipelined/queued, they will + # be discarded. + } + Finish $token "connect failed $err" + } else { + set state(state) connecting + fileevent $state(sock) writable {} + ::http::Connected $token $proto $phost $srvurl + } +} + +# http::Write +# +# Write POST query data to the socket +# +# Arguments +# token The token for the connection +# +# Side Effects +# Write the socket and handle callbacks. + +proc http::Write {token} { + variable http + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketClosing + variable socketPlayCmd + + variable $token + upvar 0 $token state + set tk [namespace tail $token] + set sock $state(sock) + + # Output a block. Tcl will buffer this if the socket blocks + set done 0 + if {[catch { + # Catch I/O errors on dead sockets + + if {[info exists state(-query)]} { + # Chop up large query strings so queryprogress callback can give + # smooth feedback. + if { $state(queryoffset) + $state(-queryblocksize) + >= $state(querylength) + } { + # This will be the last puts for the request-body. + if { (![catch {fileevent $sock readable} binding]) + && ($binding eq [list http::CheckEof $sock]) + } { + # Remove the "fileevent readable" binding of an idle + # persistent socket to http::CheckEof. We can no longer + # treat bytes received as junk. The server might still time + # out and half-close the socket if it has not yet received + # the first "puts". + fileevent $sock readable {} + } + } + puts -nonewline $sock \ + [string range $state(-query) $state(queryoffset) \ + [expr {$state(queryoffset) + $state(-queryblocksize) - 1}]] + incr state(queryoffset) $state(-queryblocksize) + if {$state(queryoffset) >= $state(querylength)} { + set state(queryoffset) $state(querylength) + set done 1 + } + } else { + # Copy blocks from the query channel + + set outStr [read $state(-querychannel) $state(-queryblocksize)] + if {[eof $state(-querychannel)]} { + # This will be the last puts for the request-body. + if { (![catch {fileevent $sock readable} binding]) + && ($binding eq [list http::CheckEof $sock]) + } { + # Remove the "fileevent readable" binding of an idle + # persistent socket to http::CheckEof. We can no longer + # treat bytes received as junk. The server might still time + # out and half-close the socket if it has not yet received + # the first "puts". + fileevent $sock readable {} + } + } + puts -nonewline $sock $outStr + incr state(queryoffset) [string length $outStr] + if {[eof $state(-querychannel)]} { + set done 1 + } + } + } err]} { + # Do not call Finish here, but instead let the read half of the socket + # process whatever server reply there is to get. + + set state(posterror) $err + set done 1 + } + + if {$done} { + catch {flush $sock} + fileevent $sock writable {} + Log ^C$tk end sending request - token $token + # End of writing (POST method). The request has been sent. + + DoneRequest $token + } + + # Callback to the client after we've completely handled everything. + + if {[string length $state(-queryprogress)]} { + eval $state(-queryprogress) \ + [list $token $state(querylength) $state(queryoffset)] + } +} + +# http::Event +# +# Handle input on the socket. This command is the core of +# the coroutine commands ${token}EventCoroutine that are +# bound to "fileevent $sock readable" and process input. +# +# Arguments +# sock The socket receiving input. +# token The token returned from http::geturl +# +# Side Effects +# Read the socket and handle callbacks. + +proc http::Event {sock token} { + variable http + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketClosing + variable socketPlayCmd + + variable $token + upvar 0 $token state + set tk [namespace tail $token] + while 1 { + yield + ##Log Event call - token $token + + if {![info exists state]} { + Log "Event $sock with invalid token '$token' - remote close?" + if {![eof $sock]} { + if {[set d [read $sock]] ne ""} { + Log "WARNING: additional data left on closed socket\ + - token $token" + } + } + Log ^X$tk end of response (token error) - token $token + CloseSocket $sock + return + } + if {$state(state) eq "connecting"} { + ##Log - connecting - token $token + if { $state(reusing) + && $state(-pipeline) + && ($state(-timeout) > 0) + && (![info exists state(after)]) + } { + set state(after) [after $state(-timeout) \ + [list http::reset $token timeout]] + } + + if {[catch {gets $sock state(http)} nsl]} { + Log "WARNING - if testing, pay special attention to this\ + case (GK) which is seldom executed - token $token" + if {[info exists state(reusing)] && $state(reusing)} { + # The socket was closed at the server end, and closed at + # this end by http::CheckEof. + + if {[TestForReplay $token read $nsl c]} { + return + } + + # else: + # This is NOT a persistent socket that has been closed since + # its last use. + # If any other requests are in flight or pipelined/queued, + # they will be discarded. + } else { + Log ^X$tk end of response (error) - token $token + Finish $token $nsl + return + } + } elseif {$nsl >= 0} { + ##Log - connecting 1 - token $token + set state(state) "header" + } elseif { [eof $sock] + && [info exists state(reusing)] + && $state(reusing) + } { + # The socket was closed at the server end, and we didn't notice. + # This is the first read - where the closure is usually first + # detected. + + if {[TestForReplay $token read {} d]} { + return + } + + # else: + # This is NOT a persistent socket that has been closed since its + # last use. + # If any other requests are in flight or pipelined/queued, they + # will be discarded. + } + } elseif {$state(state) eq "header"} { + if {[catch {gets $sock line} nhl]} { + ##Log header failed - token $token + Log ^X$tk end of response (error) - token $token + Finish $token $nhl + return + } elseif {$nhl == 0} { + ##Log header done - token $token + Log ^E$tk end of response headers - token $token + # We have now read all headers + # We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3 + if { ($state(http) == "") + || ([regexp {^\S+\s(\d+)} $state(http) {} x] && $x == 100) + } { + set state(state) "connecting" + continue + # This was a "return" in the pre-coroutine code. + } + + if { ([info exists state(connection)]) + && ([info exists socketMapping($state(socketinfo))]) + && ($state(connection) eq "keep-alive") + && ($state(-keepalive)) + && (!$state(reusing)) + && ($state(-pipeline)) + } { + # Response headers received for first request on a + # persistent socket. Now ready for pipelined writes (if + # any). + # Previous value is $token. It cannot be "pending". + set socketWrState($state(socketinfo)) Wready + http::NextPipelinedWrite $token + } + + # Once a "close" has been signaled, the client MUST NOT send any + # more requests on that connection. + # + # If either the client or the server sends the "close" token in + # the Connection header, that request becomes the last one for + # the connection. + + if { ([info exists state(connection)]) + && ([info exists socketMapping($state(socketinfo))]) + && ($state(connection) eq "close") + && ($state(-keepalive)) + } { + # The server warns that it will close the socket after this + # response. + ##Log WARNING - socket will close after response for $token + # Prepare data for a call to ReplayIfClose. + if { ($socketRdQueue($state(socketinfo)) ne {}) + || ($socketWrQueue($state(socketinfo)) ne {}) + || ($socketWrState($state(socketinfo)) ni + [list Wready peNding $token]) + } { + set InFlightW $socketWrState($state(socketinfo)) + if {$InFlightW in [list Wready peNding $token]} { + set InFlightW Wready + } else { + set msg "token ${InFlightW} is InFlightW" + ##Log $msg - token $token + } + + set socketPlayCmd($state(socketinfo)) \ + [list ReplayIfClose $InFlightW \ + $socketRdQueue($state(socketinfo)) \ + $socketWrQueue($state(socketinfo))] + + # - All tokens are preserved for re-use by ReplayCore. + # - Queues are preserved in case of Finish with error, + # but are not used for anything else because + # socketClosing(*) is set below. + # - Cancel the state(after) timeout events. + foreach tokenVal $socketRdQueue($state(socketinfo)) { + if {[info exists ${tokenVal}(after)]} { + after cancel [set ${tokenVal}(after)] + unset ${tokenVal}(after) + } + } + + } else { + set socketPlayCmd($state(socketinfo)) \ + {ReplayIfClose Wready {} {}} + } + + # Do not allow further connections on this socket. + set socketClosing($state(socketinfo)) 1 + } + + set state(state) body + + # If doing a HEAD, then we won't get any body + if {$state(-validate)} { + Log ^F$tk end of response for HEAD request - token $token + set state(state) complete + Eot $token + return + } + + # - For non-chunked transfer we may have no body - in this case + # we may get no further file event if the connection doesn't + # close and no more data is sent. We can tell and must finish + # up now - not later - the alternative would be to wait until + # the server times out. + # - In this case, the server has NOT told the client it will + # close the connection, AND it has NOT indicated the resource + # length EITHER by setting the Content-Length (totalsize) OR + # by using chunked Transfer-Encoding. + # - Do not worry here about the case (Connection: close) because + # the server should close the connection. + # - IF (NOT Connection: close) AND (NOT chunked encoding) AND + # (totalsize == 0). + + if { (!( [info exists state(connection)] + && ($state(connection) eq "close") + ) + ) + && (![info exists state(transfer)]) + && ($state(totalsize) == 0) + } { + set msg {body size is 0 and no events likely - complete} + Log "$msg - token $token" + set msg {(length unknown, set to 0)} + Log ^F$tk end of response body {*}$msg - token $token + set state(state) complete + Eot $token + return + } + + # We have to use binary translation to count bytes properly. + lassign [fconfigure $sock -translation] trRead trWrite + fconfigure $sock -translation [list binary $trWrite] + + if { + $state(-binary) || [IsBinaryContentType $state(type)] + } { + # Turn off conversions for non-text data. + set state(binary) 1 + } + if {[info exists state(-channel)]} { + if {$state(binary) || [llength [ContentEncoding $token]]} { + fconfigure $state(-channel) -translation binary + } + if {![info exists state(-handler)]} { + # Initiate a sequence of background fcopies. + fileevent $sock readable {} + rename ${token}EventCoroutine {} + CopyStart $sock $token + return + } + } + } elseif {$nhl > 0} { + # Process header lines. + ##Log header - token $token - $line + if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} { + switch -- [string tolower $key] { + content-type { + set state(type) [string trim [string tolower $value]] + # Grab the optional charset information. + if {[regexp -nocase \ + {charset\s*=\s*\"((?:[^""]|\\\")*)\"} \ + $state(type) -> cs]} { + set state(charset) [string map {{\"} \"} $cs] + } else { + regexp -nocase {charset\s*=\s*(\S+?);?} \ + $state(type) -> state(charset) + } + } + content-length { + set state(totalsize) [string trim $value] + } + content-encoding { + set state(coding) [string trim $value] + } + transfer-encoding { + set state(transfer) \ + [string trim [string tolower $value]] + } + proxy-connection - + connection { + set tmpHeader [string trim [string tolower $value]] + # RFC 7230 Section 6.1 states that a comma-separated + # list is an acceptable value. According to + # https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Connection + # any comma-separated list implies keep-alive, but I + # don't see this in the RFC so we'll play safe and + # scan any list for "close". + if {$tmpHeader in {close keep-alive}} { + # The common cases, continue. + } elseif {[string first , $tmpHeader] < 0} { + # Not a comma-separated list, not "close", + # therefore "keep-alive". + set tmpHeader keep-alive + } else { + set tmpResult keep-alive + set tmpCsl [split $tmpHeader ,] + # Optional whitespace either side of separator. + foreach el $tmpCsl { + if {[string trim $el] eq {close}} { + set tmpResult close + break + } + } + set tmpHeader $tmpResult + } + set state(connection) $tmpHeader + } + } + lappend state(meta) $key [string trim $value] + } + } + } else { + # Now reading body + ##Log body - token $token + if {[catch { + if {[info exists state(-handler)]} { + set n [eval $state(-handler) [list $sock $token]] + ##Log handler $n - token $token + # N.B. the protocol has been set to 1.0 because the -handler + # logic is not expected to handle chunked encoding. + # FIXME Allow -handler with 1.1 on dechunked stacked chan. + if {$state(totalsize) == 0} { + # We know the transfer is complete only when the server + # closes the connection - i.e. eof is not an error. + set state(state) complete + } + if {![string is integer -strict $n]} { + if 1 { + # Do not tolerate bad -handler - fail with error + # status. + set msg {the -handler command for http::geturl must\ + return an integer (the number of bytes\ + read)} + Log ^X$tk end of response (handler error) -\ + token $token + Eot $token $msg + } else { + # Tolerate the bad -handler, and continue. The + # penalty: + # (a) Because the handler returns nonsense, we know + # the transfer is complete only when the server + # closes the connection - i.e. eof is not an + # error. + # (b) http::size will not be accurate. + # (c) The transaction is already downgraded to 1.0 + # to avoid chunked transfer encoding. It MUST + # also be forced to "Connection: close" or the + # HTTP/1.0 equivalent; or it MUST fail (as + # above) if the server sends + # "Connection: keep-alive" or the HTTP/1.0 + # equivalent. + set n 0 + set state(state) complete + } + } + } elseif {[info exists state(transfer_final)]} { + # This code forgives EOF in place of the final CRLF. + set line [getTextLine $sock] + set n [string length $line] + set state(state) complete + if {$n > 0} { + # - HTTP trailers (late response headers) are permitted + # by Chunked Transfer-Encoding, and can be safely + # ignored. + # - Do not count these bytes in the total received for + # the response body. + Log "trailer of $n bytes after final chunk -\ + token $token" + append state(transfer_final) $line + set n 0 + } else { + Log ^F$tk end of response body (chunked) - token $token + Log "final chunk part - token $token" + Eot $token + } + } elseif { [info exists state(transfer)] + && ($state(transfer) eq "chunked") + } { + ##Log chunked - token $token + set size 0 + set hexLenChunk [getTextLine $sock] + #set ntl [string length $hexLenChunk] + if {[string trim $hexLenChunk] ne ""} { + scan $hexLenChunk %x size + if {$size != 0} { + ##Log chunk-measure $size - token $token + set chunk [BlockingRead $sock $size] + set n [string length $chunk] + if {$n >= 0} { + append state(body) $chunk + incr state(log_size) [string length $chunk] + ##Log chunk $n cumul $state(log_size) -\ + token $token + } + if {$size != [string length $chunk]} { + Log "WARNING: mis-sized chunk:\ + was [string length $chunk], should be\ + $size - token $token" + set n 0 + set state(connection) close + Log ^X$tk end of response (chunk error) \ + - token $token + set msg {error in chunked encoding - fetch\ + terminated} + Eot $token $msg + } + # CRLF that follows chunk. + # If eof, this is handled at the end of this proc. + getTextLine $sock + } else { + set n 0 + set state(transfer_final) {} + } + } else { + # Line expected to hold chunk length is empty, or eof. + ##Log bad-chunk-measure - token $token + set n 0 + set state(connection) close + Log ^X$tk end of response (chunk error) - token $token + Eot $token {error in chunked encoding -\ + fetch terminated} + } + } else { + ##Log unchunked - token $token + if {$state(totalsize) == 0} { + # We know the transfer is complete only when the server + # closes the connection. + set state(state) complete + set reqSize $state(-blocksize) + } else { + # Ask for the whole of the unserved response-body. + # This works around a problem with a tls::socket - for + # https in keep-alive mode, and a request for + # $state(-blocksize) bytes, the last part of the + # resource does not get read until the server times out. + set reqSize [expr { $state(totalsize) + - $state(currentsize)}] + + # The workaround fails if reqSize is + # capped at $state(-blocksize). + # set reqSize [expr {min($reqSize, $state(-blocksize))}] + } + set c $state(currentsize) + set t $state(totalsize) + ##Log non-chunk currentsize $c of totalsize $t -\ + token $token + set block [read $sock $reqSize] + set n [string length $block] + if {$n >= 0} { + append state(body) $block + ##Log non-chunk [string length $state(body)] -\ + token $token + } + } + # This calculation uses n from the -handler, chunked, or + # unchunked case as appropriate. + if {[info exists state]} { + if {$n >= 0} { + incr state(currentsize) $n + set c $state(currentsize) + set t $state(totalsize) + ##Log another $n currentsize $c totalsize $t -\ + token $token + } + # If Content-Length - check for end of data. + if { + ($state(totalsize) > 0) + && ($state(currentsize) >= $state(totalsize)) + } { + Log ^F$tk end of response body (unchunked) -\ + token $token + set state(state) complete + Eot $token + } + } + } err]} { + Log ^X$tk end of response (error ${err}) - token $token + Finish $token $err + return + } else { + if {[info exists state(-progress)]} { + eval $state(-progress) \ + [list $token $state(totalsize) $state(currentsize)] + } + } + } + + # catch as an Eot above may have closed the socket already + # $state(state) may be connecting, header, body, or complete + if {![set cc [catch {eof $sock} eof]] && $eof} { + ##Log eof - token $token + if {[info exists $token]} { + set state(connection) close + if {$state(state) eq "complete"} { + # This includes all cases in which the transaction + # can be completed by eof. + # The value "complete" is set only in http::Event, and it is + # used only in the test above. + Log ^F$tk end of response body (unchunked, eof) -\ + token $token + Eot $token + } else { + # Premature eof. + Log ^X$tk end of response (unexpected eof) - token $token + Eot $token eof + } + } else { + # open connection closed on a token that has been cleaned up. + Log ^X$tk end of response (token error) - token $token + CloseSocket $sock + } + } elseif {$cc} { + return + } + } +} + +# http::TestForReplay +# +# Command called if eof is discovered when a socket is first used for a +# new transaction. Typically this occurs if a persistent socket is used +# after a period of idleness and the server has half-closed the socket. +# +# token - the connection token returned by http::geturl +# doing - "read" or "write" +# err - error message, if any +# caller - code to identify the caller - used only in logging +# +# Return Value: boolean, true iff the command calls http::ReplayIfDead. + +proc http::TestForReplay {token doing err caller} { + variable http + variable $token + upvar 0 $token state + set tk [namespace tail $token] + if {$doing eq "read"} { + set code Q + set action response + set ing reading + } else { + set code P + set action request + set ing writing + } + + if {$err eq {}} { + set err "detect eof when $ing (server timed out?)" + } + + if {$state(method) eq "POST" && !$http(-repost)} { + # No Replay. + # The present transaction will end when Finish is called. + # That call to Finish will abort any other transactions + # currently in the write queue. + # For calls from http::Event this occurs when execution + # reaches the code block at the end of that proc. + set msg {no retry for POST with http::config -repost 0} + Log reusing socket failed "($caller)" - $msg - token $token + Log error - $err - token $token + Log ^X$tk end of $action (error) - token $token + return 0 + } else { + # Replay. + set msg {try a new socket} + Log reusing socket failed "($caller)" - $msg - token $token + Log error - $err - token $token + Log ^$code$tk Any unfinished (incl this one) failed - token $token + ReplayIfDead $token $doing + return 1 + } +} + +# http::IsBinaryContentType -- +# +# Determine if the content-type means that we should definitely transfer +# the data as binary. [Bug 838e99a76d] +# +# Arguments +# type The content-type of the data. +# +# Results: +# Boolean, true if we definitely should be binary. + +proc http::IsBinaryContentType {type} { + lassign [split [string tolower $type] "/;"] major minor + if {$major eq "text"} { + return false + } + # There's a bunch of XML-as-application-format things about. See RFC 3023 + # and so on. + if {$major eq "application"} { + set minor [string trimright $minor] + if {$minor in {"json" "xml" "xml-external-parsed-entity" "xml-dtd"}} { + return false + } + } + # Not just application/foobar+xml but also image/svg+xml, so let us not + # restrict things for now... + if {[string match "*+xml" $minor]} { + return false + } + return true +} + +# http::getTextLine -- +# +# Get one line with the stream in crlf mode. +# Used if Transfer-Encoding is chunked. +# Empty line is not distinguished from eof. The caller must +# be able to handle this. +# +# Arguments +# sock The socket receiving input. +# +# Results: +# The line of text, without trailing newline + +proc http::getTextLine {sock} { + set tr [fconfigure $sock -translation] + lassign $tr trRead trWrite + fconfigure $sock -translation [list crlf $trWrite] + set r [BlockingGets $sock] + fconfigure $sock -translation $tr + return $r +} + +# http::BlockingRead +# +# Replacement for a blocking read. +# The caller must be a coroutine. + +proc http::BlockingRead {sock size} { + if {$size < 1} { + return + } + set result {} + while 1 { + set need [expr {$size - [string length $result]}] + set block [read $sock $need] + set eof [eof $sock] + append result $block + if {[string length $result] >= $size || $eof} { + return $result + } else { + yield + } + } +} + +# http::BlockingGets +# +# Replacement for a blocking gets. +# The caller must be a coroutine. +# Empty line is not distinguished from eof. The caller must +# be able to handle this. + +proc http::BlockingGets {sock} { + while 1 { + set count [gets $sock line] + set eof [eof $sock] + if {$count > -1 || $eof} { + return $line + } else { + yield + } + } +} + +# http::CopyStart +# +# Error handling wrapper around fcopy +# +# Arguments +# sock The socket to copy from +# token The token returned from http::geturl +# +# Side Effects +# This closes the connection upon error + +proc http::CopyStart {sock token {initial 1}} { + upvar #0 $token state + if {[info exists state(transfer)] && $state(transfer) eq "chunked"} { + foreach coding [ContentEncoding $token] { + lappend state(zlib) [zlib stream $coding] + } + make-transformation-chunked $sock [namespace code [list CopyChunk $token]] + } else { + if {$initial} { + foreach coding [ContentEncoding $token] { + zlib push $coding $sock + } + } + if {[catch { + # FIXME Keep-Alive on https tls::socket with unchunked transfer + # hangs until the server times out. A workaround is possible, as for + # the case without -channel, but it does not use the neat "fcopy" + # solution. + fcopy $sock $state(-channel) -size $state(-blocksize) -command \ + [list http::CopyDone $token] + } err]} { + Finish $token $err + } + } +} + +proc http::CopyChunk {token chunk} { + upvar 0 $token state + if {[set count [string length $chunk]]} { + incr state(currentsize) $count + if {[info exists state(zlib)]} { + foreach stream $state(zlib) { + set chunk [$stream add $chunk] + } + } + puts -nonewline $state(-channel) $chunk + if {[info exists state(-progress)]} { + eval [linsert $state(-progress) end \ + $token $state(totalsize) $state(currentsize)] + } + } else { + Log "CopyChunk Finish - token $token" + if {[info exists state(zlib)]} { + set excess "" + foreach stream $state(zlib) { + catch {set excess [$stream add -finalize $excess]} + } + puts -nonewline $state(-channel) $excess + foreach stream $state(zlib) { $stream close } + unset state(zlib) + } + Eot $token ;# FIX ME: pipelining. + } +} + +# http::CopyDone +# +# fcopy completion callback +# +# Arguments +# token The token returned from http::geturl +# count The amount transfered +# +# Side Effects +# Invokes callbacks + +proc http::CopyDone {token count {error {}}} { + variable $token + upvar 0 $token state + set sock $state(sock) + incr state(currentsize) $count + if {[info exists state(-progress)]} { + eval $state(-progress) \ + [list $token $state(totalsize) $state(currentsize)] + } + # At this point the token may have been reset. + if {[string length $error]} { + Finish $token $error + } elseif {[catch {eof $sock} iseof] || $iseof} { + Eot $token + } else { + CopyStart $sock $token 0 + } +} + +# http::Eot +# +# Called when either: +# a. An eof condition is detected on the socket. +# b. The client decides that the response is complete. +# c. The client detects an inconsistency and aborts the transaction. +# +# Does: +# 1. Set state(status) +# 2. Reverse any Content-Encoding +# 3. Convert charset encoding and line ends if necessary +# 4. Call http::Finish +# +# Arguments +# token The token returned from http::geturl +# force (previously) optional, has no effect +# reason - "eof" means premature EOF (not EOF as the natural end of +# the response) +# - "" means completion of response, with or without EOF +# - anything else describes an error confition other than +# premature EOF. +# +# Side Effects +# Clean up the socket + +proc http::Eot {token {reason {}}} { + variable $token + upvar 0 $token state + if {$reason eq "eof"} { + # Premature eof. + set state(status) eof + set reason {} + } elseif {$reason ne ""} { + # Abort the transaction. + set state(status) $reason + } else { + # The response is complete. + set state(status) ok + } + + if {[string length $state(body)] > 0} { + if {[catch { + foreach coding [ContentEncoding $token] { + set state(body) [zlib $coding $state(body)] + } + } err]} { + Log "error doing decompression for token $token: $err" + Finish $token $err + return + } + + if {!$state(binary)} { + # If we are getting text, set the incoming channel's encoding + # correctly. iso8859-1 is the RFC default, but this could be any + # IANA charset. However, we only know how to convert what we have + # encodings for. + + set enc [CharsetToEncoding $state(charset)] + if {$enc ne "binary"} { + set state(body) [encoding convertfrom $enc $state(body)] + } + + # Translate text line endings. + set state(body) [string map {\r\n \n \r \n} $state(body)] + } + } + Finish $token $reason +} + +# http::wait -- +# +# See documentation for details. +# +# Arguments: +# token Connection token. +# +# Results: +# The status after the wait. + +proc http::wait {token} { + variable $token + upvar 0 $token state + + if {![info exists state(status)] || $state(status) eq ""} { + # We must wait on the original variable name, not the upvar alias + vwait ${token}(status) + } + + return [status $token] +} + +# http::formatQuery -- +# +# See documentation for details. Call http::formatQuery with an even +# number of arguments, where the first is a name, the second is a value, +# the third is another name, and so on. +# +# Arguments: +# args A list of name-value pairs. +# +# Results: +# TODO + +proc http::formatQuery {args} { + if {[llength $args] % 2} { + return \ + -code error \ + -errorcode [list HTTP BADARGCNT $args] \ + {Incorrect number of arguments, must be an even number.} + } + set result "" + set sep "" + foreach i $args { + append result $sep [mapReply $i] + if {$sep eq "="} { + set sep & + } else { + set sep = + } + } + return $result +} + +# http::mapReply -- +# +# Do x-www-urlencoded character mapping +# +# Arguments: +# string The string the needs to be encoded +# +# Results: +# The encoded string + +proc http::mapReply {string} { + variable http + variable formMap + + # The spec says: "non-alphanumeric characters are replaced by '%HH'". Use + # a pre-computed map and [string map] to do the conversion (much faster + # than [regsub]/[subst]). [Bug 1020491] + + if {$http(-urlencoding) ne ""} { + set string [encoding convertto $http(-urlencoding) $string] + return [string map $formMap $string] + } + set converted [string map $formMap $string] + if {[string match "*\[\u0100-\uffff\]*" $converted]} { + regexp "\[\u0100-\uffff\]" $converted badChar + # Return this error message for maximum compatibility... :^/ + return -code error \ + "can't read \"formMap($badChar)\": no such element in array" + } + return $converted +} +interp alias {} http::quoteString {} http::mapReply + +# http::ProxyRequired -- +# Default proxy filter. +# +# Arguments: +# host The destination host +# +# Results: +# The current proxy settings + +proc http::ProxyRequired {host} { + variable http + if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} { + if { + ![info exists http(-proxyport)] || + ![string length $http(-proxyport)] + } { + set http(-proxyport) 8080 + } + return [list $http(-proxyhost) $http(-proxyport)] + } +} + +# http::CharsetToEncoding -- +# +# Tries to map a given IANA charset to a tcl encoding. If no encoding +# can be found, returns binary. +# + +proc http::CharsetToEncoding {charset} { + variable encodings + + set charset [string tolower $charset] + if {[regexp {iso-?8859-([0-9]+)} $charset -> num]} { + set encoding "iso8859-$num" + } elseif {[regexp {iso-?2022-(jp|kr)} $charset -> ext]} { + set encoding "iso2022-$ext" + } elseif {[regexp {shift[-_]?js} $charset]} { + set encoding "shiftjis" + } elseif {[regexp {(?:windows|cp)-?([0-9]+)} $charset -> num]} { + set encoding "cp$num" + } elseif {$charset eq "us-ascii"} { + set encoding "ascii" + } elseif {[regexp {(?:iso-?)?lat(?:in)?-?([0-9]+)} $charset -> num]} { + switch -- $num { + 5 {set encoding "iso8859-9"} + 1 - 2 - 3 { + set encoding "iso8859-$num" + } + } + } else { + # other charset, like euc-xx, utf-8,... may directly map to encoding + set encoding $charset + } + set idx [lsearch -exact $encodings $encoding] + if {$idx >= 0} { + return $encoding + } else { + return "binary" + } +} + +# Return the list of content-encoding transformations we need to do in order. +proc http::ContentEncoding {token} { + upvar 0 $token state + set r {} + if {[info exists state(coding)]} { + foreach coding [split $state(coding) ,] { + switch -exact -- $coding { + deflate { lappend r inflate } + gzip - x-gzip { lappend r gunzip } + compress - x-compress { lappend r decompress } + identity {} + default { + return -code error "unsupported content-encoding \"$coding\"" + } + } + } + } + return $r +} + +proc http::ReceiveChunked {chan command} { + set data "" + set size -1 + yield + while {1} { + chan configure $chan -translation {crlf binary} + while {[gets $chan line] < 1} { yield } + chan configure $chan -translation {binary binary} + if {[scan $line %x size] != 1} { + return -code error "invalid size: \"$line\"" + } + set chunk "" + while {$size && ![chan eof $chan]} { + set part [chan read $chan $size] + incr size -[string length $part] + append chunk $part + } + if {[catch { + uplevel #0 [linsert $command end $chunk] + }]} { + http::Log "Error in callback: $::errorInfo" + } + if {[string length $chunk] == 0} { + # channel might have been closed in the callback + catch {chan event $chan readable {}} + return + } + } +} + +proc http::make-transformation-chunked {chan command} { + coroutine [namespace current]::dechunk$chan ::http::ReceiveChunked $chan $command + chan event $chan readable [namespace current]::dechunk$chan +} + +# Local variables: +# indent-tabs-mode: t +# End: diff --git a/amd64/lib/tcl86t.lib b/amd64/lib/tcl86t.lib index 661785c..89f6908 100644 Binary files a/amd64/lib/tcl86t.lib and b/amd64/lib/tcl86t.lib differ diff --git a/amd64/lib/tclConfig.sh b/amd64/lib/tclConfig.sh index 934361c..9ad3041 100644 --- a/amd64/lib/tclConfig.sh +++ b/amd64/lib/tclConfig.sh @@ -15,21 +15,21 @@ TCL_DLL_FILE="tcl86t.dll" TCL_VERSION='8.6' TCL_MAJOR_VERSION='8' TCL_MINOR_VERSION='6' -TCL_PATCH_LEVEL='8.6.10' +TCL_PATCH_LEVEL='8.6.11' # C compiler to use for compilation. TCL_CC='cl' # -D flags for use with the C compiler. -TCL_DEFS='-nologo -c /D_ATL_XP_TARGETING -W3 -wd4311 -wd4312 -wd4311 -wd4312 -FpC:\A\32\b\tcl-core-8.6.10.0\win\Release_AMD64_VC13\tcl_ThreadedDynamic\ -fp:strict -O2 -GS -GL -MD -I"C:\A\32\b\tcl-core-8.6.10.0\win\..\win" -I"C:\A\32\b\tcl-core-8.6.10.0\win\..\generic" -I"C:\A\32\b\tcl-core-8.6.10.0\win\..\libtommath" /DTCL_TOMMATH /DMP_PREC=4 /Dinline=__inline /DHAVE_ZLIB=1 /D_CRT_SECURE_NO_DEPRECATE /D_CRT_NONSTDC_NO_DEPRECATE /DMP_FIXED_CUTOFFS /DMP_NO_STDINT /DTCL_CFGVAL_ENCODING=\"cp1252\" /DSTDC_HEADERS /DTCL_THREADS=1 /DUSE_THREAD_ALLOC=1 /DNDEBUG /DTCL_CFG_OPTIMIZED /DTCL_CFG_DO64BIT /DBUILD_tcl' +TCL_DEFS='-nologo -c /D_ATL_XP_TARGETING -W3 -wd4311 -wd4312 -wd4311 -wd4312 -FpD:\_w\1\b\tcl-core-8.6.11.0\win\Release_AMD64_VC13\tcl_ThreadedDynamic\ -fp:strict -O2 -GS -GL -MD -I"D:\_w\1\b\tcl-core-8.6.11.0\win\..\win" -I"D:\_w\1\b\tcl-core-8.6.11.0\win\..\generic" -I"D:\_w\1\b\tcl-core-8.6.11.0\win\..\libtommath" /DTCL_TOMMATH /DMP_PREC=4 /Dinline=__inline /DHAVE_ZLIB=1 /D_CRT_SECURE_NO_DEPRECATE /D_CRT_NONSTDC_NO_DEPRECATE /DMP_FIXED_CUTOFFS /DSTDC_HEADERS /DHAVE_STDINT_H=1 /DHAVE_INTTYPES_H=1 /DHAVE_STDBOOL_H=1 /DTCL_THREADS=1 /DUSE_THREAD_ALLOC=1 /DNDEBUG /DTCL_CFG_OPTIMIZED /DTCL_CFG_DO64BIT /DBUILD_tcl' # If TCL was built with debugging symbols, generated libraries contain # this string at the end of the library name (before the extension). TCL_DBGX=t # Default flags used in an optimized and debuggable build, respectively. -TCL_CFLAGS_DEBUG='-nologo -c -W3 -YX -FpC:\A\32\b\tcl-core-8.6.10.0\win\Release_AMD64_VC13\tcl_ThreadedDynamic\ -MDd' -TCL_CFLAGS_OPTIMIZE='-nologo -c -W3 -YX -FpC:\A\32\b\tcl-core-8.6.10.0\win\Release_AMD64_VC13\tcl_ThreadedDynamic\ -MD' +TCL_CFLAGS_DEBUG='-nologo -c -W3 -YX -FpD:\_w\1\b\tcl-core-8.6.11.0\win\Release_AMD64_VC13\tcl_ThreadedDynamic\ -MDd' +TCL_CFLAGS_OPTIMIZE='-nologo -c -W3 -YX -FpD:\_w\1\b\tcl-core-8.6.11.0\win\Release_AMD64_VC13\tcl_ThreadedDynamic\ -MD' # Default linker flags used in an optimized and debuggable build, respectively. TCL_LDFLAGS_DEBUG='-nologo -machine:AMD64 -debug -debugtype:cv' @@ -55,11 +55,11 @@ TCL_LIBS='kernel32.lib advapi32.lib netapi32.lib user32.lib userenv.lib ws2_32.l # Top-level directory in which Tcl's platform-independent files are # installed. -TCL_PREFIX='C:\A\32\b\tcltk-8.6.10.0\amd64' +TCL_PREFIX='D:\_w\1\b\tcltk-8.6.11.0\amd64' # Top-level directory in which Tcl's platform-specific files (e.g. # executables) are installed. -TCL_EXEC_PREFIX='C:\A\32\b\tcltk-8.6.10.0\amd64\bin' +TCL_EXEC_PREFIX='D:\_w\1\b\tcltk-8.6.11.0\amd64\bin' # Flags to pass to cc when compiling the components of a shared library: TCL_SHLIB_CFLAGS='' @@ -115,11 +115,11 @@ TCL_BUILD_LIB_SPEC='' # String to pass to linker to pick up the Tcl library from its # installed directory. -TCL_LIB_SPEC='C:\A\32\b\tcltk-8.6.10.0\amd64\lib\tcl86t.lib' +TCL_LIB_SPEC='D:\_w\1\b\tcltk-8.6.11.0\amd64\lib\tcl86t.lib' # String to pass to the compiler so that an extension can # find installed Tcl headers. -TCL_INCLUDE_SPEC='-IC:\A\32\b\tcltk-8.6.10.0\amd64\include' +TCL_INCLUDE_SPEC='-ID:\_w\1\b\tcltk-8.6.11.0\amd64\include' # Indicates whether a version numbers should be used in -l switches # ("ok" means it's safe to use switches like -ltcl7.5; "nodots" means @@ -146,7 +146,7 @@ TCL_UNSHARED_LIB_SUFFIX='86t.lib' # different place than the directory containing the source files, this # points to the location of the sources, not the location where Tcl was # compiled. -TCL_SRC_DIR='C:\A\32\b\tcl-core-8.6.10.0\win\..' +TCL_SRC_DIR='D:\_w\1\b\tcl-core-8.6.11.0\win\..' # List of standard directories in which to look for packages during # "package require" commands. Contains the "prefix" directory plus also @@ -164,17 +164,17 @@ TCL_STUB_LIB_FLAG='tclstub86.lib' # String to pass to linker to pick up the Tcl stub library from its # build directory. -TCL_BUILD_STUB_LIB_SPEC='-LC:\A\32\b\tcl-core-8.6.10.0\win\Release_AMD64_VC13 tclstub86.lib' +TCL_BUILD_STUB_LIB_SPEC='-LD:\_w\1\b\tcl-core-8.6.11.0\win\Release_AMD64_VC13 tclstub86.lib' # String to pass to linker to pick up the Tcl stub library from its # installed directory. -TCL_STUB_LIB_SPEC='-LC:\A\32\b\tcltk-8.6.10.0\amd64\lib tclstub86.lib' +TCL_STUB_LIB_SPEC='-LD:\_w\1\b\tcltk-8.6.11.0\amd64\lib tclstub86.lib' # Path to the Tcl stub library in the build directory. -TCL_BUILD_STUB_LIB_PATH='C:\A\32\b\tcl-core-8.6.10.0\win\Release_AMD64_VC13\tclstub86.lib' +TCL_BUILD_STUB_LIB_PATH='D:\_w\1\b\tcl-core-8.6.11.0\win\Release_AMD64_VC13\tclstub86.lib' # Path to the Tcl stub library in the install directory. -TCL_STUB_LIB_PATH='C:\A\32\b\tcltk-8.6.10.0\amd64\lib\tclstub86.lib' +TCL_STUB_LIB_PATH='D:\_w\1\b\tcltk-8.6.11.0\amd64\lib\tclstub86.lib' # Flag, 1: we built Tcl with threads enabled, 0 we didn't TCL_THREADS=1 diff --git a/amd64/lib/tclstub86.lib b/amd64/lib/tclstub86.lib index 6f396f9..4c15093 100644 Binary files a/amd64/lib/tclstub86.lib and b/amd64/lib/tclstub86.lib differ diff --git a/amd64/lib/tix8.4.3/tix84.dll b/amd64/lib/tix8.4.3/tix84.dll index 43adc63..53f376e 100644 Binary files a/amd64/lib/tix8.4.3/tix84.dll and b/amd64/lib/tix8.4.3/tix84.dll differ diff --git a/amd64/lib/tix8.4.3/tix84.lib b/amd64/lib/tix8.4.3/tix84.lib index 88deda3..98859cb 100644 Binary files a/amd64/lib/tix8.4.3/tix84.lib and b/amd64/lib/tix8.4.3/tix84.lib differ diff --git a/amd64/lib/tk8.6/bgerror.tcl b/amd64/lib/tk8.6/bgerror.tcl index 8421924..fe8dfe0 100644 --- a/amd64/lib/tk8.6/bgerror.tcl +++ b/amd64/lib/tk8.6/bgerror.tcl @@ -41,7 +41,7 @@ proc ::tk::dialog::error::Details {} { set w .bgerrorDialog set caption [option get $w.function text {}] set command [option get $w.function command {}] - if { ($caption eq "") || ($command eq "") } { + if {($caption eq "") || ($command eq "")} { grid forget $w.function } lappend command [$w.top.info.text get 1.0 end-1c] @@ -50,7 +50,7 @@ proc ::tk::dialog::error::Details {} { } proc ::tk::dialog::error::SaveToLog {text} { - if { $::tcl_platform(platform) eq "windows" } { + if {$::tcl_platform(platform) eq "windows"} { set allFiles *.* } else { set allFiles * @@ -129,11 +129,11 @@ proc ::tk::dialog::error::bgerror {err {flag 1}} { set lines 0 set maxLine 45 foreach line [split $err \n] { - if { [string length $line] > $maxLine } { - append displayedErr "[string range $line 0 [expr {$maxLine-3}]]..." + if {[string length $line] > $maxLine} { + append displayedErr "[string range $line 0 $maxLine-3]..." break } - if { $lines > 4 } { + if {$lines > 4} { append displayedErr "..." break } else { @@ -182,7 +182,7 @@ proc ::tk::dialog::error::bgerror {err {flag 1}} { pack $W.text -side left -expand yes -fill both $W.text insert 0.0 "$err\n$info" $W.text mark set insert 0.0 - bind $W.text { focus %W } + bind $W.text {focus %W} $W.text configure -state disabled # 2. Fill the top part with bitmap and message diff --git a/amd64/lib/tk8.6/clrpick.tcl b/amd64/lib/tk8.6/clrpick.tcl index 600be16..e408d03 100644 --- a/amd64/lib/tk8.6/clrpick.tcl +++ b/amd64/lib/tk8.6/clrpick.tcl @@ -396,7 +396,7 @@ proc ::tk::dialog::color::DrawColorScale {w c {create 0}} { # Draw the selection polygons CreateSelector $w $sel $c - $sel bind $data($c,index) \ + $sel bind $data($c,index) \ [list tk::dialog::color::StartMove $w $sel $c %x $data(selPad) 1] $sel bind $data($c,index) \ [list tk::dialog::color::MoveSelector $w $sel $c %x $data(selPad)] @@ -409,14 +409,14 @@ proc ::tk::dialog::color::DrawColorScale {w c {create 0}} { set data($c,clickRegion) [$sel create rectangle 0 0 \ $data(canvasWidth) $height -fill {} -outline {}] - bind $col \ + bind $col \ [list tk::dialog::color::StartMove $w $sel $c %x $data(colorPad)] bind $col \ [list tk::dialog::color::MoveSelector $w $sel $c %x $data(colorPad)] bind $col \ [list tk::dialog::color::ReleaseMouse $w $sel $c %x $data(colorPad)] - $sel bind $data($c,clickRegion) \ + $sel bind $data($c,clickRegion) \ [list tk::dialog::color::StartMove $w $sel $c %x $data(selPad)] $sel bind $data($c,clickRegion) \ [list tk::dialog::color::MoveSelector $w $sel $c %x $data(selPad)] diff --git a/amd64/lib/tk8.6/comdlg.tcl b/amd64/lib/tk8.6/comdlg.tcl index 18df8a6..b4d8978 100644 --- a/amd64/lib/tk8.6/comdlg.tcl +++ b/amd64/lib/tk8.6/comdlg.tcl @@ -29,7 +29,8 @@ # {....} # } # -# flags = currently unused. +# flags = a list of flags. Currently supported flags are: +# DONTSETDEFAULTS = skip default values setting # # argList = The list of "-option value" pairs. # @@ -63,8 +64,10 @@ proc tclParseConfigSpec {w specs flags argList} { # 2: set the default values # - foreach cmdsw [array names cmd] { - set data($cmdsw) $def($cmdsw) + if {"DONTSETDEFAULTS" ni $flags} { + foreach cmdsw [array names cmd] { + set data($cmdsw) $def($cmdsw) + } } # 3: parse the argument list diff --git a/amd64/lib/tk8.6/console.tcl b/amd64/lib/tk8.6/console.tcl index 355a43b..30c4d88 100644 --- a/amd64/lib/tk8.6/console.tcl +++ b/amd64/lib/tk8.6/console.tcl @@ -131,7 +131,7 @@ proc ::tk::ConsoleInit {} { default { set preferred {} } } foreach {family size} $preferred { - if {[lsearch -exact $families $family] != -1} { + if {$family in $families} { font configure TkConsoleFont -family $family -size $size break } @@ -592,7 +592,7 @@ proc ::tk::ConsoleBind {w} { } bind Console { eval destroy [winfo child .] - source [file join $tk_library console.tcl] + source -encoding utf-8 [file join $tk_library console.tcl] } if {[tk windowingsystem] eq "aqua"} { bind Console { @@ -740,9 +740,9 @@ proc ::tk::console::FontchooserToggle {} { } proc ::tk::console::FontchooserVisibility {index} { if {[tk fontchooser configure -visible]} { - .menubar.edit entryconfigure $index -label [msgcat::mc "Hide Fonts"] + .menubar.edit entryconfigure $index -label [::tk::msgcat::mc "Hide Fonts"] } else { - .menubar.edit entryconfigure $index -label [msgcat::mc "Show Fonts"] + .menubar.edit entryconfigure $index -label [::tk::msgcat::mc "Show Fonts"] } } proc ::tk::console::FontchooserFocus {w isFocusIn} { diff --git a/amd64/lib/tk8.6/demos/arrow.tcl b/amd64/lib/tk8.6/demos/arrow.tcl index 12249c0..3d0b406 100644 --- a/amd64/lib/tk8.6/demos/arrow.tcl +++ b/amd64/lib/tk8.6/demos/arrow.tcl @@ -154,11 +154,11 @@ $c bind box "$c itemconfigure current $demo_arrowInfo(activeStyle)" $c bind box "$c itemconfigure current $demo_arrowInfo(boxStyle)" $c bind box " " $c bind box " " -$c bind box1 <1> {set demo_arrowInfo(motionProc) arrowMove1} -$c bind box2 <1> {set demo_arrowInfo(motionProc) arrowMove2} -$c bind box3 <1> {set demo_arrowInfo(motionProc) arrowMove3} +$c bind box1 {set demo_arrowInfo(motionProc) arrowMove1} +$c bind box2 {set demo_arrowInfo(motionProc) arrowMove2} +$c bind box3 {set demo_arrowInfo(motionProc) arrowMove3} $c bind box "\$demo_arrowInfo(motionProc) $c %x %y" -bind $c "arrowSetup $c" +bind $c "arrowSetup $c" # arrowMove1 -- # This procedure is called for each mouse motion event on box1 (the diff --git a/amd64/lib/tk8.6/demos/bind.tcl b/amd64/lib/tk8.6/demos/bind.tcl index 03f6d3b..8b56639 100644 --- a/amd64/lib/tk8.6/demos/bind.tcl +++ b/amd64/lib/tk8.6/demos/bind.tcl @@ -63,16 +63,16 @@ $w.text insert end \ # Create bindings for tags. foreach tag {d1 d2 d3 d4 d5 d6} { - $w.text tag bind $tag "$w.text tag configure $tag $bold" - $w.text tag bind $tag "$w.text tag configure $tag $normal" + $w.text tag bind $tag "$w.text tag configure $tag $bold" + $w.text tag bind $tag "$w.text tag configure $tag $normal" } # Main widget program sets variable tk_demoDirectory -$w.text tag bind d1 <1> {source [file join $tk_demoDirectory items.tcl]} -$w.text tag bind d2 <1> {source [file join $tk_demoDirectory plot.tcl]} -$w.text tag bind d3 <1> {source [file join $tk_demoDirectory ctext.tcl]} -$w.text tag bind d4 <1> {source [file join $tk_demoDirectory arrow.tcl]} -$w.text tag bind d5 <1> {source [file join $tk_demoDirectory ruler.tcl]} -$w.text tag bind d6 <1> {source [file join $tk_demoDirectory cscroll.tcl]} +$w.text tag bind d1 {source -encoding utf-8 [file join $tk_demoDirectory items.tcl]} +$w.text tag bind d2 {source -encoding utf-8 [file join $tk_demoDirectory plot.tcl]} +$w.text tag bind d3 {source -encoding utf-8 [file join $tk_demoDirectory ctext.tcl]} +$w.text tag bind d4 {source -encoding utf-8 [file join $tk_demoDirectory arrow.tcl]} +$w.text tag bind d5 {source -encoding utf-8 [file join $tk_demoDirectory ruler.tcl]} +$w.text tag bind d6 {source -encoding utf-8 [file join $tk_demoDirectory cscroll.tcl]} $w.text mark set insert 0.0 $w.text configure -state disabled diff --git a/amd64/lib/tk8.6/demos/colors.tcl b/amd64/lib/tk8.6/demos/colors.tcl index 99dec92..fdfdc5b 100644 --- a/amd64/lib/tk8.6/demos/colors.tcl +++ b/amd64/lib/tk8.6/demos/colors.tcl @@ -32,7 +32,7 @@ listbox $w.frame.list -yscroll "$w.frame.scroll set" \ -width 20 -height 16 -setgrid 1 pack $w.frame.list $w.frame.scroll -side left -fill y -expand 1 -bind $w.frame.list { +bind $w.frame.list { tk_setPalette [selection get] } $w.frame.list insert 0 gray60 gray70 gray80 gray85 gray90 gray95 \ diff --git a/amd64/lib/tk8.6/demos/cscroll.tcl b/amd64/lib/tk8.6/demos/cscroll.tcl index 443b102..d210c7d 100644 --- a/amd64/lib/tk8.6/demos/cscroll.tcl +++ b/amd64/lib/tk8.6/demos/cscroll.tcl @@ -53,54 +53,84 @@ for {set i 0} {$i < 20} {incr i} { } } -$c bind all "scrollEnter $c" -$c bind all "scrollLeave $c" -$c bind all <1> "scrollButton $c" -bind $c <2> "$c scan mark %x %y" -bind $c "$c scan dragto %x %y" -if {[tk windowingsystem] eq "aqua"} { +$c bind all "scrollEnter $c" +$c bind all "scrollLeave $c" +$c bind all "scrollButton $c" +if {([tk windowingsystem] eq "aqua") && ![package vsatisfies [package provide Tk] 8.7-]} { + bind $c "$c scan mark %x %y" + bind $c "$c scan dragto %x %y" bind $c { - %W yview scroll [expr {-(%D)}] units + %W yview scroll [expr {-%D}] units } bind $c { - %W yview scroll [expr {-10 * (%D)}] units + %W yview scroll [expr {-10*%D}] units } bind $c { - %W xview scroll [expr {-(%D)}] units + %W xview scroll [expr {-%D}] units } bind $c { - %W xview scroll [expr {-10 * (%D)}] units + %W xview scroll [expr {-10*%D}] units } } else { + bind $c "$c scan mark %x %y" + bind $c "$c scan dragto %x %y" + # We must make sure that positive and negative movements are rounded + # equally to integers, avoiding the problem that + # (int)1/-30 = -1, + # but + # (int)-1/-30 = 0 + # The following code ensure equal +/- behaviour. bind $c { - %W yview scroll [expr {-(%D / 30)}] units + if {%D >= 0} { + %W yview scroll [expr {%D/-30}] units + } else { + %W yview scroll [expr {(%D-29)/-30}] units + } + } + bind $c { + if {%D >= 0} { + %W yview scroll [expr {%D/-3}] units + } else { + %W yview scroll [expr {(%D-2)/-3}] units + } } bind $c { - %W xview scroll [expr {-(%D / 30)}] units + if {%D >= 0} { + %W xview scroll [expr {%D/-30}] units + } else { + %W xview scroll [expr {(%D-29)/-30}] units + } + } + bind $c { + if {%D >= 0} { + %W xview scroll [expr {%D/-3}] units + } else { + %W xview scroll [expr {(%D-2)/-3}] units + } } } -if {[tk windowingsystem] eq "x11"} { +if {[tk windowingsystem] eq "x11" && ![package vsatisfies [package provide Tk] 8.7-]} { # Support for mousewheels on Linux/Unix commonly comes through mapping # the wheel to the extended buttons. If you have a mousewheel, find # Linux configuration info at: # http://linuxreviews.org/howtos/xfree/mouse/ - bind $c <4> { + bind $c { if {!$tk_strictMotif} { %W yview scroll -5 units } } - bind $c { + bind $c { if {!$tk_strictMotif} { %W xview scroll -5 units } } - bind $c <5> { + bind $c { if {!$tk_strictMotif} { %W yview scroll 5 units } } - bind $c { + bind $c { if {!$tk_strictMotif} { %W xview scroll 5 units } diff --git a/amd64/lib/tk8.6/demos/ctext.tcl b/amd64/lib/tk8.6/demos/ctext.tcl index a3b4e8a..d3fec33 100644 --- a/amd64/lib/tk8.6/demos/ctext.tcl +++ b/amd64/lib/tk8.6/demos/ctext.tcl @@ -41,16 +41,20 @@ $c create rectangle 245 195 255 205 -outline black -fill red # First, create the text item and give it bindings so it can be edited. $c addtag text withtag [$c create text 250 200 -text "This is just a string of text to demonstrate the text facilities of canvas widgets. Bindings have been defined to support editing (see above)." -width 440 -anchor n -font $textFont -justify left] -$c bind text <1> "textB1Press $c %x %y" +$c bind text "textB1Press $c %x %y" $c bind text "textB1Move $c %x %y" -$c bind text "$c select adjust current @%x,%y" +$c bind text "$c select adjust current @%x,%y" $c bind text "textB1Move $c %x %y" -$c bind text "textInsert $c %A" +$c bind text "textInsert $c %A" $c bind text "textInsert $c \\n" $c bind text "textBs $c" $c bind text "textBs $c" $c bind text "textDel $c" -$c bind text <2> "textPaste $c @%x,%y" +if {[tk windowingsystem] eq "aqua" && ![package vsatisfies [package provide Tk] 8.7-]} { + $c bind text "textPaste $c @%x,%y" +} else { + $c bind text "textPaste $c @%x,%y" +} # Next, create some items that allow the text's anchor position # to be edited. @@ -58,14 +62,14 @@ $c bind text <2> "textPaste $c @%x,%y" proc mkTextConfigBox {w x y option value color} { set item [$w create rect $x $y [expr {$x+30}] [expr {$y+30}] \ -outline black -fill $color -width 1] - $w bind $item <1> "$w itemconf text $option $value" + $w bind $item "$w itemconf text $option $value" $w addtag config withtag $item } proc mkTextConfigPie {w x y a option value color} { set item [$w create arc $x $y [expr {$x+90}] [expr {$y+90}] \ -start [expr {$a-15}] -extent 30 -outline black -fill $color \ -width 1] - $w bind $item <1> "$w itemconf text $option $value" + $w bind $item "$w itemconf text $option $value" $w addtag config withtag $item } @@ -84,7 +88,7 @@ mkTextConfigBox $c [expr {$x+60}] [expr {$y+60}] -anchor nw $color set item [$c create rect \ [expr {$x+40}] [expr {$y+40}] [expr {$x+50}] [expr {$y+50}] \ -outline black -fill red] -$c bind $item <1> "$c itemconf text -anchor center" +$c bind $item "$c itemconf text -anchor center" $c create text [expr {$x+45}] [expr {$y-5}] \ -text {Text Position} -anchor s -font {Times 20} -fill brown diff --git a/amd64/lib/tk8.6/demos/dialog1.tcl b/amd64/lib/tk8.6/demos/dialog1.tcl index 976e955..66d8c9a 100644 --- a/amd64/lib/tk8.6/demos/dialog1.tcl +++ b/amd64/lib/tk8.6/demos/dialog1.tcl @@ -2,16 +2,16 @@ # # This demonstration script creates a dialog box with a local grab. -interp create slave -load {} Tk slave -slave eval { - wm title . slave +interp create child +load {} Tk child +child eval { + wm title . child wm geometry . +700+30 pack [text .t -width 30 -height 10] } after idle {.dialog1.msg configure -wraplength 4i} -set i [tk_dialog .dialog1 "Dialog with local grab" {This is a modal dialog box. It uses Tk's "grab" command to create a "local grab" on the dialog box. The grab prevents any mouse or keyboard events from getting to any other windows in the application until you have answered the dialog by invoking one of the buttons below. However, you can still interact with other applications. For example, you should be able to edit text in the window named "slave" which was created by a slave interpreter.} \ +set i [tk_dialog .dialog1 "Dialog with local grab" {This is a modal dialog box. It uses Tk's "grab" command to create a "local grab" on the dialog box. The grab prevents any mouse or keyboard events from getting to any other windows in the application until you have answered the dialog by invoking one of the buttons below. However, you can still interact with other applications. For example, you should be able to edit text in the window named "child" which was created by a child interpreter.} \ info 0 OK Cancel {Show Code}] switch $i { @@ -20,6 +20,6 @@ switch $i { 2 {showCode .dialog1} } -if {[interp exists slave]} { - interp delete slave +if {[interp exists child]} { + interp delete child } diff --git a/amd64/lib/tk8.6/demos/entry1.tcl b/amd64/lib/tk8.6/demos/entry1.tcl index eef8964..7365fc7 100644 --- a/amd64/lib/tk8.6/demos/entry1.tcl +++ b/amd64/lib/tk8.6/demos/entry1.tcl @@ -16,7 +16,7 @@ wm title $w "Entry Demonstration (no scrollbars)" wm iconname $w "entry1" positionWindow $w -label $w.msg -font $font -wraplength 5i -justify left -text "Three different entries are displayed below. You can add characters by pointing, clicking and typing. The normal Motif editing characters are supported, along with many Emacs bindings. For example, Backspace and Control-h delete the character to the left of the insertion cursor and Delete and Control-d delete the chararacter to the right of the insertion cursor. For entries that are too large to fit in the window all at once, you can scan through the entries by dragging with mouse button2 pressed." +label $w.msg -font $font -wraplength 5i -justify left -text "Three different entries are displayed below. You can add characters by pointing, clicking and typing. The normal Motif editing characters are supported, along with many Emacs bindings. For example, Backspace and Control-h delete the character to the left of the insertion cursor and Delete and Control-d delete the chararacter to the right of the insertion cursor. For entries that are too large to fit in the window all at once, you can scan through the entries by dragging with mouse the middle mouse button pressed." pack $w.msg -side top ## See Code / Dismiss buttons diff --git a/amd64/lib/tk8.6/demos/entry2.tcl b/amd64/lib/tk8.6/demos/entry2.tcl index 9e3f4ef..6405d85 100644 --- a/amd64/lib/tk8.6/demos/entry2.tcl +++ b/amd64/lib/tk8.6/demos/entry2.tcl @@ -16,7 +16,7 @@ wm title $w "Entry Demonstration (with scrollbars)" wm iconname $w "entry2" positionWindow $w -label $w.msg -font $font -wraplength 5i -justify left -text "Three different entries are displayed below, with a scrollbar for each entry. You can add characters by pointing, clicking and typing. The normal Motif editing characters are supported, along with many Emacs bindings. For example, Backspace and Control-h delete the character to the left of the insertion cursor and Delete and Control-d delete the chararacter to the right of the insertion cursor. For entries that are too large to fit in the window all at once, you can scan through the entries with the scrollbars, or by dragging with mouse button2 pressed." +label $w.msg -font $font -wraplength 5i -justify left -text "Three different entries are displayed below, with a scrollbar for each entry. You can add characters by pointing, clicking and typing. The normal Motif editing characters are supported, along with many Emacs bindings. For example, Backspace and Control-h delete the character to the left of the insertion cursor and Delete and Control-d delete the chararacter to the right of the insertion cursor. For entries that are too large to fit in the window all at once, you can scan through the entries with the scrollbars, or by dragging with the middle mouse button pressed." pack $w.msg -side top ## See Code / Dismiss buttons diff --git a/amd64/lib/tk8.6/demos/entry3.tcl b/amd64/lib/tk8.6/demos/entry3.tcl index d4435c6..acde1b3 100644 --- a/amd64/lib/tk8.6/demos/entry3.tcl +++ b/amd64/lib/tk8.6/demos/entry3.tcl @@ -102,7 +102,7 @@ foreach {chars digit} {abc 2 def 3 ghi 4 jkl 5 mno 6 pqrs 7 tuv 8 wxyz 9} { proc validatePhoneChange {W vmode idx char} { global phoneNumberMap entry3content - if {$idx == -1} {return 1} + if {$idx < 0} {return 1} after idle [list $W configure -validate $vmode -invcmd bell] if { !($idx<3 || $idx==6 || $idx==7 || $idx==11 || $idx>15) && diff --git a/amd64/lib/tk8.6/demos/floor.tcl b/amd64/lib/tk8.6/demos/floor.tcl index d5ef3a0..eb2ea7f 100644 --- a/amd64/lib/tk8.6/demos/floor.tcl +++ b/amd64/lib/tk8.6/demos/floor.tcl @@ -1354,13 +1354,18 @@ floorDisplay $c 3 # Set up event bindings for canvas: -$c bind floor1 <1> "floorDisplay $c 1" -$c bind floor2 <1> "floorDisplay $c 2" -$c bind floor3 <1> "floorDisplay $c 3" +$c bind floor1 "floorDisplay $c 1" +$c bind floor2 "floorDisplay $c 2" +$c bind floor3 "floorDisplay $c 3" $c bind room "newRoom $c" $c bind room {set currentRoom ""} -bind $c <2> "$c scan mark %x %y" -bind $c "$c scan dragto %x %y" +if {[tk windowingsystem] eq "aqua" && ![package vsatisfies [package provide Tk] 8.7-]} { + bind $c "$c scan mark %x %y" + bind $c "$c scan dragto %x %y" +} else { + bind $c "$c scan mark %x %y" + bind $c "$c scan dragto %x %y" +} bind $c "unset currentRoom" set currentRoom "" trace variable currentRoom w "roomChanged $c" diff --git a/amd64/lib/tk8.6/demos/fontchoose.tcl b/amd64/lib/tk8.6/demos/fontchoose.tcl index 8b34377..446ed34 100644 --- a/amd64/lib/tk8.6/demos/fontchoose.tcl +++ b/amd64/lib/tk8.6/demos/fontchoose.tcl @@ -55,10 +55,6 @@ grid $f.msg $f.vs -sticky news grid $f.font - -sticky e grid columnconfigure $f 0 -weight 1 grid rowconfigure $f 0 -weight 1 -bind $w { - bind %W {} - grid propagate %W.f 0 -} ## See Code / Dismiss buttons set btns [addSeeDismiss $w.buttons $w] @@ -67,3 +63,5 @@ grid $f -sticky news grid $btns -sticky ew grid columnconfigure $w 0 -weight 1 grid rowconfigure $w 0 -weight 1 +update idletasks +grid propagate $f 0 diff --git a/amd64/lib/tk8.6/demos/goldberg.tcl b/amd64/lib/tk8.6/demos/goldberg.tcl index 284b5c2..1cc52c6 100644 --- a/amd64/lib/tk8.6/demos/goldberg.tcl +++ b/amd64/lib/tk8.6/demos/goldberg.tcl @@ -105,7 +105,7 @@ proc DoDisplay {w} { $w.c yview moveto .05 pack $w.c -in $w.screen -side top -fill both -expand 1 - bind $w.c <3> [list $w.pause invoke] + bind $w.c [list $w.pause invoke] bind $w.c { after cancel $animationCallbacks(goldberg) unset animationCallbacks(goldberg) @@ -162,7 +162,7 @@ proc DoCtrlFrame {w} { grid $w.speed -in $w.ctrl -row 99 -sticky ew -pady {0 5} pack $w.speed.scale -fill both -expand 1 grid $w.about -in $w.ctrl -row 100 -sticky ew - bind $w.reset <3> {set S(mode) -1} ;# Debugging + bind $w.reset {set S(mode) -1} ;# Debugging ## See Code / Dismiss buttons hack! set btns [addSeeDismiss $w.ctrl.buttons $w] @@ -342,7 +342,7 @@ proc Draw0 {w} { set xy {719 119 763 119} $w.c create line $xy -tag I0 -fill $color -width 5 -arrow last \ -arrowshape {18 18 5} - $w.c bind I0 <1> Start + $w.c bind I0 Start } proc Move0 {w {step {}}} { set step [GetStep 0 $step] @@ -372,7 +372,7 @@ proc Draw1 {w} { set xy [box 812 122 9] $w.c create oval $xy -tag I1 -fill $color2 -outline {} - $w.c bind I1 <1> Start + $w.c bind I1 Start } proc Move1 {w {step {}}} { set step [GetStep 1 $step] @@ -1620,7 +1620,7 @@ proc Move26 {w {step {}}} { $w.c delete I24 I26 $w.c create text 430 755 -anchor s -tag I26 \ -text "click to continue" -font {{Times Roman} 24 bold} - bind $w.c <1> [list Reset $w] + bind $w.c [list Reset $w] return 4 } @@ -1675,7 +1675,7 @@ proc RotateC {x y Ox Oy beta} { proc Reset {w} { global S DrawAll $w - bind $w.c <1> {} + bind $w.c {} set S(mode) $::MSTART set S(active) 0 } diff --git a/amd64/lib/tk8.6/demos/image2.tcl b/amd64/lib/tk8.6/demos/image2.tcl index 2d7ba03..7af52be 100644 --- a/amd64/lib/tk8.6/demos/image2.tcl +++ b/amd64/lib/tk8.6/demos/image2.tcl @@ -95,7 +95,7 @@ listbox $w.f.list -width 20 -height 10 -yscrollcommand "$w.f.scroll set" ttk::scrollbar $w.f.scroll -command "$w.f.list yview" pack $w.f.list $w.f.scroll -side left -fill y -expand 1 $w.f.list insert 0 earth.gif earthris.gif teapot.ppm -bind $w.f.list "loadImage $w %x %y" +bind $w.f.list "loadImage $w %x %y" catch {image delete image2a} image create photo image2a diff --git a/amd64/lib/tk8.6/demos/items.tcl b/amd64/lib/tk8.6/demos/items.tcl index be9214a..1297046 100644 --- a/amd64/lib/tk8.6/demos/items.tcl +++ b/amd64/lib/tk8.6/demos/items.tcl @@ -17,7 +17,7 @@ wm iconname $w "Items" positionWindow $w set c $w.frame.c -label $w.msg -font $font -wraplength 5i -justify left -text "This window contains a canvas widget with examples of the various kinds of items supported by canvases. The following operations are supported:\n Button-1 drag:\tmoves item under pointer.\n Button-2 drag:\trepositions view.\n Button-3 drag:\tstrokes out area.\n Ctrl+f:\t\tprints items under area." +label $w.msg -font $font -wraplength 5i -justify left -text "This window contains a canvas widget with examples of the various kinds of items supported by canvases. The following operations are supported:\n Left-Button drag:\tmoves item under pointer.\n Middle-Button drag:\trepositions view.\n Right-Button drag:\tstrokes out area.\n Ctrl+f:\t\tprints items under area." pack $w.msg -side top ## See Code / Dismiss buttons @@ -171,14 +171,21 @@ $c create text 28.5c 17.4c -text Scale: -anchor s # Set up event bindings for canvas: -$c bind item "itemEnter $c" -$c bind item "itemLeave $c" -bind $c <2> "$c scan mark %x %y" -bind $c "$c scan dragto %x %y" -bind $c <3> "itemMark $c %x %y" -bind $c "itemStroke $c %x %y" +$c bind item "itemEnter $c" +$c bind item "itemLeave $c" +if {[tk windowingsystem] eq "aqua" && ![package vsatisfies [package provide Tk] 8.7-]} { + bind $c "itemMark $c %x %y" + bind $c "itemStroke $c %x %y" + bind $c "$c scan mark %x %y" + bind $c "$c scan dragto %x %y" +} else { + bind $c "$c scan mark %x %y" + bind $c "$c scan dragto %x %y" + bind $c "itemMark $c %x %y" + bind $c "itemStroke $c %x %y" +} bind $c <> "itemsUnderArea $c" -bind $c <1> "itemStartDrag $c %x %y" +bind $c "itemStartDrag $c %x %y" bind $c "itemDrag $c %x %y" # Utility procedures for highlighting the item under the pointer: @@ -250,14 +257,14 @@ proc itemsUnderArea {c} { set area [$c find withtag area] set items "" foreach i [$c find enclosed $areaX1 $areaY1 $areaX2 $areaY2] { - if {[lsearch [$c gettags $i] item] != -1} { + if {[lsearch [$c gettags $i] item] >= 0} { lappend items $i } } puts stdout "Items enclosed by area: $items" set items "" foreach i [$c find overlapping $areaX1 $areaY1 $areaX2 $areaY2] { - if {[lsearch [$c gettags $i] item] != -1} { + if {[lsearch [$c gettags $i] item] >= 0} { lappend items $i } } diff --git a/amd64/lib/tk8.6/demos/ixset b/amd64/lib/tk8.6/demos/ixset index 13235de..85664d9 100644 --- a/amd64/lib/tk8.6/demos/ixset +++ b/amd64/lib/tk8.6/demos/ixset @@ -54,7 +54,7 @@ proc readsettings {} { global screencyc ; set screencyc 600 set xfd [open "|xset q" r] - while {[gets $xfd line] > -1} { + while {[gets $xfd line] >= 0} { switch -- [lindex $line 0] { auto { set rpt [lindex $line 1] @@ -197,7 +197,7 @@ proc createwindows {} { bind . {.buttons.ok flash; .buttons.ok invoke} bind . {.buttons.quit flash; .buttons.quit invoke} - bind . <1> { + bind . { if {![string match .buttons* %W]} { .buttons.apply configure -state normal .buttons.cancel configure -state normal diff --git a/amd64/lib/tk8.6/demos/knightstour.tcl b/amd64/lib/tk8.6/demos/knightstour.tcl index 3c29720..11b3b5c 100644 --- a/amd64/lib/tk8.6/demos/knightstour.tcl +++ b/amd64/lib/tk8.6/demos/knightstour.tcl @@ -21,7 +21,7 @@ # If you let it repeat then it will choose random start positions # for each new tour. -package require Tk 8.5 +package require Tk # Return a list of accessible squares from a given square proc ValidMoves {square} { @@ -29,7 +29,7 @@ proc ValidMoves {square} { foreach pair {{-1 -2} {-2 -1} {-2 1} {-1 2} {1 2} {2 1} {2 -1} {1 -2}} { set col [expr {($square % 8) + [lindex $pair 0]}] set row [expr {($square / 8) + [lindex $pair 1]}] - if {$row > -1 && $row < 8 && $col > -1 && $col < 8} { + if {$row >= 0 && $row < 8 && $col >= 0 && $col < 8} { lappend moves [expr {$row * 8 + $col}] } } @@ -41,7 +41,7 @@ proc CheckSquare {square} { variable visited set moves 0 foreach test [ValidMoves $square] { - if {[lsearch -exact -integer $visited $test] == -1} { + if {[lsearch -exact -integer $visited $test] < 0} { incr moves } } @@ -55,7 +55,7 @@ proc Next {square} { set minimum 9 set nextSquare -1 foreach testSquare [ValidMoves $square] { - if {[lsearch -exact -integer $visited $testSquare] == -1} { + if {[lsearch -exact -integer $visited $testSquare] < 0} { set count [CheckSquare $testSquare] if {$count < $minimum} { set minimum $count @@ -190,7 +190,7 @@ proc CreateGUI {} { ttk::button $dlg.tf.b1 -text Start -command [list Tour $dlg] ttk::button $dlg.tf.b2 -text Exit -command [list Exit $dlg] set square 0 - for {set row 7} {$row != -1} {incr row -1} { + for {set row 7} {$row >= 0} {incr row -1} { for {set col 0} {$col < 8} {incr col} { if {(($col & 1) ^ ($row & 1))} { set fill tan3 ; set dfill tan4 @@ -218,7 +218,7 @@ proc CreateGUI {} { -fill black -activefill "#600000" } $c moveto knight {*}[lrange [$c coords [expr {1 + int(rand() * 64)}]] 0 1] - $c bind knight [namespace code [list DragStart %W %x %y]] + $c bind knight [namespace code [list DragStart %W %x %y]] $c bind knight [namespace code [list DragMotion %W %x %y]] $c bind knight [namespace code [list DragEnd %W %x %y]] diff --git a/amd64/lib/tk8.6/demos/menu.tcl b/amd64/lib/tk8.6/demos/menu.tcl index a788a65..62991f3 100644 --- a/amd64/lib/tk8.6/demos/menu.tcl +++ b/amd64/lib/tk8.6/demos/menu.tcl @@ -63,7 +63,7 @@ if {[tk windowingsystem] eq "aqua"} { } foreach i {A B C D E F} { $m add command -label "Print letter \"$i\"" -underline 14 \ - -accelerator Meta+$i -command "puts $i" -accelerator $modifier+$i + -accelerator $modifier+$i -command "puts $i" bind $w <$modifier-[string tolower $i]> "puts $i" } @@ -144,9 +144,24 @@ $m entryconfigure "Does almost nothing" -bitmap questhead -compound left \ set m $w.menu.colors $w.menu add cascade -label "Colors" -menu $m -underline 1 menu $m -tearoff 1 -foreach i {red orange yellow green blue} { - $m add command -label $i -background $i -command [list \ - puts "You invoked \"$i\"" ] +if {[tk windowingsystem] eq "aqua"} { + # Aqua ignores the -background and -foreground options, but a compound + # button can be used for selecting colors. + foreach i {red orange yellow green blue} { + image create photo image_$i -height 16 -width 16 + image_$i put black -to 0 0 16 1 + image_$i put black -to 0 1 1 16 + image_$i put black -to 0 15 16 16 + image_$i put black -to 15 1 16 16 + image_$i put $i -to 1 1 15 15 + $m add command -label $i -image image_$i -compound left -command [list \ + puts "You invoked \"$i\"" ] + } +} else { + foreach i {red orange yellow green blue} { + $m add command -label $i -background $i -command [list \ + puts "You invoked \"$i\"" ] + } } $w configure -menu $w.menu diff --git a/amd64/lib/tk8.6/demos/pendulum.tcl b/amd64/lib/tk8.6/demos/pendulum.tcl index 6422c67..9833e8f 100644 --- a/amd64/lib/tk8.6/demos/pendulum.tcl +++ b/amd64/lib/tk8.6/demos/pendulum.tcl @@ -113,7 +113,7 @@ bind $w.c { after cancel $animationCallbacks(pendulum) unset animationCallbacks(pendulum) } -bind $w.c <1> { +bind $w.c { after cancel $animationCallbacks(pendulum) showPendulum %W at %x %y } diff --git a/amd64/lib/tk8.6/demos/plot.tcl b/amd64/lib/tk8.6/demos/plot.tcl index e7f0361..453b7a6 100644 --- a/amd64/lib/tk8.6/demos/plot.tcl +++ b/amd64/lib/tk8.6/demos/plot.tcl @@ -55,9 +55,9 @@ foreach point { $c addtag point withtag $item } -$c bind point "$c itemconfig current -fill red" -$c bind point "$c itemconfig current -fill SkyBlue2" -$c bind point <1> "plotDown $c %x %y" +$c bind point "$c itemconfig current -fill red" +$c bind point "$c itemconfig current -fill SkyBlue2" +$c bind point "plotDown $c %x %y" $c bind point "$c dtag selected" bind $c "plotMove $c %x %y" diff --git a/amd64/lib/tk8.6/demos/ruler.tcl b/amd64/lib/tk8.6/demos/ruler.tcl index f7bc37b..0b78370 100644 --- a/amd64/lib/tk8.6/demos/ruler.tcl +++ b/amd64/lib/tk8.6/demos/ruler.tcl @@ -77,10 +77,10 @@ $c addtag well withtag [$c create rect 13.2c 1c 13.8c 0.5c \ $c addtag well withtag [rulerMkTab $c [winfo pixels $c 13.5c] \ [winfo pixels $c .65c]] -$c bind well <1> "rulerNewTab $c %x %y" -$c bind tab <1> "rulerSelectTab $c %x %y" +$c bind well "rulerNewTab $c %x %y" +$c bind tab "rulerSelectTab $c %x %y" bind $c "rulerMoveTab $c %x %y" -bind $c "rulerReleaseTab $c" +bind $c "rulerReleaseTab $c" # rulerNewTab -- # Does all the work of creating a tab stop, including creating the diff --git a/amd64/lib/tk8.6/demos/square b/amd64/lib/tk8.6/demos/square index 6ce91b8..9f200ba 100644 --- a/amd64/lib/tk8.6/demos/square +++ b/amd64/lib/tk8.6/demos/square @@ -18,7 +18,7 @@ square .s pack .s -expand yes -fill both wm minsize . 1 1 -bind .s <1> {center %x %y} +bind .s {center %x %y} bind .s {center %x %y} bind .s a animate focus .s diff --git a/amd64/lib/tk8.6/demos/tclIndex b/amd64/lib/tk8.6/demos/tclIndex index 86a72e2..cdb2f2c 100644 --- a/amd64/lib/tk8.6/demos/tclIndex +++ b/amd64/lib/tk8.6/demos/tclIndex @@ -6,62 +6,62 @@ # element name is the name of a command and the value is # a script that loads the command. -set auto_index(arrowSetup) [list source [file join $dir arrow.tcl]] -set auto_index(arrowMove1) [list source [file join $dir arrow.tcl]] -set auto_index(arrowMove2) [list source [file join $dir arrow.tcl]] -set auto_index(arrowMove3) [list source [file join $dir arrow.tcl]] -set auto_index(textLoadFile) [list source [file join $dir search.tcl]] -set auto_index(textSearch) [list source [file join $dir search.tcl]] -set auto_index(textToggle) [list source [file join $dir search.tcl]] -set auto_index(itemEnter) [list source [file join $dir items.tcl]] -set auto_index(itemLeave) [list source [file join $dir items.tcl]] -set auto_index(itemMark) [list source [file join $dir items.tcl]] -set auto_index(itemStroke) [list source [file join $dir items.tcl]] -set auto_index(itemsUnderArea) [list source [file join $dir items.tcl]] -set auto_index(itemStartDrag) [list source [file join $dir items.tcl]] -set auto_index(itemDrag) [list source [file join $dir items.tcl]] -set auto_index(butPress) [list source [file join $dir items.tcl]] -set auto_index(loadDir) [list source [file join $dir image2.tcl]] -set auto_index(loadImage) [list source [file join $dir image2.tcl]] -set auto_index(rulerMkTab) [list source [file join $dir ruler.tcl]] -set auto_index(rulerNewTab) [list source [file join $dir ruler.tcl]] -set auto_index(rulerSelectTab) [list source [file join $dir ruler.tcl]] -set auto_index(rulerMoveTab) [list source [file join $dir ruler.tcl]] -set auto_index(rulerReleaseTab) [list source [file join $dir ruler.tcl]] -set auto_index(mkTextConfig) [list source [file join $dir ctext.tcl]] -set auto_index(textEnter) [list source [file join $dir ctext.tcl]] -set auto_index(textInsert) [list source [file join $dir ctext.tcl]] -set auto_index(textPaste) [list source [file join $dir ctext.tcl]] -set auto_index(textB1Press) [list source [file join $dir ctext.tcl]] -set auto_index(textB1Move) [list source [file join $dir ctext.tcl]] -set auto_index(textBs) [list source [file join $dir ctext.tcl]] -set auto_index(textDel) [list source [file join $dir ctext.tcl]] -set auto_index(bitmapRow) [list source [file join $dir bitmap.tcl]] -set auto_index(scrollEnter) [list source [file join $dir cscroll.tcl]] -set auto_index(scrollLeave) [list source [file join $dir cscroll.tcl]] -set auto_index(scrollButton) [list source [file join $dir cscroll.tcl]] -set auto_index(textWindOn) [list source [file join $dir twind.tcl]] -set auto_index(textWindOff) [list source [file join $dir twind.tcl]] -set auto_index(textWindPlot) [list source [file join $dir twind.tcl]] -set auto_index(embPlotDown) [list source [file join $dir twind.tcl]] -set auto_index(embPlotMove) [list source [file join $dir twind.tcl]] -set auto_index(textWindDel) [list source [file join $dir twind.tcl]] -set auto_index(embDefBg) [list source [file join $dir twind.tcl]] -set auto_index(floorDisplay) [list source [file join $dir floor.tcl]] -set auto_index(newRoom) [list source [file join $dir floor.tcl]] -set auto_index(roomChanged) [list source [file join $dir floor.tcl]] -set auto_index(bg1) [list source [file join $dir floor.tcl]] -set auto_index(bg2) [list source [file join $dir floor.tcl]] -set auto_index(bg3) [list source [file join $dir floor.tcl]] -set auto_index(fg1) [list source [file join $dir floor.tcl]] -set auto_index(fg2) [list source [file join $dir floor.tcl]] -set auto_index(fg3) [list source [file join $dir floor.tcl]] -set auto_index(setWidth) [list source [file join $dir hscale.tcl]] -set auto_index(plotDown) [list source [file join $dir plot.tcl]] -set auto_index(plotMove) [list source [file join $dir plot.tcl]] -set auto_index(puzzleSwitch) [list source [file join $dir puzzle.tcl]] -set auto_index(setHeight) [list source [file join $dir vscale.tcl]] -set auto_index(showMessageBox) [list source [file join $dir msgbox.tcl]] -set auto_index(setColor) [list source [file join $dir clrpick.tcl]] -set auto_index(setColor_helper) [list source [file join $dir clrpick.tcl]] -set auto_index(fileDialog) [list source [file join $dir filebox.tcl]] +set auto_index(arrowSetup) [list source -encoding utf-8 [file join $dir arrow.tcl]] +set auto_index(arrowMove1) [list source -encoding utf-8 [file join $dir arrow.tcl]] +set auto_index(arrowMove2) [list source -encoding utf-8 [file join $dir arrow.tcl]] +set auto_index(arrowMove3) [list source -encoding utf-8 [file join $dir arrow.tcl]] +set auto_index(textLoadFile) [list source -encoding utf-8 [file join $dir search.tcl]] +set auto_index(textSearch) [list source -encoding utf-8 [file join $dir search.tcl]] +set auto_index(textToggle) [list source -encoding utf-8 [file join $dir search.tcl]] +set auto_index(itemEnter) [list source -encoding utf-8 [file join $dir items.tcl]] +set auto_index(itemLeave) [list source -encoding utf-8 [file join $dir items.tcl]] +set auto_index(itemMark) [list source -encoding utf-8 [file join $dir items.tcl]] +set auto_index(itemStroke) [list source -encoding utf-8 [file join $dir items.tcl]] +set auto_index(itemsUnderArea) [list source -encoding utf-8 [file join $dir items.tcl]] +set auto_index(itemStartDrag) [list source -encoding utf-8 [file join $dir items.tcl]] +set auto_index(itemDrag) [list source -encoding utf-8 [file join $dir items.tcl]] +set auto_index(butPress) [list source -encoding utf-8 [file join $dir items.tcl]] +set auto_index(loadDir) [list source -encoding utf-8 [file join $dir image2.tcl]] +set auto_index(loadImage) [list source -encoding utf-8 [file join $dir image2.tcl]] +set auto_index(rulerMkTab) [list source -encoding utf-8 [file join $dir ruler.tcl]] +set auto_index(rulerNewTab) [list source -encoding utf-8 [file join $dir ruler.tcl]] +set auto_index(rulerSelectTab) [list source -encoding utf-8 [file join $dir ruler.tcl]] +set auto_index(rulerMoveTab) [list source -encoding utf-8 [file join $dir ruler.tcl]] +set auto_index(rulerReleaseTab) [list source -encoding utf-8 [file join $dir ruler.tcl]] +set auto_index(mkTextConfig) [list source -encoding utf-8 [file join $dir ctext.tcl]] +set auto_index(textEnter) [list source -encoding utf-8 [file join $dir ctext.tcl]] +set auto_index(textInsert) [list source -encoding utf-8 [file join $dir ctext.tcl]] +set auto_index(textPaste) [list source -encoding utf-8 [file join $dir ctext.tcl]] +set auto_index(textB1Press) [list source -encoding utf-8 [file join $dir ctext.tcl]] +set auto_index(textB1Move) [list source -encoding utf-8 [file join $dir ctext.tcl]] +set auto_index(textBs) [list source -encoding utf-8 [file join $dir ctext.tcl]] +set auto_index(textDel) [list source -encoding utf-8 [file join $dir ctext.tcl]] +set auto_index(bitmapRow) [list source -encoding utf-8 [file join $dir bitmap.tcl]] +set auto_index(scrollEnter) [list source -encoding utf-8 [file join $dir cscroll.tcl]] +set auto_index(scrollLeave) [list source -encoding utf-8 [file join $dir cscroll.tcl]] +set auto_index(scrollButton) [list source -encoding utf-8 [file join $dir cscroll.tcl]] +set auto_index(textWindOn) [list source -encoding utf-8 [file join $dir twind.tcl]] +set auto_index(textWindOff) [list source -encoding utf-8 [file join $dir twind.tcl]] +set auto_index(textWindPlot) [list source -encoding utf-8 [file join $dir twind.tcl]] +set auto_index(embPlotDown) [list source -encoding utf-8 [file join $dir twind.tcl]] +set auto_index(embPlotMove) [list source -encoding utf-8 [file join $dir twind.tcl]] +set auto_index(textWindDel) [list source -encoding utf-8 [file join $dir twind.tcl]] +set auto_index(embDefBg) [list source -encoding utf-8 [file join $dir twind.tcl]] +set auto_index(floorDisplay) [list source -encoding utf-8 [file join $dir floor.tcl]] +set auto_index(newRoom) [list source -encoding utf-8 [file join $dir floor.tcl]] +set auto_index(roomChanged) [list source -encoding utf-8 [file join $dir floor.tcl]] +set auto_index(bg1) [list source -encoding utf-8 [file join $dir floor.tcl]] +set auto_index(bg2) [list source -encoding utf-8 [file join $dir floor.tcl]] +set auto_index(bg3) [list source -encoding utf-8 [file join $dir floor.tcl]] +set auto_index(fg1) [list source -encoding utf-8 [file join $dir floor.tcl]] +set auto_index(fg2) [list source -encoding utf-8 [file join $dir floor.tcl]] +set auto_index(fg3) [list source -encoding utf-8 [file join $dir floor.tcl]] +set auto_index(setWidth) [list source -encoding utf-8 [file join $dir hscale.tcl]] +set auto_index(plotDown) [list source -encoding utf-8 [file join $dir plot.tcl]] +set auto_index(plotMove) [list source -encoding utf-8 [file join $dir plot.tcl]] +set auto_index(puzzleSwitch) [list source -encoding utf-8 [file join $dir puzzle.tcl]] +set auto_index(setHeight) [list source -encoding utf-8 [file join $dir vscale.tcl]] +set auto_index(showMessageBox) [list source -encoding utf-8 [file join $dir msgbox.tcl]] +set auto_index(setColor) [list source -encoding utf-8 [file join $dir clrpick.tcl]] +set auto_index(setColor_helper) [list source -encoding utf-8 [file join $dir clrpick.tcl]] +set auto_index(fileDialog) [list source -encoding utf-8 [file join $dir filebox.tcl]] diff --git a/amd64/lib/tk8.6/demos/tcolor b/amd64/lib/tk8.6/demos/tcolor index 6e50c61..0aa133b 100644 --- a/amd64/lib/tk8.6/demos/tcolor +++ b/amd64/lib/tk8.6/demos/tcolor @@ -7,7 +7,7 @@ exec wish "$0" ${1+"$@"} # create colors using either the RGB, HSB, or CYM color spaces # and apply the color to existing applications. -package require Tk 8.4 +package require Tk wm title . "Color Editor" # Global variables that control the program: @@ -90,7 +90,7 @@ foreach i { grid columnconfigure . 0 -weight 1 listbox .names.lb -width 20 -height 12 -yscrollcommand ".names.s set" \ -exportselection false - bind .names.lb { + bind .names.lb { tc_loadNamedColor [.names.lb get [.names.lb curselection]] } scrollbar .names.s -orient vertical -command ".names.lb yview" diff --git a/amd64/lib/tk8.6/demos/text.tcl b/amd64/lib/tk8.6/demos/text.tcl index d1801d1..2736b88 100644 --- a/amd64/lib/tk8.6/demos/text.tcl +++ b/amd64/lib/tk8.6/demos/text.tcl @@ -57,8 +57,9 @@ can do to a text widget: 1. Scrolling. Use the scrollbar to adjust the view in the text window. -2. Scanning. Press mouse button 2 in the text window and drag up or down. -This will drag the text at high speed to allow you to scan its contents. +2. Scanning. Press the middle mouse button in the text window and drag up +or down. This will drag the text at high speed to allow you to scan its +contents. 3. Insert text. Press mouse button 1 to set the insertion cursor, then type text. What you type will be added to the widget. @@ -77,7 +78,8 @@ text, in which case it will replace the selected text. 6. Copy the selection. To copy the selection into this window, select what you want to copy (either here or in another application), then -click button 2 to copy the selection to the point of the mouse cursor. +click the middle mouse button to copy the selection to the point of the +mouse cursor. 7. Edit. Text widgets support the standard Motif editing characters plus many Emacs editing characters. Backspace and Control-h erase the diff --git a/amd64/lib/tk8.6/demos/tree.tcl b/amd64/lib/tk8.6/demos/tree.tcl index 8decdf2..1cc70f8 100644 --- a/amd64/lib/tk8.6/demos/tree.tcl +++ b/amd64/lib/tk8.6/demos/tree.tcl @@ -39,6 +39,7 @@ proc populateTree {tree node} { set path [$tree set $node fullpath] $tree delete [$tree children $node] foreach f [lsort -dictionary [glob -nocomplain -dir $path *]] { + set f [file normalize $f] set type [file type $f] set id [$tree insert $node end -text [file tail $f] \ -values [list $f $type]] diff --git a/amd64/lib/tk8.6/demos/twind.tcl b/amd64/lib/tk8.6/demos/twind.tcl index 45d1da8..74f11eb 100644 --- a/amd64/lib/tk8.6/demos/twind.tcl +++ b/amd64/lib/tk8.6/demos/twind.tcl @@ -265,9 +265,9 @@ proc createPlot {t} { $c addtag point withtag $item } - $c bind point "$c itemconfig current -fill red" - $c bind point "$c itemconfig current -fill SkyBlue2" - $c bind point <1> "embPlotDown $c %x %y" + $c bind point "$c itemconfig current -fill red" + $c bind point "$c itemconfig current -fill SkyBlue2" + $c bind point "embPlotDown $c %x %y" $c bind point "$c dtag selected" bind $c "embPlotMove $c %x %y" return $c diff --git a/amd64/lib/tk8.6/demos/unicodeout.tcl b/amd64/lib/tk8.6/demos/unicodeout.tcl index 811d210..759dc00 100644 --- a/amd64/lib/tk8.6/demos/unicodeout.tcl +++ b/amd64/lib/tk8.6/demos/unicodeout.tcl @@ -109,10 +109,10 @@ if {[usePresentationFormsFor Arabic]} { } addSample $w "Trad. Chinese" "\u4E2D\u570B\u7684\u6F22\u5B57" addSample $w "Simpl. Chinese" "\u6C49\u8BED" -addSample $w French "Langue fran\u00E7aise" +addSample $w French "Langue fran\xE7aise" addSample $w Greek \ - "\u0395\u03BB\u03BB\u03B7\u03BD\u03B9\u03BA\u03AE " \ - "\u03B3\u03BB\u03CE\u03C3\u03C3\u03B1" + "\u0395\u03BB\u03BB\u03B7\u03BD\u03B9\u03BA\u03AE " \ + "\u03B3\u03BB\u03CE\u03C3\u03C3\u03B1" if {[usePresentationFormsFor Hebrew]} { # Visual order (pre-layouted) addSample $w Hebrew \ @@ -123,17 +123,21 @@ if {[usePresentationFormsFor Hebrew]} { "\u05DB\u05EA\u05D1 \u05E2\u05D1\u05E8\u05D9\u05EA" } addSample $w Hindi \ - "\u0939\u093f\u0928\u094d\u0926\u0940 \u092d\u093e\u0937\u093e" -addSample $w Icelandic "\u00CDslenska" + "\u0939\u093F\u0928\u094D\u0926\u0940 \u092D\u093E\u0937\u093E" +addSample $w Icelandic "\xCDslenska" addSample $w Japanese \ - "\u65E5\u672C\u8A9E\u306E\u3072\u3089\u304C\u306A, " \ - "\u6F22\u5B57\u3068\u30AB\u30BF\u30AB\u30CA" + "\u65E5\u672C\u8A9E\u306E\u3072\u3089\u304C\u306A, " \ + "\u6F22\u5B57\u3068\u30AB\u30BF\u30AB\u30CA" addSample $w Korean "\uB300\uD55C\uBBFC\uAD6D\uC758 \uD55C\uAE00" addSample $w Russian \ "\u0420\u0443\u0441\u0441\u043A\u0438\u0439 \u044F\u0437\u044B\u043A" -if {[tk windowingsystem] ne "x11"} { - addSample $w Emoji \ - "\uD83D\uDE00\uD83D\uDCA9\uD83D\uDC4D\uD83C\uDDF3\uD83C\uDDF1" +if {([tk windowingsystem] ne "x11") || (![catch {tk::pkgconfig get fontsystem} fs] && ($fs eq "xft"))} { + if {[package vsatisfies [package provide Tcl] 8.7-]} { + addSample $w Emoji "😀💩👍🇳🇱" + } else { + addSample $w Emoji \ + "\uD83D\uDE00\uD83D\uDCA9\uD83D\uDC4D\uD83C\uDDF3\uD83C\uDDF1" + } } ## We're done processing, so change things back to normal running... diff --git a/amd64/lib/tk8.6/demos/widget b/amd64/lib/tk8.6/demos/widget index 6d0b045..58da12f 100644 --- a/amd64/lib/tk8.6/demos/widget +++ b/amd64/lib/tk8.6/demos/widget @@ -83,12 +83,20 @@ image create photo ::img::print -format GIF -data { # Note that this is run through the message catalog! This is because this is # actually an image of a word. -image create photo ::img::new -format GIF -data [mc { - R0lGODlhHgAOALMPALMAANyIiOu7u8dEROaqqvru7sxVVeGZmbgREfXd3b0iItZ3 - d8IzM9FmZvDMzP///yH5BAEAAA8ALAAAAAAeAA4AAASa8MlJq7046827WVOCHEkw - nANhUgJlEBIABJIwL3K+4IcUALCHjfbItYZDSgJgkBiYPmBMAUAkkLPKs/BAyLgM - wAQwOAAY2ByCaw4QAFQSoDEePJ6DmU1xInYZTw5nOEFFdgVUelkVDTIMd3AKFGQ1 - MgI2AwEmQW8APZ0gdRONAks5nhIFVVxdAAkUAS2pAVwFl7ITB4UqHb0XEQA7 +image create photo ::img::new -format PNG -data [mc { + iVBORw0KGgoAAAANSUhEUgAAAB4AAAAOCAYAAAA45qw5AAACMElEQVR4AeVTAwxd + QRCc2tZHGtQ2w9q2bdsOa9u2bUW1bdt2Z372JZe6DapJLqtb3h7+T8yKi5j4CsYD + EUQXxETclT7kWOlH2VV+tFkdQHPSwksSISF+BauCqL0qgOcMWgGfgEkaMsHxqUBk + 3plE/sOnh/qDPAPJH/CKFBivGHWzFwBRnHhlqbu1Mh6CoFNnC/JshQ9p4YC2lrKt + DCAV+THiVejyhMjAbrNSrroiEfKR9g7ZfCgOog8QfnUQV62wAk68ndQ9ZbyoWO1H + Y6eDY1LCQL6a9ApOp9Hi1T0+gQq2JKMlky/oTKQliKWxEZvyG575kpW4pl1aZnQK + CLOVt45Lkp8uXp2SL8KO6uitNTZLdpK6s+I/eZbhpmsmWeOGOVQNKYLITzpKPAO3 + tY7LSNZ7ccSLxX9y3uuOxRkg3dKESMoCHvL+GRVCutXsB3guLgDCeXOv4iWWkvwG + BaS+PmlpK6SI9ApI2oC2UtrwZQEkhkH+NtolVlQXJl1I+QltuU3XEc721bIRFpa8 + IA5iqTo6vNNWmkNBLQbPeXwF2g17Q94nTQAfY3YzeY+WSu8MDzQ2kpELUhSGJUHE + 0zeR3rY1L+Xl5G/re+jbiK6KhThwwInsts1fbMUUcpZszKeVtggZEiGdZDe5AtHh + 7vL4CGiRvvKPS8FAvq9Nr4ZkFadR2y6kggu1z4vlyIbBp6BugQ8JLEg4bTkD9eMZ + QZ8hpJ3VvTtuvbWrY/ElvP/9R+Aj3603+iE3fkEAAAAASUVORK5CYII= }] #---------------------------------------------------------------- @@ -186,6 +194,10 @@ if {[winfo depth .] == 1} { -foreground blue -underline 1 .t tag configure visited -lmargin1 1c -lmargin2 1c \ -foreground #303080 -underline 1 + if {[tk windowingsystem] eq "aqua"} { + .t tag configure demo -foreground systemLinkColor + .t tag configure visited -foreground purple + } .t tag configure hot -foreground red -underline 1 } .t tag bind demo { @@ -504,7 +516,7 @@ proc invoke index { .t configure -cursor [::ttk::cursor busy] update set demo [string range [lindex $tags $i] 5 end] - uplevel 1 [list source [file join $tk_demoDirectory $demo.tcl]] + uplevel 1 [list source -encoding utf-8 [file join $tk_demoDirectory $demo.tcl]] update .t configure -cursor $cursor @@ -612,6 +624,7 @@ proc showCode w { wm title $top [mc "Demo code: %s" [file join $tk_demoDirectory $file]] wm iconname $top $file set id [open [file join $tk_demoDirectory $file]] + fconfigure $id -encoding utf-8 -eofchar \032 $top.f.text delete 1.0 end $top.f.text insert 1.0 [read $id] $top.f.text mark set insert 1.0 @@ -710,10 +723,10 @@ proc PrintTextWin32 {filename} { proc tkAboutDialog {} { tk_messageBox -icon info -type ok -title [mc "About Widget Demo"] \ -message [mc "Tk widget demonstration application"] -detail \ -"[mc "Copyright \u00a9 %s" {1996-1997 Sun Microsystems, Inc.}] -[mc "Copyright \u00a9 %s" {1997-2000 Ajuba Solutions, Inc.}] -[mc "Copyright \u00a9 %s" {2001-2009 Donal K. Fellows}] -[mc "Copyright \u00a9 %s" {2002-2007 Daniel A. Steffen}]" +"[mc "Copyright \xA9 %s" {1996-1997 Sun Microsystems, Inc.}] +[mc "Copyright \xA9 %s" {1997-2000 Ajuba Solutions, Inc.}] +[mc "Copyright \xA9 %s" {2001-2009 Donal K. Fellows}] +[mc "Copyright \xA9 %s" {2002-2007 Daniel A. Steffen}]" } # Local Variables: diff --git a/amd64/lib/tk8.6/entry.tcl b/amd64/lib/tk8.6/entry.tcl index 2aab934..6539af7 100644 --- a/amd64/lib/tk8.6/entry.tcl +++ b/amd64/lib/tk8.6/entry.tcl @@ -58,7 +58,7 @@ bind Entry <> { } bind Entry <> { # ignore if there is no selection - catch { %W delete sel.first sel.last } + catch {%W delete sel.first sel.last} } bind Entry <> { if {$tk_strictMotif || ![info exists tk::Priv(mouseMoved)] @@ -74,7 +74,7 @@ bind Entry <> { # Standard Motif bindings: -bind Entry <1> { +bind Entry { tk::EntryButton1 %W %x %W selection clear } @@ -82,25 +82,25 @@ bind Entry { set tk::Priv(x) %x tk::EntryMouseSelect %W %x } -bind Entry { +bind Entry { set tk::Priv(selectMode) word tk::EntryMouseSelect %W %x catch {%W icursor sel.last} } -bind Entry { +bind Entry { set tk::Priv(selectMode) line tk::EntryMouseSelect %W %x catch {%W icursor sel.last} } -bind Entry { +bind Entry { set tk::Priv(selectMode) char %W selection adjust @%x } -bind Entry { +bind Entry { set tk::Priv(selectMode) word tk::EntryMouseSelect %W %x } -bind Entry { +bind Entry { set tk::Priv(selectMode) line tk::EntryMouseSelect %W %x } @@ -114,22 +114,22 @@ bind Entry { bind Entry { tk::CancelRepeat } -bind Entry { +bind Entry { %W icursor @%x } bind Entry <> { - tk::EntrySetCursor %W [expr {[%W index insert] - 1}] + tk::EntrySetCursor %W [expr {[%W index insert]-1}] } bind Entry <> { - tk::EntrySetCursor %W [expr {[%W index insert] + 1}] + tk::EntrySetCursor %W [expr {[%W index insert]+1}] } bind Entry <> { - tk::EntryKeySelect %W [expr {[%W index insert] - 1}] + tk::EntryKeySelect %W [expr {[%W index insert]-1}] tk::EntrySeeInsert %W } bind Entry <> { - tk::EntryKeySelect %W [expr {[%W index insert] + 1}] + tk::EntryKeySelect %W [expr {[%W index insert]+1}] tk::EntrySeeInsert %W } bind Entry <> { @@ -190,19 +190,19 @@ bind Entry <> { bind Entry <> { %W selection clear } -bind Entry { +bind Entry { tk::CancelRepeat tk::EntryInsert %W %A } # Ignore all Alt, Meta, and Control keypresses unless explicitly bound. # Otherwise, if a widget binding for one of these is defined, the -# class binding will also fire and insert the character, +# class binding will also fire and insert the character, # which is wrong. Ditto for Escape, Return, and Tab. -bind Entry {# nothing} -bind Entry {# nothing} -bind Entry {# nothing} +bind Entry {# nothing} +bind Entry {# nothing} +bind Entry {# nothing} bind Entry {# nothing} bind Entry {# nothing} bind Entry {# nothing} @@ -210,7 +210,7 @@ bind Entry {# nothing} bind Entry {# nothing} bind Entry {# nothing} if {[tk windowingsystem] eq "aqua"} { - bind Entry {# nothing} + bind Entry {# nothing} } # Tk-on-Cocoa generates characters for these two keys. [Bug 2971663] bind Entry <> {# nothing} @@ -278,7 +278,7 @@ bind Entry <> { dict set ::tk::Priv(IMETextMark) "%W" [%W index insert] } bind Entry <> { - if { [catch {dict get $::tk::Priv(IMETextMark) "%W"} mark] } { + if {[catch {dict get $::tk::Priv(IMETextMark) "%W"} mark]} { bell } else { %W selection range $mark insert @@ -293,14 +293,27 @@ bind Entry <> { # A few additional bindings of my own. -bind Entry <2> { - if {!$tk_strictMotif} { - ::tk::EntryScanMark %W %x +if {[tk windowingsystem] ne "aqua"} { + bind Entry { + if {!$tk_strictMotif} { + ::tk::EntryScanMark %W %x + } } -} -bind Entry { - if {!$tk_strictMotif} { - ::tk::EntryScanDrag %W %x + bind Entry { + if {!$tk_strictMotif} { + ::tk::EntryScanDrag %W %x + } + } +} else { + bind Entry { + if {!$tk_strictMotif} { + ::tk::EntryScanMark %W %x + } + } + bind Entry { + if {!$tk_strictMotif} { + ::tk::EntryScanDrag %W %x + } } } @@ -378,10 +391,10 @@ proc ::tk::EntryMouseSelect {w x} { word { if {$cur < $anchor} { set before [tcl_wordBreakBefore [$w get] $cur] - set after [tcl_wordBreakAfter [$w get] [expr {$anchor-1}]] + set after [tcl_wordBreakAfter [$w get] $anchor-1] } elseif {$cur > $anchor} { set before [tcl_wordBreakBefore [$w get] $anchor] - set after [tcl_wordBreakAfter [$w get] [expr {$cur - 1}]] + set after [tcl_wordBreakAfter [$w get] $cur-1] } else { if {[$w index @$Priv(pressX)] < $anchor} { incr anchor -1 @@ -505,9 +518,9 @@ proc ::tk::EntryBackspace w { if {[$w selection present]} { $w delete sel.first sel.last } else { - set x [expr {[$w index insert] - 1}] - if {$x >= 0} { - $w delete $x + set x [$w index insert] + if {$x > 0} { + $w delete [expr {$x-1}] } if {[$w index @0] >= [$w index insert]} { set range [$w xview] @@ -562,12 +575,12 @@ proc ::tk::EntryTranspose w { if {$i < [$w index end]} { incr i } - set first [expr {$i-2}] - if {$first < 0} { + if {$i < 2} { return } + set first [expr {$i-2}] set data [$w get] - set new [string index $data [expr {$i-1}]][string index $data $first] + set new [string index $data $i-1][string index $data $first] $w delete $first $i $w insert insert $new EntrySeeInsert $w @@ -647,7 +660,7 @@ proc ::tk::EntryScanMark {w x} { proc ::tk::EntryScanDrag {w x} { # Make sure these exist, as some weird situations can trigger the # motion binding without the initial press. [Bug #220269] - if {![info exists ::tk::Priv(x)]} { set ::tk::Priv(x) $x } + if {![info exists ::tk::Priv(x)]} {set ::tk::Priv(x) $x} # allow for a delta if {abs($x-$::tk::Priv(x)) > 2} { set ::tk::Priv(mouseMoved) 1 @@ -664,19 +677,10 @@ proc ::tk::EntryScanDrag {w x} { proc ::tk::EntryGetSelection {w} { set entryString [string range [$w get] [$w index sel.first] \ - [expr {[$w index sel.last] - 1}]] + [$w index sel.last]-1] if {[$w cget -show] ne ""} { return [string repeat [string index [$w cget -show] 0] \ [string length $entryString]] } return $entryString } - - - - - - - - - diff --git a/amd64/lib/tk8.6/fontchooser.tcl b/amd64/lib/tk8.6/fontchooser.tcl index 5395acb..9d49c57 100644 --- a/amd64/lib/tk8.6/fontchooser.tcl +++ b/amd64/lib/tk8.6/fontchooser.tcl @@ -14,11 +14,11 @@ namespace eval ::tk::fontchooser { set S(W) .__tk__fontchooser set S(fonts) [lsort -dictionary [font families]] set S(styles) [list \ - [::msgcat::mc "Regular"] \ - [::msgcat::mc "Italic"] \ - [::msgcat::mc "Bold"] \ - [::msgcat::mc "Bold Italic"] \ - ] + [::msgcat::mc "Regular"] \ + [::msgcat::mc "Italic"] \ + [::msgcat::mc "Bold"] \ + [::msgcat::mc "Bold Italic"] \ + ] set S(sizes) {8 9 10 11 12 14 16 18 20 22 24 26 28 36 48 72} set S(strike) 0 @@ -36,9 +36,9 @@ proc ::tk::fontchooser::Setup {} { # Canonical versions of font families, styles, etc. for easier searching set S(fonts,lcase) {} - foreach font $S(fonts) { lappend S(fonts,lcase) [string tolower $font]} + foreach font $S(fonts) {lappend S(fonts,lcase) [string tolower $font]} set S(styles,lcase) {} - foreach style $S(styles) { lappend S(styles,lcase) [string tolower $style]} + foreach style $S(styles) {lappend S(styles,lcase) [string tolower $style]} set S(sizes,lcase) $S(sizes) ::ttk::style layout FontchooserFrame { @@ -111,7 +111,7 @@ proc ::tk::fontchooser::Configure {args} { set cache [dict create -parent $S(-parent) -title $S(-title) \ -font $S(-font) -command $S(-command)] - set r [tclParseConfigSpec [namespace which -variable S] $specs "" $args] + set r [tclParseConfigSpec [namespace which -variable S] $specs DONTSETDEFAULTS $args] if {![winfo exists $S(-parent)]} { set code [list TK LOOKUP WINDOW $S(-parent)] set err "bad window path name \"$S(-parent)\"" @@ -121,7 +121,7 @@ proc ::tk::fontchooser::Configure {args} { if {[string trim $S(-title)] eq ""} { set S(-title) [::msgcat::mc "Font"] } - if {[winfo exists $S(W)] && [lsearch $args -font] != -1} { + if {[winfo exists $S(W)] && ("-font" in $args)} { Init $S(-font) event generate $S(-parent) <> } @@ -145,10 +145,13 @@ proc ::tk::fontchooser::Create {} { wm title $S(W) $S(-title) wm transient $S(W) [winfo toplevel $S(-parent)] + set scaling [tk scaling] + set sizeWidth [expr {int([string length [::msgcat::mc "&Size:"]] * $scaling)}] + set outer [::ttk::frame $S(W).outer -padding {10 10}] ::tk::AmpWidget ::ttk::label $S(W).font -text [::msgcat::mc "&Font:"] ::tk::AmpWidget ::ttk::label $S(W).style -text [::msgcat::mc "Font st&yle:"] - ::tk::AmpWidget ::ttk::label $S(W).size -text [::msgcat::mc "&Size:"] + ::tk::AmpWidget ::ttk::label $S(W).size -text [::msgcat::mc "&Size:"] -width $sizeWidth ttk::entry $S(W).efont -width 18 \ -textvariable [namespace which -variable S](font) ttk::entry $S(W).estyle -width 10 \ @@ -199,7 +202,7 @@ proc ::tk::fontchooser::Create {} { set minsize(sizes) \ [expr {[font measure TkDefaultFont "-99"] + $scroll_width}] set min [expr {$minsize(gap) * 4}] - foreach {what width} [array get minsize] { incr min $width } + foreach {what width} [array get minsize] {incr min $width} wm minsize $S(W) $min 260 bind $S(W) [namespace code [list Done 1]] @@ -277,7 +280,7 @@ proc ::tk::fontchooser::Create {} { # Arguments: # ok true if user pressed OK # -proc ::tk::::fontchooser::Done {ok} { +proc ::tk::fontchooser::Done {ok} { variable S if {! $ok} { @@ -327,13 +330,13 @@ proc ::tk::fontchooser::Init {{defaultFont ""}} { set S(size) $F(-size) set S(strike) $F(-overstrike) set S(under) $F(-underline) - set S(style) "Regular" + set S(style) [::msgcat::mc "Regular"] if {$F(-weight) eq "bold" && $F(-slant) eq "italic"} { - set S(style) "Bold Italic" + set S(style) [::msgcat::mc "Bold Italic"] } elseif {$F(-weight) eq "bold"} { - set S(style) "Bold" + set S(style) [::msgcat::mc "Bold"] } elseif {$F(-slant) eq "italic"} { - set S(style) "Italic" + set S(style) [::msgcat::mc "Italic"] } set S(first) 0 @@ -381,7 +384,7 @@ proc ::tk::fontchooser::Tracer {var1 var2 op} { $S(W).l${var}s selection clear 0 end set n [lsearch -exact $S(${var}s,lcase) $value] $S(W).l${var}s selection set $n - if {$n != -1} { + if {$n >= 0} { set S($var) [lindex $S(${var}s) $n] $S(W).e$var icursor end $S(W).e$var selection clear @@ -396,7 +399,7 @@ proc ::tk::fontchooser::Tracer {var1 var2 op} { } $S(W).l${var}s see $n } - if {!$bad} { Update } + if {!$bad} {Update} $S(W).ok configure -state $nstate } @@ -408,11 +411,11 @@ proc ::tk::fontchooser::Update {} { variable S set S(result) [list $S(font) $S(size)] - if {$S(style) eq "Bold"} { lappend S(result) bold } - if {$S(style) eq "Italic"} { lappend S(result) italic } - if {$S(style) eq "Bold Italic"} { lappend S(result) bold italic} - if {$S(strike)} { lappend S(result) overstrike} - if {$S(under)} { lappend S(result) underline} + if {$S(style) eq [::msgcat::mc "Bold"]} {lappend S(result) bold} + if {$S(style) eq [::msgcat::mc "Italic"]} {lappend S(result) italic} + if {$S(style) eq [::msgcat::mc "Bold Italic"]} {lappend S(result) bold italic} + if {$S(strike)} {lappend S(result) overstrike} + if {$S(under)} {lappend S(result) underline} $S(sample) configure -font $S(result) } diff --git a/amd64/lib/tk8.6/iconlist.tcl b/amd64/lib/tk8.6/iconlist.tcl index eed7476..34b19d0 100644 --- a/amd64/lib/tk8.6/iconlist.tcl +++ b/amd64/lib/tk8.6/iconlist.tcl @@ -26,7 +26,7 @@ # selection includes # selection set ?? -package require Tk 8.6 +package require Tk ::tk::Megawidget create ::tk::IconList ::tk::FocusableWidget { variable w canvas sbar accel accelCB fill font index \ @@ -697,7 +697,7 @@ package require Tk 8.6 } } - if {$theIndex > -1} { + if {$theIndex >= 0} { $w selection clear 0 end $w selection set $theIndex $w selection anchor $theIndex diff --git a/amd64/lib/tk8.6/listbox.tcl b/amd64/lib/tk8.6/listbox.tcl index a094883..9e628a8 100644 --- a/amd64/lib/tk8.6/listbox.tcl +++ b/amd64/lib/tk8.6/listbox.tcl @@ -311,13 +311,13 @@ proc ::tk::ListboxMotion {w el} { set Priv(listboxSelection) [$w curselection] } while {($i < $el) && ($i < $anchor)} { - if {[lsearch $Priv(listboxSelection) $i] >= 0} { + if {$i in $Priv(listboxSelection)} { $w selection set $i } incr i } while {($i > $el) && ($i > $anchor)} { - if {[lsearch $Priv(listboxSelection) $i] >= 0} { + if {$i in $Priv(listboxSelection)} { $w selection set $i } incr i -1 @@ -517,7 +517,7 @@ proc ::tk::ListboxCancel w { } $w selection clear $first $last while {$first <= $last} { - if {[lsearch $Priv(listboxSelection) $first] >= 0} { + if {$first in $Priv(listboxSelection)} { $w selection set $first } incr first diff --git a/amd64/lib/tk8.6/megawidget.tcl b/amd64/lib/tk8.6/megawidget.tcl index aeb1263..ec9f469 100644 --- a/amd64/lib/tk8.6/megawidget.tcl +++ b/amd64/lib/tk8.6/megawidget.tcl @@ -10,7 +10,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -package require Tk 8.6 +package require Tk ::oo::class create ::tk::Megawidget { superclass ::oo::class diff --git a/amd64/lib/tk8.6/menu.tcl b/amd64/lib/tk8.6/menu.tcl index 9d6370a..c4991f8 100644 --- a/amd64/lib/tk8.6/menu.tcl +++ b/amd64/lib/tk8.6/menu.tcl @@ -138,7 +138,7 @@ bind Menu { bind Menu { tk::MenuMotion %W %x %y %s } -bind Menu { +bind Menu