texlive[69897] Master/tlpkg/tltcl: Tcl/Tk 8.6.13
commits+siepo at tug.org
commits+siepo at tug.org
Thu Feb 15 22:05:13 CET 2024
Revision: 69897
https://tug.org/svn/texlive?view=revision&revision=69897
Author: siepo
Date: 2024-02-15 22:05:12 +0100 (Thu, 15 Feb 2024)
Log Message:
-----------
Tcl/Tk 8.6.13
Modified Paths:
--------------
trunk/Master/tlpkg/tltcl/bin/tcl86.dll
trunk/Master/tlpkg/tltcl/bin/tclsh.exe
trunk/Master/tlpkg/tltcl/bin/tclsh86.exe
trunk/Master/tlpkg/tltcl/bin/tk86.dll
trunk/Master/tlpkg/tltcl/bin/wish.exe
trunk/Master/tlpkg/tltcl/bin/wish86.exe
trunk/Master/tlpkg/tltcl/bin/zlib1.dll
trunk/Master/tlpkg/tltcl/lib/dde1.4/tcldde14.dll
trunk/Master/tlpkg/tltcl/lib/reg1.3/tclreg13.dll
trunk/Master/tlpkg/tltcl/lib/tcl8.6/init.tcl
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Bahia_Banderas
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Chihuahua
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Hermosillo
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Matamoros
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Mazatlan
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Merida
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Mexico_City
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Monterrey
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Nipigon
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Ojinaga
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Punta_Arenas
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Rainy_River
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Santiago
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Thunder_Bay
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Tijuana
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Antarctica/Vostok
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Arctic/Longyearbyen
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Amman
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Brunei
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Damascus
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Gaza
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Hebron
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Ho_Chi_Minh
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Kuala_Lumpur
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Tehran
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Atlantic/Jan_Mayen
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Atlantic/Reykjavik
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Amsterdam
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Copenhagen
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Dublin
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Kiev
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Luxembourg
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Monaco
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Oslo
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Simferopol
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Stockholm
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Uzhgorod
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Zaporozhye
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Iceland
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Indian/Christmas
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Indian/Cocos
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Indian/Kerguelen
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Indian/Mahe
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Indian/Reunion
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Chuuk
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Easter
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Fiji
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Funafuti
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Majuro
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Pohnpei
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Ponape
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Truk
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Wake
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Wallis
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Yap
trunk/Master/tlpkg/tltcl/lib/tclConfig.sh
trunk/Master/tlpkg/tltcl/lib/tk8.6/clrpick.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/console.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/cscroll.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/entry2.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/floor.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/goldberg.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/images/earth.gif
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/items.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/menu.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/menubu.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/puzzle.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/entry.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/fontchooser.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/iconlist.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/menu.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/msgs/eo.msg
trunk/Master/tlpkg/tltcl/lib/tk8.6/msgs/ru.msg
trunk/Master/tlpkg/tltcl/lib/tk8.6/pkgIndex.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/scale.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/spinbox.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/text.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/tk.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/tkfbox.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/cursors.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/entry.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/menubutton.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/panedwindow.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/utils.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/xmfbox.tcl
trunk/Master/tlpkg/tltcl/lib/tkConfig.sh
Added Paths:
-----------
trunk/Master/tlpkg/tltcl/lib/dde1.4/libtcldde14.dll.a
trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/
trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/itcl.tcl
trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/itcl423.dll
trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/itclConfig.sh
trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/itclHullCmds.tcl
trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/itclWidget.tcl
trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/libitclstub423.a
trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/pkgIndex.tcl
trunk/Master/tlpkg/tltcl/lib/libtcl86.dll.a
trunk/Master/tlpkg/tltcl/lib/libtclstub86.a
trunk/Master/tlpkg/tltcl/lib/libtk86.dll.a
trunk/Master/tlpkg/tltcl/lib/libtkstub86.a
trunk/Master/tlpkg/tltcl/lib/reg1.3/libtclreg13.dll.a
trunk/Master/tlpkg/tltcl/lib/sqlite3.40.0/
trunk/Master/tlpkg/tltcl/lib/sqlite3.40.0/pkgIndex.tcl
trunk/Master/tlpkg/tltcl/lib/sqlite3.40.0/sqlite3400.dll
trunk/Master/tlpkg/tltcl/lib/tcl8/8.4/platform-1.0.19.tm
trunk/Master/tlpkg/tltcl/lib/tcl8/8.5/tcltest-2.5.5.tm
trunk/Master/tlpkg/tltcl/lib/tcl8/8.6/http-2.9.8.tm
trunk/Master/tlpkg/tltcl/lib/tcl8/8.6/tdbc/sqlite3-1.1.5.tm
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Kyiv
trunk/Master/tlpkg/tltcl/lib/tdbc1.1.5/
trunk/Master/tlpkg/tltcl/lib/tdbc1.1.5/libtdbcstub115.a
trunk/Master/tlpkg/tltcl/lib/tdbc1.1.5/pkgIndex.tcl
trunk/Master/tlpkg/tltcl/lib/tdbc1.1.5/tdbc.tcl
trunk/Master/tlpkg/tltcl/lib/tdbc1.1.5/tdbc115.dll
trunk/Master/tlpkg/tltcl/lib/tdbc1.1.5/tdbcConfig.sh
trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.5/
trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.5/pkgIndex.tcl
trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.5/tdbcmysql.tcl
trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.5/tdbcmysql115.dll
trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.5/
trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.5/pkgIndex.tcl
trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.5/tdbcodbc.tcl
trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.5/tdbcodbc115.dll
trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.5/
trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.5/pkgIndex.tcl
trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.5/tdbcpostgres.tcl
trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.5/tdbcpostgres115.dll
trunk/Master/tlpkg/tltcl/lib/thread2.8.8/
trunk/Master/tlpkg/tltcl/lib/thread2.8.8/pkgIndex.tcl
trunk/Master/tlpkg/tltcl/lib/thread2.8.8/thread288.dll
trunk/Master/tlpkg/tltcl/lib/thread2.8.8/ttrace.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/msgs/fi.msg
trunk/Master/tlpkg/tltcl/lib/tk8.6/msgs/zh_cn.msg
Removed Paths:
-------------
trunk/Master/tlpkg/tltcl/lib/itcl4.2.2/
trunk/Master/tlpkg/tltcl/lib/sqlite3.36.0/
trunk/Master/tlpkg/tltcl/lib/tcl8/8.4/platform-1.0.18.tm
trunk/Master/tlpkg/tltcl/lib/tcl8/8.5/tcltest-2.5.3.tm
trunk/Master/tlpkg/tltcl/lib/tcl8/8.6/http-2.9.5.tm
trunk/Master/tlpkg/tltcl/lib/tcl8/8.6/tdbc/sqlite3-1.1.3.tm
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Canada/East-Saskatchewan
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/US/Pacific-New
trunk/Master/tlpkg/tltcl/lib/tdbc1.1.3/
trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.3/
trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.3/
trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.3/
trunk/Master/tlpkg/tltcl/lib/thread2.8.7/
Modified: trunk/Master/tlpkg/tltcl/bin/tcl86.dll
===================================================================
(Binary files differ)
Modified: trunk/Master/tlpkg/tltcl/bin/tclsh.exe
===================================================================
(Binary files differ)
Modified: trunk/Master/tlpkg/tltcl/bin/tclsh86.exe
===================================================================
(Binary files differ)
Modified: trunk/Master/tlpkg/tltcl/bin/tk86.dll
===================================================================
(Binary files differ)
Modified: trunk/Master/tlpkg/tltcl/bin/wish.exe
===================================================================
(Binary files differ)
Modified: trunk/Master/tlpkg/tltcl/bin/wish86.exe
===================================================================
(Binary files differ)
Modified: trunk/Master/tlpkg/tltcl/bin/zlib1.dll
===================================================================
(Binary files differ)
Added: trunk/Master/tlpkg/tltcl/lib/dde1.4/libtcldde14.dll.a
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/dde1.4/libtcldde14.dll.a
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/dde1.4/libtcldde14.dll.a 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/dde1.4/libtcldde14.dll.a 2024-02-15 21:05:12 UTC (rev 69897)
Property changes on: trunk/Master/tlpkg/tltcl/lib/dde1.4/libtcldde14.dll.a
___________________________________________________________________
Added: svn:mime-type
## -0,0 +1 ##
+application/x-archive
\ No newline at end of property
Modified: trunk/Master/tlpkg/tltcl/lib/dde1.4/tcldde14.dll
===================================================================
(Binary files differ)
Added: trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/itcl.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/itcl.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/itcl.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -0,0 +1,151 @@
+#
+# itcl.tcl
+# ----------------------------------------------------------------------
+# Invoked automatically upon startup to customize the interpreter
+# for [incr Tcl].
+# ----------------------------------------------------------------------
+# AUTHOR: Michael J. McLennan
+# Bell Labs Innovations for Lucent Technologies
+# mmclennan at lucent.com
+# http://www.tcltk.com/itcl
+# ----------------------------------------------------------------------
+# Copyright (c) 1993-1998 Lucent Technologies, Inc.
+# ======================================================================
+# See the file "license.terms" for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+proc ::itcl::delete_helper { name args } {
+ ::itcl::delete object $name
+}
+
+# ----------------------------------------------------------------------
+# USAGE: local <className> <objName> ?<arg> <arg>...?
+#
+# Creates a new object called <objName> in class <className>, passing
+# the remaining <arg>'s to the constructor. Unlike the usual
+# [incr Tcl] objects, however, an object created by this procedure
+# will be automatically deleted when the local call frame is destroyed.
+# This command is useful for creating objects that should only remain
+# alive until a procedure exits.
+# ----------------------------------------------------------------------
+proc ::itcl::local {class name args} {
+ set ptr [uplevel [list $class $name] $args]
+ uplevel [list set itcl-local-$ptr $ptr]
+ set cmd [uplevel namespace which -command $ptr]
+ uplevel [list trace variable itcl-local-$ptr u \
+ "::itcl::delete_helper $cmd"]
+ return $ptr
+}
+
+# ----------------------------------------------------------------------
+# auto_mkindex
+# ----------------------------------------------------------------------
+# Define Itcl commands that will be recognized by the auto_mkindex
+# parser in Tcl...
+#
+
+#
+# USAGE: itcl::class name body
+# Adds an entry for the given class declaration.
+#
+foreach __cmd {itcl::class class itcl::type type ictl::widget widget itcl::widgetadaptor widgetadaptor itcl::extendedclass extendedclass} {
+ auto_mkindex_parser::command $__cmd {name body} {
+ variable index
+ variable scriptFile
+ append index "set [list auto_index([fullname $name])]"
+ append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
+
+ variable parser
+ variable contextStack
+ set contextStack [linsert $contextStack 0 $name]
+ $parser eval $body
+ set contextStack [lrange $contextStack 1 end]
+ }
+}
+
+#
+# USAGE: itcl::body name arglist body
+# Adds an entry for the given method/proc body.
+#
+foreach __cmd {itcl::body body} {
+ auto_mkindex_parser::command $__cmd {name arglist body} {
+ variable index
+ variable scriptFile
+ append index "set [list auto_index([fullname $name])]"
+ append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
+ }
+}
+
+#
+# USAGE: itcl::configbody name arglist body
+# Adds an entry for the given method/proc body.
+#
+foreach __cmd {itcl::configbody configbody} {
+ auto_mkindex_parser::command $__cmd {name body} {
+ variable index
+ variable scriptFile
+ append index "set [list auto_index([fullname $name])]"
+ append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
+ }
+}
+
+#
+# USAGE: ensemble name ?body?
+# Adds an entry to the auto index list for the given ensemble name.
+#
+foreach __cmd {itcl::ensemble ensemble} {
+ auto_mkindex_parser::command $__cmd {name {body ""}} {
+ variable index
+ variable scriptFile
+ append index "set [list auto_index([fullname $name])]"
+ append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
+ }
+}
+
+#
+# USAGE: public arg ?arg arg...?
+# protected arg ?arg arg...?
+# private arg ?arg arg...?
+#
+# Evaluates the arguments as commands, so we can recognize proc
+# declarations within classes.
+#
+foreach __cmd {public protected private} {
+ auto_mkindex_parser::command $__cmd {args} {
+ variable parser
+ $parser eval $args
+ }
+}
+
+# SF bug #246 unset variable __cmd to avoid problems in user programs!!
+unset __cmd
+
+# ----------------------------------------------------------------------
+# auto_import
+# ----------------------------------------------------------------------
+# This procedure overrides the usual "auto_import" function in the
+# Tcl library. It is invoked during "namespace import" to make see
+# if the imported commands reside in an autoloaded library. If so,
+# stubs are created to represent the commands. Executing a stub
+# later on causes the real implementation to be autoloaded.
+#
+# Arguments -
+# pattern The pattern of commands being imported (like "foo::*")
+# a canonical namespace as returned by [namespace current]
+
+proc auto_import {pattern} {
+ global auto_index
+
+ set ns [uplevel namespace current]
+ set patternList [auto_qualify $pattern $ns]
+
+ auto_load_index
+
+ foreach pattern $patternList {
+ foreach name [array names auto_index $pattern] {
+ if {"" == [info commands $name]} {
+ ::itcl::import::stub create $name
+ }
+ }
+ }
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/itcl.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/itcl423.dll
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/itcl423.dll
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/itcl423.dll 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/itcl423.dll 2024-02-15 21:05:12 UTC (rev 69897)
Property changes on: trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/itcl423.dll
___________________________________________________________________
Added: svn:mime-type
## -0,0 +1 ##
+application/vnd.microsoft.portable-executable
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/itclConfig.sh
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/itclConfig.sh (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/itclConfig.sh 2024-02-15 21:05:12 UTC (rev 69897)
@@ -0,0 +1,67 @@
+# itclConfig.sh --
+#
+# This shell script (for sh) is generated automatically by Itcl's
+# configure script. It will create shell variables for most of
+# the configuration options discovered by the configure script.
+# This script is intended to be included by the configure scripts
+# for Itcl extensions so that they don't have to figure this all
+# out for themselves. This file does not duplicate information
+# already provided by tclConfig.sh, so you may need to use that
+# file in addition to this one.
+#
+# The information in this file is specific to a single platform.
+
+# Itcl's version number.
+itcl_VERSION='4.2.3'
+ITCL_VERSION='4.2.3'
+
+# The name of the Itcl library (may be either a .a file or a shared library):
+itcl_LIB_FILE=itcl423.dll
+ITCL_LIB_FILE=itcl423.dll
+
+# String to pass to linker to pick up the Itcl library from its
+# build directory.
+itcl_BUILD_LIB_SPEC='-L/tmp/siepo/tcl8.6.13/win/pkgs/itcl4.2.3 -litcl423'
+ITCL_BUILD_LIB_SPEC='-L/tmp/siepo/tcl8.6.13/win/pkgs/itcl4.2.3 -litcl423'
+
+# String to pass to linker to pick up the Itcl library from its
+# installed directory.
+itcl_LIB_SPEC='-L/home/siepo/tltcl/lib/itcl4.2.3 -litcl423'
+ITCL_LIB_SPEC='-L/home/siepo/tltcl/lib/itcl4.2.3 -litcl423'
+
+# The name of the Itcl stub library (a .a file):
+itcl_STUB_LIB_FILE=libitclstub423.a
+ITCL_STUB_LIB_FILE=libitclstub423.a
+
+# String to pass to linker to pick up the Itcl stub library from its
+# build directory.
+itcl_BUILD_STUB_LIB_SPEC='-L/tmp/siepo/tcl8.6.13/win/pkgs/itcl4.2.3 -litclstub423'
+ITCL_BUILD_STUB_LIB_SPEC='-L/tmp/siepo/tcl8.6.13/win/pkgs/itcl4.2.3 -litclstub423'
+
+# String to pass to linker to pick up the Itcl stub library from its
+# installed directory.
+itcl_STUB_LIB_SPEC='-L/home/siepo/tltcl/lib/itcl4.2.3 -litclstub423'
+ITCL_STUB_LIB_SPEC='-L/home/siepo/tltcl/lib/itcl4.2.3 -litclstub423'
+
+# String to pass to linker to pick up the Itcl stub library from its
+# build directory.
+itcl_BUILD_STUB_LIB_PATH='/tmp/siepo/tcl8.6.13/win/pkgs/itcl4.2.3/libitclstub423.a'
+ITCL_BUILD_STUB_LIB_PATH='/tmp/siepo/tcl8.6.13/win/pkgs/itcl4.2.3/libitclstub423.a'
+
+# String to pass to linker to pick up the Itcl stub library from its
+# installed directory.
+itcl_STUB_LIB_PATH='/home/siepo/tltcl/lib/itcl4.2.3/libitclstub423.a'
+ITCL_STUB_LIB_PATH='/home/siepo/tltcl/lib/itcl4.2.3/libitclstub423.a'
+
+# Location of the top-level source directories from which [incr Tcl]
+# was built. This is the directory that contains generic, unix, etc.
+# If [incr Tcl] was compiled in a different place than the directory
+# containing the source files, this points to the location of the sources,
+# not the location where [incr Tcl] was compiled.
+itcl_SRC_DIR='/tmp/siepo/tcl8.6.13/pkgs/itcl4.2.3'
+ITCL_SRC_DIR='/tmp/siepo/tcl8.6.13/pkgs/itcl4.2.3'
+
+# String to pass to the compiler so that an extension can
+# find installed Itcl headers.
+itcl_INCLUDE_SPEC='-I/tmp/siepo/tcl8.6.13/pkgs/itcl4.2.3/generic'
+ITCL_INCLUDE_SPEC='-I/tmp/siepo/tcl8.6.13/pkgs/itcl4.2.3/generic'
Property changes on: trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/itclConfig.sh
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/itclHullCmds.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/itclHullCmds.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/itclHullCmds.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -0,0 +1,562 @@
+#
+# itclHullCmds.tcl
+# ----------------------------------------------------------------------
+# Invoked automatically upon startup to customize the interpreter
+# for [incr Tcl] when one of setupcomponent or createhull is called.
+# ----------------------------------------------------------------------
+# AUTHOR: Arnulf P. Wiedemann
+#
+# ----------------------------------------------------------------------
+# Copyright (c) 2008 Arnulf P. Wiedemann
+# ======================================================================
+# See the file "license.terms" for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require Tk 8.6
+
+namespace eval ::itcl::internal::commands {
+
+# ======================= widgetDeleted ===========================
+
+proc widgetDeleted {oldName newName op} {
+ # The widget is beeing deleted, so we have to delete the object
+ # which had the widget as itcl_hull too!
+ # We have to get the real name from for example
+ # ::itcl::internal::widgets::hull1.lw
+ # we need only .lw here
+
+#puts stderr "widgetDeleted!$oldName!$newName!$op!"
+ set cmdName [namespace tail $oldName]
+ set flds [split $cmdName {.}]
+ set cmdName .[join [lrange $flds 1 end] {.}]
+#puts stderr "DELWIDGET![namespace current]!$cmdName![::info command $cmdName]!"
+ rename $cmdName {}
+}
+
+}
+
+namespace eval ::itcl::builtin {
+
+# ======================= createhull ===========================
+# the hull widget is a tk widget which is the (mega) widget handled behind the itcl
+# extendedclass/itcl widget.
+# It is created be renaming the itcl class object to a temporary name <itcl object name>_
+# creating the widget with the
+# appropriate options and the installing that as the "hull" widget (the container)
+# All the options in args and the options delegated to component itcl_hull are used
+# Then a unique name (hull_widget_name) in the itcl namespace is created for widget:
+# ::itcl::internal::widgets::hull<unique number><namespace tail path>
+# and widget is renamed to that name
+# Finally the <itcl object name>_ is renamed to the original <itcl object name> again
+# Component itcl_hull is created if not existent
+# itcl_hull is set to the hull_widget_name and the <itcl object name>
+# is returned to the caller
+# ==============================================================
+
+proc createhull {widget_type path args} {
+ variable hullCount
+ upvar this this
+ upvar win win
+
+
+#puts stderr "il-1![::info level -1]!$this!"
+#puts stderr "createhull!$widget_type!$path!$args!$this![::info command $this]!"
+#puts stderr "ns1![uplevel 1 namespace current]!"
+#puts stderr "ns2![uplevel 2 namespace current]!"
+#puts stderr "ns3![uplevel 3 namespace current]!"
+#puts stderr "level-1![::info level -1]!"
+#puts stderr "level-2![::info level -2]!"
+# set my_this [namespace tail $this]
+ set my_this $this
+ set tmp $my_this
+#puts stderr "II![::info command $this]![::info command $tmp]!"
+#puts stderr "rename1!rename $my_this ${tmp}_!"
+ rename ::$my_this ${tmp}_
+ set options [list]
+ foreach {option_name value} $args {
+ switch -glob -- $option_name {
+ -class {
+ lappend options $option_name [namespace tail $value]
+ }
+ -* {
+ lappend options $option_name $value
+ }
+ default {
+ return -code error "bad option name\"$option_name\" options must start with a \"-\""
+ }
+ }
+ }
+ set my_win [namespace tail $path]
+ set cmd [list $widget_type $my_win]
+#puts stderr "my_win!$my_win!cmd!$cmd!$path!"
+ if {[llength $options] > 0} {
+ lappend cmd {*}$options
+ }
+ set widget [uplevel 1 $cmd]
+#puts stderr "widget!$widget!"
+ trace add command $widget delete ::itcl::internal::commands::widgetDeleted
+ set opts [uplevel 1 info delegated options]
+ foreach entry $opts {
+ foreach {optName compName} $entry break
+ if {$compName eq "itcl_hull"} {
+ set optInfos [uplevel 1 info delegated option $optName]
+ set realOptName [lindex $optInfos 4]
+ # strip off the "-" at the beginning
+ set myOptName [string range $realOptName 1 end]
+ set my_opt_val [option get $my_win $myOptName *]
+ if {$my_opt_val ne ""} {
+ $my_win configure -$myOptName $my_opt_val
+ }
+ }
+ }
+ set idx 1
+ while {1} {
+ set widgetName ::itcl::internal::widgets::hull${idx}$my_win
+#puts stderr "widgetName!$widgetName!"
+ if {[string length [::info command $widgetName]] == 0} {
+ break
+ }
+ incr idx
+ }
+#puts stderr "rename2!rename $widget $widgetName!"
+ set dorename 0
+ rename $widget $widgetName
+#puts stderr "rename3!rename ${tmp}_ $tmp![::info command ${tmp}_]!my_this!$my_this!"
+ rename ${tmp}_ ::$tmp
+ set exists [uplevel 1 ::info exists itcl_hull]
+ if {!$exists} {
+ # that does not yet work, beacause of problems with resolving
+ ::itcl::addcomponent $my_this itcl_hull
+ }
+ upvar itcl_hull itcl_hull
+ ::itcl::setcomponent $my_this itcl_hull $widgetName
+#puts stderr "IC![::info command $my_win]!"
+ set exists [uplevel 1 ::info exists itcl_interior]
+ if {!$exists} {
+ # that does not yet work, beacause of problems with resolving
+ ::itcl::addcomponent $this itcl_interior
+ }
+ upvar itcl_interior itcl_interior
+ set itcl_interior $my_win
+#puts stderr "hull end!win!$win!itcl_hull!$itcl_hull!itcl_interior!$itcl_interior!"
+ return $my_win
+}
+
+# ======================= addToItclOptions ===========================
+
+proc addToItclOptions {my_class my_win myOptions argsDict} {
+ upvar win win
+ upvar itcl_hull itcl_hull
+
+ set opt_lst [list configure]
+ foreach opt [lsort $myOptions] {
+#puts stderr "IOPT!$opt!$my_class!$my_win![::itcl::is class $my_class]!"
+ set isClass [::itcl::is class $my_class]
+ set found 0
+ if {$isClass} {
+ if {[catch {
+ set resource [namespace eval $my_class info option $opt -resource]
+ set class [namespace eval $my_class info option $opt -class]
+ set default_val [uplevel 2 info option $opt -default]
+ set found 1
+ } msg]} {
+# puts stderr "MSG!$opt!$my_class!$msg!"
+ }
+ } else {
+ set tmp_win [uplevel #0 $my_class .___xx]
+
+ set my_info [$tmp_win configure $opt]
+ set resource [lindex $my_info 1]
+ set class [lindex $my_info 2]
+ set default_val [lindex $my_info 3]
+ uplevel #0 destroy $tmp_win
+ set found 1
+ }
+ if {$found} {
+ if {[catch {
+ set val [uplevel #0 ::option get $win $resource $class]
+ } msg]} {
+ set val ""
+ }
+ if {[::dict exists $argsDict $opt]} {
+ # we have an explicitly set option
+ set val [::dict get $argsDict $opt]
+ } else {
+ if {[string length $val] == 0} {
+ set val $default_val
+ }
+ }
+ set ::itcl::internal::variables::${my_win}::itcl_options($opt) $val
+ set ::itcl::internal::variables::${my_win}::__itcl_option_infos($opt) [list $resource $class $default_val]
+#puts stderr "OPT1!$opt!$val!"
+# uplevel 1 [list set itcl_options($opt) [list $val]]
+ if {[catch {uplevel 1 $win configure $opt [list $val]} msg]} {
+#puts stderr "addToItclOptions ERR!$msg!$my_class!$win!configure!$opt!$val!"
+ }
+ }
+ }
+}
+
+# ======================= setupcomponent ===========================
+
+proc setupcomponent {comp using widget_type path args} {
+ upvar this this
+ upvar win win
+ upvar itcl_hull itcl_hull
+
+#puts stderr "setupcomponent!$comp!$widget_type!$path!$args!$this!$win!$itcl_hull!"
+#puts stderr "CONT![uplevel 1 info context]!"
+#puts stderr "ns1![uplevel 1 namespace current]!"
+#puts stderr "ns2![uplevel 2 namespace current]!"
+#puts stderr "ns3![uplevel 3 namespace current]!"
+ set my_comp_object [lindex [uplevel 1 info context] 1]
+ if {[::info exists ::itcl::internal::component_objects($my_comp_object)]} {
+ set my_comp_object [set ::itcl::internal::component_objects($my_comp_object)]
+ } else {
+ set ::itcl::internal::component_objects($path) $my_comp_object
+ }
+ set options [list]
+ foreach {option_name value} $args {
+ switch -glob -- $option_name {
+ -* {
+ lappend options $option_name $value
+ }
+ default {
+ return -code error "bad option name\"$option_name\" options must start with a \"-\""
+ }
+ }
+ }
+ if {[llength $args]} {
+ set argsDict [dict create {*}$args]
+ } else {
+ set argsDict [dict create]
+ }
+ set cmd [list $widget_type $path]
+ if {[llength $options] > 0} {
+ lappend cmd {*}$options
+ }
+#puts stderr "cmd0![::info command $widget_type]!$path![::info command $path]!"
+#puts stderr "cmd1!$cmd!"
+# set my_comp [uplevel 3 $cmd]
+ set my_comp [uplevel #0 $cmd]
+#puts stderr 111![::info command $path]!
+ ::itcl::setcomponent $this $comp $my_comp
+ set opts [uplevel 1 info delegated options]
+ foreach entry $opts {
+ foreach {optName compName} $entry break
+ if {$compName eq $my_comp} {
+ set optInfos [uplevel 1 info delegated option $optName]
+ set realOptName [lindex $optInfos 4]
+ # strip off the "-" at the beginning
+ set myOptName [string range $realOptName 1 end]
+ set my_opt_val [option get $my_win $myOptName *]
+ if {$my_opt_val ne ""} {
+ $my_comp configure -$myOptName $my_opt_val
+ }
+ }
+ }
+ set my_class $widget_type
+ set my_parent_class [uplevel 1 namespace current]
+ if {[catch {
+ set myOptions [namespace eval $my_class {info classoptions}]
+ } msg]} {
+ set myOptions [list]
+ }
+ foreach entry [$path configure] {
+ foreach {opt dummy1 dummy2 dummy3} $entry break
+ lappend myOptions $opt
+ }
+#puts stderr "OPTS!$myOptions!"
+ addToItclOptions $widget_type $my_comp_object $myOptions $argsDict
+#puts stderr END!$path![::info command $path]!
+}
+
+proc itcl_initoptions {args} {
+puts stderr "ITCL_INITOPT!$args!"
+}
+
+# ======================= initoptions ===========================
+
+proc initoptions {args} {
+ upvar win win
+ upvar itcl_hull itcl_hull
+ upvar itcl_option_components itcl_option_components
+
+#puts stderr "INITOPT!!$win!"
+ if {[llength $args]} {
+ set argsDict [dict create {*}$args]
+ } else {
+ set argsDict [dict create]
+ }
+ set my_class [uplevel 1 namespace current]
+ set myOptions [namespace eval $my_class {info classoptions}]
+ if {[dict exists $::itcl::internal::dicts::classComponents $my_class]} {
+ set class_info_dict [dict get $::itcl::internal::dicts::classComponents $my_class]
+# set myOptions [lsort -unique [namespace eval $my_class {info options}]]
+ foreach comp [uplevel 1 info components] {
+ if {[dict exists $class_info_dict $comp -keptoptions]} {
+ foreach my_opt [dict get $class_info_dict $comp -keptoptions] {
+ if {[lsearch $myOptions $my_opt] < 0} {
+#puts stderr "KEOPT!$my_opt!"
+ lappend myOptions $my_opt
+ }
+ }
+ }
+ }
+ } else {
+ set class_info_dict [list]
+ }
+#puts stderr "OPTS!$win!$my_class![join [lsort $myOptions]] \n]!"
+ set opt_lst [list configure]
+ set my_win $win
+ foreach opt [lsort $myOptions] {
+ set found 0
+ if {[catch {
+ set resource [uplevel 1 info option $opt -resource]
+ set class [uplevel 1 info option $opt -class]
+ set default_val [uplevel 1 info option $opt -default]
+ set found 1
+ } msg]} {
+# puts stderr "MSG!$opt!$msg!"
+ }
+#puts stderr "OPT!$opt!$found!"
+ if {$found} {
+ if {[catch {
+ set val [uplevel #0 ::option get $my_win $resource $class]
+ } msg]} {
+ set val ""
+ }
+ if {[::dict exists $argsDict $opt]} {
+ # we have an explicitly set option
+ set val [::dict get $argsDict $opt]
+ } else {
+ if {[string length $val] == 0} {
+ set val $default_val
+ }
+ }
+ set ::itcl::internal::variables::${win}::itcl_options($opt) $val
+ set ::itcl::internal::variables::${win}::__itcl_option_infos($opt) [list $resource $class $default_val]
+#puts stderr "OPT1!$opt!$val!"
+# uplevel 1 [list set itcl_options($opt) [list $val]]
+ if {[catch {uplevel 1 $my_win configure $opt [list $val]} msg]} {
+puts stderr "initoptions ERR!$msg!$my_class!$my_win!configure!$opt!$val!"
+ }
+ }
+ foreach comp [dict keys $class_info_dict] {
+#puts stderr "OPT1!$opt!$comp![dict get $class_info_dict $comp]!"
+ if {[dict exists $class_info_dict $comp -keptoptions]} {
+ if {[lsearch [dict get $class_info_dict $comp -keptoptions] $opt] >= 0} {
+ if {$found == 0} {
+ # we use the option value of the first component for setting
+ # the option, as the components are traversed in the dict
+ # depending on the ordering of the component creation!!
+ set my_info [uplevel 1 \[set $comp\] configure $opt]
+ set resource [lindex $my_info 1]
+ set class [lindex $my_info 2]
+ set default_val [lindex $my_info 3]
+ set found 2
+ set val [uplevel #0 ::option get $my_win $resource $class]
+ if {[::dict exists $argsDict $opt]} {
+ # we have an explicitly set option
+ set val [::dict get $argsDict $opt]
+ } else {
+ if {[string length $val] == 0} {
+ set val $default_val
+ }
+ }
+#puts stderr "OPT2!$opt!$val!"
+ set ::itcl::internal::variables::${win}::itcl_options($opt) $val
+ set ::itcl::internal::variables::${win}::__itcl_option_infos($opt) [list $resource $class $default_val]
+# uplevel 1 [list set itcl_options($opt) [list $val]]
+ }
+ if {[catch {uplevel 1 \[set $comp\] configure $opt [list $val]} msg]} {
+puts stderr "initoptions ERR2!$msg!$my_class!$comp!configure!$opt!$val!"
+ }
+ if {![uplevel 1 info exists itcl_option_components($opt)]} {
+ set itcl_option_components($opt) [list]
+ }
+ if {[lsearch [set itcl_option_components($opt)] $comp] < 0} {
+ if {![catch {
+ set optval [uplevel 1 [list set itcl_options($opt)]]
+ } msg3]} {
+ uplevel 1 \[set $comp\] configure $opt $optval
+ }
+ lappend itcl_option_components($opt) $comp
+ }
+ }
+ }
+ }
+ }
+# uplevel 1 $opt_lst
+}
+
+# ======================= setoptions ===========================
+
+proc setoptions {args} {
+
+#puts stderr "setOPT!!$args!"
+ if {[llength $args]} {
+ set argsDict [dict create {*}$args]
+ } else {
+ set argsDict [dict create]
+ }
+ set my_class [uplevel 1 namespace current]
+ set myOptions [namespace eval $my_class {info options}]
+#puts stderr "OPTS!$win!$my_class![join [lsort $myOptions]] \n]!"
+ set opt_lst [list configure]
+ foreach opt [lsort $myOptions] {
+ set found 0
+ if {[catch {
+ set resource [uplevel 1 info option $opt -resource]
+ set class [uplevel 1 info option $opt -class]
+ set default_val [uplevel 1 info option $opt -default]
+ set found 1
+ } msg]} {
+# puts stderr "MSG!$opt!$msg!"
+ }
+#puts stderr "OPT!$opt!$found!"
+ if {$found} {
+ set val ""
+ if {[::dict exists $argsDict $opt]} {
+ # we have an explicitly set option
+ set val [::dict get $argsDict $opt]
+ } else {
+ if {[string length $val] == 0} {
+ set val $default_val
+ }
+ }
+ set myObj [uplevel 1 set this]
+#puts stderr "myObj!$myObj!"
+ set ::itcl::internal::variables::${myObj}::itcl_options($opt) $val
+ set ::itcl::internal::variables::${myObj}::__itcl_option_infos($opt) [list $resource $class $default_val]
+#puts stderr "OPT1!$opt!$val!"
+ uplevel 1 [list set itcl_options($opt) [list $val]]
+# if {[catch {uplevel 1 $myObj configure $opt [list $val]} msg]} {
+#puts stderr "initoptions ERR!$msg!$my_class!$my_win!configure!$opt!$val!"
+# }
+ }
+ }
+# uplevel 1 $opt_lst
+}
+
+# ========================= keepcomponentoption ======================
+# Invoked by Tcl during evaluating constructor whenever
+# the "keepcomponentoption" command is invoked to list the options
+# to be kept when an ::itcl::extendedclass component has been setup
+# for an object.
+#
+# It checks, for all arguments, if the opt is an option of that class
+# and of that component. If that is the case it adds the component name
+# to the list of components for that option.
+# The variable is the object variable: itcl_option_components($opt)
+#
+# Handles the following syntax:
+#
+# keepcomponentoption <componentName> <optionName> ?<optionName> ...?
+#
+# ======================================================================
+
+
+proc keepcomponentoption {args} {
+ upvar win win
+ upvar itcl_hull itcl_hull
+
+ set usage "wrong # args, should be: keepcomponentoption componentName optionName ?optionName ...?"
+
+#puts stderr "KEEP!$args![uplevel 1 namespace current]!"
+ if {[llength $args] < 2} {
+ puts stderr $usage
+ return -code error
+ }
+ set my_hull [uplevel 1 set itcl_hull]
+ set my_class [uplevel 1 namespace current]
+ set comp [lindex $args 0]
+ set args [lrange $args 1 end]
+ set class_info_dict [dict get $::itcl::internal::dicts::classComponents $my_class]
+ if {![dict exists $class_info_dict $comp]} {
+ puts stderr "keepcomponentoption cannot find component \"$comp\""
+ return -code error
+ }
+ set class_comp_dict [dict get $class_info_dict $comp]
+ if {![dict exists $class_comp_dict -keptoptions]} {
+ dict set class_comp_dict -keptoptions [list]
+ }
+ foreach opt $args {
+#puts stderr "KEEP!$opt!"
+ if {[string range $opt 0 0] ne "-"} {
+ puts stderr "keepcomponentoption: option must begin with a \"-\"!"
+ return -code error
+ }
+ if {[lsearch [dict get $class_comp_dict -keptoptions] $opt] < 0} {
+ dict lappend class_comp_dict -keptoptions $opt
+ }
+ }
+ if {![info exists ::itcl::internal::component_objects([lindex [uplevel 1 info context] 1])]} {
+ set comp_object $::itcl::internal::component_objects([lindex [uplevel 1 info context] 1])
+ } else {
+ set comp_object "unknown_comp_obj_$comp!"
+ }
+ dict set class_info_dict $comp $class_comp_dict
+ dict set ::itcl::internal::dicts::classComponents $my_class $class_info_dict
+puts stderr "CLDI!$class_comp_dict!"
+ addToItclOptions $my_class $comp_object $args [list]
+}
+
+proc ignorecomponentoption {args} {
+puts stderr "IGNORE_COMPONENT_OPTION!$args!"
+}
+
+proc renamecomponentoption {args} {
+puts stderr "rename_COMPONENT_OPTION!$args!"
+}
+
+proc addoptioncomponent {args} {
+puts stderr "ADD_OPTION_COMPONENT!$args!"
+}
+
+proc ignoreoptioncomponent {args} {
+puts stderr "IGNORE_OPTION_COMPONENT!$args!"
+}
+
+proc renameoptioncomponent {args} {
+puts stderr "RENAME_OPTION_COMPONENT!$args!"
+}
+
+proc getEclassOptions {args} {
+ upvar win win
+
+#puts stderr "getEclassOptions!$args!$win![uplevel 1 namespace current]!"
+#parray ::itcl::internal::variables::${win}::itcl_options
+ set result [list]
+ foreach opt [array names ::itcl::internal::variables::${win}::itcl_options] {
+ if {[catch {
+ foreach {res cls def} [set ::itcl::internal::variables::${win}::__itcl_option_infos($opt)] break
+ lappend result [list $opt $res $cls $def [set ::itcl::internal::variables::${win}::itcl_options($opt)]]
+ } msg]} {
+ }
+ }
+ return $result
+}
+
+proc eclassConfigure {args} {
+ upvar win win
+
+#puts stderr "+++ eclassConfigure!$args!"
+ if {[llength $args] > 1} {
+ foreach {opt val} $args break
+ if {[::info exists ::itcl::internal::variables::${win}::itcl_options($opt)]} {
+ set ::itcl::internal::variables::${win}::itcl_options($opt) $val
+ return
+ }
+ } else {
+ foreach {opt} $args break
+ if {[::info exists ::itcl::internal::variables::${win}::itcl_options($opt)]} {
+#puts stderr "OP![set ::itcl::internal::variables::${win}::itcl_options($opt)]!"
+ foreach {res cls def} [set ::itcl::internal::variables::${win}::__itcl_option_infos($opt)] break
+ return [list $opt $res $cls $def [set ::itcl::internal::variables::${win}::itcl_options($opt)]]
+ }
+ }
+ return -code error
+}
+
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/itclHullCmds.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/itclWidget.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/itclWidget.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/itclWidget.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -0,0 +1,447 @@
+#
+# itclWidget.tcl
+# ----------------------------------------------------------------------
+# Invoked automatically upon startup to customize the interpreter
+# for [incr Tcl] when one of ::itcl::widget or ::itcl::widgetadaptor is called.
+# ----------------------------------------------------------------------
+# AUTHOR: Arnulf P. Wiedemann
+#
+# ----------------------------------------------------------------------
+# Copyright (c) 2008 Arnulf P. Wiedemann
+# ======================================================================
+# See the file "license.terms" for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require Tk 8.6
+# package require itclwidget [set ::itcl::version]
+
+namespace eval ::itcl {
+
+proc widget {name args} {
+ set result [uplevel 1 ::itcl::internal::commands::genericclass widget $name $args]
+ # we handle create by owerselfs !! allow classunknown to handle that
+ oo::objdefine $result unexport create
+ return $result
+}
+
+proc widgetadaptor {name args} {
+ set result [uplevel 1 ::itcl::internal::commands::genericclass widgetadaptor $name $args]
+ # we handle create by owerselfs !! allow classunknown to handle that
+ oo::objdefine $result unexport create
+ return $result
+}
+
+} ; # end ::itcl
+
+
+namespace eval ::itcl::internal::commands {
+
+proc initWidgetOptions {varNsName widgetName className} {
+ set myDict [set ::itcl::internal::dicts::classOptions]
+ if {$myDict eq ""} {
+ return
+ }
+ if {![dict exists $myDict $className]} {
+ return
+ }
+ set myDict [dict get $myDict $className]
+ foreach option [dict keys $myDict] {
+ set infos [dict get $myDict $option]
+ set resource [dict get $infos -resource]
+ set class [dict get $infos -class]
+ set value [::option get $widgetName $resource $class]
+ if {$value eq ""} {
+ if {[dict exists $infos -default]} {
+ set defaultValue [dict get $infos -default]
+ uplevel 1 set ${varNsName}::itcl_options($option) $defaultValue
+ }
+ } else {
+ uplevel 1 set ${varNsName}::itcl_options($option) $value
+ }
+ }
+}
+
+proc initWidgetDelegatedOptions {varNsName widgetName className args} {
+ set myDict [set ::itcl::internal::dicts::classDelegatedOptions]
+ if {$myDict eq ""} {
+ return
+ }
+ if {![dict exists $myDict $className]} {
+ return
+ }
+ set myDict [dict get $myDict $className]
+ foreach option [dict keys $myDict] {
+ set infos [dict get $myDict $option]
+ if {![dict exists $infos -resource]} {
+ # this is the case when delegating "*"
+ continue
+ }
+ if {![dict exists $infos -component]} {
+ # nothing to do
+ continue
+ }
+ # check if not in the command line options
+ # these have higher priority
+ set myOption $option
+ if {[dict exists $infos -as]} {
+ set myOption [dict get $infos -as]
+ }
+ set noOptionSet 0
+ foreach {optName optVal} $args {
+ if {$optName eq $myOption} {
+ set noOptionSet 1
+ break
+ }
+ }
+ if {$noOptionSet} {
+ continue
+ }
+ set resource [dict get $infos -resource]
+ set class [dict get $infos -class]
+ set component [dict get $infos -component]
+ set value [::option get $widgetName $resource $class]
+ if {$component ne ""} {
+ if {$value ne ""} {
+ set compVar [namespace eval ${varNsName}${className} "set $component"]
+ if {$compVar ne ""} {
+ uplevel 1 $compVar configure $myOption $value
+ }
+ }
+ }
+ }
+}
+
+proc widgetinitobjectoptions {varNsName widgetName className} {
+#puts stderr "initWidgetObjectOptions!$varNsName!$widgetName!$className!"
+}
+
+proc deletehull {newName oldName what} {
+ if {$what eq "delete"} {
+ set name [namespace tail $newName]
+ regsub {hull[0-9]+} $name {} name
+ rename $name {}
+ }
+ if {$what eq "rename"} {
+ set name [namespace tail $newName]
+ regsub {hull[0-9]+} $name {} name
+ rename $name {}
+ }
+}
+
+proc hullandoptionsinstall {objectName className widgetClass hulltype args} {
+ if {$hulltype eq ""} {
+ set hulltype frame
+ }
+ set idx 0
+ set found 0
+ foreach {optName optValue} $args {
+ if {$optName eq "-class"} {
+ set found 1
+ set widgetClass $optValue
+ break
+ }
+ incr idx
+ }
+ if {$found} {
+ set args [lreplace $args $idx [expr {$idx + 1}]]
+ }
+ if {$widgetClass eq ""} {
+ set widgetClass $className
+ set widgetClass [string totitle $widgetClass]
+ }
+ set cmd "set win $objectName; ::itcl::builtin::installhull using $hulltype -class $widgetClass $args"
+ uplevel 2 $cmd
+}
+
+} ; # end ::itcl::internal::commands
+
+namespace eval ::itcl::builtin {
+
+proc installhull {args} {
+ set cmdPath ::itcl::internal::commands
+ set className [uplevel 1 info class]
+
+ set replace 0
+ switch -- [llength $args] {
+ 0 {
+ return -code error\
+ "wrong # args: should be \"[lindex [info level 0] 0]\
+ name|using <widgetType> ?arg ...?\""
+ }
+ 1 {
+ set widgetName [lindex $args 0]
+ set varNsName $::itcl::internal::varNsName($widgetName)
+ }
+ default {
+ upvar win win
+ set widgetName $win
+
+ set varNsName $::itcl::internal::varNsName($widgetName)
+ set widgetType [lindex $args 1]
+ incr replace
+ if {[llength $args] > 3 && [lindex $args 2] eq "-class"} {
+ set classNam [lindex $args 3]
+ incr replace 2
+ } else {
+ set classNam [string totitle $widgetType]
+ }
+ uplevel 1 [lreplace $args 0 $replace $widgetType $widgetName -class $classNam]
+ uplevel 1 [list ${cmdPath}::initWidgetOptions $varNsName $widgetName $className]
+ }
+ }
+
+ # initialize the itcl_hull variable
+ set i 0
+ set nam ::itcl::internal::widgets::hull
+ while {1} {
+ incr i
+ set hullNam ${nam}${i}$widgetName
+ if {[::info command $hullNam] eq ""} {
+ break
+ }
+ }
+ uplevel 1 [list ${cmdPath}::sethullwindowname $widgetName]
+ uplevel 1 [list ::rename $widgetName $hullNam]
+ uplevel 1 [list ::trace add command $hullNam {delete rename} ::itcl::internal::commands::deletehull]
+ catch {${cmdPath}::checksetitclhull [list] 0}
+ namespace eval ${varNsName}${className} "set itcl_hull $hullNam"
+ catch {${cmdPath}::checksetitclhull [list] 2}
+ uplevel 1 [lreplace $args 0 $replace ${cmdPath}::initWidgetDelegatedOptions $varNsName $widgetName $className]
+}
+
+proc installcomponent {args} {
+ upvar win win
+
+ set className [uplevel 1 info class]
+ set myType [${className}::info types [namespace tail $className]]
+ set isType 0
+ if {$myType ne ""} {
+ set isType 1
+ }
+ set numArgs [llength $args]
+ set usage "usage: installcomponent <componentName> using <widgetType> <widgetPath> ?-option value ...?"
+ if {$numArgs < 4} {
+ error $usage
+ }
+ foreach {componentName using widgetType widgetPath} $args break
+ set opts [lrange $args 4 end]
+ if {$using ne "using"} {
+ error $usage
+ }
+ if {!$isType} {
+ set hullExists [uplevel 1 ::info exists itcl_hull]
+ if {!$hullExists} {
+ error "cannot install \"$componentName\" before \"itcl_hull\" exists"
+ }
+ set hullVal [uplevel 1 set itcl_hull]
+ if {$hullVal eq ""} {
+ error "cannot install \"$componentName\" before \"itcl_hull\" exists"
+ }
+ }
+ # check for delegated option and ask the option database for the values
+ # first check for number of delegated options
+ set numOpts 0
+ set starOption 0
+ set myDict [set ::itcl::internal::dicts::classDelegatedOptions]
+ if {[dict exists $myDict $className]} {
+ set myDict [dict get $myDict $className]
+ foreach option [dict keys $myDict] {
+ if {$option eq "*"} {
+ set starOption 1
+ }
+ incr numOpts
+ }
+ }
+ set myOptionDict [set ::itcl::internal::dicts::classOptions]
+ if {[dict exists $myOptionDict $className]} {
+ set myOptionDict [dict get $myOptionDict $className]
+ }
+ set cmd [list $widgetPath configure]
+ set cmd1 "set $componentName \[$widgetType $widgetPath\]"
+ uplevel 1 $cmd1
+ if {$starOption} {
+ upvar $componentName compName
+ set cmd1 [list $compName configure]
+ set configInfos [uplevel 1 $cmd1]
+ foreach entry $configInfos {
+ if {[llength $entry] > 2} {
+ foreach {optName resource class defaultValue} $entry break
+ set val ""
+ catch {
+ set val [::option get $win $resource $class]
+ }
+ if {$val ne ""} {
+ set addOpt 1
+ if {[dict exists $myDict $$optName]} {
+ set addOpt 0
+ } else {
+ set starDict [dict get $myDict "*"]
+ if {[dict exists $starDict -except]} {
+ set exceptions [dict get $starDict -except]
+ if {[lsearch $exceptions $optName] >= 0} {
+ set addOpt 0
+ }
+
+ }
+ if {[dict exists $myOptionDict $optName]} {
+ set addOpt 0
+ }
+ }
+ if {$addOpt} {
+ lappend cmd $optName $val
+ }
+
+ }
+
+ }
+ }
+ } else {
+ foreach optName [dict keys $myDict] {
+ set optInfos [dict get $myDict $optName]
+ set resource [dict get $optInfos -resource]
+ set class [namespace tail $className]
+ set class [string totitle $class]
+ set val ""
+ catch {
+ set val [::option get $win $resource $class]
+ }
+ if {$val ne ""} {
+ if {[dict exists $optInfos -as] } {
+ set optName [dict get $optInfos -as]
+ }
+ lappend cmd $optName $val
+ }
+ }
+ }
+ lappend cmd {*}$opts
+ uplevel 1 $cmd
+}
+
+} ; # end ::itcl::builtin
+
+set ::itcl::internal::dicts::hullTypes [list \
+ frame \
+ toplevel \
+ labelframe \
+ ttk:frame \
+ ttk:toplevel \
+ ttk:labelframe \
+ ]
+
+namespace eval ::itcl::builtin::Info {
+
+proc hulltypes {args} {
+ namespace upvar ::itcl::internal::dicts hullTypes hullTypes
+
+ set numArgs [llength $args]
+ if {$numArgs > 1} {
+ error "wrong # args should be: info hulltypes ?<pattern>?"
+ }
+ set pattern ""
+ if {$numArgs > 0} {
+ set pattern [lindex $args 0]
+ }
+ if {$pattern ne ""} {
+ return [lsearch -all -inline -glob $hullTypes $pattern]
+ }
+ return $hullTypes
+
+}
+
+proc widgetclasses {args} {
+ set numArgs [llength $args]
+ if {$numArgs > 1} {
+ error "wrong # args should be: info widgetclasses ?<pattern>?"
+ }
+ set pattern ""
+ if {$numArgs > 0} {
+ set pattern [lindex $args 0]
+ }
+ set myDict [set ::itcl::internal::dicts::classes]
+ if {![dict exists $myDict widget]} {
+ return [list]
+ }
+ set myDict [dict get $myDict widget]
+ set result [list]
+ if {$pattern ne ""} {
+ foreach key [dict keys $myDict] {
+ set myInfo [dict get $myDict $key]
+ set value [dict get $myInfo -widget]
+ if {[string match $pattern $value]} {
+ lappend result $value
+ }
+ }
+ } else {
+ foreach key [dict keys $myDict] {
+ set myInfo [dict get $myDict $key]
+ lappend result [dict get $myInfo -widget]
+ }
+ }
+ return $result
+}
+
+proc widgets {args} {
+ set numArgs [llength $args]
+ if {$numArgs > 1} {
+ error "wrong # args should be: info widgets ?<pattern>?"
+ }
+ set pattern ""
+ if {$numArgs > 0} {
+ set pattern [lindex $args 0]
+ }
+ set myDict [set ::itcl::internal::dicts::classes]
+ if {![dict exists $myDict widget]} {
+ return [list]
+ }
+ set myDict [dict get $myDict widget]
+ set result [list]
+ if {$pattern ne ""} {
+ foreach key [dict keys $myDict] {
+ set myInfo [dict get $myDict $key]
+ set value [dict get $myInfo -name]
+ if {[string match $pattern $value]} {
+ lappend result $value
+ }
+ }
+ } else {
+ foreach key [dict keys $myDict] {
+ set myInfo [dict get $myDict $key]
+ lappend result [dict get $myInfo -name]
+ }
+ }
+ return $result
+}
+
+proc widgetadaptors {args} {
+ set numArgs [llength $args]
+ if {$numArgs > 1} {
+ error "wrong # args should be: info widgetadaptors ?<pattern>?"
+ }
+ set pattern ""
+ if {$numArgs > 0} {
+ set pattern [lindex $args 0]
+ }
+ set myDict [set ::itcl::internal::dicts::classes]
+ if {![dict exists $myDict widgetadaptor]} {
+ return [list]
+ }
+ set myDict [dict get $myDict widgetadaptor]
+ set result [list]
+ if {$pattern ne ""} {
+ foreach key [dict keys $myDict] {
+ set myInfo [dict get $myDict $key]
+ set value [dict get $myInfo -name]
+ if {[string match $pattern $value]} {
+ lappend result $value
+ }
+ }
+ } else {
+ foreach key [dict keys $myDict] {
+ set myInfo [dict get $myDict $key]
+ lappend result [dict get $myInfo -name]
+ }
+ }
+ return $result
+}
+
+} ; # end ::itcl::builtin::Info
Property changes on: trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/itclWidget.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/libitclstub423.a
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/libitclstub423.a
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/libitclstub423.a 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/libitclstub423.a 2024-02-15 21:05:12 UTC (rev 69897)
Property changes on: trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/libitclstub423.a
___________________________________________________________________
Added: svn:mime-type
## -0,0 +1 ##
+application/x-archive
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/pkgIndex.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/pkgIndex.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/pkgIndex.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -0,0 +1,14 @@
+# -*- tcl -*-
+# Tcl package index file, version 1.1
+#
+
+if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
+
+if {[package vsatisfies [package provide Tcl] 9.0-]} {
+ package ifneeded itcl 4.2.3 \
+ [list load [file join $dir tcl9itcl423.dll] Itcl]
+} else {
+ package ifneeded itcl 4.2.3 \
+ [list load [file join $dir itcl423.dll] Itcl]
+}
+package ifneeded Itcl 4.2.3 [list package require -exact itcl 4.2.3]
Property changes on: trunk/Master/tlpkg/tltcl/lib/itcl4.2.3/pkgIndex.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/libtcl86.dll.a
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/libtcl86.dll.a
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/libtcl86.dll.a 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/libtcl86.dll.a 2024-02-15 21:05:12 UTC (rev 69897)
Property changes on: trunk/Master/tlpkg/tltcl/lib/libtcl86.dll.a
___________________________________________________________________
Added: svn:mime-type
## -0,0 +1 ##
+application/x-archive
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/libtclstub86.a
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/libtclstub86.a
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/libtclstub86.a 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/libtclstub86.a 2024-02-15 21:05:12 UTC (rev 69897)
Property changes on: trunk/Master/tlpkg/tltcl/lib/libtclstub86.a
___________________________________________________________________
Added: svn:mime-type
## -0,0 +1 ##
+application/x-archive
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/libtk86.dll.a
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/libtk86.dll.a
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/libtk86.dll.a 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/libtk86.dll.a 2024-02-15 21:05:12 UTC (rev 69897)
Property changes on: trunk/Master/tlpkg/tltcl/lib/libtk86.dll.a
___________________________________________________________________
Added: svn:mime-type
## -0,0 +1 ##
+application/x-archive
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/libtkstub86.a
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/libtkstub86.a
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/libtkstub86.a 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/libtkstub86.a 2024-02-15 21:05:12 UTC (rev 69897)
Property changes on: trunk/Master/tlpkg/tltcl/lib/libtkstub86.a
___________________________________________________________________
Added: svn:mime-type
## -0,0 +1 ##
+application/x-archive
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/reg1.3/libtclreg13.dll.a
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/reg1.3/libtclreg13.dll.a
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/reg1.3/libtclreg13.dll.a 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/reg1.3/libtclreg13.dll.a 2024-02-15 21:05:12 UTC (rev 69897)
Property changes on: trunk/Master/tlpkg/tltcl/lib/reg1.3/libtclreg13.dll.a
___________________________________________________________________
Added: svn:mime-type
## -0,0 +1 ##
+application/x-archive
\ No newline at end of property
Modified: trunk/Master/tlpkg/tltcl/lib/reg1.3/tclreg13.dll
===================================================================
(Binary files differ)
Added: trunk/Master/tlpkg/tltcl/lib/sqlite3.40.0/pkgIndex.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/sqlite3.40.0/pkgIndex.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/sqlite3.40.0/pkgIndex.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -0,0 +1,12 @@
+# -*- tcl -*-
+# Tcl package index file, version 1.1
+#
+# Note sqlite*3* init specifically
+#
+if {[package vsatisfies [package provide Tcl] 9.0-]} {
+ package ifneeded sqlite3 3.40.0 \
+ [list load [file join $dir tcl9sqlite3400.dll] Sqlite3]
+} else {
+ package ifneeded sqlite3 3.40.0 \
+ [list load [file join $dir sqlite3400.dll] Sqlite3]
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/sqlite3.40.0/pkgIndex.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/sqlite3.40.0/sqlite3400.dll
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/sqlite3.40.0/sqlite3400.dll
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/sqlite3.40.0/sqlite3400.dll 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/sqlite3.40.0/sqlite3400.dll 2024-02-15 21:05:12 UTC (rev 69897)
Property changes on: trunk/Master/tlpkg/tltcl/lib/sqlite3.40.0/sqlite3400.dll
___________________________________________________________________
Added: svn:mime-type
## -0,0 +1 ##
+application/vnd.microsoft.portable-executable
\ No newline at end of property
Deleted: trunk/Master/tlpkg/tltcl/lib/tcl8/8.4/platform-1.0.18.tm
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8/8.4/platform-1.0.18.tm 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8/8.4/platform-1.0.18.tm 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,439 +0,0 @@
-# -*- 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
-# % amd64 -> x86_64
-# % arm* -> arm
-# % sun4* -> sparc
-# % ia32* -> ix86
-# % 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 -
- ia32* -
- i*86* {
- set cpu ix86
- }
- x86_64 {
- if {$tcl_platform(wordSize) == 4} {
- # See Example <1> at the top of this file.
- set cpu ix86
- }
- }
- ppc -
- "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} {
- set minor [lindex [split $tcl_platform(osVersion) .] 1]
- incr major -9
- append plat $major.[expr {$minor - 1}]
- } 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 12} {
- # Add 12.0 to 12.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 11
- set minor 5
- }
- 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.18
-
-# ### ### ### ######### ######### #########
-## 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
-}
Added: trunk/Master/tlpkg/tltcl/lib/tcl8/8.4/platform-1.0.19.tm
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8/8.4/platform-1.0.19.tm (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8/8.4/platform-1.0.19.tm 2024-02-15 21:05:12 UTC (rev 69897)
@@ -0,0 +1,450 @@
+# -*- 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
+# % amd64 -> x86_64
+# % arm* -> arm
+# % sun4* -> sparc
+# % ia32* -> ix86
+# % 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 -
+ ia32* -
+ i*86* {
+ set cpu ix86
+ }
+ x86_64 {
+ if {$tcl_platform(wordSize) == 4} {
+ # See Example <1> at the top of this file.
+ set cpu ix86
+ }
+ }
+ ppc -
+ "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} {
+ set minor [lindex [split $tcl_platform(osVersion) .] 1]
+ incr major -9
+ append plat $major.[expr {$minor - 1}]
+ } 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 13} {
+ # Add 13.0 to 13.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 12
+ set minor 5
+ }
+ if {$major eq 12} {
+ # Add 12.0 to 12.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 11
+ set minor 5
+ }
+ 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.19
+
+# ### ### ### ######### ######### #########
+## 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
+}
Deleted: trunk/Master/tlpkg/tltcl/lib/tcl8/8.5/tcltest-2.5.3.tm
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8/8.5/tcltest-2.5.3.tm 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8/8.5/tcltest-2.5.3.tm 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,3515 +0,0 @@
-# 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) -- <whew!> -- 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 {$level in $Option(-verbose)}]
- }
-
- # 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 <name>, and write <contents> 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 <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
-}
Added: trunk/Master/tlpkg/tltcl/lib/tcl8/8.5/tcltest-2.5.5.tm
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8/8.5/tcltest-2.5.5.tm (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8/8.5/tcltest-2.5.5.tm 2024-02-15 21:05:12 UTC (rev 69897)
@@ -0,0 +1,3533 @@
+# 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 © 1994-1997 Sun Microsystems, Inc.
+# Copyright © 1998-1999 Scriptics Corporation.
+# Copyright © 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.5
+
+ # 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) -- <whew!> -- 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]
+ if {[package vsatisfies [package provide Tcl] 8.7-]} {
+ fconfigure $outputChannel -encoding utf-8
+ }
+ 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]
+ if {[package vsatisfies [package provide Tcl] 8.7-]} {
+ fconfigure $errorChannel -encoding utf-8
+ }
+ 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 {$level in $Option(-verbose)}]
+ }
+
+ # 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]
+ if {[package vsatisfies [package provide Tcl] 8.7-]} {
+ fconfigure $tmp -encoding utf-8
+ }
+ 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 {[package vsatisfies [package provide Tcl] 8.7-]} {
+ fconfigure $f -encoding utf-8
+ }
+ 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 \xB5s"
+ }
+ 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]
+ if {[package vsatisfies [package provide Tcl] 8.7-]} {
+ fconfigure $testFd -encoding utf-8
+ }
+ 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"]
+ if {[package vsatisfies [package provide Tcl] 8.7-]} {
+ fconfigure $pipeFd -encoding utf-8
+ }
+ 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 <name>, and write <contents> 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 <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
+}
Deleted: trunk/Master/tlpkg/tltcl/lib/tcl8/8.6/http-2.9.5.tm
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8/8.6/http-2.9.5.tm 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8/8.6/http-2.9.5.tm 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,3506 +0,0 @@
-# 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 at 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+) : ) ? # <protocol scheme>
- (?: //
- (?:
- (
- [^@/\#?]+ # <userinfo part of authority>
- ) @
- )?
- ( # <host part of authority>
- [^/:\#?]+ | # host name or IPv4 address
- \[ [^/\#?]+ \] # IPv6 address in square brackets
- )
- (?: : (\d+) )? # <port part of authority>
- )?
- ( [/\?] [^\#]*)? # <path> (including query)
- (?: \# (.*) )? # <fragment>
- $
- }
-
- # 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:
Added: trunk/Master/tlpkg/tltcl/lib/tcl8/8.6/http-2.9.8.tm
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8/8.6/http-2.9.8.tm (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8/8.6/http-2.9.8.tm 2024-02-15 21:05:12 UTC (rev 69897)
@@ -0,0 +1,3604 @@
+# 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.8
+
+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 {}
+ }
+
+ # Is this an upgrade request/response?
+ set upgradeResponse \
+ [expr { [info exists state(upgradeRequest)] && $state(upgradeRequest)
+ && [info exists state(http)] && [ncode $token] eq {101}
+ && [info exists state(connection)] && "upgrade" in $state(connection)
+ && [info exists state(upgrade)] && "" ne $state(upgrade)}]
+
+ if { ($state(status) eq "timeout")
+ || ($state(status) eq "error")
+ || ($state(status) eq "eof")
+ } {
+ set closeQueue 1
+ set connId $state(socketinfo)
+ set sock $state(sock)
+ CloseSocket $state(sock) $token
+ } elseif {$upgradeResponse} {
+ # Special handling for an upgrade request/response.
+ # - geturl ensures that this is not a "persistent" socket used for
+ # multiple HTTP requests, so a call to KeepSocket is not needed.
+ # - Leave socket open, so a call to CloseSocket is not needed either.
+ # - Remove fileevent bindings. The caller will set its own bindings.
+ # - THE CALLER MUST PROCESS THE UPGRADED SOCKET IN THE CALLBACK COMMAND
+ # PASSED TO http::geturl AS -command callback.
+ catch {fileevent $state(sock) readable {}}
+ catch {fileevent $state(sock) writable {}}
+ } elseif {
+ ([info exists state(-keepalive)] && !$state(-keepalive))
+ || ([info exists state(connection)] && ("close" in $state(connection)))
+ } {
+ 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)] && ("close" ni $state(connection)))
+ } {
+ 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 ("close" in $state(connection)) 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)]
+ && ("close" ni $state(connection))
+ } {
+ # 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 list
+ }
+ 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 { [info exists type($flag)]
+ && (![string is $type($flag) -strict $value])
+ } {
+ unset $token
+ return -code error \
+ "Bad value for $flag ($value), must be $type($flag)"
+ }
+ if {($flag eq "-headers") && ([llength $value] % 2 != 0)} {
+ unset $token
+ return -code error \
+ "Bad value for $flag ($value), number of list elements must be even"
+ }
+ 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 at 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+) : ) ? # <protocol scheme>
+ (?: //
+ (?:
+ (
+ [^@/\#?]+ # <userinfo part of authority>
+ ) @
+ )?
+ ( # <host part of authority>
+ [^/:\#?]+ | # host name or IPv4 address
+ \[ [^/\#?]+ \] # IPv6 address in square brackets
+ )
+ (?: : (\d+) )? # <port part of authority>
+ )?
+ ( [/\?] [^\#]*)? # <path> (including query)
+ (?: \# (.*) )? # <fragment>
+ $
+ }
+
+ # 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"
+ }
+ if {![regexp {^[^?#]+} $srvurl state(path)]} {
+ set state(path) /
+ }
+ } else {
+ set srvurl /
+ set state(path) /
+ }
+ 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)
+
+ # Check whether this is an Upgrade request.
+ set connectionValues [SplitCommaSeparatedFieldValue \
+ [GetFieldValue $state(-headers) Connection]]
+ set connectionValues [string tolower $connectionValues]
+ set upgradeValues [SplitCommaSeparatedFieldValue \
+ [GetFieldValue $state(-headers) Upgrade]]
+ set state(upgradeRequest) [expr { "upgrade" in $connectionValues
+ && [llength $upgradeValues] >= 1}]
+
+ 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
+ }
+ } elseif {$state(upgradeRequest)} {
+ # It's an upgrade request. Method must be GET (untested).
+ # Force -keepalive to 0 so the connection is not made over a persistent
+ # socket, i.e. one used for multiple HTTP requests.
+ set state(-keepalive) 0
+ } else {
+ # It's a non-upgrade 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)]
+ regexp {^(.+):([^:]+)$} $state(socketinfo) {} host port
+
+ 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)"
+ set hostValue [GetFieldValue $state(-headers) Host]
+ if {$hostValue ne {}} {
+ # Allow Host spoofing. [Bug 928154]
+ regexp {^[^:]+} $hostValue state(host)
+ puts $sock "Host: $hostValue"
+ } elseif {$port == $defport} {
+ # Don't add port in this case, to handle broken servers. [Bug
+ # #504508]
+ set state(host) $host
+ puts $sock "Host: $host"
+ } else {
+ set state(host) $host
+ 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
+ foreach {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))])
+ && ("keep-alive" in $state(connection))
+ && ($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))])
+ && ("close" in $state(connection))
+ && ($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
+
+ # According to
+ # https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Connection
+ # any comma-separated "Connection:" list implies keep-alive, but I
+ # don't see this in the RFC so we'll play safe and
+ # scan any list for "close".
+ # Done here to support combining duplicate header field's values.
+ if { [info exists state(connection)]
+ && ("close" ni $state(connection))
+ && ("keep-alive" ni $state(connection))
+ } {
+ lappend state(connection) "keep-alive"
+ }
+
+ # 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)]
+ && ("close" in $state(connection))
+ )
+ )
+ && (![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 {
+ # RFC 7230 Section 6.1 states that a comma-separated
+ # list is an acceptable value.
+ foreach el [SplitCommaSeparatedFieldValue $value] {
+ lappend state(connection) [string tolower $el]
+ }
+ }
+ upgrade {
+ set state(upgrade) [string trim $value]
+ }
+ }
+ 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 >= 0 || $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[-_]?jis} $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"
+ }
+ default {
+ set encoding "binary"
+ }
+ }
+ } 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 {}
+ br {
+ return -code error\
+ "content-encoding \"br\" not implemented"
+ }
+ default {
+ Log "unknown content-encoding \"$coding\" ignored"
+ }
+ }
+ }
+ }
+ 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
+ }
+ }
+}
+
+# http::SplitCommaSeparatedFieldValue --
+# Return the individual values of a comma-separated field value.
+#
+# Arguments:
+# fieldValue Comma-separated header field value.
+#
+# Results:
+# List of values.
+proc http::SplitCommaSeparatedFieldValue {fieldValue} {
+ set r {}
+ foreach el [split $fieldValue ,] {
+ lappend r [string trim $el]
+ }
+ return $r
+}
+
+
+# http::GetFieldValue --
+# Return the value of a header field.
+#
+# Arguments:
+# headers Headers key-value list
+# fieldName Name of header field whose value to return.
+#
+# Results:
+# The value of the fieldName header field
+#
+# Field names are matched case-insensitively (RFC 7230 Section 3.2).
+#
+# If the field is present multiple times, it is assumed that the field is
+# defined as a comma-separated list and the values are combined (by separating
+# them with commas, see RFC 7230 Section 3.2.2) and returned at once.
+proc http::GetFieldValue {headers fieldName} {
+ set r {}
+ foreach {field value} $headers {
+ if {[string equal -nocase $fieldName $field]} {
+ if {$r eq {}} {
+ set r $value
+ } else {
+ append r ", $value"
+ }
+ }
+ }
+ return $r
+}
+
+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:
Deleted: trunk/Master/tlpkg/tltcl/lib/tcl8/8.6/tdbc/sqlite3-1.1.3.tm
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8/8.6/tdbc/sqlite3-1.1.3.tm 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8/8.6/tdbc/sqlite3-1.1.3.tm 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,715 +0,0 @@
-# tdbcsqlite3.tcl --
-#
-# SQLite3 database driver for TDBC
-#
-# Copyright (c) 2008 by Kevin B. Kenny.
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: tdbcodbc.tcl,v 1.47 2008/02/27 02:08:27 kennykb Exp $
-#
-#------------------------------------------------------------------------------
-
-package require tdbc
-package require sqlite3
-
-package provide tdbc::sqlite3 1.1.3
-
-namespace eval tdbc::sqlite3 {
- namespace export connection
-}
-
-#------------------------------------------------------------------------------
-#
-# tdbc::sqlite3::connection --
-#
-# Class representing a SQLite3 database connection
-#
-#------------------------------------------------------------------------------
-
-::oo::class create ::tdbc::sqlite3::connection {
-
- superclass ::tdbc::connection
-
- variable timeout
-
- # The constructor accepts a database name and opens the database.
-
- constructor {databaseName args} {
- set timeout 0
- if {[llength $args] % 2 != 0} {
- set cmd [lrange [info level 0] 0 end-[llength $args]]
- return -code error \
- -errorcode {TDBC GENERAL_ERROR HY000 SQLITE3 WRONGNUMARGS} \
- "wrong # args, should be \"$cmd ?-option value?...\""
- }
- next
- sqlite3 [namespace current]::db $databaseName
- if {[llength $args] > 0} {
- my configure {*}$args
- }
- db nullvalue \ufffd
- }
-
- # The 'statementCreate' method forwards to the constructor of the
- # statement class
-
- forward statementCreate ::tdbc::sqlite3::statement create
-
- # The 'configure' method queries and sets options to the database
-
- method configure args {
- if {[llength $args] == 0} {
-
- # Query all configuration options
-
- set result {-encoding utf-8}
- lappend result -isolation
- if {[db onecolumn {PRAGMA read_uncommitted}]} {
- lappend result readuncommitted
- } else {
- lappend result serializable
- }
- lappend result -readonly 0
- lappend result -timeout $timeout
- return $result
-
- } elseif {[llength $args] == 1} {
-
- # Query a single option
-
- set option [lindex $args 0]
- switch -exact -- $option {
- -e - -en - -enc - -enco - -encod - -encodi - -encodin -
- -encoding {
- return utf-8
- }
- -i - -is - -iso - -isol - -isola - -isolat - -isolati -
- -isolatio - -isolation {
- if {[db onecolumn {PRAGMA read_uncommitted}]} {
- return readuncommitted
- } else {
- return serializable
- }
- }
- -r - -re - -rea - -read - -reado - -readon - -readonl -
- -readonly {
- return 0
- }
- -t - -ti - -tim - -time - -timeo - -timeou - -timeout {
- return $timeout
- }
- default {
- return -code error \
- -errorcode [list TDBC GENERAL_ERROR HY000 SQLITE3 \
- BADOPTION $option] \
- "bad option \"$option\": must be\
- -encoding, -isolation, -readonly or -timeout"
-
- }
- }
-
- } elseif {[llength $args] % 2 != 0} {
-
- # Syntax error
-
- set cmd [lrange [info level 0] 0 end-[llength $args]]
- return -code error \
- -errorcode [list TDBC GENERAL_ERROR HY000 \
- SQLITE3 WRONGNUMARGS] \
- "wrong # args, should be \" $cmd ?-option value?...\""
- }
-
- # Set one or more options
-
- foreach {option value} $args {
- switch -exact -- $option {
- -e - -en - -enc - -enco - -encod - -encodi - -encodin -
- -encoding {
- if {$value ne {utf-8}} {
- return -code error \
- -errorcode [list TDBC FEATURE_NOT_SUPPORTED 0A000 \
- SQLITE3 ENCODING] \
- "-encoding not supported. SQLite3 is always \
- Unicode."
- }
- }
- -i - -is - -iso - -isol - -isola - -isolat - -isolati -
- -isolatio - -isolation {
- switch -exact -- $value {
- readu - readun - readunc - readunco - readuncom -
- readuncomm - readuncommi - readuncommit -
- readuncommitt - readuncommitte - readuncommitted {
- db eval {PRAGMA read_uncommitted = 1}
- }
- readc - readco - readcom - readcomm - readcommi -
- readcommit - readcommitt - readcommitte -
- readcommitted -
- rep - repe - repea - repeat - repeata - repeatab -
- repeatabl - repeatable - repeatabler - repeatablere -
- repeatablerea - repeatablread -
- s - se - ser - seri - seria - serial - seriali -
- serializ - serializa - serializab - serializabl -
- serializable -
- reado - readon - readonl - readonly {
- db eval {PRAGMA read_uncommitted = 0}
- }
- default {
- return -code error \
- -errorcode [list TDBC GENERAL_ERROR HY000 \
- SQLITE3 BADISOLATION $value] \
- "bad isolation level \"$value\":\
- should be readuncommitted, readcommitted,\
- repeatableread, serializable, or readonly"
- }
- }
- }
- -r - -re - -rea - -read - -reado - -readon - -readonl -
- -readonly {
- if {$value} {
- return -code error \
- -errorcode [list TDBC FEATURE_NOT_SUPPORTED 0A000 \
- SQLITE3 READONLY] \
- "SQLite3's Tcl API does not support read-only\
- access"
- }
- }
- -t - -ti - -tim - -time - -timeo - -timeou - -timeout {
- if {![string is integer $value]} {
- return -code error \
- -errorcode [list TDBC DATA_EXCEPTION 22018 \
- SQLITE3 $value] \
- "expected integer but got \"$value\""
- }
- db timeout $value
- set timeout $value
- }
- default {
- return -code error \
- -errorcode [list TDBC GENERAL_ERROR HY000 \
- SQLITE3 BADOPTION $value] \
- "bad option \"$option\": must be\
- -encoding, -isolation, -readonly or -timeout"
-
- }
- }
- }
- return
- }
-
- # The 'tables' method introspects on the tables in the database.
-
- method tables {{pattern %}} {
- set retval {}
- my foreach row {
- SELECT * from sqlite_master
- WHERE type IN ('table', 'view')
- AND name LIKE :pattern
- } {
- dict set row name [string tolower [dict get $row name]]
- dict set retval [dict get $row name] $row
- }
- return $retval
- }
-
- # The 'columns' method introspects on columns of a table.
-
- method columns {table {pattern %}} {
- regsub -all ' $table '' table
- set retval {}
- set pattern [string map [list \
- * {[*]} \
- ? {[?]} \
- \[ \\\[ \
- \] \\\[ \
- _ ? \
- % *] [string tolower $pattern]]
- my foreach origrow "PRAGMA table_info('$table')" {
- set row {}
- dict for {key value} $origrow {
- dict set row [string tolower $key] $value
- }
- dict set row name [string tolower [dict get $row name]]
- if {![string match $pattern [dict get $row name]]} {
- continue
- }
- switch -regexp -matchvar info [dict get $row type] {
- {^(.+)\(\s*([[:digit:]]+)\s*,\s*([[:digit:]]+)\s*\)\s*$} {
- dict set row type [string tolower [lindex $info 1]]
- dict set row precision [lindex $info 2]
- dict set row scale [lindex $info 3]
- }
- {^(.+)\(\s*([[:digit:]]+)\s*\)\s*$} {
- dict set row type [string tolower [lindex $info 1]]
- dict set row precision [lindex $info 2]
- dict set row scale 0
- }
- default {
- dict set row type [string tolower [dict get $row type]]
- dict set row precision 0
- dict set row scale 0
- }
- }
- dict set row nullable [expr {![dict get $row notnull]}]
- dict set retval [dict get $row name] $row
- }
- return $retval
- }
-
- # The 'primarykeys' method enumerates the primary keys on a table.
-
- method primarykeys {table} {
- set result {}
- my foreach row "PRAGMA table_info($table)" {
- if {[dict get $row pk]} {
- lappend result [dict create ordinalPosition \
- [expr {[dict get $row cid]+1}] \
- columnName \
- [dict get $row name]]
- }
- }
- return $result
- }
-
- # The 'foreignkeys' method enumerates the foreign keys that are
- # declared in a table or that refer to a given table.
-
- method foreignkeys {args} {
-
- variable ::tdbc::generalError
-
- # Check arguments
-
- set argdict {}
- if {[llength $args] % 2 != 0} {
- set errorcode $generalError
- lappend errorcode wrongNumArgs
- return -code error -errorcode $errorcode \
- "wrong # args: should be [lrange [info level 0] 0 1]\
- ?-option value?..."
- }
- foreach {key value} $args {
- if {$key ni {-primary -foreign}} {
- set errorcode $generalError
- lappend errorcode badOption
- return -code error -errorcode $errorcode \
- "bad option \"$key\", must be -primary or -foreign"
- }
- set key [string range $key 1 end]
- if {[dict exists $argdict $key]} {
- set errorcode $generalError
- lappend errorcode dupOption
- return -code error -errorcode $errorcode \
- "duplicate option \"$key\" supplied"
- }
- dict set argdict $key $value
- }
-
- # If we know the table with the foreign key, search just its
- # foreign keys. Otherwise, iterate over all the tables in the
- # database.
-
- if {[dict exists $argdict foreign]} {
- return [my ForeignKeysForTable [dict get $argdict foreign] \
- $argdict]
- } else {
- set result {}
- foreach foreignTable [dict keys [my tables]] {
- lappend result {*}[my ForeignKeysForTable \
- $foreignTable $argdict]
- }
- return $result
- }
-
- }
-
- # The private ForeignKeysForTable method enumerates the foreign keys
- # in a specific table.
- #
- # Parameters:
- #
- # foreignTable - Name of the table containing foreign keys.
- # argdict - Dictionary that may or may not contain a key,
- # 'primary', whose value is the name of a table that
- # must hold the primary key corresponding to the foreign
- # key. If the 'primary' key is absent, all tables are
- # candidates.
- # Results:
- #
- # Returns the list of foreign keys that meed the specified
- # conditions, as a list of dictionaries, each containing the
- # keys, foreignConstraintName, foreignTable, foreignColumn,
- # primaryTable, primaryColumn, and ordinalPosition. Note that the
- # foreign constraint name is constructed arbitrarily, since SQLite3
- # does not report this information.
-
- method ForeignKeysForTable {foreignTable argdict} {
-
- set result {}
- set n 0
-
- # Go through the foreign keys in the given table, looking for
- # ones that refer to the primary table (if one is given), or
- # for any primary keys if none is given.
- my foreach row "PRAGMA foreign_key_list($foreignTable)" {
- if {(![dict exists $argdict primary])
- || ([string tolower [dict get $row table]]
- eq [dict get $argdict primary])} {
-
- # Construct a dictionary for each key, translating
- # SQLite names to TDBC ones and converting sequence
- # numbers to 1-based indexing.
-
- set rrow [dict create foreignTable $foreignTable \
- foreignConstraintName \
- ?$foreignTable?[dict get $row id]]
- if {[dict exists $row seq]} {
- dict set rrow ordinalPosition \
- [expr {1 + [dict get $row seq]}]
- }
- foreach {to from} {
- foreignColumn from
- primaryTable table
- primaryColumn to
- deleteAction on_delete
- updateAction on_update
- } {
- if {[dict exists $row $from]} {
- dict set rrow $to [dict get $row $from]
- }
- }
-
- # Add the newly-constucted dictionary to the result list
-
- lappend result $rrow
- }
- }
-
- return $result
- }
-
- # The 'preparecall' method prepares a call to a stored procedure.
- # SQLite3 does not have stored procedures, since it's an in-process
- # server.
-
- method preparecall {call} {
- return -code error \
- -errorcode [list TDBC FEATURE_NOT_SUPPORTED 0A000 \
- SQLITE3 PREPARECALL] \
- {SQLite3 does not support stored procedures}
- }
-
- # The 'begintransaction' method launches a database transaction
-
- method begintransaction {} {
- db eval {BEGIN TRANSACTION}
- }
-
- # The 'commit' method commits a database transaction
-
- method commit {} {
- db eval {COMMIT}
- }
-
- # The 'rollback' method abandons a database transaction
-
- method rollback {} {
- db eval {ROLLBACK}
- }
-
- # The 'transaction' method executes a script as a single transaction.
- # We override the 'transaction' method of the base class, since SQLite3
- # has a faster implementation of the same thing. (The base class's generic
- # method should also work.)
- # (Don't overload the base class method, because 'break', 'continue'
- # and 'return' in the transaction body don't work!)
-
- #method transaction {script} {
- # uplevel 1 [list {*}[namespace code db] transaction $script]
- #}
-
- method prepare {sqlCode} {
- set result [next $sqlCode]
- return $result
- }
-
- method getDBhandle {} {
- return [namespace which db]
- }
-}
-
-#------------------------------------------------------------------------------
-#
-# tdbc::sqlite3::statement --
-#
-# Class representing a statement to execute against a SQLite3 database
-#
-#------------------------------------------------------------------------------
-
-::oo::class create ::tdbc::sqlite3::statement {
-
- superclass ::tdbc::statement
-
- variable Params db sql
-
- # The constructor accepts the handle to the connection and the SQL
- # code for the statement to prepare. All that it does is to parse the
- # statement and store it. The parse is used to support the
- # 'params' and 'paramtype' methods.
-
- constructor {connection sqlcode} {
- next
- set Params {}
- set db [$connection getDBhandle]
- set sql $sqlcode
- foreach token [::tdbc::tokenize $sqlcode] {
- if {[string index $token 0] in {$ : @}} {
- dict set Params [string range $token 1 end] \
- {type Tcl_Obj precision 0 scale 0 nullable 1 direction in}
- }
- }
- }
-
- # The 'resultSetCreate' method relays to the result set constructor
-
- forward resultSetCreate ::tdbc::sqlite3::resultset create
-
- # The 'params' method returns descriptions of the parameters accepted
- # by the statement
-
- method params {} {
- return $Params
- }
-
- # The 'paramtype' method need do nothing; Sqlite3 uses manifest typing.
-
- method paramtype args {;}
-
- method getDBhandle {} {
- return $db
- }
-
- method getSql {} {
- return $sql
- }
-
-}
-
-#-------------------------------------------------------------------------------
-#
-# tdbc::sqlite3::resultset --
-#
-# Class that represents a SQLlite result set in Tcl
-#
-#-------------------------------------------------------------------------------
-
-::oo::class create ::tdbc::sqlite3::resultset {
-
- superclass ::tdbc::resultset
-
- # The variables of this class all have peculiar names. The reason is
- # that the RunQuery method needs to execute with an activation record
- # that has no local variables whose names could conflict with names
- # in the SQL query. We start the variable names with hyphens because
- # they can't be bind variables.
-
- variable -set {*}{
- -columns -db -needcolumns -resultArray
- -results -sql -Cursor -RowCount -END
- }
-
- constructor {statement args} {
- next
- set -db [$statement getDBhandle]
- set -sql [$statement getSql]
- set -columns {}
- set -results {}
- ${-db} trace [namespace code {my RecordStatement}]
- if {[llength $args] == 0} {
-
- # Variable substitutions are evaluated in caller's context
-
- uplevel 1 [list ${-db} eval ${-sql} \
- [namespace which -variable -resultArray] \
- [namespace code {my RecordResult}]]
-
- } elseif {[llength $args] == 1} {
-
- # Variable substitutions are in the dictionary at [lindex $args 0].
-
- set -paramDict [lindex $args 0]
-
- # At this point, the activation record must contain no variables
- # that might be bound within the query. All variables at this point
- # begin with hyphens so that they are syntactically incorrect
- # as bound variables in SQL.
-
- unset args
- unset statement
-
- dict with -paramDict {
- ${-db} eval ${-sql} -resultArray {
- my RecordResult
- }
- }
-
- } else {
-
- ${-db} trace {}
-
- # Too many args
-
- return -code error \
- -errorcode [list TDBC GENERAL_ERROR HY000 \
- SQLITE3 WRONGNUMARGS] \
- "wrong # args: should be\
- [lrange [info level 0] 0 1] statement ?dictionary?"
-
- }
- ${-db} trace {}
- set -Cursor 0
- if {${-Cursor} < [llength ${-results}]
- && [lindex ${-results} ${-Cursor}] eq {statement}} {
- incr -Cursor 2
- }
- if {${-Cursor} < [llength ${-results}]
- && [lindex ${-results} ${-Cursor}] eq {columns}} {
- incr -Cursor
- set -columns [lindex ${-results} ${-Cursor}]
- incr -Cursor
- }
- set -RowCount [${-db} changes]
- }
-
- # Record the start of a SQL statement
-
- method RecordStatement {stmt} {
- set -needcolumns 1
- lappend -results statement {}
- }
-
- # Record one row of results from a query by appending it as a dictionary
- # to the 'results' list. As a side effect, set 'columns' to a list
- # comprising the names of the columns of the result.
-
- method RecordResult {} {
- set columns ${-resultArray(*)}
- if {[info exists -needcolumns]} {
- lappend -results columns $columns
- unset -needcolumns
- }
- set dict {}
- foreach key $columns {
- if {[set -resultArray($key)] ne "\ufffd"} {
- dict set dict $key [set -resultArray($key)]
- }
- }
- lappend -results row $dict
- }
-
- # Advance to the next result set
-
- method nextresults {} {
- set have 0
- while {${-Cursor} < [llength ${-results}]} {
- if {[lindex ${-results} ${-Cursor}] eq {statement}} {
- set have 1
- incr -Cursor 2
- break
- }
- incr -Cursor 2
- }
- if {!$have} {
- set -END {}
- }
- if {${-Cursor} >= [llength ${-results}]} {
- set -columns {}
- } elseif {[lindex ${-results} ${-Cursor}] eq {columns}} {
- incr -Cursor
- set -columns [lindex ${-results} ${-Cursor}]
- incr -Cursor
- } else {
- set -columns {}
- }
- return $have
- }
-
- method getDBhandle {} {
- return ${-db}
- }
-
- # Return a list of the columns
-
- method columns {} {
- if {[info exists -END]} {
- return -code error \
- -errorcode {TDBC GENERAL_ERROR HY010 SQLITE3 FUNCTIONSEQ} \
- "Function sequence error: result set is exhausted."
- }
- return ${-columns}
- }
-
- # Return the next row of the result set as a list
-
- method nextlist var {
-
- upvar 1 $var row
-
- if {[info exists -END]} {
- return -code error \
- -errorcode {TDBC GENERAL_ERROR HY010 SQLITE3 FUNCTIONSEQ} \
- "Function sequence error: result set is exhausted."
- }
- if {${-Cursor} >= [llength ${-results}]
- || [lindex ${-results} ${-Cursor}] ne {row}} {
- return 0
- } else {
- set row {}
- incr -Cursor
- set d [lindex ${-results} ${-Cursor}]
- incr -Cursor
- foreach key ${-columns} {
- if {[dict exists $d $key]} {
- lappend row [dict get $d $key]
- } else {
- lappend row {}
- }
- }
- }
- return 1
- }
-
- # Return the next row of the result set as a dict
-
- method nextdict var {
-
- upvar 1 $var row
-
- if {[info exists -END]} {
- return -code error \
- -errorcode {TDBC GENERAL_ERROR HY010 SQLITE3 FUNCTIONSEQ} \
- "Function sequence error: result set is exhausted."
- }
- if {${-Cursor} >= [llength ${-results}]
- || [lindex ${-results} ${-Cursor}] ne {row}} {
- return 0
- } else {
- incr -Cursor
- set row [lindex ${-results} ${-Cursor}]
- incr -Cursor
- }
- return 1
- }
-
- # Return the number of rows affected by a statement
-
- method rowcount {} {
- if {[info exists -END]} {
- return -code error \
- -errorcode {TDBC GENERAL_ERROR HY010 SQLITE3 FUNCTIONSEQ} \
- "Function sequence error: result set is exhausted."
- }
- return ${-RowCount}
- }
-
-}
Added: trunk/Master/tlpkg/tltcl/lib/tcl8/8.6/tdbc/sqlite3-1.1.5.tm
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8/8.6/tdbc/sqlite3-1.1.5.tm (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8/8.6/tdbc/sqlite3-1.1.5.tm 2024-02-15 21:05:12 UTC (rev 69897)
@@ -0,0 +1,715 @@
+# tdbcsqlite3.tcl --
+#
+# SQLite3 database driver for TDBC
+#
+# Copyright (c) 2008 by Kevin B. Kenny.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: tdbcodbc.tcl,v 1.47 2008/02/27 02:08:27 kennykb Exp $
+#
+#------------------------------------------------------------------------------
+
+package require tdbc
+package require sqlite3
+
+package provide tdbc::sqlite3 1.1.5
+
+namespace eval tdbc::sqlite3 {
+ namespace export connection
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::sqlite3::connection --
+#
+# Class representing a SQLite3 database connection
+#
+#------------------------------------------------------------------------------
+
+::oo::class create ::tdbc::sqlite3::connection {
+
+ superclass ::tdbc::connection
+
+ variable timeout
+
+ # The constructor accepts a database name and opens the database.
+
+ constructor {databaseName args} {
+ set timeout 0
+ if {[llength $args] % 2 != 0} {
+ set cmd [lrange [info level 0] 0 end-[llength $args]]
+ return -code error \
+ -errorcode {TDBC GENERAL_ERROR HY000 SQLITE3 WRONGNUMARGS} \
+ "wrong # args, should be \"$cmd ?-option value?...\""
+ }
+ next
+ sqlite3 [namespace current]::db $databaseName
+ if {[llength $args] > 0} {
+ my configure {*}$args
+ }
+ db nullvalue \ufffd
+ }
+
+ # The 'statementCreate' method forwards to the constructor of the
+ # statement class
+
+ forward statementCreate ::tdbc::sqlite3::statement create
+
+ # The 'configure' method queries and sets options to the database
+
+ method configure args {
+ if {[llength $args] == 0} {
+
+ # Query all configuration options
+
+ set result {-encoding utf-8}
+ lappend result -isolation
+ if {[db onecolumn {PRAGMA read_uncommitted}]} {
+ lappend result readuncommitted
+ } else {
+ lappend result serializable
+ }
+ lappend result -readonly 0
+ lappend result -timeout $timeout
+ return $result
+
+ } elseif {[llength $args] == 1} {
+
+ # Query a single option
+
+ set option [lindex $args 0]
+ switch -exact -- $option {
+ -e - -en - -enc - -enco - -encod - -encodi - -encodin -
+ -encoding {
+ return utf-8
+ }
+ -i - -is - -iso - -isol - -isola - -isolat - -isolati -
+ -isolatio - -isolation {
+ if {[db onecolumn {PRAGMA read_uncommitted}]} {
+ return readuncommitted
+ } else {
+ return serializable
+ }
+ }
+ -r - -re - -rea - -read - -reado - -readon - -readonl -
+ -readonly {
+ return 0
+ }
+ -t - -ti - -tim - -time - -timeo - -timeou - -timeout {
+ return $timeout
+ }
+ default {
+ return -code error \
+ -errorcode [list TDBC GENERAL_ERROR HY000 SQLITE3 \
+ BADOPTION $option] \
+ "bad option \"$option\": must be\
+ -encoding, -isolation, -readonly or -timeout"
+
+ }
+ }
+
+ } elseif {[llength $args] % 2 != 0} {
+
+ # Syntax error
+
+ set cmd [lrange [info level 0] 0 end-[llength $args]]
+ return -code error \
+ -errorcode [list TDBC GENERAL_ERROR HY000 \
+ SQLITE3 WRONGNUMARGS] \
+ "wrong # args, should be \" $cmd ?-option value?...\""
+ }
+
+ # Set one or more options
+
+ foreach {option value} $args {
+ switch -exact -- $option {
+ -e - -en - -enc - -enco - -encod - -encodi - -encodin -
+ -encoding {
+ if {$value ne {utf-8}} {
+ return -code error \
+ -errorcode [list TDBC FEATURE_NOT_SUPPORTED 0A000 \
+ SQLITE3 ENCODING] \
+ "-encoding not supported. SQLite3 is always \
+ Unicode."
+ }
+ }
+ -i - -is - -iso - -isol - -isola - -isolat - -isolati -
+ -isolatio - -isolation {
+ switch -exact -- $value {
+ readu - readun - readunc - readunco - readuncom -
+ readuncomm - readuncommi - readuncommit -
+ readuncommitt - readuncommitte - readuncommitted {
+ db eval {PRAGMA read_uncommitted = 1}
+ }
+ readc - readco - readcom - readcomm - readcommi -
+ readcommit - readcommitt - readcommitte -
+ readcommitted -
+ rep - repe - repea - repeat - repeata - repeatab -
+ repeatabl - repeatable - repeatabler - repeatablere -
+ repeatablerea - repeatablread -
+ s - se - ser - seri - seria - serial - seriali -
+ serializ - serializa - serializab - serializabl -
+ serializable -
+ reado - readon - readonl - readonly {
+ db eval {PRAGMA read_uncommitted = 0}
+ }
+ default {
+ return -code error \
+ -errorcode [list TDBC GENERAL_ERROR HY000 \
+ SQLITE3 BADISOLATION $value] \
+ "bad isolation level \"$value\":\
+ should be readuncommitted, readcommitted,\
+ repeatableread, serializable, or readonly"
+ }
+ }
+ }
+ -r - -re - -rea - -read - -reado - -readon - -readonl -
+ -readonly {
+ if {$value} {
+ return -code error \
+ -errorcode [list TDBC FEATURE_NOT_SUPPORTED 0A000 \
+ SQLITE3 READONLY] \
+ "SQLite3's Tcl API does not support read-only\
+ access"
+ }
+ }
+ -t - -ti - -tim - -time - -timeo - -timeou - -timeout {
+ if {![string is integer $value]} {
+ return -code error \
+ -errorcode [list TDBC DATA_EXCEPTION 22018 \
+ SQLITE3 $value] \
+ "expected integer but got \"$value\""
+ }
+ db timeout $value
+ set timeout $value
+ }
+ default {
+ return -code error \
+ -errorcode [list TDBC GENERAL_ERROR HY000 \
+ SQLITE3 BADOPTION $value] \
+ "bad option \"$option\": must be\
+ -encoding, -isolation, -readonly or -timeout"
+
+ }
+ }
+ }
+ return
+ }
+
+ # The 'tables' method introspects on the tables in the database.
+
+ method tables {{pattern %}} {
+ set retval {}
+ my foreach row {
+ SELECT * from sqlite_master
+ WHERE type IN ('table', 'view')
+ AND name LIKE :pattern
+ } {
+ dict set row name [string tolower [dict get $row name]]
+ dict set retval [dict get $row name] $row
+ }
+ return $retval
+ }
+
+ # The 'columns' method introspects on columns of a table.
+
+ method columns {table {pattern %}} {
+ regsub -all ' $table '' table
+ set retval {}
+ set pattern [string map [list \
+ * {[*]} \
+ ? {[?]} \
+ \[ \\\[ \
+ \] \\\[ \
+ _ ? \
+ % *] [string tolower $pattern]]
+ my foreach origrow "PRAGMA table_info('$table')" {
+ set row {}
+ dict for {key value} $origrow {
+ dict set row [string tolower $key] $value
+ }
+ dict set row name [string tolower [dict get $row name]]
+ if {![string match $pattern [dict get $row name]]} {
+ continue
+ }
+ switch -regexp -matchvar info [dict get $row type] {
+ {^(.+)\(\s*([[:digit:]]+)\s*,\s*([[:digit:]]+)\s*\)\s*$} {
+ dict set row type [string tolower [lindex $info 1]]
+ dict set row precision [lindex $info 2]
+ dict set row scale [lindex $info 3]
+ }
+ {^(.+)\(\s*([[:digit:]]+)\s*\)\s*$} {
+ dict set row type [string tolower [lindex $info 1]]
+ dict set row precision [lindex $info 2]
+ dict set row scale 0
+ }
+ default {
+ dict set row type [string tolower [dict get $row type]]
+ dict set row precision 0
+ dict set row scale 0
+ }
+ }
+ dict set row nullable [expr {![dict get $row notnull]}]
+ dict set retval [dict get $row name] $row
+ }
+ return $retval
+ }
+
+ # The 'primarykeys' method enumerates the primary keys on a table.
+
+ method primarykeys {table} {
+ set result {}
+ my foreach row "PRAGMA table_info($table)" {
+ if {[dict get $row pk]} {
+ lappend result [dict create ordinalPosition \
+ [expr {[dict get $row cid]+1}] \
+ columnName \
+ [dict get $row name]]
+ }
+ }
+ return $result
+ }
+
+ # The 'foreignkeys' method enumerates the foreign keys that are
+ # declared in a table or that refer to a given table.
+
+ method foreignkeys {args} {
+
+ variable ::tdbc::generalError
+
+ # Check arguments
+
+ set argdict {}
+ if {[llength $args] % 2 != 0} {
+ set errorcode $generalError
+ lappend errorcode wrongNumArgs
+ return -code error -errorcode $errorcode \
+ "wrong # args: should be [lrange [info level 0] 0 1]\
+ ?-option value?..."
+ }
+ foreach {key value} $args {
+ if {$key ni {-primary -foreign}} {
+ set errorcode $generalError
+ lappend errorcode badOption
+ return -code error -errorcode $errorcode \
+ "bad option \"$key\", must be -primary or -foreign"
+ }
+ set key [string range $key 1 end]
+ if {[dict exists $argdict $key]} {
+ set errorcode $generalError
+ lappend errorcode dupOption
+ return -code error -errorcode $errorcode \
+ "duplicate option \"$key\" supplied"
+ }
+ dict set argdict $key $value
+ }
+
+ # If we know the table with the foreign key, search just its
+ # foreign keys. Otherwise, iterate over all the tables in the
+ # database.
+
+ if {[dict exists $argdict foreign]} {
+ return [my ForeignKeysForTable [dict get $argdict foreign] \
+ $argdict]
+ } else {
+ set result {}
+ foreach foreignTable [dict keys [my tables]] {
+ lappend result {*}[my ForeignKeysForTable \
+ $foreignTable $argdict]
+ }
+ return $result
+ }
+
+ }
+
+ # The private ForeignKeysForTable method enumerates the foreign keys
+ # in a specific table.
+ #
+ # Parameters:
+ #
+ # foreignTable - Name of the table containing foreign keys.
+ # argdict - Dictionary that may or may not contain a key,
+ # 'primary', whose value is the name of a table that
+ # must hold the primary key corresponding to the foreign
+ # key. If the 'primary' key is absent, all tables are
+ # candidates.
+ # Results:
+ #
+ # Returns the list of foreign keys that meed the specified
+ # conditions, as a list of dictionaries, each containing the
+ # keys, foreignConstraintName, foreignTable, foreignColumn,
+ # primaryTable, primaryColumn, and ordinalPosition. Note that the
+ # foreign constraint name is constructed arbitrarily, since SQLite3
+ # does not report this information.
+
+ method ForeignKeysForTable {foreignTable argdict} {
+
+ set result {}
+ set n 0
+
+ # Go through the foreign keys in the given table, looking for
+ # ones that refer to the primary table (if one is given), or
+ # for any primary keys if none is given.
+ my foreach row "PRAGMA foreign_key_list($foreignTable)" {
+ if {(![dict exists $argdict primary])
+ || ([string tolower [dict get $row table]]
+ eq [dict get $argdict primary])} {
+
+ # Construct a dictionary for each key, translating
+ # SQLite names to TDBC ones and converting sequence
+ # numbers to 1-based indexing.
+
+ set rrow [dict create foreignTable $foreignTable \
+ foreignConstraintName \
+ ?$foreignTable?[dict get $row id]]
+ if {[dict exists $row seq]} {
+ dict set rrow ordinalPosition \
+ [expr {1 + [dict get $row seq]}]
+ }
+ foreach {to from} {
+ foreignColumn from
+ primaryTable table
+ primaryColumn to
+ deleteAction on_delete
+ updateAction on_update
+ } {
+ if {[dict exists $row $from]} {
+ dict set rrow $to [dict get $row $from]
+ }
+ }
+
+ # Add the newly-constucted dictionary to the result list
+
+ lappend result $rrow
+ }
+ }
+
+ return $result
+ }
+
+ # The 'preparecall' method prepares a call to a stored procedure.
+ # SQLite3 does not have stored procedures, since it's an in-process
+ # server.
+
+ method preparecall {call} {
+ return -code error \
+ -errorcode [list TDBC FEATURE_NOT_SUPPORTED 0A000 \
+ SQLITE3 PREPARECALL] \
+ {SQLite3 does not support stored procedures}
+ }
+
+ # The 'begintransaction' method launches a database transaction
+
+ method begintransaction {} {
+ db eval {BEGIN TRANSACTION}
+ }
+
+ # The 'commit' method commits a database transaction
+
+ method commit {} {
+ db eval {COMMIT}
+ }
+
+ # The 'rollback' method abandons a database transaction
+
+ method rollback {} {
+ db eval {ROLLBACK}
+ }
+
+ # The 'transaction' method executes a script as a single transaction.
+ # We override the 'transaction' method of the base class, since SQLite3
+ # has a faster implementation of the same thing. (The base class's generic
+ # method should also work.)
+ # (Don't overload the base class method, because 'break', 'continue'
+ # and 'return' in the transaction body don't work!)
+
+ #method transaction {script} {
+ # uplevel 1 [list {*}[namespace code db] transaction $script]
+ #}
+
+ method prepare {sqlCode} {
+ set result [next $sqlCode]
+ return $result
+ }
+
+ method getDBhandle {} {
+ return [namespace which db]
+ }
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::sqlite3::statement --
+#
+# Class representing a statement to execute against a SQLite3 database
+#
+#------------------------------------------------------------------------------
+
+::oo::class create ::tdbc::sqlite3::statement {
+
+ superclass ::tdbc::statement
+
+ variable Params db sql
+
+ # The constructor accepts the handle to the connection and the SQL
+ # code for the statement to prepare. All that it does is to parse the
+ # statement and store it. The parse is used to support the
+ # 'params' and 'paramtype' methods.
+
+ constructor {connection sqlcode} {
+ next
+ set Params {}
+ set db [$connection getDBhandle]
+ set sql $sqlcode
+ foreach token [::tdbc::tokenize $sqlcode] {
+ if {[string index $token 0] in {$ : @}} {
+ dict set Params [string range $token 1 end] \
+ {type Tcl_Obj precision 0 scale 0 nullable 1 direction in}
+ }
+ }
+ }
+
+ # The 'resultSetCreate' method relays to the result set constructor
+
+ forward resultSetCreate ::tdbc::sqlite3::resultset create
+
+ # The 'params' method returns descriptions of the parameters accepted
+ # by the statement
+
+ method params {} {
+ return $Params
+ }
+
+ # The 'paramtype' method need do nothing; Sqlite3 uses manifest typing.
+
+ method paramtype args {;}
+
+ method getDBhandle {} {
+ return $db
+ }
+
+ method getSql {} {
+ return $sql
+ }
+
+}
+
+#-------------------------------------------------------------------------------
+#
+# tdbc::sqlite3::resultset --
+#
+# Class that represents a SQLlite result set in Tcl
+#
+#-------------------------------------------------------------------------------
+
+::oo::class create ::tdbc::sqlite3::resultset {
+
+ superclass ::tdbc::resultset
+
+ # The variables of this class all have peculiar names. The reason is
+ # that the RunQuery method needs to execute with an activation record
+ # that has no local variables whose names could conflict with names
+ # in the SQL query. We start the variable names with hyphens because
+ # they can't be bind variables.
+
+ variable -set {*}{
+ -columns -db -needcolumns -resultArray
+ -results -sql -Cursor -RowCount -END
+ }
+
+ constructor {statement args} {
+ next
+ set -db [$statement getDBhandle]
+ set -sql [$statement getSql]
+ set -columns {}
+ set -results {}
+ ${-db} trace [namespace code {my RecordStatement}]
+ if {[llength $args] == 0} {
+
+ # Variable substitutions are evaluated in caller's context
+
+ uplevel 1 [list ${-db} eval ${-sql} \
+ [namespace which -variable -resultArray] \
+ [namespace code {my RecordResult}]]
+
+ } elseif {[llength $args] == 1} {
+
+ # Variable substitutions are in the dictionary at [lindex $args 0].
+
+ set -paramDict [lindex $args 0]
+
+ # At this point, the activation record must contain no variables
+ # that might be bound within the query. All variables at this point
+ # begin with hyphens so that they are syntactically incorrect
+ # as bound variables in SQL.
+
+ unset args
+ unset statement
+
+ dict with -paramDict {
+ ${-db} eval ${-sql} -resultArray {
+ my RecordResult
+ }
+ }
+
+ } else {
+
+ ${-db} trace {}
+
+ # Too many args
+
+ return -code error \
+ -errorcode [list TDBC GENERAL_ERROR HY000 \
+ SQLITE3 WRONGNUMARGS] \
+ "wrong # args: should be\
+ [lrange [info level 0] 0 1] statement ?dictionary?"
+
+ }
+ ${-db} trace {}
+ set -Cursor 0
+ if {${-Cursor} < [llength ${-results}]
+ && [lindex ${-results} ${-Cursor}] eq {statement}} {
+ incr -Cursor 2
+ }
+ if {${-Cursor} < [llength ${-results}]
+ && [lindex ${-results} ${-Cursor}] eq {columns}} {
+ incr -Cursor
+ set -columns [lindex ${-results} ${-Cursor}]
+ incr -Cursor
+ }
+ set -RowCount [${-db} changes]
+ }
+
+ # Record the start of a SQL statement
+
+ method RecordStatement {stmt} {
+ set -needcolumns 1
+ lappend -results statement {}
+ }
+
+ # Record one row of results from a query by appending it as a dictionary
+ # to the 'results' list. As a side effect, set 'columns' to a list
+ # comprising the names of the columns of the result.
+
+ method RecordResult {} {
+ set columns ${-resultArray(*)}
+ if {[info exists -needcolumns]} {
+ lappend -results columns $columns
+ unset -needcolumns
+ }
+ set dict {}
+ foreach key $columns {
+ if {[set -resultArray($key)] ne "\ufffd"} {
+ dict set dict $key [set -resultArray($key)]
+ }
+ }
+ lappend -results row $dict
+ }
+
+ # Advance to the next result set
+
+ method nextresults {} {
+ set have 0
+ while {${-Cursor} < [llength ${-results}]} {
+ if {[lindex ${-results} ${-Cursor}] eq {statement}} {
+ set have 1
+ incr -Cursor 2
+ break
+ }
+ incr -Cursor 2
+ }
+ if {!$have} {
+ set -END {}
+ }
+ if {${-Cursor} >= [llength ${-results}]} {
+ set -columns {}
+ } elseif {[lindex ${-results} ${-Cursor}] eq {columns}} {
+ incr -Cursor
+ set -columns [lindex ${-results} ${-Cursor}]
+ incr -Cursor
+ } else {
+ set -columns {}
+ }
+ return $have
+ }
+
+ method getDBhandle {} {
+ return ${-db}
+ }
+
+ # Return a list of the columns
+
+ method columns {} {
+ if {[info exists -END]} {
+ return -code error \
+ -errorcode {TDBC GENERAL_ERROR HY010 SQLITE3 FUNCTIONSEQ} \
+ "Function sequence error: result set is exhausted."
+ }
+ return ${-columns}
+ }
+
+ # Return the next row of the result set as a list
+
+ method nextlist var {
+
+ upvar 1 $var row
+
+ if {[info exists -END]} {
+ return -code error \
+ -errorcode {TDBC GENERAL_ERROR HY010 SQLITE3 FUNCTIONSEQ} \
+ "Function sequence error: result set is exhausted."
+ }
+ if {${-Cursor} >= [llength ${-results}]
+ || [lindex ${-results} ${-Cursor}] ne {row}} {
+ return 0
+ } else {
+ set row {}
+ incr -Cursor
+ set d [lindex ${-results} ${-Cursor}]
+ incr -Cursor
+ foreach key ${-columns} {
+ if {[dict exists $d $key]} {
+ lappend row [dict get $d $key]
+ } else {
+ lappend row {}
+ }
+ }
+ }
+ return 1
+ }
+
+ # Return the next row of the result set as a dict
+
+ method nextdict var {
+
+ upvar 1 $var row
+
+ if {[info exists -END]} {
+ return -code error \
+ -errorcode {TDBC GENERAL_ERROR HY010 SQLITE3 FUNCTIONSEQ} \
+ "Function sequence error: result set is exhausted."
+ }
+ if {${-Cursor} >= [llength ${-results}]
+ || [lindex ${-results} ${-Cursor}] ne {row}} {
+ return 0
+ } else {
+ incr -Cursor
+ set row [lindex ${-results} ${-Cursor}]
+ incr -Cursor
+ }
+ return 1
+ }
+
+ # Return the number of rows affected by a statement
+
+ method rowcount {} {
+ if {[info exists -END]} {
+ return -code error \
+ -errorcode {TDBC GENERAL_ERROR HY010 SQLITE3 FUNCTIONSEQ} \
+ "Function sequence error: result set is exhausted."
+ }
+ return ${-RowCount}
+ }
+
+}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/init.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/init.tcl 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/init.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -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.12
+package require -exact Tcl 8.6.13
# Compute the auto path to use in this interpreter.
# The values on the path come from several locations:
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Bahia_Banderas
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Bahia_Banderas 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Bahia_Banderas 2024-02-15 21:05:12 UTC (rev 69897)
@@ -5,7 +5,7 @@
{-1514739600 -25200 0 MST}
{-1343066400 -21600 0 CST}
{-1234807200 -25200 0 MST}
- {-1220292000 -21600 0 CST}
+ {-1220292000 -21600 1 MDT}
{-1207159200 -25200 0 MST}
{-1191344400 -21600 0 CST}
{-873828000 -25200 0 MST}
@@ -65,158 +65,4 @@
{1635663600 -21600 0 CST}
{1648972800 -18000 1 CDT}
{1667113200 -21600 0 CST}
- {1680422400 -18000 1 CDT}
- {1698562800 -21600 0 CST}
- {1712476800 -18000 1 CDT}
- {1730012400 -21600 0 CST}
- {1743926400 -18000 1 CDT}
- {1761462000 -21600 0 CST}
- {1775376000 -18000 1 CDT}
- {1792911600 -21600 0 CST}
- {1806825600 -18000 1 CDT}
- {1824966000 -21600 0 CST}
- {1838275200 -18000 1 CDT}
- {1856415600 -21600 0 CST}
- {1869724800 -18000 1 CDT}
- {1887865200 -21600 0 CST}
- {1901779200 -18000 1 CDT}
- {1919314800 -21600 0 CST}
- {1933228800 -18000 1 CDT}
- {1950764400 -21600 0 CST}
- {1964678400 -18000 1 CDT}
- {1982818800 -21600 0 CST}
- {1996128000 -18000 1 CDT}
- {2014268400 -21600 0 CST}
- {2027577600 -18000 1 CDT}
- {2045718000 -21600 0 CST}
- {2059027200 -18000 1 CDT}
- {2077167600 -21600 0 CST}
- {2091081600 -18000 1 CDT}
- {2108617200 -21600 0 CST}
- {2122531200 -18000 1 CDT}
- {2140066800 -21600 0 CST}
- {2153980800 -18000 1 CDT}
- {2172121200 -21600 0 CST}
- {2185430400 -18000 1 CDT}
- {2203570800 -21600 0 CST}
- {2216880000 -18000 1 CDT}
- {2235020400 -21600 0 CST}
- {2248934400 -18000 1 CDT}
- {2266470000 -21600 0 CST}
- {2280384000 -18000 1 CDT}
- {2297919600 -21600 0 CST}
- {2311833600 -18000 1 CDT}
- {2329369200 -21600 0 CST}
- {2343283200 -18000 1 CDT}
- {2361423600 -21600 0 CST}
- {2374732800 -18000 1 CDT}
- {2392873200 -21600 0 CST}
- {2406182400 -18000 1 CDT}
- {2424322800 -21600 0 CST}
- {2438236800 -18000 1 CDT}
- {2455772400 -21600 0 CST}
- {2469686400 -18000 1 CDT}
- {2487222000 -21600 0 CST}
- {2501136000 -18000 1 CDT}
- {2519276400 -21600 0 CST}
- {2532585600 -18000 1 CDT}
- {2550726000 -21600 0 CST}
- {2564035200 -18000 1 CDT}
- {2582175600 -21600 0 CST}
- {2596089600 -18000 1 CDT}
- {2613625200 -21600 0 CST}
- {2627539200 -18000 1 CDT}
- {2645074800 -21600 0 CST}
- {2658988800 -18000 1 CDT}
- {2676524400 -21600 0 CST}
- {2690438400 -18000 1 CDT}
- {2708578800 -21600 0 CST}
- {2721888000 -18000 1 CDT}
- {2740028400 -21600 0 CST}
- {2753337600 -18000 1 CDT}
- {2771478000 -21600 0 CST}
- {2785392000 -18000 1 CDT}
- {2802927600 -21600 0 CST}
- {2816841600 -18000 1 CDT}
- {2834377200 -21600 0 CST}
- {2848291200 -18000 1 CDT}
- {2866431600 -21600 0 CST}
- {2879740800 -18000 1 CDT}
- {2897881200 -21600 0 CST}
- {2911190400 -18000 1 CDT}
- {2929330800 -21600 0 CST}
- {2942640000 -18000 1 CDT}
- {2960780400 -21600 0 CST}
- {2974694400 -18000 1 CDT}
- {2992230000 -21600 0 CST}
- {3006144000 -18000 1 CDT}
- {3023679600 -21600 0 CST}
- {3037593600 -18000 1 CDT}
- {3055734000 -21600 0 CST}
- {3069043200 -18000 1 CDT}
- {3087183600 -21600 0 CST}
- {3100492800 -18000 1 CDT}
- {3118633200 -21600 0 CST}
- {3132547200 -18000 1 CDT}
- {3150082800 -21600 0 CST}
- {3163996800 -18000 1 CDT}
- {3181532400 -21600 0 CST}
- {3195446400 -18000 1 CDT}
- {3212982000 -21600 0 CST}
- {3226896000 -18000 1 CDT}
- {3245036400 -21600 0 CST}
- {3258345600 -18000 1 CDT}
- {3276486000 -21600 0 CST}
- {3289795200 -18000 1 CDT}
- {3307935600 -21600 0 CST}
- {3321849600 -18000 1 CDT}
- {3339385200 -21600 0 CST}
- {3353299200 -18000 1 CDT}
- {3370834800 -21600 0 CST}
- {3384748800 -18000 1 CDT}
- {3402889200 -21600 0 CST}
- {3416198400 -18000 1 CDT}
- {3434338800 -21600 0 CST}
- {3447648000 -18000 1 CDT}
- {3465788400 -21600 0 CST}
- {3479702400 -18000 1 CDT}
- {3497238000 -21600 0 CST}
- {3511152000 -18000 1 CDT}
- {3528687600 -21600 0 CST}
- {3542601600 -18000 1 CDT}
- {3560137200 -21600 0 CST}
- {3574051200 -18000 1 CDT}
- {3592191600 -21600 0 CST}
- {3605500800 -18000 1 CDT}
- {3623641200 -21600 0 CST}
- {3636950400 -18000 1 CDT}
- {3655090800 -21600 0 CST}
- {3669004800 -18000 1 CDT}
- {3686540400 -21600 0 CST}
- {3700454400 -18000 1 CDT}
- {3717990000 -21600 0 CST}
- {3731904000 -18000 1 CDT}
- {3750044400 -21600 0 CST}
- {3763353600 -18000 1 CDT}
- {3781494000 -21600 0 CST}
- {3794803200 -18000 1 CDT}
- {3812943600 -21600 0 CST}
- {3826252800 -18000 1 CDT}
- {3844393200 -21600 0 CST}
- {3858307200 -18000 1 CDT}
- {3875842800 -21600 0 CST}
- {3889756800 -18000 1 CDT}
- {3907292400 -21600 0 CST}
- {3921206400 -18000 1 CDT}
- {3939346800 -21600 0 CST}
- {3952656000 -18000 1 CDT}
- {3970796400 -21600 0 CST}
- {3984105600 -18000 1 CDT}
- {4002246000 -21600 0 CST}
- {4016160000 -18000 1 CDT}
- {4033695600 -21600 0 CST}
- {4047609600 -18000 1 CDT}
- {4065145200 -21600 0 CST}
- {4079059200 -18000 1 CDT}
- {4096594800 -21600 0 CST}
}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Chihuahua
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Chihuahua 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Chihuahua 2024-02-15 21:05:12 UTC (rev 69897)
@@ -5,7 +5,7 @@
{-1514739600 -25200 0 MST}
{-1343066400 -21600 0 CST}
{-1234807200 -25200 0 MST}
- {-1220292000 -21600 0 CST}
+ {-1220292000 -21600 1 MDT}
{-1207159200 -25200 0 MST}
{-1191344400 -21600 0 CST}
{820476000 -21600 0 CST}
@@ -63,159 +63,5 @@
{1617526800 -21600 1 MDT}
{1635667200 -25200 0 MST}
{1648976400 -21600 1 MDT}
- {1667116800 -25200 0 MST}
- {1680426000 -21600 1 MDT}
- {1698566400 -25200 0 MST}
- {1712480400 -21600 1 MDT}
- {1730016000 -25200 0 MST}
- {1743930000 -21600 1 MDT}
- {1761465600 -25200 0 MST}
- {1775379600 -21600 1 MDT}
- {1792915200 -25200 0 MST}
- {1806829200 -21600 1 MDT}
- {1824969600 -25200 0 MST}
- {1838278800 -21600 1 MDT}
- {1856419200 -25200 0 MST}
- {1869728400 -21600 1 MDT}
- {1887868800 -25200 0 MST}
- {1901782800 -21600 1 MDT}
- {1919318400 -25200 0 MST}
- {1933232400 -21600 1 MDT}
- {1950768000 -25200 0 MST}
- {1964682000 -21600 1 MDT}
- {1982822400 -25200 0 MST}
- {1996131600 -21600 1 MDT}
- {2014272000 -25200 0 MST}
- {2027581200 -21600 1 MDT}
- {2045721600 -25200 0 MST}
- {2059030800 -21600 1 MDT}
- {2077171200 -25200 0 MST}
- {2091085200 -21600 1 MDT}
- {2108620800 -25200 0 MST}
- {2122534800 -21600 1 MDT}
- {2140070400 -25200 0 MST}
- {2153984400 -21600 1 MDT}
- {2172124800 -25200 0 MST}
- {2185434000 -21600 1 MDT}
- {2203574400 -25200 0 MST}
- {2216883600 -21600 1 MDT}
- {2235024000 -25200 0 MST}
- {2248938000 -21600 1 MDT}
- {2266473600 -25200 0 MST}
- {2280387600 -21600 1 MDT}
- {2297923200 -25200 0 MST}
- {2311837200 -21600 1 MDT}
- {2329372800 -25200 0 MST}
- {2343286800 -21600 1 MDT}
- {2361427200 -25200 0 MST}
- {2374736400 -21600 1 MDT}
- {2392876800 -25200 0 MST}
- {2406186000 -21600 1 MDT}
- {2424326400 -25200 0 MST}
- {2438240400 -21600 1 MDT}
- {2455776000 -25200 0 MST}
- {2469690000 -21600 1 MDT}
- {2487225600 -25200 0 MST}
- {2501139600 -21600 1 MDT}
- {2519280000 -25200 0 MST}
- {2532589200 -21600 1 MDT}
- {2550729600 -25200 0 MST}
- {2564038800 -21600 1 MDT}
- {2582179200 -25200 0 MST}
- {2596093200 -21600 1 MDT}
- {2613628800 -25200 0 MST}
- {2627542800 -21600 1 MDT}
- {2645078400 -25200 0 MST}
- {2658992400 -21600 1 MDT}
- {2676528000 -25200 0 MST}
- {2690442000 -21600 1 MDT}
- {2708582400 -25200 0 MST}
- {2721891600 -21600 1 MDT}
- {2740032000 -25200 0 MST}
- {2753341200 -21600 1 MDT}
- {2771481600 -25200 0 MST}
- {2785395600 -21600 1 MDT}
- {2802931200 -25200 0 MST}
- {2816845200 -21600 1 MDT}
- {2834380800 -25200 0 MST}
- {2848294800 -21600 1 MDT}
- {2866435200 -25200 0 MST}
- {2879744400 -21600 1 MDT}
- {2897884800 -25200 0 MST}
- {2911194000 -21600 1 MDT}
- {2929334400 -25200 0 MST}
- {2942643600 -21600 1 MDT}
- {2960784000 -25200 0 MST}
- {2974698000 -21600 1 MDT}
- {2992233600 -25200 0 MST}
- {3006147600 -21600 1 MDT}
- {3023683200 -25200 0 MST}
- {3037597200 -21600 1 MDT}
- {3055737600 -25200 0 MST}
- {3069046800 -21600 1 MDT}
- {3087187200 -25200 0 MST}
- {3100496400 -21600 1 MDT}
- {3118636800 -25200 0 MST}
- {3132550800 -21600 1 MDT}
- {3150086400 -25200 0 MST}
- {3164000400 -21600 1 MDT}
- {3181536000 -25200 0 MST}
- {3195450000 -21600 1 MDT}
- {3212985600 -25200 0 MST}
- {3226899600 -21600 1 MDT}
- {3245040000 -25200 0 MST}
- {3258349200 -21600 1 MDT}
- {3276489600 -25200 0 MST}
- {3289798800 -21600 1 MDT}
- {3307939200 -25200 0 MST}
- {3321853200 -21600 1 MDT}
- {3339388800 -25200 0 MST}
- {3353302800 -21600 1 MDT}
- {3370838400 -25200 0 MST}
- {3384752400 -21600 1 MDT}
- {3402892800 -25200 0 MST}
- {3416202000 -21600 1 MDT}
- {3434342400 -25200 0 MST}
- {3447651600 -21600 1 MDT}
- {3465792000 -25200 0 MST}
- {3479706000 -21600 1 MDT}
- {3497241600 -25200 0 MST}
- {3511155600 -21600 1 MDT}
- {3528691200 -25200 0 MST}
- {3542605200 -21600 1 MDT}
- {3560140800 -25200 0 MST}
- {3574054800 -21600 1 MDT}
- {3592195200 -25200 0 MST}
- {3605504400 -21600 1 MDT}
- {3623644800 -25200 0 MST}
- {3636954000 -21600 1 MDT}
- {3655094400 -25200 0 MST}
- {3669008400 -21600 1 MDT}
- {3686544000 -25200 0 MST}
- {3700458000 -21600 1 MDT}
- {3717993600 -25200 0 MST}
- {3731907600 -21600 1 MDT}
- {3750048000 -25200 0 MST}
- {3763357200 -21600 1 MDT}
- {3781497600 -25200 0 MST}
- {3794806800 -21600 1 MDT}
- {3812947200 -25200 0 MST}
- {3826256400 -21600 1 MDT}
- {3844396800 -25200 0 MST}
- {3858310800 -21600 1 MDT}
- {3875846400 -25200 0 MST}
- {3889760400 -21600 1 MDT}
- {3907296000 -25200 0 MST}
- {3921210000 -21600 1 MDT}
- {3939350400 -25200 0 MST}
- {3952659600 -21600 1 MDT}
- {3970800000 -25200 0 MST}
- {3984109200 -21600 1 MDT}
- {4002249600 -25200 0 MST}
- {4016163600 -21600 1 MDT}
- {4033699200 -25200 0 MST}
- {4047613200 -21600 1 MDT}
- {4065148800 -25200 0 MST}
- {4079062800 -21600 1 MDT}
- {4096598400 -25200 0 MST}
+ {1667120400 -21600 0 CST}
}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Hermosillo
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Hermosillo 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Hermosillo 2024-02-15 21:05:12 UTC (rev 69897)
@@ -5,7 +5,7 @@
{-1514739600 -25200 0 MST}
{-1343066400 -21600 0 CST}
{-1234807200 -25200 0 MST}
- {-1220292000 -21600 0 CST}
+ {-1220292000 -21600 1 MDT}
{-1207159200 -25200 0 MST}
{-1191344400 -21600 0 CST}
{-873828000 -25200 0 MST}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Matamoros
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Matamoros 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Matamoros 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,7 +1,7 @@
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Matamoros) {
- {-9223372036854775808 -24000 0 LMT}
+ {-9223372036854775808 -23400 0 LMT}
{-1514743200 -21600 0 CST}
{568015200 -21600 0 CST}
{576057600 -18000 1 CDT}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Mazatlan
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Mazatlan 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Mazatlan 2024-02-15 21:05:12 UTC (rev 69897)
@@ -5,7 +5,7 @@
{-1514739600 -25200 0 MST}
{-1343066400 -21600 0 CST}
{-1234807200 -25200 0 MST}
- {-1220292000 -21600 0 CST}
+ {-1220292000 -21600 1 MDT}
{-1207159200 -25200 0 MST}
{-1191344400 -21600 0 CST}
{-873828000 -25200 0 MST}
@@ -65,158 +65,4 @@
{1635667200 -25200 0 MST}
{1648976400 -21600 1 MDT}
{1667116800 -25200 0 MST}
- {1680426000 -21600 1 MDT}
- {1698566400 -25200 0 MST}
- {1712480400 -21600 1 MDT}
- {1730016000 -25200 0 MST}
- {1743930000 -21600 1 MDT}
- {1761465600 -25200 0 MST}
- {1775379600 -21600 1 MDT}
- {1792915200 -25200 0 MST}
- {1806829200 -21600 1 MDT}
- {1824969600 -25200 0 MST}
- {1838278800 -21600 1 MDT}
- {1856419200 -25200 0 MST}
- {1869728400 -21600 1 MDT}
- {1887868800 -25200 0 MST}
- {1901782800 -21600 1 MDT}
- {1919318400 -25200 0 MST}
- {1933232400 -21600 1 MDT}
- {1950768000 -25200 0 MST}
- {1964682000 -21600 1 MDT}
- {1982822400 -25200 0 MST}
- {1996131600 -21600 1 MDT}
- {2014272000 -25200 0 MST}
- {2027581200 -21600 1 MDT}
- {2045721600 -25200 0 MST}
- {2059030800 -21600 1 MDT}
- {2077171200 -25200 0 MST}
- {2091085200 -21600 1 MDT}
- {2108620800 -25200 0 MST}
- {2122534800 -21600 1 MDT}
- {2140070400 -25200 0 MST}
- {2153984400 -21600 1 MDT}
- {2172124800 -25200 0 MST}
- {2185434000 -21600 1 MDT}
- {2203574400 -25200 0 MST}
- {2216883600 -21600 1 MDT}
- {2235024000 -25200 0 MST}
- {2248938000 -21600 1 MDT}
- {2266473600 -25200 0 MST}
- {2280387600 -21600 1 MDT}
- {2297923200 -25200 0 MST}
- {2311837200 -21600 1 MDT}
- {2329372800 -25200 0 MST}
- {2343286800 -21600 1 MDT}
- {2361427200 -25200 0 MST}
- {2374736400 -21600 1 MDT}
- {2392876800 -25200 0 MST}
- {2406186000 -21600 1 MDT}
- {2424326400 -25200 0 MST}
- {2438240400 -21600 1 MDT}
- {2455776000 -25200 0 MST}
- {2469690000 -21600 1 MDT}
- {2487225600 -25200 0 MST}
- {2501139600 -21600 1 MDT}
- {2519280000 -25200 0 MST}
- {2532589200 -21600 1 MDT}
- {2550729600 -25200 0 MST}
- {2564038800 -21600 1 MDT}
- {2582179200 -25200 0 MST}
- {2596093200 -21600 1 MDT}
- {2613628800 -25200 0 MST}
- {2627542800 -21600 1 MDT}
- {2645078400 -25200 0 MST}
- {2658992400 -21600 1 MDT}
- {2676528000 -25200 0 MST}
- {2690442000 -21600 1 MDT}
- {2708582400 -25200 0 MST}
- {2721891600 -21600 1 MDT}
- {2740032000 -25200 0 MST}
- {2753341200 -21600 1 MDT}
- {2771481600 -25200 0 MST}
- {2785395600 -21600 1 MDT}
- {2802931200 -25200 0 MST}
- {2816845200 -21600 1 MDT}
- {2834380800 -25200 0 MST}
- {2848294800 -21600 1 MDT}
- {2866435200 -25200 0 MST}
- {2879744400 -21600 1 MDT}
- {2897884800 -25200 0 MST}
- {2911194000 -21600 1 MDT}
- {2929334400 -25200 0 MST}
- {2942643600 -21600 1 MDT}
- {2960784000 -25200 0 MST}
- {2974698000 -21600 1 MDT}
- {2992233600 -25200 0 MST}
- {3006147600 -21600 1 MDT}
- {3023683200 -25200 0 MST}
- {3037597200 -21600 1 MDT}
- {3055737600 -25200 0 MST}
- {3069046800 -21600 1 MDT}
- {3087187200 -25200 0 MST}
- {3100496400 -21600 1 MDT}
- {3118636800 -25200 0 MST}
- {3132550800 -21600 1 MDT}
- {3150086400 -25200 0 MST}
- {3164000400 -21600 1 MDT}
- {3181536000 -25200 0 MST}
- {3195450000 -21600 1 MDT}
- {3212985600 -25200 0 MST}
- {3226899600 -21600 1 MDT}
- {3245040000 -25200 0 MST}
- {3258349200 -21600 1 MDT}
- {3276489600 -25200 0 MST}
- {3289798800 -21600 1 MDT}
- {3307939200 -25200 0 MST}
- {3321853200 -21600 1 MDT}
- {3339388800 -25200 0 MST}
- {3353302800 -21600 1 MDT}
- {3370838400 -25200 0 MST}
- {3384752400 -21600 1 MDT}
- {3402892800 -25200 0 MST}
- {3416202000 -21600 1 MDT}
- {3434342400 -25200 0 MST}
- {3447651600 -21600 1 MDT}
- {3465792000 -25200 0 MST}
- {3479706000 -21600 1 MDT}
- {3497241600 -25200 0 MST}
- {3511155600 -21600 1 MDT}
- {3528691200 -25200 0 MST}
- {3542605200 -21600 1 MDT}
- {3560140800 -25200 0 MST}
- {3574054800 -21600 1 MDT}
- {3592195200 -25200 0 MST}
- {3605504400 -21600 1 MDT}
- {3623644800 -25200 0 MST}
- {3636954000 -21600 1 MDT}
- {3655094400 -25200 0 MST}
- {3669008400 -21600 1 MDT}
- {3686544000 -25200 0 MST}
- {3700458000 -21600 1 MDT}
- {3717993600 -25200 0 MST}
- {3731907600 -21600 1 MDT}
- {3750048000 -25200 0 MST}
- {3763357200 -21600 1 MDT}
- {3781497600 -25200 0 MST}
- {3794806800 -21600 1 MDT}
- {3812947200 -25200 0 MST}
- {3826256400 -21600 1 MDT}
- {3844396800 -25200 0 MST}
- {3858310800 -21600 1 MDT}
- {3875846400 -25200 0 MST}
- {3889760400 -21600 1 MDT}
- {3907296000 -25200 0 MST}
- {3921210000 -21600 1 MDT}
- {3939350400 -25200 0 MST}
- {3952659600 -21600 1 MDT}
- {3970800000 -25200 0 MST}
- {3984109200 -21600 1 MDT}
- {4002249600 -25200 0 MST}
- {4016163600 -21600 1 MDT}
- {4033699200 -25200 0 MST}
- {4047613200 -21600 1 MDT}
- {4065148800 -25200 0 MST}
- {4079062800 -21600 1 MDT}
- {4096598400 -25200 0 MST}
}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Merida
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Merida 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Merida 2024-02-15 21:05:12 UTC (rev 69897)
@@ -59,158 +59,4 @@
{1635663600 -21600 0 CST}
{1648972800 -18000 1 CDT}
{1667113200 -21600 0 CST}
- {1680422400 -18000 1 CDT}
- {1698562800 -21600 0 CST}
- {1712476800 -18000 1 CDT}
- {1730012400 -21600 0 CST}
- {1743926400 -18000 1 CDT}
- {1761462000 -21600 0 CST}
- {1775376000 -18000 1 CDT}
- {1792911600 -21600 0 CST}
- {1806825600 -18000 1 CDT}
- {1824966000 -21600 0 CST}
- {1838275200 -18000 1 CDT}
- {1856415600 -21600 0 CST}
- {1869724800 -18000 1 CDT}
- {1887865200 -21600 0 CST}
- {1901779200 -18000 1 CDT}
- {1919314800 -21600 0 CST}
- {1933228800 -18000 1 CDT}
- {1950764400 -21600 0 CST}
- {1964678400 -18000 1 CDT}
- {1982818800 -21600 0 CST}
- {1996128000 -18000 1 CDT}
- {2014268400 -21600 0 CST}
- {2027577600 -18000 1 CDT}
- {2045718000 -21600 0 CST}
- {2059027200 -18000 1 CDT}
- {2077167600 -21600 0 CST}
- {2091081600 -18000 1 CDT}
- {2108617200 -21600 0 CST}
- {2122531200 -18000 1 CDT}
- {2140066800 -21600 0 CST}
- {2153980800 -18000 1 CDT}
- {2172121200 -21600 0 CST}
- {2185430400 -18000 1 CDT}
- {2203570800 -21600 0 CST}
- {2216880000 -18000 1 CDT}
- {2235020400 -21600 0 CST}
- {2248934400 -18000 1 CDT}
- {2266470000 -21600 0 CST}
- {2280384000 -18000 1 CDT}
- {2297919600 -21600 0 CST}
- {2311833600 -18000 1 CDT}
- {2329369200 -21600 0 CST}
- {2343283200 -18000 1 CDT}
- {2361423600 -21600 0 CST}
- {2374732800 -18000 1 CDT}
- {2392873200 -21600 0 CST}
- {2406182400 -18000 1 CDT}
- {2424322800 -21600 0 CST}
- {2438236800 -18000 1 CDT}
- {2455772400 -21600 0 CST}
- {2469686400 -18000 1 CDT}
- {2487222000 -21600 0 CST}
- {2501136000 -18000 1 CDT}
- {2519276400 -21600 0 CST}
- {2532585600 -18000 1 CDT}
- {2550726000 -21600 0 CST}
- {2564035200 -18000 1 CDT}
- {2582175600 -21600 0 CST}
- {2596089600 -18000 1 CDT}
- {2613625200 -21600 0 CST}
- {2627539200 -18000 1 CDT}
- {2645074800 -21600 0 CST}
- {2658988800 -18000 1 CDT}
- {2676524400 -21600 0 CST}
- {2690438400 -18000 1 CDT}
- {2708578800 -21600 0 CST}
- {2721888000 -18000 1 CDT}
- {2740028400 -21600 0 CST}
- {2753337600 -18000 1 CDT}
- {2771478000 -21600 0 CST}
- {2785392000 -18000 1 CDT}
- {2802927600 -21600 0 CST}
- {2816841600 -18000 1 CDT}
- {2834377200 -21600 0 CST}
- {2848291200 -18000 1 CDT}
- {2866431600 -21600 0 CST}
- {2879740800 -18000 1 CDT}
- {2897881200 -21600 0 CST}
- {2911190400 -18000 1 CDT}
- {2929330800 -21600 0 CST}
- {2942640000 -18000 1 CDT}
- {2960780400 -21600 0 CST}
- {2974694400 -18000 1 CDT}
- {2992230000 -21600 0 CST}
- {3006144000 -18000 1 CDT}
- {3023679600 -21600 0 CST}
- {3037593600 -18000 1 CDT}
- {3055734000 -21600 0 CST}
- {3069043200 -18000 1 CDT}
- {3087183600 -21600 0 CST}
- {3100492800 -18000 1 CDT}
- {3118633200 -21600 0 CST}
- {3132547200 -18000 1 CDT}
- {3150082800 -21600 0 CST}
- {3163996800 -18000 1 CDT}
- {3181532400 -21600 0 CST}
- {3195446400 -18000 1 CDT}
- {3212982000 -21600 0 CST}
- {3226896000 -18000 1 CDT}
- {3245036400 -21600 0 CST}
- {3258345600 -18000 1 CDT}
- {3276486000 -21600 0 CST}
- {3289795200 -18000 1 CDT}
- {3307935600 -21600 0 CST}
- {3321849600 -18000 1 CDT}
- {3339385200 -21600 0 CST}
- {3353299200 -18000 1 CDT}
- {3370834800 -21600 0 CST}
- {3384748800 -18000 1 CDT}
- {3402889200 -21600 0 CST}
- {3416198400 -18000 1 CDT}
- {3434338800 -21600 0 CST}
- {3447648000 -18000 1 CDT}
- {3465788400 -21600 0 CST}
- {3479702400 -18000 1 CDT}
- {3497238000 -21600 0 CST}
- {3511152000 -18000 1 CDT}
- {3528687600 -21600 0 CST}
- {3542601600 -18000 1 CDT}
- {3560137200 -21600 0 CST}
- {3574051200 -18000 1 CDT}
- {3592191600 -21600 0 CST}
- {3605500800 -18000 1 CDT}
- {3623641200 -21600 0 CST}
- {3636950400 -18000 1 CDT}
- {3655090800 -21600 0 CST}
- {3669004800 -18000 1 CDT}
- {3686540400 -21600 0 CST}
- {3700454400 -18000 1 CDT}
- {3717990000 -21600 0 CST}
- {3731904000 -18000 1 CDT}
- {3750044400 -21600 0 CST}
- {3763353600 -18000 1 CDT}
- {3781494000 -21600 0 CST}
- {3794803200 -18000 1 CDT}
- {3812943600 -21600 0 CST}
- {3826252800 -18000 1 CDT}
- {3844393200 -21600 0 CST}
- {3858307200 -18000 1 CDT}
- {3875842800 -21600 0 CST}
- {3889756800 -18000 1 CDT}
- {3907292400 -21600 0 CST}
- {3921206400 -18000 1 CDT}
- {3939346800 -21600 0 CST}
- {3952656000 -18000 1 CDT}
- {3970796400 -21600 0 CST}
- {3984105600 -18000 1 CDT}
- {4002246000 -21600 0 CST}
- {4016160000 -18000 1 CDT}
- {4033695600 -21600 0 CST}
- {4047609600 -18000 1 CDT}
- {4065145200 -21600 0 CST}
- {4079059200 -18000 1 CDT}
- {4096594800 -21600 0 CST}
}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Mexico_City
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Mexico_City 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Mexico_City 2024-02-15 21:05:12 UTC (rev 69897)
@@ -5,7 +5,7 @@
{-1514739600 -25200 0 MST}
{-1343066400 -21600 0 CST}
{-1234807200 -25200 0 MST}
- {-1220292000 -21600 0 CST}
+ {-1220292000 -21600 1 MDT}
{-1207159200 -25200 0 MST}
{-1191344400 -21600 0 CST}
{-975261600 -18000 1 CDT}
@@ -71,158 +71,4 @@
{1635663600 -21600 0 CST}
{1648972800 -18000 1 CDT}
{1667113200 -21600 0 CST}
- {1680422400 -18000 1 CDT}
- {1698562800 -21600 0 CST}
- {1712476800 -18000 1 CDT}
- {1730012400 -21600 0 CST}
- {1743926400 -18000 1 CDT}
- {1761462000 -21600 0 CST}
- {1775376000 -18000 1 CDT}
- {1792911600 -21600 0 CST}
- {1806825600 -18000 1 CDT}
- {1824966000 -21600 0 CST}
- {1838275200 -18000 1 CDT}
- {1856415600 -21600 0 CST}
- {1869724800 -18000 1 CDT}
- {1887865200 -21600 0 CST}
- {1901779200 -18000 1 CDT}
- {1919314800 -21600 0 CST}
- {1933228800 -18000 1 CDT}
- {1950764400 -21600 0 CST}
- {1964678400 -18000 1 CDT}
- {1982818800 -21600 0 CST}
- {1996128000 -18000 1 CDT}
- {2014268400 -21600 0 CST}
- {2027577600 -18000 1 CDT}
- {2045718000 -21600 0 CST}
- {2059027200 -18000 1 CDT}
- {2077167600 -21600 0 CST}
- {2091081600 -18000 1 CDT}
- {2108617200 -21600 0 CST}
- {2122531200 -18000 1 CDT}
- {2140066800 -21600 0 CST}
- {2153980800 -18000 1 CDT}
- {2172121200 -21600 0 CST}
- {2185430400 -18000 1 CDT}
- {2203570800 -21600 0 CST}
- {2216880000 -18000 1 CDT}
- {2235020400 -21600 0 CST}
- {2248934400 -18000 1 CDT}
- {2266470000 -21600 0 CST}
- {2280384000 -18000 1 CDT}
- {2297919600 -21600 0 CST}
- {2311833600 -18000 1 CDT}
- {2329369200 -21600 0 CST}
- {2343283200 -18000 1 CDT}
- {2361423600 -21600 0 CST}
- {2374732800 -18000 1 CDT}
- {2392873200 -21600 0 CST}
- {2406182400 -18000 1 CDT}
- {2424322800 -21600 0 CST}
- {2438236800 -18000 1 CDT}
- {2455772400 -21600 0 CST}
- {2469686400 -18000 1 CDT}
- {2487222000 -21600 0 CST}
- {2501136000 -18000 1 CDT}
- {2519276400 -21600 0 CST}
- {2532585600 -18000 1 CDT}
- {2550726000 -21600 0 CST}
- {2564035200 -18000 1 CDT}
- {2582175600 -21600 0 CST}
- {2596089600 -18000 1 CDT}
- {2613625200 -21600 0 CST}
- {2627539200 -18000 1 CDT}
- {2645074800 -21600 0 CST}
- {2658988800 -18000 1 CDT}
- {2676524400 -21600 0 CST}
- {2690438400 -18000 1 CDT}
- {2708578800 -21600 0 CST}
- {2721888000 -18000 1 CDT}
- {2740028400 -21600 0 CST}
- {2753337600 -18000 1 CDT}
- {2771478000 -21600 0 CST}
- {2785392000 -18000 1 CDT}
- {2802927600 -21600 0 CST}
- {2816841600 -18000 1 CDT}
- {2834377200 -21600 0 CST}
- {2848291200 -18000 1 CDT}
- {2866431600 -21600 0 CST}
- {2879740800 -18000 1 CDT}
- {2897881200 -21600 0 CST}
- {2911190400 -18000 1 CDT}
- {2929330800 -21600 0 CST}
- {2942640000 -18000 1 CDT}
- {2960780400 -21600 0 CST}
- {2974694400 -18000 1 CDT}
- {2992230000 -21600 0 CST}
- {3006144000 -18000 1 CDT}
- {3023679600 -21600 0 CST}
- {3037593600 -18000 1 CDT}
- {3055734000 -21600 0 CST}
- {3069043200 -18000 1 CDT}
- {3087183600 -21600 0 CST}
- {3100492800 -18000 1 CDT}
- {3118633200 -21600 0 CST}
- {3132547200 -18000 1 CDT}
- {3150082800 -21600 0 CST}
- {3163996800 -18000 1 CDT}
- {3181532400 -21600 0 CST}
- {3195446400 -18000 1 CDT}
- {3212982000 -21600 0 CST}
- {3226896000 -18000 1 CDT}
- {3245036400 -21600 0 CST}
- {3258345600 -18000 1 CDT}
- {3276486000 -21600 0 CST}
- {3289795200 -18000 1 CDT}
- {3307935600 -21600 0 CST}
- {3321849600 -18000 1 CDT}
- {3339385200 -21600 0 CST}
- {3353299200 -18000 1 CDT}
- {3370834800 -21600 0 CST}
- {3384748800 -18000 1 CDT}
- {3402889200 -21600 0 CST}
- {3416198400 -18000 1 CDT}
- {3434338800 -21600 0 CST}
- {3447648000 -18000 1 CDT}
- {3465788400 -21600 0 CST}
- {3479702400 -18000 1 CDT}
- {3497238000 -21600 0 CST}
- {3511152000 -18000 1 CDT}
- {3528687600 -21600 0 CST}
- {3542601600 -18000 1 CDT}
- {3560137200 -21600 0 CST}
- {3574051200 -18000 1 CDT}
- {3592191600 -21600 0 CST}
- {3605500800 -18000 1 CDT}
- {3623641200 -21600 0 CST}
- {3636950400 -18000 1 CDT}
- {3655090800 -21600 0 CST}
- {3669004800 -18000 1 CDT}
- {3686540400 -21600 0 CST}
- {3700454400 -18000 1 CDT}
- {3717990000 -21600 0 CST}
- {3731904000 -18000 1 CDT}
- {3750044400 -21600 0 CST}
- {3763353600 -18000 1 CDT}
- {3781494000 -21600 0 CST}
- {3794803200 -18000 1 CDT}
- {3812943600 -21600 0 CST}
- {3826252800 -18000 1 CDT}
- {3844393200 -21600 0 CST}
- {3858307200 -18000 1 CDT}
- {3875842800 -21600 0 CST}
- {3889756800 -18000 1 CDT}
- {3907292400 -21600 0 CST}
- {3921206400 -18000 1 CDT}
- {3939346800 -21600 0 CST}
- {3952656000 -18000 1 CDT}
- {3970796400 -21600 0 CST}
- {3984105600 -18000 1 CDT}
- {4002246000 -21600 0 CST}
- {4016160000 -18000 1 CDT}
- {4033695600 -21600 0 CST}
- {4047609600 -18000 1 CDT}
- {4065145200 -21600 0 CST}
- {4079059200 -18000 1 CDT}
- {4096594800 -21600 0 CST}
}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Monterrey
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Monterrey 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Monterrey 2024-02-15 21:05:12 UTC (rev 69897)
@@ -61,158 +61,4 @@
{1635663600 -21600 0 CST}
{1648972800 -18000 1 CDT}
{1667113200 -21600 0 CST}
- {1680422400 -18000 1 CDT}
- {1698562800 -21600 0 CST}
- {1712476800 -18000 1 CDT}
- {1730012400 -21600 0 CST}
- {1743926400 -18000 1 CDT}
- {1761462000 -21600 0 CST}
- {1775376000 -18000 1 CDT}
- {1792911600 -21600 0 CST}
- {1806825600 -18000 1 CDT}
- {1824966000 -21600 0 CST}
- {1838275200 -18000 1 CDT}
- {1856415600 -21600 0 CST}
- {1869724800 -18000 1 CDT}
- {1887865200 -21600 0 CST}
- {1901779200 -18000 1 CDT}
- {1919314800 -21600 0 CST}
- {1933228800 -18000 1 CDT}
- {1950764400 -21600 0 CST}
- {1964678400 -18000 1 CDT}
- {1982818800 -21600 0 CST}
- {1996128000 -18000 1 CDT}
- {2014268400 -21600 0 CST}
- {2027577600 -18000 1 CDT}
- {2045718000 -21600 0 CST}
- {2059027200 -18000 1 CDT}
- {2077167600 -21600 0 CST}
- {2091081600 -18000 1 CDT}
- {2108617200 -21600 0 CST}
- {2122531200 -18000 1 CDT}
- {2140066800 -21600 0 CST}
- {2153980800 -18000 1 CDT}
- {2172121200 -21600 0 CST}
- {2185430400 -18000 1 CDT}
- {2203570800 -21600 0 CST}
- {2216880000 -18000 1 CDT}
- {2235020400 -21600 0 CST}
- {2248934400 -18000 1 CDT}
- {2266470000 -21600 0 CST}
- {2280384000 -18000 1 CDT}
- {2297919600 -21600 0 CST}
- {2311833600 -18000 1 CDT}
- {2329369200 -21600 0 CST}
- {2343283200 -18000 1 CDT}
- {2361423600 -21600 0 CST}
- {2374732800 -18000 1 CDT}
- {2392873200 -21600 0 CST}
- {2406182400 -18000 1 CDT}
- {2424322800 -21600 0 CST}
- {2438236800 -18000 1 CDT}
- {2455772400 -21600 0 CST}
- {2469686400 -18000 1 CDT}
- {2487222000 -21600 0 CST}
- {2501136000 -18000 1 CDT}
- {2519276400 -21600 0 CST}
- {2532585600 -18000 1 CDT}
- {2550726000 -21600 0 CST}
- {2564035200 -18000 1 CDT}
- {2582175600 -21600 0 CST}
- {2596089600 -18000 1 CDT}
- {2613625200 -21600 0 CST}
- {2627539200 -18000 1 CDT}
- {2645074800 -21600 0 CST}
- {2658988800 -18000 1 CDT}
- {2676524400 -21600 0 CST}
- {2690438400 -18000 1 CDT}
- {2708578800 -21600 0 CST}
- {2721888000 -18000 1 CDT}
- {2740028400 -21600 0 CST}
- {2753337600 -18000 1 CDT}
- {2771478000 -21600 0 CST}
- {2785392000 -18000 1 CDT}
- {2802927600 -21600 0 CST}
- {2816841600 -18000 1 CDT}
- {2834377200 -21600 0 CST}
- {2848291200 -18000 1 CDT}
- {2866431600 -21600 0 CST}
- {2879740800 -18000 1 CDT}
- {2897881200 -21600 0 CST}
- {2911190400 -18000 1 CDT}
- {2929330800 -21600 0 CST}
- {2942640000 -18000 1 CDT}
- {2960780400 -21600 0 CST}
- {2974694400 -18000 1 CDT}
- {2992230000 -21600 0 CST}
- {3006144000 -18000 1 CDT}
- {3023679600 -21600 0 CST}
- {3037593600 -18000 1 CDT}
- {3055734000 -21600 0 CST}
- {3069043200 -18000 1 CDT}
- {3087183600 -21600 0 CST}
- {3100492800 -18000 1 CDT}
- {3118633200 -21600 0 CST}
- {3132547200 -18000 1 CDT}
- {3150082800 -21600 0 CST}
- {3163996800 -18000 1 CDT}
- {3181532400 -21600 0 CST}
- {3195446400 -18000 1 CDT}
- {3212982000 -21600 0 CST}
- {3226896000 -18000 1 CDT}
- {3245036400 -21600 0 CST}
- {3258345600 -18000 1 CDT}
- {3276486000 -21600 0 CST}
- {3289795200 -18000 1 CDT}
- {3307935600 -21600 0 CST}
- {3321849600 -18000 1 CDT}
- {3339385200 -21600 0 CST}
- {3353299200 -18000 1 CDT}
- {3370834800 -21600 0 CST}
- {3384748800 -18000 1 CDT}
- {3402889200 -21600 0 CST}
- {3416198400 -18000 1 CDT}
- {3434338800 -21600 0 CST}
- {3447648000 -18000 1 CDT}
- {3465788400 -21600 0 CST}
- {3479702400 -18000 1 CDT}
- {3497238000 -21600 0 CST}
- {3511152000 -18000 1 CDT}
- {3528687600 -21600 0 CST}
- {3542601600 -18000 1 CDT}
- {3560137200 -21600 0 CST}
- {3574051200 -18000 1 CDT}
- {3592191600 -21600 0 CST}
- {3605500800 -18000 1 CDT}
- {3623641200 -21600 0 CST}
- {3636950400 -18000 1 CDT}
- {3655090800 -21600 0 CST}
- {3669004800 -18000 1 CDT}
- {3686540400 -21600 0 CST}
- {3700454400 -18000 1 CDT}
- {3717990000 -21600 0 CST}
- {3731904000 -18000 1 CDT}
- {3750044400 -21600 0 CST}
- {3763353600 -18000 1 CDT}
- {3781494000 -21600 0 CST}
- {3794803200 -18000 1 CDT}
- {3812943600 -21600 0 CST}
- {3826252800 -18000 1 CDT}
- {3844393200 -21600 0 CST}
- {3858307200 -18000 1 CDT}
- {3875842800 -21600 0 CST}
- {3889756800 -18000 1 CDT}
- {3907292400 -21600 0 CST}
- {3921206400 -18000 1 CDT}
- {3939346800 -21600 0 CST}
- {3952656000 -18000 1 CDT}
- {3970796400 -21600 0 CST}
- {3984105600 -18000 1 CDT}
- {4002246000 -21600 0 CST}
- {4016160000 -18000 1 CDT}
- {4033695600 -21600 0 CST}
- {4047609600 -18000 1 CDT}
- {4065145200 -21600 0 CST}
- {4079059200 -18000 1 CDT}
- {4096594800 -21600 0 CST}
}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Nipigon
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Nipigon 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Nipigon 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,264 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-
-set TZData(:America/Nipigon) {
- {-9223372036854775808 -21184 0 LMT}
- {-2366734016 -18000 0 EST}
- {-1632070800 -14400 1 EDT}
- {-1615140000 -18000 0 EST}
- {-923252400 -14400 1 EDT}
- {-880218000 -14400 0 EWT}
- {-769395600 -14400 1 EPT}
- {-765396000 -18000 0 EST}
- {136364400 -14400 1 EDT}
- {152085600 -18000 0 EST}
- {167814000 -14400 1 EDT}
- {183535200 -18000 0 EST}
- {199263600 -14400 1 EDT}
- {215589600 -18000 0 EST}
- {230713200 -14400 1 EDT}
- {247039200 -18000 0 EST}
- {262767600 -14400 1 EDT}
- {278488800 -18000 0 EST}
- {294217200 -14400 1 EDT}
- {309938400 -18000 0 EST}
- {325666800 -14400 1 EDT}
- {341388000 -18000 0 EST}
- {357116400 -14400 1 EDT}
- {372837600 -18000 0 EST}
- {388566000 -14400 1 EDT}
- {404892000 -18000 0 EST}
- {420015600 -14400 1 EDT}
- {436341600 -18000 0 EST}
- {452070000 -14400 1 EDT}
- {467791200 -18000 0 EST}
- {483519600 -14400 1 EDT}
- {499240800 -18000 0 EST}
- {514969200 -14400 1 EDT}
- {530690400 -18000 0 EST}
- {544604400 -14400 1 EDT}
- {562140000 -18000 0 EST}
- {576054000 -14400 1 EDT}
- {594194400 -18000 0 EST}
- {607503600 -14400 1 EDT}
- {625644000 -18000 0 EST}
- {638953200 -14400 1 EDT}
- {657093600 -18000 0 EST}
- {671007600 -14400 1 EDT}
- {688543200 -18000 0 EST}
- {702457200 -14400 1 EDT}
- {719992800 -18000 0 EST}
- {733906800 -14400 1 EDT}
- {752047200 -18000 0 EST}
- {765356400 -14400 1 EDT}
- {783496800 -18000 0 EST}
- {796806000 -14400 1 EDT}
- {814946400 -18000 0 EST}
- {828860400 -14400 1 EDT}
- {846396000 -18000 0 EST}
- {860310000 -14400 1 EDT}
- {877845600 -18000 0 EST}
- {891759600 -14400 1 EDT}
- {909295200 -18000 0 EST}
- {923209200 -14400 1 EDT}
- {941349600 -18000 0 EST}
- {954658800 -14400 1 EDT}
- {972799200 -18000 0 EST}
- {986108400 -14400 1 EDT}
- {1004248800 -18000 0 EST}
- {1018162800 -14400 1 EDT}
- {1035698400 -18000 0 EST}
- {1049612400 -14400 1 EDT}
- {1067148000 -18000 0 EST}
- {1081062000 -14400 1 EDT}
- {1099202400 -18000 0 EST}
- {1112511600 -14400 1 EDT}
- {1130652000 -18000 0 EST}
- {1143961200 -14400 1 EDT}
- {1162101600 -18000 0 EST}
- {1173596400 -14400 1 EDT}
- {1194156000 -18000 0 EST}
- {1205046000 -14400 1 EDT}
- {1225605600 -18000 0 EST}
- {1236495600 -14400 1 EDT}
- {1257055200 -18000 0 EST}
- {1268550000 -14400 1 EDT}
- {1289109600 -18000 0 EST}
- {1299999600 -14400 1 EDT}
- {1320559200 -18000 0 EST}
- {1331449200 -14400 1 EDT}
- {1352008800 -18000 0 EST}
- {1362898800 -14400 1 EDT}
- {1383458400 -18000 0 EST}
- {1394348400 -14400 1 EDT}
- {1414908000 -18000 0 EST}
- {1425798000 -14400 1 EDT}
- {1446357600 -18000 0 EST}
- {1457852400 -14400 1 EDT}
- {1478412000 -18000 0 EST}
- {1489302000 -14400 1 EDT}
- {1509861600 -18000 0 EST}
- {1520751600 -14400 1 EDT}
- {1541311200 -18000 0 EST}
- {1552201200 -14400 1 EDT}
- {1572760800 -18000 0 EST}
- {1583650800 -14400 1 EDT}
- {1604210400 -18000 0 EST}
- {1615705200 -14400 1 EDT}
- {1636264800 -18000 0 EST}
- {1647154800 -14400 1 EDT}
- {1667714400 -18000 0 EST}
- {1678604400 -14400 1 EDT}
- {1699164000 -18000 0 EST}
- {1710054000 -14400 1 EDT}
- {1730613600 -18000 0 EST}
- {1741503600 -14400 1 EDT}
- {1762063200 -18000 0 EST}
- {1772953200 -14400 1 EDT}
- {1793512800 -18000 0 EST}
- {1805007600 -14400 1 EDT}
- {1825567200 -18000 0 EST}
- {1836457200 -14400 1 EDT}
- {1857016800 -18000 0 EST}
- {1867906800 -14400 1 EDT}
- {1888466400 -18000 0 EST}
- {1899356400 -14400 1 EDT}
- {1919916000 -18000 0 EST}
- {1930806000 -14400 1 EDT}
- {1951365600 -18000 0 EST}
- {1962860400 -14400 1 EDT}
- {1983420000 -18000 0 EST}
- {1994310000 -14400 1 EDT}
- {2014869600 -18000 0 EST}
- {2025759600 -14400 1 EDT}
- {2046319200 -18000 0 EST}
- {2057209200 -14400 1 EDT}
- {2077768800 -18000 0 EST}
- {2088658800 -14400 1 EDT}
- {2109218400 -18000 0 EST}
- {2120108400 -14400 1 EDT}
- {2140668000 -18000 0 EST}
- {2152162800 -14400 1 EDT}
- {2172722400 -18000 0 EST}
- {2183612400 -14400 1 EDT}
- {2204172000 -18000 0 EST}
- {2215062000 -14400 1 EDT}
- {2235621600 -18000 0 EST}
- {2246511600 -14400 1 EDT}
- {2267071200 -18000 0 EST}
- {2277961200 -14400 1 EDT}
- {2298520800 -18000 0 EST}
- {2309410800 -14400 1 EDT}
- {2329970400 -18000 0 EST}
- {2341465200 -14400 1 EDT}
- {2362024800 -18000 0 EST}
- {2372914800 -14400 1 EDT}
- {2393474400 -18000 0 EST}
- {2404364400 -14400 1 EDT}
- {2424924000 -18000 0 EST}
- {2435814000 -14400 1 EDT}
- {2456373600 -18000 0 EST}
- {2467263600 -14400 1 EDT}
- {2487823200 -18000 0 EST}
- {2499318000 -14400 1 EDT}
- {2519877600 -18000 0 EST}
- {2530767600 -14400 1 EDT}
- {2551327200 -18000 0 EST}
- {2562217200 -14400 1 EDT}
- {2582776800 -18000 0 EST}
- {2593666800 -14400 1 EDT}
- {2614226400 -18000 0 EST}
- {2625116400 -14400 1 EDT}
- {2645676000 -18000 0 EST}
- {2656566000 -14400 1 EDT}
- {2677125600 -18000 0 EST}
- {2688620400 -14400 1 EDT}
- {2709180000 -18000 0 EST}
- {2720070000 -14400 1 EDT}
- {2740629600 -18000 0 EST}
- {2751519600 -14400 1 EDT}
- {2772079200 -18000 0 EST}
- {2782969200 -14400 1 EDT}
- {2803528800 -18000 0 EST}
- {2814418800 -14400 1 EDT}
- {2834978400 -18000 0 EST}
- {2846473200 -14400 1 EDT}
- {2867032800 -18000 0 EST}
- {2877922800 -14400 1 EDT}
- {2898482400 -18000 0 EST}
- {2909372400 -14400 1 EDT}
- {2929932000 -18000 0 EST}
- {2940822000 -14400 1 EDT}
- {2961381600 -18000 0 EST}
- {2972271600 -14400 1 EDT}
- {2992831200 -18000 0 EST}
- {3003721200 -14400 1 EDT}
- {3024280800 -18000 0 EST}
- {3035775600 -14400 1 EDT}
- {3056335200 -18000 0 EST}
- {3067225200 -14400 1 EDT}
- {3087784800 -18000 0 EST}
- {3098674800 -14400 1 EDT}
- {3119234400 -18000 0 EST}
- {3130124400 -14400 1 EDT}
- {3150684000 -18000 0 EST}
- {3161574000 -14400 1 EDT}
- {3182133600 -18000 0 EST}
- {3193023600 -14400 1 EDT}
- {3213583200 -18000 0 EST}
- {3225078000 -14400 1 EDT}
- {3245637600 -18000 0 EST}
- {3256527600 -14400 1 EDT}
- {3277087200 -18000 0 EST}
- {3287977200 -14400 1 EDT}
- {3308536800 -18000 0 EST}
- {3319426800 -14400 1 EDT}
- {3339986400 -18000 0 EST}
- {3350876400 -14400 1 EDT}
- {3371436000 -18000 0 EST}
- {3382930800 -14400 1 EDT}
- {3403490400 -18000 0 EST}
- {3414380400 -14400 1 EDT}
- {3434940000 -18000 0 EST}
- {3445830000 -14400 1 EDT}
- {3466389600 -18000 0 EST}
- {3477279600 -14400 1 EDT}
- {3497839200 -18000 0 EST}
- {3508729200 -14400 1 EDT}
- {3529288800 -18000 0 EST}
- {3540178800 -14400 1 EDT}
- {3560738400 -18000 0 EST}
- {3572233200 -14400 1 EDT}
- {3592792800 -18000 0 EST}
- {3603682800 -14400 1 EDT}
- {3624242400 -18000 0 EST}
- {3635132400 -14400 1 EDT}
- {3655692000 -18000 0 EST}
- {3666582000 -14400 1 EDT}
- {3687141600 -18000 0 EST}
- {3698031600 -14400 1 EDT}
- {3718591200 -18000 0 EST}
- {3730086000 -14400 1 EDT}
- {3750645600 -18000 0 EST}
- {3761535600 -14400 1 EDT}
- {3782095200 -18000 0 EST}
- {3792985200 -14400 1 EDT}
- {3813544800 -18000 0 EST}
- {3824434800 -14400 1 EDT}
- {3844994400 -18000 0 EST}
- {3855884400 -14400 1 EDT}
- {3876444000 -18000 0 EST}
- {3887334000 -14400 1 EDT}
- {3907893600 -18000 0 EST}
- {3919388400 -14400 1 EDT}
- {3939948000 -18000 0 EST}
- {3950838000 -14400 1 EDT}
- {3971397600 -18000 0 EST}
- {3982287600 -14400 1 EDT}
- {4002847200 -18000 0 EST}
- {4013737200 -14400 1 EDT}
- {4034296800 -18000 0 EST}
- {4045186800 -14400 1 EDT}
- {4065746400 -18000 0 EST}
- {4076636400 -14400 1 EDT}
- {4097196000 -18000 0 EST}
+if {![info exists TZData(America/Toronto)]} {
+ LoadTimeZoneFile America/Toronto
}
+set TZData(:America/Nipigon) $TZData(:America/Toronto)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Ojinaga
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Ojinaga 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Ojinaga 2024-02-15 21:05:12 UTC (rev 69897)
@@ -5,7 +5,7 @@
{-1514739600 -25200 0 MST}
{-1343066400 -21600 0 CST}
{-1234807200 -25200 0 MST}
- {-1220292000 -21600 0 CST}
+ {-1220292000 -21600 1 MDT}
{-1207159200 -25200 0 MST}
{-1191344400 -21600 0 CST}
{820476000 -21600 0 CST}
@@ -64,159 +64,5 @@
{1615712400 -21600 1 MDT}
{1636272000 -25200 0 MST}
{1647162000 -21600 1 MDT}
- {1667721600 -25200 0 MST}
- {1678611600 -21600 1 MDT}
- {1699171200 -25200 0 MST}
- {1710061200 -21600 1 MDT}
- {1730620800 -25200 0 MST}
- {1741510800 -21600 1 MDT}
- {1762070400 -25200 0 MST}
- {1772960400 -21600 1 MDT}
- {1793520000 -25200 0 MST}
- {1805014800 -21600 1 MDT}
- {1825574400 -25200 0 MST}
- {1836464400 -21600 1 MDT}
- {1857024000 -25200 0 MST}
- {1867914000 -21600 1 MDT}
- {1888473600 -25200 0 MST}
- {1899363600 -21600 1 MDT}
- {1919923200 -25200 0 MST}
- {1930813200 -21600 1 MDT}
- {1951372800 -25200 0 MST}
- {1962867600 -21600 1 MDT}
- {1983427200 -25200 0 MST}
- {1994317200 -21600 1 MDT}
- {2014876800 -25200 0 MST}
- {2025766800 -21600 1 MDT}
- {2046326400 -25200 0 MST}
- {2057216400 -21600 1 MDT}
- {2077776000 -25200 0 MST}
- {2088666000 -21600 1 MDT}
- {2109225600 -25200 0 MST}
- {2120115600 -21600 1 MDT}
- {2140675200 -25200 0 MST}
- {2152170000 -21600 1 MDT}
- {2172729600 -25200 0 MST}
- {2183619600 -21600 1 MDT}
- {2204179200 -25200 0 MST}
- {2215069200 -21600 1 MDT}
- {2235628800 -25200 0 MST}
- {2246518800 -21600 1 MDT}
- {2267078400 -25200 0 MST}
- {2277968400 -21600 1 MDT}
- {2298528000 -25200 0 MST}
- {2309418000 -21600 1 MDT}
- {2329977600 -25200 0 MST}
- {2341472400 -21600 1 MDT}
- {2362032000 -25200 0 MST}
- {2372922000 -21600 1 MDT}
- {2393481600 -25200 0 MST}
- {2404371600 -21600 1 MDT}
- {2424931200 -25200 0 MST}
- {2435821200 -21600 1 MDT}
- {2456380800 -25200 0 MST}
- {2467270800 -21600 1 MDT}
- {2487830400 -25200 0 MST}
- {2499325200 -21600 1 MDT}
- {2519884800 -25200 0 MST}
- {2530774800 -21600 1 MDT}
- {2551334400 -25200 0 MST}
- {2562224400 -21600 1 MDT}
- {2582784000 -25200 0 MST}
- {2593674000 -21600 1 MDT}
- {2614233600 -25200 0 MST}
- {2625123600 -21600 1 MDT}
- {2645683200 -25200 0 MST}
- {2656573200 -21600 1 MDT}
- {2677132800 -25200 0 MST}
- {2688627600 -21600 1 MDT}
- {2709187200 -25200 0 MST}
- {2720077200 -21600 1 MDT}
- {2740636800 -25200 0 MST}
- {2751526800 -21600 1 MDT}
- {2772086400 -25200 0 MST}
- {2782976400 -21600 1 MDT}
- {2803536000 -25200 0 MST}
- {2814426000 -21600 1 MDT}
- {2834985600 -25200 0 MST}
- {2846480400 -21600 1 MDT}
- {2867040000 -25200 0 MST}
- {2877930000 -21600 1 MDT}
- {2898489600 -25200 0 MST}
- {2909379600 -21600 1 MDT}
- {2929939200 -25200 0 MST}
- {2940829200 -21600 1 MDT}
- {2961388800 -25200 0 MST}
- {2972278800 -21600 1 MDT}
- {2992838400 -25200 0 MST}
- {3003728400 -21600 1 MDT}
- {3024288000 -25200 0 MST}
- {3035782800 -21600 1 MDT}
- {3056342400 -25200 0 MST}
- {3067232400 -21600 1 MDT}
- {3087792000 -25200 0 MST}
- {3098682000 -21600 1 MDT}
- {3119241600 -25200 0 MST}
- {3130131600 -21600 1 MDT}
- {3150691200 -25200 0 MST}
- {3161581200 -21600 1 MDT}
- {3182140800 -25200 0 MST}
- {3193030800 -21600 1 MDT}
- {3213590400 -25200 0 MST}
- {3225085200 -21600 1 MDT}
- {3245644800 -25200 0 MST}
- {3256534800 -21600 1 MDT}
- {3277094400 -25200 0 MST}
- {3287984400 -21600 1 MDT}
- {3308544000 -25200 0 MST}
- {3319434000 -21600 1 MDT}
- {3339993600 -25200 0 MST}
- {3350883600 -21600 1 MDT}
- {3371443200 -25200 0 MST}
- {3382938000 -21600 1 MDT}
- {3403497600 -25200 0 MST}
- {3414387600 -21600 1 MDT}
- {3434947200 -25200 0 MST}
- {3445837200 -21600 1 MDT}
- {3466396800 -25200 0 MST}
- {3477286800 -21600 1 MDT}
- {3497846400 -25200 0 MST}
- {3508736400 -21600 1 MDT}
- {3529296000 -25200 0 MST}
- {3540186000 -21600 1 MDT}
- {3560745600 -25200 0 MST}
- {3572240400 -21600 1 MDT}
- {3592800000 -25200 0 MST}
- {3603690000 -21600 1 MDT}
- {3624249600 -25200 0 MST}
- {3635139600 -21600 1 MDT}
- {3655699200 -25200 0 MST}
- {3666589200 -21600 1 MDT}
- {3687148800 -25200 0 MST}
- {3698038800 -21600 1 MDT}
- {3718598400 -25200 0 MST}
- {3730093200 -21600 1 MDT}
- {3750652800 -25200 0 MST}
- {3761542800 -21600 1 MDT}
- {3782102400 -25200 0 MST}
- {3792992400 -21600 1 MDT}
- {3813552000 -25200 0 MST}
- {3824442000 -21600 1 MDT}
- {3845001600 -25200 0 MST}
- {3855891600 -21600 1 MDT}
- {3876451200 -25200 0 MST}
- {3887341200 -21600 1 MDT}
- {3907900800 -25200 0 MST}
- {3919395600 -21600 1 MDT}
- {3939955200 -25200 0 MST}
- {3950845200 -21600 1 MDT}
- {3971404800 -25200 0 MST}
- {3982294800 -21600 1 MDT}
- {4002854400 -25200 0 MST}
- {4013744400 -21600 1 MDT}
- {4034304000 -25200 0 MST}
- {4045194000 -21600 1 MDT}
- {4065753600 -25200 0 MST}
- {4076643600 -21600 1 MDT}
- {4097203200 -25200 0 MST}
+ {1667120400 -21600 0 CST}
}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Punta_Arenas
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Punta_Arenas 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Punta_Arenas 2024-02-15 21:05:12 UTC (rev 69897)
@@ -2,12 +2,12 @@
set TZData(:America/Punta_Arenas) {
{-9223372036854775808 -17020 0 LMT}
- {-2524504580 -16966 0 SMT}
- {-1892661434 -18000 0 -05}
- {-1688410800 -16966 0 SMT}
- {-1619205434 -14400 0 -04}
- {-1593806400 -16966 0 SMT}
- {-1335986234 -18000 0 -05}
+ {-2524504580 -16965 0 SMT}
+ {-1892661435 -18000 0 -05}
+ {-1688410800 -16965 0 SMT}
+ {-1619205435 -14400 0 -04}
+ {-1593806400 -16965 0 SMT}
+ {-1335986235 -18000 0 -05}
{-1335985200 -14400 1 -05}
{-1317585600 -18000 0 -05}
{-1304362800 -14400 1 -05}
@@ -21,6 +21,7 @@
{-1178132400 -14400 0 -04}
{-870552000 -18000 0 -05}
{-865278000 -14400 0 -04}
+ {-736632000 -14400 1 -04}
{-718056000 -18000 0 -05}
{-713649600 -14400 0 -04}
{-36619200 -10800 1 -04}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Rainy_River
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Rainy_River 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Rainy_River 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,264 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-
-set TZData(:America/Rainy_River) {
- {-9223372036854775808 -22696 0 LMT}
- {-2366732504 -21600 0 CST}
- {-1632067200 -18000 1 CDT}
- {-1615136400 -21600 0 CST}
- {-923248800 -18000 1 CDT}
- {-880214400 -18000 0 CWT}
- {-769395600 -18000 1 CPT}
- {-765392400 -21600 0 CST}
- {136368000 -18000 1 CDT}
- {152089200 -21600 0 CST}
- {167817600 -18000 1 CDT}
- {183538800 -21600 0 CST}
- {199267200 -18000 1 CDT}
- {215593200 -21600 0 CST}
- {230716800 -18000 1 CDT}
- {247042800 -21600 0 CST}
- {262771200 -18000 1 CDT}
- {278492400 -21600 0 CST}
- {294220800 -18000 1 CDT}
- {309942000 -21600 0 CST}
- {325670400 -18000 1 CDT}
- {341391600 -21600 0 CST}
- {357120000 -18000 1 CDT}
- {372841200 -21600 0 CST}
- {388569600 -18000 1 CDT}
- {404895600 -21600 0 CST}
- {420019200 -18000 1 CDT}
- {436345200 -21600 0 CST}
- {452073600 -18000 1 CDT}
- {467794800 -21600 0 CST}
- {483523200 -18000 1 CDT}
- {499244400 -21600 0 CST}
- {514972800 -18000 1 CDT}
- {530694000 -21600 0 CST}
- {544608000 -18000 1 CDT}
- {562143600 -21600 0 CST}
- {576057600 -18000 1 CDT}
- {594198000 -21600 0 CST}
- {607507200 -18000 1 CDT}
- {625647600 -21600 0 CST}
- {638956800 -18000 1 CDT}
- {657097200 -21600 0 CST}
- {671011200 -18000 1 CDT}
- {688546800 -21600 0 CST}
- {702460800 -18000 1 CDT}
- {719996400 -21600 0 CST}
- {733910400 -18000 1 CDT}
- {752050800 -21600 0 CST}
- {765360000 -18000 1 CDT}
- {783500400 -21600 0 CST}
- {796809600 -18000 1 CDT}
- {814950000 -21600 0 CST}
- {828864000 -18000 1 CDT}
- {846399600 -21600 0 CST}
- {860313600 -18000 1 CDT}
- {877849200 -21600 0 CST}
- {891763200 -18000 1 CDT}
- {909298800 -21600 0 CST}
- {923212800 -18000 1 CDT}
- {941353200 -21600 0 CST}
- {954662400 -18000 1 CDT}
- {972802800 -21600 0 CST}
- {986112000 -18000 1 CDT}
- {1004252400 -21600 0 CST}
- {1018166400 -18000 1 CDT}
- {1035702000 -21600 0 CST}
- {1049616000 -18000 1 CDT}
- {1067151600 -21600 0 CST}
- {1081065600 -18000 1 CDT}
- {1099206000 -21600 0 CST}
- {1112515200 -18000 1 CDT}
- {1130655600 -21600 0 CST}
- {1143964800 -18000 1 CDT}
- {1162105200 -21600 0 CST}
- {1173600000 -18000 1 CDT}
- {1194159600 -21600 0 CST}
- {1205049600 -18000 1 CDT}
- {1225609200 -21600 0 CST}
- {1236499200 -18000 1 CDT}
- {1257058800 -21600 0 CST}
- {1268553600 -18000 1 CDT}
- {1289113200 -21600 0 CST}
- {1300003200 -18000 1 CDT}
- {1320562800 -21600 0 CST}
- {1331452800 -18000 1 CDT}
- {1352012400 -21600 0 CST}
- {1362902400 -18000 1 CDT}
- {1383462000 -21600 0 CST}
- {1394352000 -18000 1 CDT}
- {1414911600 -21600 0 CST}
- {1425801600 -18000 1 CDT}
- {1446361200 -21600 0 CST}
- {1457856000 -18000 1 CDT}
- {1478415600 -21600 0 CST}
- {1489305600 -18000 1 CDT}
- {1509865200 -21600 0 CST}
- {1520755200 -18000 1 CDT}
- {1541314800 -21600 0 CST}
- {1552204800 -18000 1 CDT}
- {1572764400 -21600 0 CST}
- {1583654400 -18000 1 CDT}
- {1604214000 -21600 0 CST}
- {1615708800 -18000 1 CDT}
- {1636268400 -21600 0 CST}
- {1647158400 -18000 1 CDT}
- {1667718000 -21600 0 CST}
- {1678608000 -18000 1 CDT}
- {1699167600 -21600 0 CST}
- {1710057600 -18000 1 CDT}
- {1730617200 -21600 0 CST}
- {1741507200 -18000 1 CDT}
- {1762066800 -21600 0 CST}
- {1772956800 -18000 1 CDT}
- {1793516400 -21600 0 CST}
- {1805011200 -18000 1 CDT}
- {1825570800 -21600 0 CST}
- {1836460800 -18000 1 CDT}
- {1857020400 -21600 0 CST}
- {1867910400 -18000 1 CDT}
- {1888470000 -21600 0 CST}
- {1899360000 -18000 1 CDT}
- {1919919600 -21600 0 CST}
- {1930809600 -18000 1 CDT}
- {1951369200 -21600 0 CST}
- {1962864000 -18000 1 CDT}
- {1983423600 -21600 0 CST}
- {1994313600 -18000 1 CDT}
- {2014873200 -21600 0 CST}
- {2025763200 -18000 1 CDT}
- {2046322800 -21600 0 CST}
- {2057212800 -18000 1 CDT}
- {2077772400 -21600 0 CST}
- {2088662400 -18000 1 CDT}
- {2109222000 -21600 0 CST}
- {2120112000 -18000 1 CDT}
- {2140671600 -21600 0 CST}
- {2152166400 -18000 1 CDT}
- {2172726000 -21600 0 CST}
- {2183616000 -18000 1 CDT}
- {2204175600 -21600 0 CST}
- {2215065600 -18000 1 CDT}
- {2235625200 -21600 0 CST}
- {2246515200 -18000 1 CDT}
- {2267074800 -21600 0 CST}
- {2277964800 -18000 1 CDT}
- {2298524400 -21600 0 CST}
- {2309414400 -18000 1 CDT}
- {2329974000 -21600 0 CST}
- {2341468800 -18000 1 CDT}
- {2362028400 -21600 0 CST}
- {2372918400 -18000 1 CDT}
- {2393478000 -21600 0 CST}
- {2404368000 -18000 1 CDT}
- {2424927600 -21600 0 CST}
- {2435817600 -18000 1 CDT}
- {2456377200 -21600 0 CST}
- {2467267200 -18000 1 CDT}
- {2487826800 -21600 0 CST}
- {2499321600 -18000 1 CDT}
- {2519881200 -21600 0 CST}
- {2530771200 -18000 1 CDT}
- {2551330800 -21600 0 CST}
- {2562220800 -18000 1 CDT}
- {2582780400 -21600 0 CST}
- {2593670400 -18000 1 CDT}
- {2614230000 -21600 0 CST}
- {2625120000 -18000 1 CDT}
- {2645679600 -21600 0 CST}
- {2656569600 -18000 1 CDT}
- {2677129200 -21600 0 CST}
- {2688624000 -18000 1 CDT}
- {2709183600 -21600 0 CST}
- {2720073600 -18000 1 CDT}
- {2740633200 -21600 0 CST}
- {2751523200 -18000 1 CDT}
- {2772082800 -21600 0 CST}
- {2782972800 -18000 1 CDT}
- {2803532400 -21600 0 CST}
- {2814422400 -18000 1 CDT}
- {2834982000 -21600 0 CST}
- {2846476800 -18000 1 CDT}
- {2867036400 -21600 0 CST}
- {2877926400 -18000 1 CDT}
- {2898486000 -21600 0 CST}
- {2909376000 -18000 1 CDT}
- {2929935600 -21600 0 CST}
- {2940825600 -18000 1 CDT}
- {2961385200 -21600 0 CST}
- {2972275200 -18000 1 CDT}
- {2992834800 -21600 0 CST}
- {3003724800 -18000 1 CDT}
- {3024284400 -21600 0 CST}
- {3035779200 -18000 1 CDT}
- {3056338800 -21600 0 CST}
- {3067228800 -18000 1 CDT}
- {3087788400 -21600 0 CST}
- {3098678400 -18000 1 CDT}
- {3119238000 -21600 0 CST}
- {3130128000 -18000 1 CDT}
- {3150687600 -21600 0 CST}
- {3161577600 -18000 1 CDT}
- {3182137200 -21600 0 CST}
- {3193027200 -18000 1 CDT}
- {3213586800 -21600 0 CST}
- {3225081600 -18000 1 CDT}
- {3245641200 -21600 0 CST}
- {3256531200 -18000 1 CDT}
- {3277090800 -21600 0 CST}
- {3287980800 -18000 1 CDT}
- {3308540400 -21600 0 CST}
- {3319430400 -18000 1 CDT}
- {3339990000 -21600 0 CST}
- {3350880000 -18000 1 CDT}
- {3371439600 -21600 0 CST}
- {3382934400 -18000 1 CDT}
- {3403494000 -21600 0 CST}
- {3414384000 -18000 1 CDT}
- {3434943600 -21600 0 CST}
- {3445833600 -18000 1 CDT}
- {3466393200 -21600 0 CST}
- {3477283200 -18000 1 CDT}
- {3497842800 -21600 0 CST}
- {3508732800 -18000 1 CDT}
- {3529292400 -21600 0 CST}
- {3540182400 -18000 1 CDT}
- {3560742000 -21600 0 CST}
- {3572236800 -18000 1 CDT}
- {3592796400 -21600 0 CST}
- {3603686400 -18000 1 CDT}
- {3624246000 -21600 0 CST}
- {3635136000 -18000 1 CDT}
- {3655695600 -21600 0 CST}
- {3666585600 -18000 1 CDT}
- {3687145200 -21600 0 CST}
- {3698035200 -18000 1 CDT}
- {3718594800 -21600 0 CST}
- {3730089600 -18000 1 CDT}
- {3750649200 -21600 0 CST}
- {3761539200 -18000 1 CDT}
- {3782098800 -21600 0 CST}
- {3792988800 -18000 1 CDT}
- {3813548400 -21600 0 CST}
- {3824438400 -18000 1 CDT}
- {3844998000 -21600 0 CST}
- {3855888000 -18000 1 CDT}
- {3876447600 -21600 0 CST}
- {3887337600 -18000 1 CDT}
- {3907897200 -21600 0 CST}
- {3919392000 -18000 1 CDT}
- {3939951600 -21600 0 CST}
- {3950841600 -18000 1 CDT}
- {3971401200 -21600 0 CST}
- {3982291200 -18000 1 CDT}
- {4002850800 -21600 0 CST}
- {4013740800 -18000 1 CDT}
- {4034300400 -21600 0 CST}
- {4045190400 -18000 1 CDT}
- {4065750000 -21600 0 CST}
- {4076640000 -18000 1 CDT}
- {4097199600 -21600 0 CST}
+if {![info exists TZData(America/Winnipeg)]} {
+ LoadTimeZoneFile America/Winnipeg
}
+set TZData(:America/Rainy_River) $TZData(:America/Winnipeg)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Santiago
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Santiago 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Santiago 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,13 +1,13 @@
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Santiago) {
- {-9223372036854775808 -16966 0 LMT}
- {-2524504634 -16966 0 SMT}
- {-1892661434 -18000 0 -05}
- {-1688410800 -16966 0 SMT}
- {-1619205434 -14400 0 -04}
- {-1593806400 -16966 0 SMT}
- {-1335986234 -18000 0 -05}
+ {-9223372036854775808 -16965 0 LMT}
+ {-2524504635 -16965 0 SMT}
+ {-1892661435 -18000 0 -05}
+ {-1688410800 -16965 0 SMT}
+ {-1619205435 -14400 0 -04}
+ {-1593806400 -16965 0 SMT}
+ {-1335986235 -18000 0 -05}
{-1335985200 -14400 1 -05}
{-1317585600 -18000 0 -05}
{-1304362800 -14400 1 -05}
@@ -22,7 +22,7 @@
{-870552000 -18000 0 -05}
{-865278000 -14400 0 -04}
{-740520000 -10800 1 -03}
- {-736376400 -14400 0 -04}
+ {-736635600 -14400 1 -04}
{-718056000 -18000 0 -05}
{-713649600 -14400 0 -04}
{-36619200 -10800 1 -04}
@@ -131,7 +131,7 @@
{1617505200 -14400 0 -04}
{1630814400 -10800 1 -04}
{1648954800 -14400 0 -04}
- {1662264000 -10800 1 -04}
+ {1662868800 -10800 1 -04}
{1680404400 -14400 0 -04}
{1693713600 -10800 1 -04}
{1712458800 -14400 0 -04}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Thunder_Bay
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Thunder_Bay 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Thunder_Bay 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,272 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-
-set TZData(:America/Thunder_Bay) {
- {-9223372036854775808 -21420 0 LMT}
- {-2366733780 -21600 0 CST}
- {-1893434400 -18000 0 EST}
- {-883594800 -18000 0 EST}
- {-880218000 -14400 1 EWT}
- {-769395600 -14400 1 EPT}
- {-765396000 -18000 0 EST}
- {18000 -18000 0 EST}
- {9961200 -14400 1 EDT}
- {25682400 -18000 0 EST}
- {41410800 -14400 1 EDT}
- {57736800 -18000 0 EST}
- {73465200 -14400 1 EDT}
- {89186400 -18000 0 EST}
- {94712400 -18000 0 EST}
- {126248400 -18000 0 EST}
- {136364400 -14400 1 EDT}
- {152085600 -18000 0 EST}
- {167814000 -14400 1 EDT}
- {183535200 -18000 0 EST}
- {199263600 -14400 1 EDT}
- {215589600 -18000 0 EST}
- {230713200 -14400 1 EDT}
- {247039200 -18000 0 EST}
- {262767600 -14400 1 EDT}
- {278488800 -18000 0 EST}
- {294217200 -14400 1 EDT}
- {309938400 -18000 0 EST}
- {325666800 -14400 1 EDT}
- {341388000 -18000 0 EST}
- {357116400 -14400 1 EDT}
- {372837600 -18000 0 EST}
- {388566000 -14400 1 EDT}
- {404892000 -18000 0 EST}
- {420015600 -14400 1 EDT}
- {436341600 -18000 0 EST}
- {452070000 -14400 1 EDT}
- {467791200 -18000 0 EST}
- {483519600 -14400 1 EDT}
- {499240800 -18000 0 EST}
- {514969200 -14400 1 EDT}
- {530690400 -18000 0 EST}
- {544604400 -14400 1 EDT}
- {562140000 -18000 0 EST}
- {576054000 -14400 1 EDT}
- {594194400 -18000 0 EST}
- {607503600 -14400 1 EDT}
- {625644000 -18000 0 EST}
- {638953200 -14400 1 EDT}
- {657093600 -18000 0 EST}
- {671007600 -14400 1 EDT}
- {688543200 -18000 0 EST}
- {702457200 -14400 1 EDT}
- {719992800 -18000 0 EST}
- {733906800 -14400 1 EDT}
- {752047200 -18000 0 EST}
- {765356400 -14400 1 EDT}
- {783496800 -18000 0 EST}
- {796806000 -14400 1 EDT}
- {814946400 -18000 0 EST}
- {828860400 -14400 1 EDT}
- {846396000 -18000 0 EST}
- {860310000 -14400 1 EDT}
- {877845600 -18000 0 EST}
- {891759600 -14400 1 EDT}
- {909295200 -18000 0 EST}
- {923209200 -14400 1 EDT}
- {941349600 -18000 0 EST}
- {954658800 -14400 1 EDT}
- {972799200 -18000 0 EST}
- {986108400 -14400 1 EDT}
- {1004248800 -18000 0 EST}
- {1018162800 -14400 1 EDT}
- {1035698400 -18000 0 EST}
- {1049612400 -14400 1 EDT}
- {1067148000 -18000 0 EST}
- {1081062000 -14400 1 EDT}
- {1099202400 -18000 0 EST}
- {1112511600 -14400 1 EDT}
- {1130652000 -18000 0 EST}
- {1143961200 -14400 1 EDT}
- {1162101600 -18000 0 EST}
- {1173596400 -14400 1 EDT}
- {1194156000 -18000 0 EST}
- {1205046000 -14400 1 EDT}
- {1225605600 -18000 0 EST}
- {1236495600 -14400 1 EDT}
- {1257055200 -18000 0 EST}
- {1268550000 -14400 1 EDT}
- {1289109600 -18000 0 EST}
- {1299999600 -14400 1 EDT}
- {1320559200 -18000 0 EST}
- {1331449200 -14400 1 EDT}
- {1352008800 -18000 0 EST}
- {1362898800 -14400 1 EDT}
- {1383458400 -18000 0 EST}
- {1394348400 -14400 1 EDT}
- {1414908000 -18000 0 EST}
- {1425798000 -14400 1 EDT}
- {1446357600 -18000 0 EST}
- {1457852400 -14400 1 EDT}
- {1478412000 -18000 0 EST}
- {1489302000 -14400 1 EDT}
- {1509861600 -18000 0 EST}
- {1520751600 -14400 1 EDT}
- {1541311200 -18000 0 EST}
- {1552201200 -14400 1 EDT}
- {1572760800 -18000 0 EST}
- {1583650800 -14400 1 EDT}
- {1604210400 -18000 0 EST}
- {1615705200 -14400 1 EDT}
- {1636264800 -18000 0 EST}
- {1647154800 -14400 1 EDT}
- {1667714400 -18000 0 EST}
- {1678604400 -14400 1 EDT}
- {1699164000 -18000 0 EST}
- {1710054000 -14400 1 EDT}
- {1730613600 -18000 0 EST}
- {1741503600 -14400 1 EDT}
- {1762063200 -18000 0 EST}
- {1772953200 -14400 1 EDT}
- {1793512800 -18000 0 EST}
- {1805007600 -14400 1 EDT}
- {1825567200 -18000 0 EST}
- {1836457200 -14400 1 EDT}
- {1857016800 -18000 0 EST}
- {1867906800 -14400 1 EDT}
- {1888466400 -18000 0 EST}
- {1899356400 -14400 1 EDT}
- {1919916000 -18000 0 EST}
- {1930806000 -14400 1 EDT}
- {1951365600 -18000 0 EST}
- {1962860400 -14400 1 EDT}
- {1983420000 -18000 0 EST}
- {1994310000 -14400 1 EDT}
- {2014869600 -18000 0 EST}
- {2025759600 -14400 1 EDT}
- {2046319200 -18000 0 EST}
- {2057209200 -14400 1 EDT}
- {2077768800 -18000 0 EST}
- {2088658800 -14400 1 EDT}
- {2109218400 -18000 0 EST}
- {2120108400 -14400 1 EDT}
- {2140668000 -18000 0 EST}
- {2152162800 -14400 1 EDT}
- {2172722400 -18000 0 EST}
- {2183612400 -14400 1 EDT}
- {2204172000 -18000 0 EST}
- {2215062000 -14400 1 EDT}
- {2235621600 -18000 0 EST}
- {2246511600 -14400 1 EDT}
- {2267071200 -18000 0 EST}
- {2277961200 -14400 1 EDT}
- {2298520800 -18000 0 EST}
- {2309410800 -14400 1 EDT}
- {2329970400 -18000 0 EST}
- {2341465200 -14400 1 EDT}
- {2362024800 -18000 0 EST}
- {2372914800 -14400 1 EDT}
- {2393474400 -18000 0 EST}
- {2404364400 -14400 1 EDT}
- {2424924000 -18000 0 EST}
- {2435814000 -14400 1 EDT}
- {2456373600 -18000 0 EST}
- {2467263600 -14400 1 EDT}
- {2487823200 -18000 0 EST}
- {2499318000 -14400 1 EDT}
- {2519877600 -18000 0 EST}
- {2530767600 -14400 1 EDT}
- {2551327200 -18000 0 EST}
- {2562217200 -14400 1 EDT}
- {2582776800 -18000 0 EST}
- {2593666800 -14400 1 EDT}
- {2614226400 -18000 0 EST}
- {2625116400 -14400 1 EDT}
- {2645676000 -18000 0 EST}
- {2656566000 -14400 1 EDT}
- {2677125600 -18000 0 EST}
- {2688620400 -14400 1 EDT}
- {2709180000 -18000 0 EST}
- {2720070000 -14400 1 EDT}
- {2740629600 -18000 0 EST}
- {2751519600 -14400 1 EDT}
- {2772079200 -18000 0 EST}
- {2782969200 -14400 1 EDT}
- {2803528800 -18000 0 EST}
- {2814418800 -14400 1 EDT}
- {2834978400 -18000 0 EST}
- {2846473200 -14400 1 EDT}
- {2867032800 -18000 0 EST}
- {2877922800 -14400 1 EDT}
- {2898482400 -18000 0 EST}
- {2909372400 -14400 1 EDT}
- {2929932000 -18000 0 EST}
- {2940822000 -14400 1 EDT}
- {2961381600 -18000 0 EST}
- {2972271600 -14400 1 EDT}
- {2992831200 -18000 0 EST}
- {3003721200 -14400 1 EDT}
- {3024280800 -18000 0 EST}
- {3035775600 -14400 1 EDT}
- {3056335200 -18000 0 EST}
- {3067225200 -14400 1 EDT}
- {3087784800 -18000 0 EST}
- {3098674800 -14400 1 EDT}
- {3119234400 -18000 0 EST}
- {3130124400 -14400 1 EDT}
- {3150684000 -18000 0 EST}
- {3161574000 -14400 1 EDT}
- {3182133600 -18000 0 EST}
- {3193023600 -14400 1 EDT}
- {3213583200 -18000 0 EST}
- {3225078000 -14400 1 EDT}
- {3245637600 -18000 0 EST}
- {3256527600 -14400 1 EDT}
- {3277087200 -18000 0 EST}
- {3287977200 -14400 1 EDT}
- {3308536800 -18000 0 EST}
- {3319426800 -14400 1 EDT}
- {3339986400 -18000 0 EST}
- {3350876400 -14400 1 EDT}
- {3371436000 -18000 0 EST}
- {3382930800 -14400 1 EDT}
- {3403490400 -18000 0 EST}
- {3414380400 -14400 1 EDT}
- {3434940000 -18000 0 EST}
- {3445830000 -14400 1 EDT}
- {3466389600 -18000 0 EST}
- {3477279600 -14400 1 EDT}
- {3497839200 -18000 0 EST}
- {3508729200 -14400 1 EDT}
- {3529288800 -18000 0 EST}
- {3540178800 -14400 1 EDT}
- {3560738400 -18000 0 EST}
- {3572233200 -14400 1 EDT}
- {3592792800 -18000 0 EST}
- {3603682800 -14400 1 EDT}
- {3624242400 -18000 0 EST}
- {3635132400 -14400 1 EDT}
- {3655692000 -18000 0 EST}
- {3666582000 -14400 1 EDT}
- {3687141600 -18000 0 EST}
- {3698031600 -14400 1 EDT}
- {3718591200 -18000 0 EST}
- {3730086000 -14400 1 EDT}
- {3750645600 -18000 0 EST}
- {3761535600 -14400 1 EDT}
- {3782095200 -18000 0 EST}
- {3792985200 -14400 1 EDT}
- {3813544800 -18000 0 EST}
- {3824434800 -14400 1 EDT}
- {3844994400 -18000 0 EST}
- {3855884400 -14400 1 EDT}
- {3876444000 -18000 0 EST}
- {3887334000 -14400 1 EDT}
- {3907893600 -18000 0 EST}
- {3919388400 -14400 1 EDT}
- {3939948000 -18000 0 EST}
- {3950838000 -14400 1 EDT}
- {3971397600 -18000 0 EST}
- {3982287600 -14400 1 EDT}
- {4002847200 -18000 0 EST}
- {4013737200 -14400 1 EDT}
- {4034296800 -18000 0 EST}
- {4045186800 -14400 1 EDT}
- {4065746400 -18000 0 EST}
- {4076636400 -14400 1 EDT}
- {4097196000 -18000 0 EST}
+if {![info exists TZData(America/Toronto)]} {
+ LoadTimeZoneFile America/Toronto
}
+set TZData(:America/Thunder_Bay) $TZData(:America/Toronto)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Tijuana
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Tijuana 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Tijuana 2024-02-15 21:05:12 UTC (rev 69897)
@@ -2,7 +2,7 @@
set TZData(:America/Tijuana) {
{-9223372036854775808 -28084 0 LMT}
- {-1514736000 -25200 0 MST}
+ {-1514739600 -25200 0 MST}
{-1451667600 -28800 0 PST}
{-1343062800 -25200 0 MST}
{-1234803600 -28800 0 PST}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Antarctica/Vostok
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Antarctica/Vostok 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Antarctica/Vostok 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,6 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-
-set TZData(:Antarctica/Vostok) {
- {-9223372036854775808 0 0 -00}
- {-380073600 21600 0 +06}
+if {![info exists TZData(Asia/Urumqi)]} {
+ LoadTimeZoneFile Asia/Urumqi
}
+set TZData(:Antarctica/Vostok) $TZData(:Asia/Urumqi)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Arctic/Longyearbyen
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Arctic/Longyearbyen 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Arctic/Longyearbyen 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,5 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-if {![info exists TZData(Europe/Oslo)]} {
- LoadTimeZoneFile Europe/Oslo
+if {![info exists TZData(Europe/Berlin)]} {
+ LoadTimeZoneFile Europe/Berlin
}
-set TZData(:Arctic/Longyearbyen) $TZData(:Europe/Oslo)
+set TZData(:Arctic/Longyearbyen) $TZData(:Europe/Berlin)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Amman
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Amman 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Amman 2024-02-15 21:05:12 UTC (rev 69897)
@@ -88,159 +88,5 @@
{1616709600 10800 1 EEST}
{1635458400 7200 0 EET}
{1645740000 10800 1 EEST}
- {1666908000 7200 0 EET}
- {1677189600 10800 1 EEST}
- {1698357600 7200 0 EET}
- {1709244000 10800 1 EEST}
- {1729807200 7200 0 EET}
- {1740693600 10800 1 EEST}
- {1761861600 7200 0 EET}
- {1772143200 10800 1 EEST}
- {1793311200 7200 0 EET}
- {1803592800 10800 1 EEST}
- {1824760800 7200 0 EET}
- {1835042400 10800 1 EEST}
- {1856210400 7200 0 EET}
- {1866492000 10800 1 EEST}
- {1887660000 7200 0 EET}
- {1898546400 10800 1 EEST}
- {1919109600 7200 0 EET}
- {1929996000 10800 1 EEST}
- {1951164000 7200 0 EET}
- {1961445600 10800 1 EEST}
- {1982613600 7200 0 EET}
- {1992895200 10800 1 EEST}
- {2014063200 7200 0 EET}
- {2024344800 10800 1 EEST}
- {2045512800 7200 0 EET}
- {2055794400 10800 1 EEST}
- {2076962400 7200 0 EET}
- {2087848800 10800 1 EEST}
- {2109016800 7200 0 EET}
- {2119298400 10800 1 EEST}
- {2140466400 7200 0 EET}
- {2150748000 10800 1 EEST}
- {2171916000 7200 0 EET}
- {2182197600 10800 1 EEST}
- {2203365600 7200 0 EET}
- {2213647200 10800 1 EEST}
- {2234815200 7200 0 EET}
- {2245701600 10800 1 EEST}
- {2266264800 7200 0 EET}
- {2277151200 10800 1 EEST}
- {2298319200 7200 0 EET}
- {2308600800 10800 1 EEST}
- {2329768800 7200 0 EET}
- {2340050400 10800 1 EEST}
- {2361218400 7200 0 EET}
- {2371500000 10800 1 EEST}
- {2392668000 7200 0 EET}
- {2402949600 10800 1 EEST}
- {2424117600 7200 0 EET}
- {2435004000 10800 1 EEST}
- {2455567200 7200 0 EET}
- {2466453600 10800 1 EEST}
- {2487621600 7200 0 EET}
- {2497903200 10800 1 EEST}
- {2519071200 7200 0 EET}
- {2529352800 10800 1 EEST}
- {2550520800 7200 0 EET}
- {2560802400 10800 1 EEST}
- {2581970400 7200 0 EET}
- {2592856800 10800 1 EEST}
- {2613420000 7200 0 EET}
- {2624306400 10800 1 EEST}
- {2645474400 7200 0 EET}
- {2655756000 10800 1 EEST}
- {2676924000 7200 0 EET}
- {2687205600 10800 1 EEST}
- {2708373600 7200 0 EET}
- {2718655200 10800 1 EEST}
- {2739823200 7200 0 EET}
- {2750104800 10800 1 EEST}
- {2771272800 7200 0 EET}
- {2782159200 10800 1 EEST}
- {2802722400 7200 0 EET}
- {2813608800 10800 1 EEST}
- {2834776800 7200 0 EET}
- {2845058400 10800 1 EEST}
- {2866226400 7200 0 EET}
- {2876508000 10800 1 EEST}
- {2897676000 7200 0 EET}
- {2907957600 10800 1 EEST}
- {2929125600 7200 0 EET}
- {2939407200 10800 1 EEST}
- {2960575200 7200 0 EET}
- {2971461600 10800 1 EEST}
- {2992629600 7200 0 EET}
- {3002911200 10800 1 EEST}
- {3024079200 7200 0 EET}
- {3034360800 10800 1 EEST}
- {3055528800 7200 0 EET}
- {3065810400 10800 1 EEST}
- {3086978400 7200 0 EET}
- {3097260000 10800 1 EEST}
- {3118428000 7200 0 EET}
- {3129314400 10800 1 EEST}
- {3149877600 7200 0 EET}
- {3160764000 10800 1 EEST}
- {3181932000 7200 0 EET}
- {3192213600 10800 1 EEST}
- {3213381600 7200 0 EET}
- {3223663200 10800 1 EEST}
- {3244831200 7200 0 EET}
- {3255112800 10800 1 EEST}
- {3276280800 7200 0 EET}
- {3286562400 10800 1 EEST}
- {3307730400 7200 0 EET}
- {3318616800 10800 1 EEST}
- {3339180000 7200 0 EET}
- {3350066400 10800 1 EEST}
- {3371234400 7200 0 EET}
- {3381516000 10800 1 EEST}
- {3402684000 7200 0 EET}
- {3412965600 10800 1 EEST}
- {3434133600 7200 0 EET}
- {3444415200 10800 1 EEST}
- {3465583200 7200 0 EET}
- {3476469600 10800 1 EEST}
- {3497032800 7200 0 EET}
- {3507919200 10800 1 EEST}
- {3529087200 7200 0 EET}
- {3539368800 10800 1 EEST}
- {3560536800 7200 0 EET}
- {3570818400 10800 1 EEST}
- {3591986400 7200 0 EET}
- {3602268000 10800 1 EEST}
- {3623436000 7200 0 EET}
- {3633717600 10800 1 EEST}
- {3654885600 7200 0 EET}
- {3665772000 10800 1 EEST}
- {3686335200 7200 0 EET}
- {3697221600 10800 1 EEST}
- {3718389600 7200 0 EET}
- {3728671200 10800 1 EEST}
- {3749839200 7200 0 EET}
- {3760120800 10800 1 EEST}
- {3781288800 7200 0 EET}
- {3791570400 10800 1 EEST}
- {3812738400 7200 0 EET}
- {3823020000 10800 1 EEST}
- {3844188000 7200 0 EET}
- {3855074400 10800 1 EEST}
- {3876242400 7200 0 EET}
- {3886524000 10800 1 EEST}
- {3907692000 7200 0 EET}
- {3917973600 10800 1 EEST}
- {3939141600 7200 0 EET}
- {3949423200 10800 1 EEST}
- {3970591200 7200 0 EET}
- {3980872800 10800 1 EEST}
- {4002040800 7200 0 EET}
- {4012927200 10800 1 EEST}
- {4033490400 7200 0 EET}
- {4044376800 10800 1 EEST}
- {4065544800 7200 0 EET}
- {4075826400 10800 1 EEST}
- {4096994400 7200 0 EET}
+ {1666908000 10800 0 +03}
}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Brunei
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Brunei 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Brunei 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,7 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-
-set TZData(:Asia/Brunei) {
- {-9223372036854775808 27580 0 LMT}
- {-1383464380 27000 0 +0730}
- {-1167636600 28800 0 +08}
+if {![info exists TZData(Asia/Kuching)]} {
+ LoadTimeZoneFile Asia/Kuching
}
+set TZData(:Asia/Brunei) $TZData(:Asia/Kuching)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Damascus
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Damascus 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Damascus 2024-02-15 21:05:12 UTC (rev 69897)
@@ -122,159 +122,5 @@
{1616709600 10800 1 EEST}
{1635454800 7200 0 EET}
{1648159200 10800 1 EEST}
- {1666904400 7200 0 EET}
- {1680213600 10800 1 EEST}
- {1698354000 7200 0 EET}
- {1711663200 10800 1 EEST}
- {1729803600 7200 0 EET}
- {1743112800 10800 1 EEST}
- {1761858000 7200 0 EET}
- {1774562400 10800 1 EEST}
- {1793307600 7200 0 EET}
- {1806012000 10800 1 EEST}
- {1824757200 7200 0 EET}
- {1838066400 10800 1 EEST}
- {1856206800 7200 0 EET}
- {1869516000 10800 1 EEST}
- {1887656400 7200 0 EET}
- {1900965600 10800 1 EEST}
- {1919106000 7200 0 EET}
- {1932415200 10800 1 EEST}
- {1951160400 7200 0 EET}
- {1963864800 10800 1 EEST}
- {1982610000 7200 0 EET}
- {1995314400 10800 1 EEST}
- {2014059600 7200 0 EET}
- {2027368800 10800 1 EEST}
- {2045509200 7200 0 EET}
- {2058818400 10800 1 EEST}
- {2076958800 7200 0 EET}
- {2090268000 10800 1 EEST}
- {2109013200 7200 0 EET}
- {2121717600 10800 1 EEST}
- {2140462800 7200 0 EET}
- {2153167200 10800 1 EEST}
- {2171912400 7200 0 EET}
- {2184616800 10800 1 EEST}
- {2203362000 7200 0 EET}
- {2216671200 10800 1 EEST}
- {2234811600 7200 0 EET}
- {2248120800 10800 1 EEST}
- {2266261200 7200 0 EET}
- {2279570400 10800 1 EEST}
- {2298315600 7200 0 EET}
- {2311020000 10800 1 EEST}
- {2329765200 7200 0 EET}
- {2342469600 10800 1 EEST}
- {2361214800 7200 0 EET}
- {2374524000 10800 1 EEST}
- {2392664400 7200 0 EET}
- {2405973600 10800 1 EEST}
- {2424114000 7200 0 EET}
- {2437423200 10800 1 EEST}
- {2455563600 7200 0 EET}
- {2468872800 10800 1 EEST}
- {2487618000 7200 0 EET}
- {2500322400 10800 1 EEST}
- {2519067600 7200 0 EET}
- {2531772000 10800 1 EEST}
- {2550517200 7200 0 EET}
- {2563826400 10800 1 EEST}
- {2581966800 7200 0 EET}
- {2595276000 10800 1 EEST}
- {2613416400 7200 0 EET}
- {2626725600 10800 1 EEST}
- {2645470800 7200 0 EET}
- {2658175200 10800 1 EEST}
- {2676920400 7200 0 EET}
- {2689624800 10800 1 EEST}
- {2708370000 7200 0 EET}
- {2721679200 10800 1 EEST}
- {2739819600 7200 0 EET}
- {2753128800 10800 1 EEST}
- {2771269200 7200 0 EET}
- {2784578400 10800 1 EEST}
- {2802718800 7200 0 EET}
- {2816028000 10800 1 EEST}
- {2834773200 7200 0 EET}
- {2847477600 10800 1 EEST}
- {2866222800 7200 0 EET}
- {2878927200 10800 1 EEST}
- {2897672400 7200 0 EET}
- {2910981600 10800 1 EEST}
- {2929122000 7200 0 EET}
- {2942431200 10800 1 EEST}
- {2960571600 7200 0 EET}
- {2973880800 10800 1 EEST}
- {2992626000 7200 0 EET}
- {3005330400 10800 1 EEST}
- {3024075600 7200 0 EET}
- {3036780000 10800 1 EEST}
- {3055525200 7200 0 EET}
- {3068229600 10800 1 EEST}
- {3086974800 7200 0 EET}
- {3100284000 10800 1 EEST}
- {3118424400 7200 0 EET}
- {3131733600 10800 1 EEST}
- {3149874000 7200 0 EET}
- {3163183200 10800 1 EEST}
- {3181928400 7200 0 EET}
- {3194632800 10800 1 EEST}
- {3213378000 7200 0 EET}
- {3226082400 10800 1 EEST}
- {3244827600 7200 0 EET}
- {3258136800 10800 1 EEST}
- {3276277200 7200 0 EET}
- {3289586400 10800 1 EEST}
- {3307726800 7200 0 EET}
- {3321036000 10800 1 EEST}
- {3339176400 7200 0 EET}
- {3352485600 10800 1 EEST}
- {3371230800 7200 0 EET}
- {3383935200 10800 1 EEST}
- {3402680400 7200 0 EET}
- {3415384800 10800 1 EEST}
- {3434130000 7200 0 EET}
- {3447439200 10800 1 EEST}
- {3465579600 7200 0 EET}
- {3478888800 10800 1 EEST}
- {3497029200 7200 0 EET}
- {3510338400 10800 1 EEST}
- {3529083600 7200 0 EET}
- {3541788000 10800 1 EEST}
- {3560533200 7200 0 EET}
- {3573237600 10800 1 EEST}
- {3591982800 7200 0 EET}
- {3605292000 10800 1 EEST}
- {3623432400 7200 0 EET}
- {3636741600 10800 1 EEST}
- {3654882000 7200 0 EET}
- {3668191200 10800 1 EEST}
- {3686331600 7200 0 EET}
- {3699640800 10800 1 EEST}
- {3718386000 7200 0 EET}
- {3731090400 10800 1 EEST}
- {3749835600 7200 0 EET}
- {3762540000 10800 1 EEST}
- {3781285200 7200 0 EET}
- {3794594400 10800 1 EEST}
- {3812734800 7200 0 EET}
- {3826044000 10800 1 EEST}
- {3844184400 7200 0 EET}
- {3857493600 10800 1 EEST}
- {3876238800 7200 0 EET}
- {3888943200 10800 1 EEST}
- {3907688400 7200 0 EET}
- {3920392800 10800 1 EEST}
- {3939138000 7200 0 EET}
- {3951842400 10800 1 EEST}
- {3970587600 7200 0 EET}
- {3983896800 10800 1 EEST}
- {4002037200 7200 0 EET}
- {4015346400 10800 1 EEST}
- {4033486800 7200 0 EET}
- {4046796000 10800 1 EEST}
- {4065541200 7200 0 EET}
- {4078245600 10800 1 EEST}
- {4096990800 7200 0 EET}
+ {1666908000 10800 0 +03}
}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Gaza
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Gaza 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Gaza 2024-02-15 21:05:12 UTC (rev 69897)
@@ -125,160 +125,160 @@
{1603490400 7200 0 EET}
{1616796000 10800 1 EEST}
{1635458400 7200 0 EET}
- {1648245600 10800 1 EEST}
- {1666908000 7200 0 EET}
- {1679695200 10800 1 EEST}
- {1698357600 7200 0 EET}
- {1711749600 10800 1 EEST}
- {1729807200 7200 0 EET}
- {1743199200 10800 1 EEST}
- {1761861600 7200 0 EET}
- {1774648800 10800 1 EEST}
- {1793311200 7200 0 EET}
- {1806098400 10800 1 EEST}
- {1824760800 7200 0 EET}
- {1837548000 10800 1 EEST}
- {1856210400 7200 0 EET}
- {1868997600 10800 1 EEST}
- {1887660000 7200 0 EET}
- {1901052000 10800 1 EEST}
- {1919109600 7200 0 EET}
- {1932501600 10800 1 EEST}
- {1951164000 7200 0 EET}
- {1963951200 10800 1 EEST}
- {1982613600 7200 0 EET}
- {1995400800 10800 1 EEST}
- {2014063200 7200 0 EET}
- {2026850400 10800 1 EEST}
- {2045512800 7200 0 EET}
- {2058300000 10800 1 EEST}
- {2076962400 7200 0 EET}
- {2090354400 10800 1 EEST}
- {2109016800 7200 0 EET}
- {2121804000 10800 1 EEST}
- {2140466400 7200 0 EET}
- {2153253600 10800 1 EEST}
- {2171916000 7200 0 EET}
- {2184703200 10800 1 EEST}
- {2203365600 7200 0 EET}
- {2216152800 10800 1 EEST}
- {2234815200 7200 0 EET}
- {2248207200 10800 1 EEST}
- {2266264800 7200 0 EET}
- {2279656800 10800 1 EEST}
- {2298319200 7200 0 EET}
- {2311106400 10800 1 EEST}
- {2329768800 7200 0 EET}
- {2342556000 10800 1 EEST}
- {2361218400 7200 0 EET}
- {2374005600 10800 1 EEST}
- {2392668000 7200 0 EET}
- {2405455200 10800 1 EEST}
- {2424117600 7200 0 EET}
- {2437509600 10800 1 EEST}
- {2455567200 7200 0 EET}
- {2468959200 10800 1 EEST}
- {2487621600 7200 0 EET}
- {2500408800 10800 1 EEST}
- {2519071200 7200 0 EET}
- {2531858400 10800 1 EEST}
- {2550520800 7200 0 EET}
- {2563308000 10800 1 EEST}
- {2581970400 7200 0 EET}
- {2595362400 10800 1 EEST}
- {2613420000 7200 0 EET}
- {2626812000 10800 1 EEST}
- {2645474400 7200 0 EET}
- {2658261600 10800 1 EEST}
- {2676924000 7200 0 EET}
- {2689711200 10800 1 EEST}
- {2708373600 7200 0 EET}
- {2721160800 10800 1 EEST}
- {2739823200 7200 0 EET}
- {2752610400 10800 1 EEST}
- {2771272800 7200 0 EET}
- {2784664800 10800 1 EEST}
- {2802722400 7200 0 EET}
- {2816114400 10800 1 EEST}
- {2834776800 7200 0 EET}
- {2847564000 10800 1 EEST}
- {2866226400 7200 0 EET}
- {2879013600 10800 1 EEST}
- {2897676000 7200 0 EET}
- {2910463200 10800 1 EEST}
- {2929125600 7200 0 EET}
- {2941912800 10800 1 EEST}
- {2960575200 7200 0 EET}
- {2973967200 10800 1 EEST}
- {2992629600 7200 0 EET}
- {3005416800 10800 1 EEST}
- {3024079200 7200 0 EET}
- {3036866400 10800 1 EEST}
- {3055528800 7200 0 EET}
- {3068316000 10800 1 EEST}
- {3086978400 7200 0 EET}
- {3099765600 10800 1 EEST}
- {3118428000 7200 0 EET}
- {3131820000 10800 1 EEST}
- {3149877600 7200 0 EET}
- {3163269600 10800 1 EEST}
- {3181932000 7200 0 EET}
- {3194719200 10800 1 EEST}
- {3213381600 7200 0 EET}
- {3226168800 10800 1 EEST}
- {3244831200 7200 0 EET}
- {3257618400 10800 1 EEST}
- {3276280800 7200 0 EET}
- {3289068000 10800 1 EEST}
- {3307730400 7200 0 EET}
- {3321122400 10800 1 EEST}
- {3339180000 7200 0 EET}
- {3352572000 10800 1 EEST}
- {3371234400 7200 0 EET}
- {3384021600 10800 1 EEST}
- {3402684000 7200 0 EET}
- {3415471200 10800 1 EEST}
- {3434133600 7200 0 EET}
- {3446920800 10800 1 EEST}
- {3465583200 7200 0 EET}
- {3478975200 10800 1 EEST}
- {3497032800 7200 0 EET}
- {3510424800 10800 1 EEST}
- {3529087200 7200 0 EET}
- {3541874400 10800 1 EEST}
- {3560536800 7200 0 EET}
- {3573324000 10800 1 EEST}
- {3591986400 7200 0 EET}
- {3604773600 10800 1 EEST}
- {3623436000 7200 0 EET}
- {3636223200 10800 1 EEST}
- {3654885600 7200 0 EET}
- {3668277600 10800 1 EEST}
- {3686335200 7200 0 EET}
- {3699727200 10800 1 EEST}
- {3718389600 7200 0 EET}
- {3731176800 10800 1 EEST}
- {3749839200 7200 0 EET}
- {3762626400 10800 1 EEST}
- {3781288800 7200 0 EET}
- {3794076000 10800 1 EEST}
- {3812738400 7200 0 EET}
- {3825525600 10800 1 EEST}
- {3844188000 7200 0 EET}
- {3857580000 10800 1 EEST}
- {3876242400 7200 0 EET}
- {3889029600 10800 1 EEST}
- {3907692000 7200 0 EET}
- {3920479200 10800 1 EEST}
- {3939141600 7200 0 EET}
- {3951928800 10800 1 EEST}
- {3970591200 7200 0 EET}
- {3983378400 10800 1 EEST}
- {4002040800 7200 0 EET}
- {4015432800 10800 1 EEST}
- {4033490400 7200 0 EET}
- {4046882400 10800 1 EEST}
- {4065544800 7200 0 EET}
- {4078332000 10800 1 EEST}
- {4096994400 7200 0 EET}
+ {1648332000 10800 1 EEST}
+ {1666998000 7200 0 EET}
+ {1679702400 10800 1 EEST}
+ {1698447600 7200 0 EET}
+ {1711756800 10800 1 EEST}
+ {1729897200 7200 0 EET}
+ {1743206400 10800 1 EEST}
+ {1761346800 7200 0 EET}
+ {1774656000 10800 1 EEST}
+ {1792796400 7200 0 EET}
+ {1806105600 10800 1 EEST}
+ {1824850800 7200 0 EET}
+ {1837555200 10800 1 EEST}
+ {1856300400 7200 0 EET}
+ {1869004800 10800 1 EEST}
+ {1887750000 7200 0 EET}
+ {1901059200 10800 1 EEST}
+ {1919199600 7200 0 EET}
+ {1932508800 10800 1 EEST}
+ {1950649200 7200 0 EET}
+ {1963958400 10800 1 EEST}
+ {1982703600 7200 0 EET}
+ {1995408000 10800 1 EEST}
+ {2014153200 7200 0 EET}
+ {2026857600 10800 1 EEST}
+ {2045602800 7200 0 EET}
+ {2058307200 10800 1 EEST}
+ {2077052400 7200 0 EET}
+ {2090361600 10800 1 EEST}
+ {2108502000 7200 0 EET}
+ {2121811200 10800 1 EEST}
+ {2139951600 7200 0 EET}
+ {2153260800 10800 1 EEST}
+ {2172006000 7200 0 EET}
+ {2184710400 10800 1 EEST}
+ {2203455600 7200 0 EET}
+ {2216160000 10800 1 EEST}
+ {2234905200 7200 0 EET}
+ {2248214400 10800 1 EEST}
+ {2266354800 7200 0 EET}
+ {2279664000 10800 1 EEST}
+ {2297804400 7200 0 EET}
+ {2311113600 10800 1 EEST}
+ {2329254000 7200 0 EET}
+ {2342563200 10800 1 EEST}
+ {2361308400 7200 0 EET}
+ {2374012800 10800 1 EEST}
+ {2392758000 7200 0 EET}
+ {2405462400 10800 1 EEST}
+ {2424207600 7200 0 EET}
+ {2437516800 10800 1 EEST}
+ {2455657200 7200 0 EET}
+ {2468966400 10800 1 EEST}
+ {2487106800 7200 0 EET}
+ {2500416000 10800 1 EEST}
+ {2519161200 7200 0 EET}
+ {2531865600 10800 1 EEST}
+ {2550610800 7200 0 EET}
+ {2563315200 10800 1 EEST}
+ {2582060400 7200 0 EET}
+ {2595369600 10800 1 EEST}
+ {2613510000 7200 0 EET}
+ {2626819200 10800 1 EEST}
+ {2644959600 7200 0 EET}
+ {2658268800 10800 1 EEST}
+ {2676409200 7200 0 EET}
+ {2689718400 10800 1 EEST}
+ {2708463600 7200 0 EET}
+ {2721168000 10800 1 EEST}
+ {2739913200 7200 0 EET}
+ {2752617600 10800 1 EEST}
+ {2771362800 7200 0 EET}
+ {2784672000 10800 1 EEST}
+ {2802812400 7200 0 EET}
+ {2816121600 10800 1 EEST}
+ {2834262000 7200 0 EET}
+ {2847571200 10800 1 EEST}
+ {2866316400 7200 0 EET}
+ {2879020800 10800 1 EEST}
+ {2897766000 7200 0 EET}
+ {2910470400 10800 1 EEST}
+ {2929215600 7200 0 EET}
+ {2941920000 10800 1 EEST}
+ {2960665200 7200 0 EET}
+ {2973974400 10800 1 EEST}
+ {2992114800 7200 0 EET}
+ {3005424000 10800 1 EEST}
+ {3023564400 7200 0 EET}
+ {3036873600 10800 1 EEST}
+ {3055618800 7200 0 EET}
+ {3068323200 10800 1 EEST}
+ {3087068400 7200 0 EET}
+ {3099772800 10800 1 EEST}
+ {3118518000 7200 0 EET}
+ {3131827200 10800 1 EEST}
+ {3149967600 7200 0 EET}
+ {3163276800 10800 1 EEST}
+ {3181417200 7200 0 EET}
+ {3194726400 10800 1 EEST}
+ {3212866800 7200 0 EET}
+ {3226176000 10800 1 EEST}
+ {3244921200 7200 0 EET}
+ {3257625600 10800 1 EEST}
+ {3276370800 7200 0 EET}
+ {3289075200 10800 1 EEST}
+ {3307820400 7200 0 EET}
+ {3321129600 10800 1 EEST}
+ {3339270000 7200 0 EET}
+ {3352579200 10800 1 EEST}
+ {3370719600 7200 0 EET}
+ {3384028800 10800 1 EEST}
+ {3402774000 7200 0 EET}
+ {3415478400 10800 1 EEST}
+ {3434223600 7200 0 EET}
+ {3446928000 10800 1 EEST}
+ {3465673200 7200 0 EET}
+ {3478982400 10800 1 EEST}
+ {3497122800 7200 0 EET}
+ {3510432000 10800 1 EEST}
+ {3528572400 7200 0 EET}
+ {3541881600 10800 1 EEST}
+ {3560022000 7200 0 EET}
+ {3573331200 10800 1 EEST}
+ {3592076400 7200 0 EET}
+ {3604780800 10800 1 EEST}
+ {3623526000 7200 0 EET}
+ {3636230400 10800 1 EEST}
+ {3654975600 7200 0 EET}
+ {3668284800 10800 1 EEST}
+ {3686425200 7200 0 EET}
+ {3699734400 10800 1 EEST}
+ {3717874800 7200 0 EET}
+ {3731184000 10800 1 EEST}
+ {3749929200 7200 0 EET}
+ {3762633600 10800 1 EEST}
+ {3781378800 7200 0 EET}
+ {3794083200 10800 1 EEST}
+ {3812828400 7200 0 EET}
+ {3825532800 10800 1 EEST}
+ {3844278000 7200 0 EET}
+ {3857587200 10800 1 EEST}
+ {3875727600 7200 0 EET}
+ {3889036800 10800 1 EEST}
+ {3907177200 7200 0 EET}
+ {3920486400 10800 1 EEST}
+ {3939231600 7200 0 EET}
+ {3951936000 10800 1 EEST}
+ {3970681200 7200 0 EET}
+ {3983385600 10800 1 EEST}
+ {4002130800 7200 0 EET}
+ {4015440000 10800 1 EEST}
+ {4033580400 7200 0 EET}
+ {4046889600 10800 1 EEST}
+ {4065030000 7200 0 EET}
+ {4078339200 10800 1 EEST}
+ {4096479600 7200 0 EET}
}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Hebron
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Hebron 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Hebron 2024-02-15 21:05:12 UTC (rev 69897)
@@ -124,160 +124,160 @@
{1603490400 7200 0 EET}
{1616796000 10800 1 EEST}
{1635458400 7200 0 EET}
- {1648245600 10800 1 EEST}
- {1666908000 7200 0 EET}
- {1679695200 10800 1 EEST}
- {1698357600 7200 0 EET}
- {1711749600 10800 1 EEST}
- {1729807200 7200 0 EET}
- {1743199200 10800 1 EEST}
- {1761861600 7200 0 EET}
- {1774648800 10800 1 EEST}
- {1793311200 7200 0 EET}
- {1806098400 10800 1 EEST}
- {1824760800 7200 0 EET}
- {1837548000 10800 1 EEST}
- {1856210400 7200 0 EET}
- {1868997600 10800 1 EEST}
- {1887660000 7200 0 EET}
- {1901052000 10800 1 EEST}
- {1919109600 7200 0 EET}
- {1932501600 10800 1 EEST}
- {1951164000 7200 0 EET}
- {1963951200 10800 1 EEST}
- {1982613600 7200 0 EET}
- {1995400800 10800 1 EEST}
- {2014063200 7200 0 EET}
- {2026850400 10800 1 EEST}
- {2045512800 7200 0 EET}
- {2058300000 10800 1 EEST}
- {2076962400 7200 0 EET}
- {2090354400 10800 1 EEST}
- {2109016800 7200 0 EET}
- {2121804000 10800 1 EEST}
- {2140466400 7200 0 EET}
- {2153253600 10800 1 EEST}
- {2171916000 7200 0 EET}
- {2184703200 10800 1 EEST}
- {2203365600 7200 0 EET}
- {2216152800 10800 1 EEST}
- {2234815200 7200 0 EET}
- {2248207200 10800 1 EEST}
- {2266264800 7200 0 EET}
- {2279656800 10800 1 EEST}
- {2298319200 7200 0 EET}
- {2311106400 10800 1 EEST}
- {2329768800 7200 0 EET}
- {2342556000 10800 1 EEST}
- {2361218400 7200 0 EET}
- {2374005600 10800 1 EEST}
- {2392668000 7200 0 EET}
- {2405455200 10800 1 EEST}
- {2424117600 7200 0 EET}
- {2437509600 10800 1 EEST}
- {2455567200 7200 0 EET}
- {2468959200 10800 1 EEST}
- {2487621600 7200 0 EET}
- {2500408800 10800 1 EEST}
- {2519071200 7200 0 EET}
- {2531858400 10800 1 EEST}
- {2550520800 7200 0 EET}
- {2563308000 10800 1 EEST}
- {2581970400 7200 0 EET}
- {2595362400 10800 1 EEST}
- {2613420000 7200 0 EET}
- {2626812000 10800 1 EEST}
- {2645474400 7200 0 EET}
- {2658261600 10800 1 EEST}
- {2676924000 7200 0 EET}
- {2689711200 10800 1 EEST}
- {2708373600 7200 0 EET}
- {2721160800 10800 1 EEST}
- {2739823200 7200 0 EET}
- {2752610400 10800 1 EEST}
- {2771272800 7200 0 EET}
- {2784664800 10800 1 EEST}
- {2802722400 7200 0 EET}
- {2816114400 10800 1 EEST}
- {2834776800 7200 0 EET}
- {2847564000 10800 1 EEST}
- {2866226400 7200 0 EET}
- {2879013600 10800 1 EEST}
- {2897676000 7200 0 EET}
- {2910463200 10800 1 EEST}
- {2929125600 7200 0 EET}
- {2941912800 10800 1 EEST}
- {2960575200 7200 0 EET}
- {2973967200 10800 1 EEST}
- {2992629600 7200 0 EET}
- {3005416800 10800 1 EEST}
- {3024079200 7200 0 EET}
- {3036866400 10800 1 EEST}
- {3055528800 7200 0 EET}
- {3068316000 10800 1 EEST}
- {3086978400 7200 0 EET}
- {3099765600 10800 1 EEST}
- {3118428000 7200 0 EET}
- {3131820000 10800 1 EEST}
- {3149877600 7200 0 EET}
- {3163269600 10800 1 EEST}
- {3181932000 7200 0 EET}
- {3194719200 10800 1 EEST}
- {3213381600 7200 0 EET}
- {3226168800 10800 1 EEST}
- {3244831200 7200 0 EET}
- {3257618400 10800 1 EEST}
- {3276280800 7200 0 EET}
- {3289068000 10800 1 EEST}
- {3307730400 7200 0 EET}
- {3321122400 10800 1 EEST}
- {3339180000 7200 0 EET}
- {3352572000 10800 1 EEST}
- {3371234400 7200 0 EET}
- {3384021600 10800 1 EEST}
- {3402684000 7200 0 EET}
- {3415471200 10800 1 EEST}
- {3434133600 7200 0 EET}
- {3446920800 10800 1 EEST}
- {3465583200 7200 0 EET}
- {3478975200 10800 1 EEST}
- {3497032800 7200 0 EET}
- {3510424800 10800 1 EEST}
- {3529087200 7200 0 EET}
- {3541874400 10800 1 EEST}
- {3560536800 7200 0 EET}
- {3573324000 10800 1 EEST}
- {3591986400 7200 0 EET}
- {3604773600 10800 1 EEST}
- {3623436000 7200 0 EET}
- {3636223200 10800 1 EEST}
- {3654885600 7200 0 EET}
- {3668277600 10800 1 EEST}
- {3686335200 7200 0 EET}
- {3699727200 10800 1 EEST}
- {3718389600 7200 0 EET}
- {3731176800 10800 1 EEST}
- {3749839200 7200 0 EET}
- {3762626400 10800 1 EEST}
- {3781288800 7200 0 EET}
- {3794076000 10800 1 EEST}
- {3812738400 7200 0 EET}
- {3825525600 10800 1 EEST}
- {3844188000 7200 0 EET}
- {3857580000 10800 1 EEST}
- {3876242400 7200 0 EET}
- {3889029600 10800 1 EEST}
- {3907692000 7200 0 EET}
- {3920479200 10800 1 EEST}
- {3939141600 7200 0 EET}
- {3951928800 10800 1 EEST}
- {3970591200 7200 0 EET}
- {3983378400 10800 1 EEST}
- {4002040800 7200 0 EET}
- {4015432800 10800 1 EEST}
- {4033490400 7200 0 EET}
- {4046882400 10800 1 EEST}
- {4065544800 7200 0 EET}
- {4078332000 10800 1 EEST}
- {4096994400 7200 0 EET}
+ {1648332000 10800 1 EEST}
+ {1666998000 7200 0 EET}
+ {1679702400 10800 1 EEST}
+ {1698447600 7200 0 EET}
+ {1711756800 10800 1 EEST}
+ {1729897200 7200 0 EET}
+ {1743206400 10800 1 EEST}
+ {1761346800 7200 0 EET}
+ {1774656000 10800 1 EEST}
+ {1792796400 7200 0 EET}
+ {1806105600 10800 1 EEST}
+ {1824850800 7200 0 EET}
+ {1837555200 10800 1 EEST}
+ {1856300400 7200 0 EET}
+ {1869004800 10800 1 EEST}
+ {1887750000 7200 0 EET}
+ {1901059200 10800 1 EEST}
+ {1919199600 7200 0 EET}
+ {1932508800 10800 1 EEST}
+ {1950649200 7200 0 EET}
+ {1963958400 10800 1 EEST}
+ {1982703600 7200 0 EET}
+ {1995408000 10800 1 EEST}
+ {2014153200 7200 0 EET}
+ {2026857600 10800 1 EEST}
+ {2045602800 7200 0 EET}
+ {2058307200 10800 1 EEST}
+ {2077052400 7200 0 EET}
+ {2090361600 10800 1 EEST}
+ {2108502000 7200 0 EET}
+ {2121811200 10800 1 EEST}
+ {2139951600 7200 0 EET}
+ {2153260800 10800 1 EEST}
+ {2172006000 7200 0 EET}
+ {2184710400 10800 1 EEST}
+ {2203455600 7200 0 EET}
+ {2216160000 10800 1 EEST}
+ {2234905200 7200 0 EET}
+ {2248214400 10800 1 EEST}
+ {2266354800 7200 0 EET}
+ {2279664000 10800 1 EEST}
+ {2297804400 7200 0 EET}
+ {2311113600 10800 1 EEST}
+ {2329254000 7200 0 EET}
+ {2342563200 10800 1 EEST}
+ {2361308400 7200 0 EET}
+ {2374012800 10800 1 EEST}
+ {2392758000 7200 0 EET}
+ {2405462400 10800 1 EEST}
+ {2424207600 7200 0 EET}
+ {2437516800 10800 1 EEST}
+ {2455657200 7200 0 EET}
+ {2468966400 10800 1 EEST}
+ {2487106800 7200 0 EET}
+ {2500416000 10800 1 EEST}
+ {2519161200 7200 0 EET}
+ {2531865600 10800 1 EEST}
+ {2550610800 7200 0 EET}
+ {2563315200 10800 1 EEST}
+ {2582060400 7200 0 EET}
+ {2595369600 10800 1 EEST}
+ {2613510000 7200 0 EET}
+ {2626819200 10800 1 EEST}
+ {2644959600 7200 0 EET}
+ {2658268800 10800 1 EEST}
+ {2676409200 7200 0 EET}
+ {2689718400 10800 1 EEST}
+ {2708463600 7200 0 EET}
+ {2721168000 10800 1 EEST}
+ {2739913200 7200 0 EET}
+ {2752617600 10800 1 EEST}
+ {2771362800 7200 0 EET}
+ {2784672000 10800 1 EEST}
+ {2802812400 7200 0 EET}
+ {2816121600 10800 1 EEST}
+ {2834262000 7200 0 EET}
+ {2847571200 10800 1 EEST}
+ {2866316400 7200 0 EET}
+ {2879020800 10800 1 EEST}
+ {2897766000 7200 0 EET}
+ {2910470400 10800 1 EEST}
+ {2929215600 7200 0 EET}
+ {2941920000 10800 1 EEST}
+ {2960665200 7200 0 EET}
+ {2973974400 10800 1 EEST}
+ {2992114800 7200 0 EET}
+ {3005424000 10800 1 EEST}
+ {3023564400 7200 0 EET}
+ {3036873600 10800 1 EEST}
+ {3055618800 7200 0 EET}
+ {3068323200 10800 1 EEST}
+ {3087068400 7200 0 EET}
+ {3099772800 10800 1 EEST}
+ {3118518000 7200 0 EET}
+ {3131827200 10800 1 EEST}
+ {3149967600 7200 0 EET}
+ {3163276800 10800 1 EEST}
+ {3181417200 7200 0 EET}
+ {3194726400 10800 1 EEST}
+ {3212866800 7200 0 EET}
+ {3226176000 10800 1 EEST}
+ {3244921200 7200 0 EET}
+ {3257625600 10800 1 EEST}
+ {3276370800 7200 0 EET}
+ {3289075200 10800 1 EEST}
+ {3307820400 7200 0 EET}
+ {3321129600 10800 1 EEST}
+ {3339270000 7200 0 EET}
+ {3352579200 10800 1 EEST}
+ {3370719600 7200 0 EET}
+ {3384028800 10800 1 EEST}
+ {3402774000 7200 0 EET}
+ {3415478400 10800 1 EEST}
+ {3434223600 7200 0 EET}
+ {3446928000 10800 1 EEST}
+ {3465673200 7200 0 EET}
+ {3478982400 10800 1 EEST}
+ {3497122800 7200 0 EET}
+ {3510432000 10800 1 EEST}
+ {3528572400 7200 0 EET}
+ {3541881600 10800 1 EEST}
+ {3560022000 7200 0 EET}
+ {3573331200 10800 1 EEST}
+ {3592076400 7200 0 EET}
+ {3604780800 10800 1 EEST}
+ {3623526000 7200 0 EET}
+ {3636230400 10800 1 EEST}
+ {3654975600 7200 0 EET}
+ {3668284800 10800 1 EEST}
+ {3686425200 7200 0 EET}
+ {3699734400 10800 1 EEST}
+ {3717874800 7200 0 EET}
+ {3731184000 10800 1 EEST}
+ {3749929200 7200 0 EET}
+ {3762633600 10800 1 EEST}
+ {3781378800 7200 0 EET}
+ {3794083200 10800 1 EEST}
+ {3812828400 7200 0 EET}
+ {3825532800 10800 1 EEST}
+ {3844278000 7200 0 EET}
+ {3857587200 10800 1 EEST}
+ {3875727600 7200 0 EET}
+ {3889036800 10800 1 EEST}
+ {3907177200 7200 0 EET}
+ {3920486400 10800 1 EEST}
+ {3939231600 7200 0 EET}
+ {3951936000 10800 1 EEST}
+ {3970681200 7200 0 EET}
+ {3983385600 10800 1 EEST}
+ {4002130800 7200 0 EET}
+ {4015440000 10800 1 EEST}
+ {4033580400 7200 0 EET}
+ {4046889600 10800 1 EEST}
+ {4065030000 7200 0 EET}
+ {4078339200 10800 1 EEST}
+ {4096479600 7200 0 EET}
}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Ho_Chi_Minh
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Ho_Chi_Minh 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Ho_Chi_Minh 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,8 +1,8 @@
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Ho_Chi_Minh) {
- {-9223372036854775808 25600 0 LMT}
- {-2004073600 25590 0 PLMT}
+ {-9223372036854775808 25590 0 LMT}
+ {-2004073590 25590 0 PLMT}
{-1851577590 25200 0 +07}
{-852105600 28800 0 +08}
{-782643600 32400 0 +09}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Kuala_Lumpur
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Kuala_Lumpur 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Kuala_Lumpur 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,13 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-
-set TZData(:Asia/Kuala_Lumpur) {
- {-9223372036854775808 24406 0 LMT}
- {-2177477206 24925 0 SMT}
- {-2038200925 25200 0 +07}
- {-1167634800 26400 1 +0720}
- {-1073028000 26400 0 +0720}
- {-894180000 27000 0 +0730}
- {-879665400 32400 0 +09}
- {-767005200 27000 0 +0730}
- {378664200 28800 0 +08}
+if {![info exists TZData(Asia/Singapore)]} {
+ LoadTimeZoneFile Asia/Singapore
}
+set TZData(:Asia/Kuala_Lumpur) $TZData(:Asia/Singapore)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Tehran
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Tehran 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Tehran 2024-02-15 21:05:12 UTC (rev 69897)
@@ -3,12 +3,13 @@
set TZData(:Asia/Tehran) {
{-9223372036854775808 12344 0 LMT}
{-1704165944 12344 0 TMT}
- {-757394744 12600 0 +0330}
- {247177800 14400 0 +04}
- {259272000 18000 1 +04}
- {277758000 14400 0 +04}
+ {-1090466744 12600 0 +0330}
+ {227820600 16200 1 +0330}
+ {246227400 14400 0 +04}
+ {259617600 18000 1 +04}
+ {271108800 14400 0 +04}
{283982400 12600 0 +0330}
- {290809800 16200 1 +0330}
+ {296598600 16200 1 +0330}
{306531000 12600 0 +0330}
{322432200 16200 1 +0330}
{338499000 12600 0 +0330}
@@ -72,158 +73,4 @@
{1632252600 12600 0 +0330}
{1647894600 16200 1 +0330}
{1663788600 12600 0 +0330}
- {1679430600 16200 1 +0330}
- {1695324600 12600 0 +0330}
- {1710966600 16200 1 +0330}
- {1726860600 12600 0 +0330}
- {1742589000 16200 1 +0330}
- {1758483000 12600 0 +0330}
- {1774125000 16200 1 +0330}
- {1790019000 12600 0 +0330}
- {1805661000 16200 1 +0330}
- {1821555000 12600 0 +0330}
- {1837197000 16200 1 +0330}
- {1853091000 12600 0 +0330}
- {1868733000 16200 1 +0330}
- {1884627000 12600 0 +0330}
- {1900355400 16200 1 +0330}
- {1916249400 12600 0 +0330}
- {1931891400 16200 1 +0330}
- {1947785400 12600 0 +0330}
- {1963427400 16200 1 +0330}
- {1979321400 12600 0 +0330}
- {1994963400 16200 1 +0330}
- {2010857400 12600 0 +0330}
- {2026585800 16200 1 +0330}
- {2042479800 12600 0 +0330}
- {2058121800 16200 1 +0330}
- {2074015800 12600 0 +0330}
- {2089657800 16200 1 +0330}
- {2105551800 12600 0 +0330}
- {2121193800 16200 1 +0330}
- {2137087800 12600 0 +0330}
- {2152816200 16200 1 +0330}
- {2168710200 12600 0 +0330}
- {2184352200 16200 1 +0330}
- {2200246200 12600 0 +0330}
- {2215888200 16200 1 +0330}
- {2231782200 12600 0 +0330}
- {2247424200 16200 1 +0330}
- {2263318200 12600 0 +0330}
- {2279046600 16200 1 +0330}
- {2294940600 12600 0 +0330}
- {2310582600 16200 1 +0330}
- {2326476600 12600 0 +0330}
- {2342118600 16200 1 +0330}
- {2358012600 12600 0 +0330}
- {2373654600 16200 1 +0330}
- {2389548600 12600 0 +0330}
- {2405277000 16200 1 +0330}
- {2421171000 12600 0 +0330}
- {2436813000 16200 1 +0330}
- {2452707000 12600 0 +0330}
- {2468349000 16200 1 +0330}
- {2484243000 12600 0 +0330}
- {2499885000 16200 1 +0330}
- {2515779000 12600 0 +0330}
- {2531507400 16200 1 +0330}
- {2547401400 12600 0 +0330}
- {2563043400 16200 1 +0330}
- {2578937400 12600 0 +0330}
- {2594579400 16200 1 +0330}
- {2610473400 12600 0 +0330}
- {2626115400 16200 1 +0330}
- {2642009400 12600 0 +0330}
- {2657737800 16200 1 +0330}
- {2673631800 12600 0 +0330}
- {2689273800 16200 1 +0330}
- {2705167800 12600 0 +0330}
- {2720809800 16200 1 +0330}
- {2736703800 12600 0 +0330}
- {2752345800 16200 1 +0330}
- {2768239800 12600 0 +0330}
- {2783968200 16200 1 +0330}
- {2799862200 12600 0 +0330}
- {2815504200 16200 1 +0330}
- {2831398200 12600 0 +0330}
- {2847040200 16200 1 +0330}
- {2862934200 12600 0 +0330}
- {2878576200 16200 1 +0330}
- {2894470200 12600 0 +0330}
- {2910112200 16200 1 +0330}
- {2926006200 12600 0 +0330}
- {2941734600 16200 1 +0330}
- {2957628600 12600 0 +0330}
- {2973270600 16200 1 +0330}
- {2989164600 12600 0 +0330}
- {3004806600 16200 1 +0330}
- {3020700600 12600 0 +0330}
- {3036342600 16200 1 +0330}
- {3052236600 12600 0 +0330}
- {3067965000 16200 1 +0330}
- {3083859000 12600 0 +0330}
- {3099501000 16200 1 +0330}
- {3115395000 12600 0 +0330}
- {3131037000 16200 1 +0330}
- {3146931000 12600 0 +0330}
- {3162573000 16200 1 +0330}
- {3178467000 12600 0 +0330}
- {3194195400 16200 1 +0330}
- {3210089400 12600 0 +0330}
- {3225731400 16200 1 +0330}
- {3241625400 12600 0 +0330}
- {3257267400 16200 1 +0330}
- {3273161400 12600 0 +0330}
- {3288803400 16200 1 +0330}
- {3304697400 12600 0 +0330}
- {3320425800 16200 1 +0330}
- {3336319800 12600 0 +0330}
- {3351961800 16200 1 +0330}
- {3367855800 12600 0 +0330}
- {3383497800 16200 1 +0330}
- {3399391800 12600 0 +0330}
- {3415033800 16200 1 +0330}
- {3430927800 12600 0 +0330}
- {3446656200 16200 1 +0330}
- {3462550200 12600 0 +0330}
- {3478192200 16200 1 +0330}
- {3494086200 12600 0 +0330}
- {3509728200 16200 1 +0330}
- {3525622200 12600 0 +0330}
- {3541264200 16200 1 +0330}
- {3557158200 12600 0 +0330}
- {3572886600 16200 1 +0330}
- {3588780600 12600 0 +0330}
- {3604422600 16200 1 +0330}
- {3620316600 12600 0 +0330}
- {3635958600 16200 1 +0330}
- {3651852600 12600 0 +0330}
- {3667494600 16200 1 +0330}
- {3683388600 12600 0 +0330}
- {3699117000 16200 1 +0330}
- {3715011000 12600 0 +0330}
- {3730653000 16200 1 +0330}
- {3746547000 12600 0 +0330}
- {3762189000 16200 1 +0330}
- {3778083000 12600 0 +0330}
- {3793725000 16200 1 +0330}
- {3809619000 12600 0 +0330}
- {3825261000 16200 1 +0330}
- {3841155000 12600 0 +0330}
- {3856883400 16200 1 +0330}
- {3872777400 12600 0 +0330}
- {3888419400 16200 1 +0330}
- {3904313400 12600 0 +0330}
- {3919955400 16200 1 +0330}
- {3935849400 12600 0 +0330}
- {3951491400 16200 1 +0330}
- {3967385400 12600 0 +0330}
- {3983113800 16200 1 +0330}
- {3999007800 12600 0 +0330}
- {4014649800 16200 1 +0330}
- {4030543800 12600 0 +0330}
- {4046185800 16200 1 +0330}
- {4062079800 12600 0 +0330}
- {4077721800 16200 1 +0330}
- {4093615800 12600 0 +0330}
}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Atlantic/Jan_Mayen
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Atlantic/Jan_Mayen 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Atlantic/Jan_Mayen 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,5 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-if {![info exists TZData(Europe/Oslo)]} {
- LoadTimeZoneFile Europe/Oslo
+if {![info exists TZData(Europe/Berlin)]} {
+ LoadTimeZoneFile Europe/Berlin
}
-set TZData(:Atlantic/Jan_Mayen) $TZData(:Europe/Oslo)
+set TZData(:Atlantic/Jan_Mayen) $TZData(:Europe/Berlin)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Atlantic/Reykjavik
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Atlantic/Reykjavik 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Atlantic/Reykjavik 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,73 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-
-set TZData(:Atlantic/Reykjavik) {
- {-9223372036854775808 -5280 0 LMT}
- {-1956609120 -3600 0 -01}
- {-1668211200 0 1 -01}
- {-1647212400 -3600 0 -01}
- {-1636675200 0 1 -01}
- {-1613430000 -3600 0 -01}
- {-1605139200 0 1 -01}
- {-1581894000 -3600 0 -01}
- {-1539561600 0 1 -01}
- {-1531350000 -3600 0 -01}
- {-968025600 0 1 -01}
- {-952293600 -3600 0 -01}
- {-942008400 0 1 -01}
- {-920239200 -3600 0 -01}
- {-909957600 0 1 -01}
- {-888789600 -3600 0 -01}
- {-877903200 0 1 -01}
- {-857944800 -3600 0 -01}
- {-846453600 0 1 -01}
- {-826495200 -3600 0 -01}
- {-815004000 0 1 -01}
- {-795045600 -3600 0 -01}
- {-783554400 0 1 -01}
- {-762991200 -3600 0 -01}
- {-752104800 0 1 -01}
- {-731541600 -3600 0 -01}
- {-717631200 0 1 -01}
- {-700092000 -3600 0 -01}
- {-686181600 0 1 -01}
- {-668642400 -3600 0 -01}
- {-654732000 0 1 -01}
- {-636588000 -3600 0 -01}
- {-623282400 0 1 -01}
- {-605743200 -3600 0 -01}
- {-591832800 0 1 -01}
- {-573688800 -3600 0 -01}
- {-559778400 0 1 -01}
- {-542239200 -3600 0 -01}
- {-528328800 0 1 -01}
- {-510789600 -3600 0 -01}
- {-496879200 0 1 -01}
- {-479340000 -3600 0 -01}
- {-465429600 0 1 -01}
- {-447890400 -3600 0 -01}
- {-433980000 0 1 -01}
- {-415836000 -3600 0 -01}
- {-401925600 0 1 -01}
- {-384386400 -3600 0 -01}
- {-370476000 0 1 -01}
- {-352936800 -3600 0 -01}
- {-339026400 0 1 -01}
- {-321487200 -3600 0 -01}
- {-307576800 0 1 -01}
- {-290037600 -3600 0 -01}
- {-276127200 0 1 -01}
- {-258588000 -3600 0 -01}
- {-244677600 0 1 -01}
- {-226533600 -3600 0 -01}
- {-212623200 0 1 -01}
- {-195084000 -3600 0 -01}
- {-181173600 0 1 -01}
- {-163634400 -3600 0 -01}
- {-149724000 0 1 -01}
- {-132184800 -3600 0 -01}
- {-118274400 0 1 -01}
- {-100735200 -3600 0 -01}
- {-86824800 0 1 -01}
- {-68680800 -3600 0 -01}
- {-54770400 0 0 GMT}
+if {![info exists TZData(Africa/Abidjan)]} {
+ LoadTimeZoneFile Africa/Abidjan
}
+set TZData(:Atlantic/Reykjavik) $TZData(:Africa/Abidjan)
Deleted: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Canada/East-Saskatchewan
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Canada/East-Saskatchewan 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Canada/East-Saskatchewan 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,5 +0,0 @@
-# created by tools/tclZIC.tcl - do not edit
-if {![info exists TZData(America/Regina)]} {
- LoadTimeZoneFile America/Regina
-}
-set TZData(:Canada/East-Saskatchewan) $TZData(:America/Regina)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Amsterdam
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Amsterdam 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Amsterdam 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,310 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-
-set TZData(:Europe/Amsterdam) {
- {-9223372036854775808 1172 0 LMT}
- {-4260212372 1172 0 AMT}
- {-1693700372 4772 1 NST}
- {-1680484772 1172 0 AMT}
- {-1663453172 4772 1 NST}
- {-1650147572 1172 0 AMT}
- {-1633213172 4772 1 NST}
- {-1617488372 1172 0 AMT}
- {-1601158772 4772 1 NST}
- {-1586038772 1172 0 AMT}
- {-1569709172 4772 1 NST}
- {-1554589172 1172 0 AMT}
- {-1538259572 4772 1 NST}
- {-1523139572 1172 0 AMT}
- {-1507501172 4772 1 NST}
- {-1490566772 1172 0 AMT}
- {-1470176372 4772 1 NST}
- {-1459117172 1172 0 AMT}
- {-1443997172 4772 1 NST}
- {-1427667572 1172 0 AMT}
- {-1406672372 4772 1 NST}
- {-1396217972 1172 0 AMT}
- {-1376950772 4772 1 NST}
- {-1364768372 1172 0 AMT}
- {-1345414772 4772 1 NST}
- {-1333318772 1172 0 AMT}
- {-1313792372 4772 1 NST}
- {-1301264372 1172 0 AMT}
- {-1282256372 4772 1 NST}
- {-1269814772 1172 0 AMT}
- {-1250720372 4772 1 NST}
- {-1238365172 1172 0 AMT}
- {-1219184372 4772 1 NST}
- {-1206915572 1172 0 AMT}
- {-1186957172 4772 1 NST}
- {-1175465972 1172 0 AMT}
- {-1156025972 4772 1 NST}
- {-1143411572 1172 0 AMT}
- {-1124489972 4772 1 NST}
- {-1111961972 1172 0 AMT}
- {-1092953972 4772 1 NST}
- {-1080512372 1172 0 AMT}
- {-1061331572 4772 1 NST}
- {-1049062772 1172 0 AMT}
- {-1029190772 4772 1 NST}
- {-1025741972 4800 0 +0120}
- {-1017613200 1200 0 +0020}
- {-998259600 4800 1 +0120}
- {-986163600 1200 0 +0020}
- {-966723600 4800 1 +0120}
- {-954109200 1200 0 +0020}
- {-935022000 7200 0 CEST}
- {-857257200 3600 0 CET}
- {-844556400 7200 1 CEST}
- {-828226800 3600 0 CET}
- {-812502000 7200 1 CEST}
- {-796777200 3600 0 CET}
- {-781052400 7200 0 CEST}
- {-766623600 3600 0 CET}
- {220921200 3600 0 CET}
- {228877200 7200 1 CEST}
- {243997200 3600 0 CET}
- {260326800 7200 1 CEST}
- {276051600 3600 0 CET}
- {291776400 7200 1 CEST}
- {307501200 3600 0 CET}
- {323830800 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}
- {449024400 7200 1 CEST}
- {465354000 3600 0 CET}
- {481078800 7200 1 CEST}
- {496803600 3600 0 CET}
- {512528400 7200 1 CEST}
- {528253200 3600 0 CET}
- {543978000 7200 1 CEST}
- {559702800 3600 0 CET}
- {575427600 7200 1 CEST}
- {591152400 3600 0 CET}
- {606877200 7200 1 CEST}
- {622602000 3600 0 CET}
- {638326800 7200 1 CEST}
- {654656400 3600 0 CET}
- {670381200 7200 1 CEST}
- {686106000 3600 0 CET}
- {701830800 7200 1 CEST}
- {717555600 3600 0 CET}
- {733280400 7200 1 CEST}
- {749005200 3600 0 CET}
- {764730000 7200 1 CEST}
- {780454800 3600 0 CET}
- {796179600 7200 1 CEST}
- {811904400 3600 0 CET}
- {828234000 7200 1 CEST}
- {846378000 3600 0 CET}
- {859683600 7200 1 CEST}
- {877827600 3600 0 CET}
- {891133200 7200 1 CEST}
- {909277200 3600 0 CET}
- {922582800 7200 1 CEST}
- {941331600 3600 0 CET}
- {954032400 7200 1 CEST}
- {972781200 3600 0 CET}
- {985482000 7200 1 CEST}
- {1004230800 3600 0 CET}
- {1017536400 7200 1 CEST}
- {1035680400 3600 0 CET}
- {1048986000 7200 1 CEST}
- {1067130000 3600 0 CET}
- {1080435600 7200 1 CEST}
- {1099184400 3600 0 CET}
- {1111885200 7200 1 CEST}
- {1130634000 3600 0 CET}
- {1143334800 7200 1 CEST}
- {1162083600 3600 0 CET}
- {1174784400 7200 1 CEST}
- {1193533200 3600 0 CET}
- {1206838800 7200 1 CEST}
- {1224982800 3600 0 CET}
- {1238288400 7200 1 CEST}
- {1256432400 3600 0 CET}
- {1269738000 7200 1 CEST}
- {1288486800 3600 0 CET}
- {1301187600 7200 1 CEST}
- {1319936400 3600 0 CET}
- {1332637200 7200 1 CEST}
- {1351386000 3600 0 CET}
- {1364691600 7200 1 CEST}
- {1382835600 3600 0 CET}
- {1396141200 7200 1 CEST}
- {1414285200 3600 0 CET}
- {1427590800 7200 1 CEST}
- {1445734800 3600 0 CET}
- {1459040400 7200 1 CEST}
- {1477789200 3600 0 CET}
- {1490490000 7200 1 CEST}
- {1509238800 3600 0 CET}
- {1521939600 7200 1 CEST}
- {1540688400 3600 0 CET}
- {1553994000 7200 1 CEST}
- {1572138000 3600 0 CET}
- {1585443600 7200 1 CEST}
- {1603587600 3600 0 CET}
- {1616893200 7200 1 CEST}
- {1635642000 3600 0 CET}
- {1648342800 7200 1 CEST}
- {1667091600 3600 0 CET}
- {1679792400 7200 1 CEST}
- {1698541200 3600 0 CET}
- {1711846800 7200 1 CEST}
- {1729990800 3600 0 CET}
- {1743296400 7200 1 CEST}
- {1761440400 3600 0 CET}
- {1774746000 7200 1 CEST}
- {1792890000 3600 0 CET}
- {1806195600 7200 1 CEST}
- {1824944400 3600 0 CET}
- {1837645200 7200 1 CEST}
- {1856394000 3600 0 CET}
- {1869094800 7200 1 CEST}
- {1887843600 3600 0 CET}
- {1901149200 7200 1 CEST}
- {1919293200 3600 0 CET}
- {1932598800 7200 1 CEST}
- {1950742800 3600 0 CET}
- {1964048400 7200 1 CEST}
- {1982797200 3600 0 CET}
- {1995498000 7200 1 CEST}
- {2014246800 3600 0 CET}
- {2026947600 7200 1 CEST}
- {2045696400 3600 0 CET}
- {2058397200 7200 1 CEST}
- {2077146000 3600 0 CET}
- {2090451600 7200 1 CEST}
- {2108595600 3600 0 CET}
- {2121901200 7200 1 CEST}
- {2140045200 3600 0 CET}
- {2153350800 7200 1 CEST}
- {2172099600 3600 0 CET}
- {2184800400 7200 1 CEST}
- {2203549200 3600 0 CET}
- {2216250000 7200 1 CEST}
- {2234998800 3600 0 CET}
- {2248304400 7200 1 CEST}
- {2266448400 3600 0 CET}
- {2279754000 7200 1 CEST}
- {2297898000 3600 0 CET}
- {2311203600 7200 1 CEST}
- {2329347600 3600 0 CET}
- {2342653200 7200 1 CEST}
- {2361402000 3600 0 CET}
- {2374102800 7200 1 CEST}
- {2392851600 3600 0 CET}
- {2405552400 7200 1 CEST}
- {2424301200 3600 0 CET}
- {2437606800 7200 1 CEST}
- {2455750800 3600 0 CET}
- {2469056400 7200 1 CEST}
- {2487200400 3600 0 CET}
- {2500506000 7200 1 CEST}
- {2519254800 3600 0 CET}
- {2531955600 7200 1 CEST}
- {2550704400 3600 0 CET}
- {2563405200 7200 1 CEST}
- {2582154000 3600 0 CET}
- {2595459600 7200 1 CEST}
- {2613603600 3600 0 CET}
- {2626909200 7200 1 CEST}
- {2645053200 3600 0 CET}
- {2658358800 7200 1 CEST}
- {2676502800 3600 0 CET}
- {2689808400 7200 1 CEST}
- {2708557200 3600 0 CET}
- {2721258000 7200 1 CEST}
- {2740006800 3600 0 CET}
- {2752707600 7200 1 CEST}
- {2771456400 3600 0 CET}
- {2784762000 7200 1 CEST}
- {2802906000 3600 0 CET}
- {2816211600 7200 1 CEST}
- {2834355600 3600 0 CET}
- {2847661200 7200 1 CEST}
- {2866410000 3600 0 CET}
- {2879110800 7200 1 CEST}
- {2897859600 3600 0 CET}
- {2910560400 7200 1 CEST}
- {2929309200 3600 0 CET}
- {2942010000 7200 1 CEST}
- {2960758800 3600 0 CET}
- {2974064400 7200 1 CEST}
- {2992208400 3600 0 CET}
- {3005514000 7200 1 CEST}
- {3023658000 3600 0 CET}
- {3036963600 7200 1 CEST}
- {3055712400 3600 0 CET}
- {3068413200 7200 1 CEST}
- {3087162000 3600 0 CET}
- {3099862800 7200 1 CEST}
- {3118611600 3600 0 CET}
- {3131917200 7200 1 CEST}
- {3150061200 3600 0 CET}
- {3163366800 7200 1 CEST}
- {3181510800 3600 0 CET}
- {3194816400 7200 1 CEST}
- {3212960400 3600 0 CET}
- {3226266000 7200 1 CEST}
- {3245014800 3600 0 CET}
- {3257715600 7200 1 CEST}
- {3276464400 3600 0 CET}
- {3289165200 7200 1 CEST}
- {3307914000 3600 0 CET}
- {3321219600 7200 1 CEST}
- {3339363600 3600 0 CET}
- {3352669200 7200 1 CEST}
- {3370813200 3600 0 CET}
- {3384118800 7200 1 CEST}
- {3402867600 3600 0 CET}
- {3415568400 7200 1 CEST}
- {3434317200 3600 0 CET}
- {3447018000 7200 1 CEST}
- {3465766800 3600 0 CET}
- {3479072400 7200 1 CEST}
- {3497216400 3600 0 CET}
- {3510522000 7200 1 CEST}
- {3528666000 3600 0 CET}
- {3541971600 7200 1 CEST}
- {3560115600 3600 0 CET}
- {3573421200 7200 1 CEST}
- {3592170000 3600 0 CET}
- {3604870800 7200 1 CEST}
- {3623619600 3600 0 CET}
- {3636320400 7200 1 CEST}
- {3655069200 3600 0 CET}
- {3668374800 7200 1 CEST}
- {3686518800 3600 0 CET}
- {3699824400 7200 1 CEST}
- {3717968400 3600 0 CET}
- {3731274000 7200 1 CEST}
- {3750022800 3600 0 CET}
- {3762723600 7200 1 CEST}
- {3781472400 3600 0 CET}
- {3794173200 7200 1 CEST}
- {3812922000 3600 0 CET}
- {3825622800 7200 1 CEST}
- {3844371600 3600 0 CET}
- {3857677200 7200 1 CEST}
- {3875821200 3600 0 CET}
- {3889126800 7200 1 CEST}
- {3907270800 3600 0 CET}
- {3920576400 7200 1 CEST}
- {3939325200 3600 0 CET}
- {3952026000 7200 1 CEST}
- {3970774800 3600 0 CET}
- {3983475600 7200 1 CEST}
- {4002224400 3600 0 CET}
- {4015530000 7200 1 CEST}
- {4033674000 3600 0 CET}
- {4046979600 7200 1 CEST}
- {4065123600 3600 0 CET}
- {4078429200 7200 1 CEST}
- {4096573200 3600 0 CET}
+if {![info exists TZData(Europe/Brussels)]} {
+ LoadTimeZoneFile Europe/Brussels
}
+set TZData(:Europe/Amsterdam) $TZData(:Europe/Brussels)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Copenhagen
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Copenhagen 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Copenhagen 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,264 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-
-set TZData(:Europe/Copenhagen) {
- {-9223372036854775808 3020 0 LMT}
- {-2524524620 3020 0 CMT}
- {-2398294220 3600 0 CET}
- {-1692496800 7200 1 CEST}
- {-1680490800 3600 0 CET}
- {-935110800 7200 1 CEST}
- {-857257200 3600 0 CET}
- {-844556400 7200 1 CEST}
- {-828226800 3600 0 CET}
- {-812502000 7200 1 CEST}
- {-796777200 3600 0 CET}
- {-781052400 7200 0 CEST}
- {-769388400 3600 0 CET}
- {-747010800 7200 1 CEST}
- {-736383600 3600 0 CET}
- {-715215600 7200 1 CEST}
- {-706748400 3600 0 CET}
- {-683161200 7200 1 CEST}
- {-675298800 3600 0 CET}
- {315529200 3600 0 CET}
- {323830800 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}
- {449024400 7200 1 CEST}
- {465354000 3600 0 CET}
- {481078800 7200 1 CEST}
- {496803600 3600 0 CET}
- {512528400 7200 1 CEST}
- {528253200 3600 0 CET}
- {543978000 7200 1 CEST}
- {559702800 3600 0 CET}
- {575427600 7200 1 CEST}
- {591152400 3600 0 CET}
- {606877200 7200 1 CEST}
- {622602000 3600 0 CET}
- {638326800 7200 1 CEST}
- {654656400 3600 0 CET}
- {670381200 7200 1 CEST}
- {686106000 3600 0 CET}
- {701830800 7200 1 CEST}
- {717555600 3600 0 CET}
- {733280400 7200 1 CEST}
- {749005200 3600 0 CET}
- {764730000 7200 1 CEST}
- {780454800 3600 0 CET}
- {796179600 7200 1 CEST}
- {811904400 3600 0 CET}
- {828234000 7200 1 CEST}
- {846378000 3600 0 CET}
- {859683600 7200 1 CEST}
- {877827600 3600 0 CET}
- {891133200 7200 1 CEST}
- {909277200 3600 0 CET}
- {922582800 7200 1 CEST}
- {941331600 3600 0 CET}
- {954032400 7200 1 CEST}
- {972781200 3600 0 CET}
- {985482000 7200 1 CEST}
- {1004230800 3600 0 CET}
- {1017536400 7200 1 CEST}
- {1035680400 3600 0 CET}
- {1048986000 7200 1 CEST}
- {1067130000 3600 0 CET}
- {1080435600 7200 1 CEST}
- {1099184400 3600 0 CET}
- {1111885200 7200 1 CEST}
- {1130634000 3600 0 CET}
- {1143334800 7200 1 CEST}
- {1162083600 3600 0 CET}
- {1174784400 7200 1 CEST}
- {1193533200 3600 0 CET}
- {1206838800 7200 1 CEST}
- {1224982800 3600 0 CET}
- {1238288400 7200 1 CEST}
- {1256432400 3600 0 CET}
- {1269738000 7200 1 CEST}
- {1288486800 3600 0 CET}
- {1301187600 7200 1 CEST}
- {1319936400 3600 0 CET}
- {1332637200 7200 1 CEST}
- {1351386000 3600 0 CET}
- {1364691600 7200 1 CEST}
- {1382835600 3600 0 CET}
- {1396141200 7200 1 CEST}
- {1414285200 3600 0 CET}
- {1427590800 7200 1 CEST}
- {1445734800 3600 0 CET}
- {1459040400 7200 1 CEST}
- {1477789200 3600 0 CET}
- {1490490000 7200 1 CEST}
- {1509238800 3600 0 CET}
- {1521939600 7200 1 CEST}
- {1540688400 3600 0 CET}
- {1553994000 7200 1 CEST}
- {1572138000 3600 0 CET}
- {1585443600 7200 1 CEST}
- {1603587600 3600 0 CET}
- {1616893200 7200 1 CEST}
- {1635642000 3600 0 CET}
- {1648342800 7200 1 CEST}
- {1667091600 3600 0 CET}
- {1679792400 7200 1 CEST}
- {1698541200 3600 0 CET}
- {1711846800 7200 1 CEST}
- {1729990800 3600 0 CET}
- {1743296400 7200 1 CEST}
- {1761440400 3600 0 CET}
- {1774746000 7200 1 CEST}
- {1792890000 3600 0 CET}
- {1806195600 7200 1 CEST}
- {1824944400 3600 0 CET}
- {1837645200 7200 1 CEST}
- {1856394000 3600 0 CET}
- {1869094800 7200 1 CEST}
- {1887843600 3600 0 CET}
- {1901149200 7200 1 CEST}
- {1919293200 3600 0 CET}
- {1932598800 7200 1 CEST}
- {1950742800 3600 0 CET}
- {1964048400 7200 1 CEST}
- {1982797200 3600 0 CET}
- {1995498000 7200 1 CEST}
- {2014246800 3600 0 CET}
- {2026947600 7200 1 CEST}
- {2045696400 3600 0 CET}
- {2058397200 7200 1 CEST}
- {2077146000 3600 0 CET}
- {2090451600 7200 1 CEST}
- {2108595600 3600 0 CET}
- {2121901200 7200 1 CEST}
- {2140045200 3600 0 CET}
- {2153350800 7200 1 CEST}
- {2172099600 3600 0 CET}
- {2184800400 7200 1 CEST}
- {2203549200 3600 0 CET}
- {2216250000 7200 1 CEST}
- {2234998800 3600 0 CET}
- {2248304400 7200 1 CEST}
- {2266448400 3600 0 CET}
- {2279754000 7200 1 CEST}
- {2297898000 3600 0 CET}
- {2311203600 7200 1 CEST}
- {2329347600 3600 0 CET}
- {2342653200 7200 1 CEST}
- {2361402000 3600 0 CET}
- {2374102800 7200 1 CEST}
- {2392851600 3600 0 CET}
- {2405552400 7200 1 CEST}
- {2424301200 3600 0 CET}
- {2437606800 7200 1 CEST}
- {2455750800 3600 0 CET}
- {2469056400 7200 1 CEST}
- {2487200400 3600 0 CET}
- {2500506000 7200 1 CEST}
- {2519254800 3600 0 CET}
- {2531955600 7200 1 CEST}
- {2550704400 3600 0 CET}
- {2563405200 7200 1 CEST}
- {2582154000 3600 0 CET}
- {2595459600 7200 1 CEST}
- {2613603600 3600 0 CET}
- {2626909200 7200 1 CEST}
- {2645053200 3600 0 CET}
- {2658358800 7200 1 CEST}
- {2676502800 3600 0 CET}
- {2689808400 7200 1 CEST}
- {2708557200 3600 0 CET}
- {2721258000 7200 1 CEST}
- {2740006800 3600 0 CET}
- {2752707600 7200 1 CEST}
- {2771456400 3600 0 CET}
- {2784762000 7200 1 CEST}
- {2802906000 3600 0 CET}
- {2816211600 7200 1 CEST}
- {2834355600 3600 0 CET}
- {2847661200 7200 1 CEST}
- {2866410000 3600 0 CET}
- {2879110800 7200 1 CEST}
- {2897859600 3600 0 CET}
- {2910560400 7200 1 CEST}
- {2929309200 3600 0 CET}
- {2942010000 7200 1 CEST}
- {2960758800 3600 0 CET}
- {2974064400 7200 1 CEST}
- {2992208400 3600 0 CET}
- {3005514000 7200 1 CEST}
- {3023658000 3600 0 CET}
- {3036963600 7200 1 CEST}
- {3055712400 3600 0 CET}
- {3068413200 7200 1 CEST}
- {3087162000 3600 0 CET}
- {3099862800 7200 1 CEST}
- {3118611600 3600 0 CET}
- {3131917200 7200 1 CEST}
- {3150061200 3600 0 CET}
- {3163366800 7200 1 CEST}
- {3181510800 3600 0 CET}
- {3194816400 7200 1 CEST}
- {3212960400 3600 0 CET}
- {3226266000 7200 1 CEST}
- {3245014800 3600 0 CET}
- {3257715600 7200 1 CEST}
- {3276464400 3600 0 CET}
- {3289165200 7200 1 CEST}
- {3307914000 3600 0 CET}
- {3321219600 7200 1 CEST}
- {3339363600 3600 0 CET}
- {3352669200 7200 1 CEST}
- {3370813200 3600 0 CET}
- {3384118800 7200 1 CEST}
- {3402867600 3600 0 CET}
- {3415568400 7200 1 CEST}
- {3434317200 3600 0 CET}
- {3447018000 7200 1 CEST}
- {3465766800 3600 0 CET}
- {3479072400 7200 1 CEST}
- {3497216400 3600 0 CET}
- {3510522000 7200 1 CEST}
- {3528666000 3600 0 CET}
- {3541971600 7200 1 CEST}
- {3560115600 3600 0 CET}
- {3573421200 7200 1 CEST}
- {3592170000 3600 0 CET}
- {3604870800 7200 1 CEST}
- {3623619600 3600 0 CET}
- {3636320400 7200 1 CEST}
- {3655069200 3600 0 CET}
- {3668374800 7200 1 CEST}
- {3686518800 3600 0 CET}
- {3699824400 7200 1 CEST}
- {3717968400 3600 0 CET}
- {3731274000 7200 1 CEST}
- {3750022800 3600 0 CET}
- {3762723600 7200 1 CEST}
- {3781472400 3600 0 CET}
- {3794173200 7200 1 CEST}
- {3812922000 3600 0 CET}
- {3825622800 7200 1 CEST}
- {3844371600 3600 0 CET}
- {3857677200 7200 1 CEST}
- {3875821200 3600 0 CET}
- {3889126800 7200 1 CEST}
- {3907270800 3600 0 CET}
- {3920576400 7200 1 CEST}
- {3939325200 3600 0 CET}
- {3952026000 7200 1 CEST}
- {3970774800 3600 0 CET}
- {3983475600 7200 1 CEST}
- {4002224400 3600 0 CET}
- {4015530000 7200 1 CEST}
- {4033674000 3600 0 CET}
- {4046979600 7200 1 CEST}
- {4065123600 3600 0 CET}
- {4078429200 7200 1 CEST}
- {4096573200 3600 0 CET}
+if {![info exists TZData(Europe/Berlin)]} {
+ LoadTimeZoneFile Europe/Berlin
}
+set TZData(:Europe/Copenhagen) $TZData(:Europe/Berlin)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Dublin
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Dublin 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Dublin 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,8 +1,8 @@
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Dublin) {
- {-9223372036854775808 -1500 0 LMT}
- {-2821649700 -1521 0 DMT}
+ {-9223372036854775808 -1521 0 LMT}
+ {-2821649679 -1521 0 DMT}
{-1691962479 2079 1 IST}
{-1680471279 0 0 GMT}
{-1664143200 3600 1 BST}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Kiev
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Kiev 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Kiev 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,251 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-
-set TZData(:Europe/Kiev) {
- {-9223372036854775808 7324 0 LMT}
- {-2840148124 7324 0 KMT}
- {-1441159324 7200 0 EET}
- {-1247536800 10800 0 MSK}
- {-892522800 3600 0 CET}
- {-857257200 3600 0 CET}
- {-844556400 7200 1 CEST}
- {-828226800 3600 0 CET}
- {-825382800 10800 0 MSD}
- {354920400 14400 1 MSD}
- {370728000 10800 0 MSK}
- {386456400 14400 1 MSD}
- {402264000 10800 0 MSK}
- {417992400 14400 1 MSD}
- {433800000 10800 0 MSK}
- {449614800 14400 1 MSD}
- {465346800 10800 0 MSK}
- {481071600 14400 1 MSD}
- {496796400 10800 0 MSK}
- {512521200 14400 1 MSD}
- {528246000 10800 0 MSK}
- {543970800 14400 1 MSD}
- {559695600 10800 0 MSK}
- {575420400 14400 1 MSD}
- {591145200 10800 0 MSK}
- {606870000 14400 1 MSD}
- {622594800 10800 0 MSK}
- {638319600 14400 1 MSD}
- {646786800 10800 1 EEST}
- {686102400 7200 0 EET}
- {701820000 10800 1 EEST}
- {717541200 7200 0 EET}
- {733269600 10800 1 EEST}
- {748990800 7200 0 EET}
- {764719200 10800 1 EEST}
- {780440400 7200 0 EET}
- {788911200 7200 0 EET}
- {796179600 10800 1 EEST}
- {811904400 7200 0 EET}
- {828234000 10800 1 EEST}
- {846378000 7200 0 EET}
- {859683600 10800 1 EEST}
- {877827600 7200 0 EET}
- {891133200 10800 1 EEST}
- {909277200 7200 0 EET}
- {922582800 10800 1 EEST}
- {941331600 7200 0 EET}
- {954032400 10800 1 EEST}
- {972781200 7200 0 EET}
- {985482000 10800 1 EEST}
- {1004230800 7200 0 EET}
- {1017536400 10800 1 EEST}
- {1035680400 7200 0 EET}
- {1048986000 10800 1 EEST}
- {1067130000 7200 0 EET}
- {1080435600 10800 1 EEST}
- {1099184400 7200 0 EET}
- {1111885200 10800 1 EEST}
- {1130634000 7200 0 EET}
- {1143334800 10800 1 EEST}
- {1162083600 7200 0 EET}
- {1174784400 10800 1 EEST}
- {1193533200 7200 0 EET}
- {1206838800 10800 1 EEST}
- {1224982800 7200 0 EET}
- {1238288400 10800 1 EEST}
- {1256432400 7200 0 EET}
- {1269738000 10800 1 EEST}
- {1288486800 7200 0 EET}
- {1301187600 10800 1 EEST}
- {1319936400 7200 0 EET}
- {1332637200 10800 1 EEST}
- {1351386000 7200 0 EET}
- {1364691600 10800 1 EEST}
- {1382835600 7200 0 EET}
- {1396141200 10800 1 EEST}
- {1414285200 7200 0 EET}
- {1427590800 10800 1 EEST}
- {1445734800 7200 0 EET}
- {1459040400 10800 1 EEST}
- {1477789200 7200 0 EET}
- {1490490000 10800 1 EEST}
- {1509238800 7200 0 EET}
- {1521939600 10800 1 EEST}
- {1540688400 7200 0 EET}
- {1553994000 10800 1 EEST}
- {1572138000 7200 0 EET}
- {1585443600 10800 1 EEST}
- {1603587600 7200 0 EET}
- {1616893200 10800 1 EEST}
- {1635642000 7200 0 EET}
- {1648342800 10800 1 EEST}
- {1667091600 7200 0 EET}
- {1679792400 10800 1 EEST}
- {1698541200 7200 0 EET}
- {1711846800 10800 1 EEST}
- {1729990800 7200 0 EET}
- {1743296400 10800 1 EEST}
- {1761440400 7200 0 EET}
- {1774746000 10800 1 EEST}
- {1792890000 7200 0 EET}
- {1806195600 10800 1 EEST}
- {1824944400 7200 0 EET}
- {1837645200 10800 1 EEST}
- {1856394000 7200 0 EET}
- {1869094800 10800 1 EEST}
- {1887843600 7200 0 EET}
- {1901149200 10800 1 EEST}
- {1919293200 7200 0 EET}
- {1932598800 10800 1 EEST}
- {1950742800 7200 0 EET}
- {1964048400 10800 1 EEST}
- {1982797200 7200 0 EET}
- {1995498000 10800 1 EEST}
- {2014246800 7200 0 EET}
- {2026947600 10800 1 EEST}
- {2045696400 7200 0 EET}
- {2058397200 10800 1 EEST}
- {2077146000 7200 0 EET}
- {2090451600 10800 1 EEST}
- {2108595600 7200 0 EET}
- {2121901200 10800 1 EEST}
- {2140045200 7200 0 EET}
- {2153350800 10800 1 EEST}
- {2172099600 7200 0 EET}
- {2184800400 10800 1 EEST}
- {2203549200 7200 0 EET}
- {2216250000 10800 1 EEST}
- {2234998800 7200 0 EET}
- {2248304400 10800 1 EEST}
- {2266448400 7200 0 EET}
- {2279754000 10800 1 EEST}
- {2297898000 7200 0 EET}
- {2311203600 10800 1 EEST}
- {2329347600 7200 0 EET}
- {2342653200 10800 1 EEST}
- {2361402000 7200 0 EET}
- {2374102800 10800 1 EEST}
- {2392851600 7200 0 EET}
- {2405552400 10800 1 EEST}
- {2424301200 7200 0 EET}
- {2437606800 10800 1 EEST}
- {2455750800 7200 0 EET}
- {2469056400 10800 1 EEST}
- {2487200400 7200 0 EET}
- {2500506000 10800 1 EEST}
- {2519254800 7200 0 EET}
- {2531955600 10800 1 EEST}
- {2550704400 7200 0 EET}
- {2563405200 10800 1 EEST}
- {2582154000 7200 0 EET}
- {2595459600 10800 1 EEST}
- {2613603600 7200 0 EET}
- {2626909200 10800 1 EEST}
- {2645053200 7200 0 EET}
- {2658358800 10800 1 EEST}
- {2676502800 7200 0 EET}
- {2689808400 10800 1 EEST}
- {2708557200 7200 0 EET}
- {2721258000 10800 1 EEST}
- {2740006800 7200 0 EET}
- {2752707600 10800 1 EEST}
- {2771456400 7200 0 EET}
- {2784762000 10800 1 EEST}
- {2802906000 7200 0 EET}
- {2816211600 10800 1 EEST}
- {2834355600 7200 0 EET}
- {2847661200 10800 1 EEST}
- {2866410000 7200 0 EET}
- {2879110800 10800 1 EEST}
- {2897859600 7200 0 EET}
- {2910560400 10800 1 EEST}
- {2929309200 7200 0 EET}
- {2942010000 10800 1 EEST}
- {2960758800 7200 0 EET}
- {2974064400 10800 1 EEST}
- {2992208400 7200 0 EET}
- {3005514000 10800 1 EEST}
- {3023658000 7200 0 EET}
- {3036963600 10800 1 EEST}
- {3055712400 7200 0 EET}
- {3068413200 10800 1 EEST}
- {3087162000 7200 0 EET}
- {3099862800 10800 1 EEST}
- {3118611600 7200 0 EET}
- {3131917200 10800 1 EEST}
- {3150061200 7200 0 EET}
- {3163366800 10800 1 EEST}
- {3181510800 7200 0 EET}
- {3194816400 10800 1 EEST}
- {3212960400 7200 0 EET}
- {3226266000 10800 1 EEST}
- {3245014800 7200 0 EET}
- {3257715600 10800 1 EEST}
- {3276464400 7200 0 EET}
- {3289165200 10800 1 EEST}
- {3307914000 7200 0 EET}
- {3321219600 10800 1 EEST}
- {3339363600 7200 0 EET}
- {3352669200 10800 1 EEST}
- {3370813200 7200 0 EET}
- {3384118800 10800 1 EEST}
- {3402867600 7200 0 EET}
- {3415568400 10800 1 EEST}
- {3434317200 7200 0 EET}
- {3447018000 10800 1 EEST}
- {3465766800 7200 0 EET}
- {3479072400 10800 1 EEST}
- {3497216400 7200 0 EET}
- {3510522000 10800 1 EEST}
- {3528666000 7200 0 EET}
- {3541971600 10800 1 EEST}
- {3560115600 7200 0 EET}
- {3573421200 10800 1 EEST}
- {3592170000 7200 0 EET}
- {3604870800 10800 1 EEST}
- {3623619600 7200 0 EET}
- {3636320400 10800 1 EEST}
- {3655069200 7200 0 EET}
- {3668374800 10800 1 EEST}
- {3686518800 7200 0 EET}
- {3699824400 10800 1 EEST}
- {3717968400 7200 0 EET}
- {3731274000 10800 1 EEST}
- {3750022800 7200 0 EET}
- {3762723600 10800 1 EEST}
- {3781472400 7200 0 EET}
- {3794173200 10800 1 EEST}
- {3812922000 7200 0 EET}
- {3825622800 10800 1 EEST}
- {3844371600 7200 0 EET}
- {3857677200 10800 1 EEST}
- {3875821200 7200 0 EET}
- {3889126800 10800 1 EEST}
- {3907270800 7200 0 EET}
- {3920576400 10800 1 EEST}
- {3939325200 7200 0 EET}
- {3952026000 10800 1 EEST}
- {3970774800 7200 0 EET}
- {3983475600 10800 1 EEST}
- {4002224400 7200 0 EET}
- {4015530000 10800 1 EEST}
- {4033674000 7200 0 EET}
- {4046979600 10800 1 EEST}
- {4065123600 7200 0 EET}
- {4078429200 10800 1 EEST}
- {4096573200 7200 0 EET}
+if {![info exists TZData(Europe/Kyiv)]} {
+ LoadTimeZoneFile Europe/Kyiv
}
+set TZData(:Europe/Kiev) $TZData(:Europe/Kyiv)
Added: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Kyiv
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Kyiv (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Kyiv 2024-02-15 21:05:12 UTC (rev 69897)
@@ -0,0 +1,251 @@
+# created by tools/tclZIC.tcl - do not edit
+
+set TZData(:Europe/Kyiv) {
+ {-9223372036854775808 7324 0 LMT}
+ {-2840148124 7324 0 KMT}
+ {-1441159324 7200 0 EET}
+ {-1247536800 10800 0 MSK}
+ {-892522800 3600 0 CET}
+ {-857257200 3600 0 CET}
+ {-844556400 7200 1 CEST}
+ {-828226800 3600 0 CET}
+ {-825382800 10800 0 MSD}
+ {354920400 14400 1 MSD}
+ {370728000 10800 0 MSK}
+ {386456400 14400 1 MSD}
+ {402264000 10800 0 MSK}
+ {417992400 14400 1 MSD}
+ {433800000 10800 0 MSK}
+ {449614800 14400 1 MSD}
+ {465346800 10800 0 MSK}
+ {481071600 14400 1 MSD}
+ {496796400 10800 0 MSK}
+ {512521200 14400 1 MSD}
+ {528246000 10800 0 MSK}
+ {543970800 14400 1 MSD}
+ {559695600 10800 0 MSK}
+ {575420400 14400 1 MSD}
+ {591145200 10800 0 MSK}
+ {606870000 14400 1 MSD}
+ {622594800 10800 0 MSK}
+ {638319600 14400 1 MSD}
+ {646786800 10800 1 EEST}
+ {686102400 7200 0 EET}
+ {701827200 10800 1 EEST}
+ {717552000 7200 0 EET}
+ {733276800 10800 1 EEST}
+ {749001600 7200 0 EET}
+ {764726400 10800 1 EEST}
+ {780451200 7200 0 EET}
+ {796176000 10800 1 EEST}
+ {811900800 7200 0 EET}
+ {828230400 10800 1 EEST}
+ {831938400 10800 0 EEST}
+ {846378000 7200 0 EET}
+ {859683600 10800 1 EEST}
+ {877827600 7200 0 EET}
+ {891133200 10800 1 EEST}
+ {909277200 7200 0 EET}
+ {922582800 10800 1 EEST}
+ {941331600 7200 0 EET}
+ {954032400 10800 1 EEST}
+ {972781200 7200 0 EET}
+ {985482000 10800 1 EEST}
+ {1004230800 7200 0 EET}
+ {1017536400 10800 1 EEST}
+ {1035680400 7200 0 EET}
+ {1048986000 10800 1 EEST}
+ {1067130000 7200 0 EET}
+ {1080435600 10800 1 EEST}
+ {1099184400 7200 0 EET}
+ {1111885200 10800 1 EEST}
+ {1130634000 7200 0 EET}
+ {1143334800 10800 1 EEST}
+ {1162083600 7200 0 EET}
+ {1174784400 10800 1 EEST}
+ {1193533200 7200 0 EET}
+ {1206838800 10800 1 EEST}
+ {1224982800 7200 0 EET}
+ {1238288400 10800 1 EEST}
+ {1256432400 7200 0 EET}
+ {1269738000 10800 1 EEST}
+ {1288486800 7200 0 EET}
+ {1301187600 10800 1 EEST}
+ {1319936400 7200 0 EET}
+ {1332637200 10800 1 EEST}
+ {1351386000 7200 0 EET}
+ {1364691600 10800 1 EEST}
+ {1382835600 7200 0 EET}
+ {1396141200 10800 1 EEST}
+ {1414285200 7200 0 EET}
+ {1427590800 10800 1 EEST}
+ {1445734800 7200 0 EET}
+ {1459040400 10800 1 EEST}
+ {1477789200 7200 0 EET}
+ {1490490000 10800 1 EEST}
+ {1509238800 7200 0 EET}
+ {1521939600 10800 1 EEST}
+ {1540688400 7200 0 EET}
+ {1553994000 10800 1 EEST}
+ {1572138000 7200 0 EET}
+ {1585443600 10800 1 EEST}
+ {1603587600 7200 0 EET}
+ {1616893200 10800 1 EEST}
+ {1635642000 7200 0 EET}
+ {1648342800 10800 1 EEST}
+ {1667091600 7200 0 EET}
+ {1679792400 10800 1 EEST}
+ {1698541200 7200 0 EET}
+ {1711846800 10800 1 EEST}
+ {1729990800 7200 0 EET}
+ {1743296400 10800 1 EEST}
+ {1761440400 7200 0 EET}
+ {1774746000 10800 1 EEST}
+ {1792890000 7200 0 EET}
+ {1806195600 10800 1 EEST}
+ {1824944400 7200 0 EET}
+ {1837645200 10800 1 EEST}
+ {1856394000 7200 0 EET}
+ {1869094800 10800 1 EEST}
+ {1887843600 7200 0 EET}
+ {1901149200 10800 1 EEST}
+ {1919293200 7200 0 EET}
+ {1932598800 10800 1 EEST}
+ {1950742800 7200 0 EET}
+ {1964048400 10800 1 EEST}
+ {1982797200 7200 0 EET}
+ {1995498000 10800 1 EEST}
+ {2014246800 7200 0 EET}
+ {2026947600 10800 1 EEST}
+ {2045696400 7200 0 EET}
+ {2058397200 10800 1 EEST}
+ {2077146000 7200 0 EET}
+ {2090451600 10800 1 EEST}
+ {2108595600 7200 0 EET}
+ {2121901200 10800 1 EEST}
+ {2140045200 7200 0 EET}
+ {2153350800 10800 1 EEST}
+ {2172099600 7200 0 EET}
+ {2184800400 10800 1 EEST}
+ {2203549200 7200 0 EET}
+ {2216250000 10800 1 EEST}
+ {2234998800 7200 0 EET}
+ {2248304400 10800 1 EEST}
+ {2266448400 7200 0 EET}
+ {2279754000 10800 1 EEST}
+ {2297898000 7200 0 EET}
+ {2311203600 10800 1 EEST}
+ {2329347600 7200 0 EET}
+ {2342653200 10800 1 EEST}
+ {2361402000 7200 0 EET}
+ {2374102800 10800 1 EEST}
+ {2392851600 7200 0 EET}
+ {2405552400 10800 1 EEST}
+ {2424301200 7200 0 EET}
+ {2437606800 10800 1 EEST}
+ {2455750800 7200 0 EET}
+ {2469056400 10800 1 EEST}
+ {2487200400 7200 0 EET}
+ {2500506000 10800 1 EEST}
+ {2519254800 7200 0 EET}
+ {2531955600 10800 1 EEST}
+ {2550704400 7200 0 EET}
+ {2563405200 10800 1 EEST}
+ {2582154000 7200 0 EET}
+ {2595459600 10800 1 EEST}
+ {2613603600 7200 0 EET}
+ {2626909200 10800 1 EEST}
+ {2645053200 7200 0 EET}
+ {2658358800 10800 1 EEST}
+ {2676502800 7200 0 EET}
+ {2689808400 10800 1 EEST}
+ {2708557200 7200 0 EET}
+ {2721258000 10800 1 EEST}
+ {2740006800 7200 0 EET}
+ {2752707600 10800 1 EEST}
+ {2771456400 7200 0 EET}
+ {2784762000 10800 1 EEST}
+ {2802906000 7200 0 EET}
+ {2816211600 10800 1 EEST}
+ {2834355600 7200 0 EET}
+ {2847661200 10800 1 EEST}
+ {2866410000 7200 0 EET}
+ {2879110800 10800 1 EEST}
+ {2897859600 7200 0 EET}
+ {2910560400 10800 1 EEST}
+ {2929309200 7200 0 EET}
+ {2942010000 10800 1 EEST}
+ {2960758800 7200 0 EET}
+ {2974064400 10800 1 EEST}
+ {2992208400 7200 0 EET}
+ {3005514000 10800 1 EEST}
+ {3023658000 7200 0 EET}
+ {3036963600 10800 1 EEST}
+ {3055712400 7200 0 EET}
+ {3068413200 10800 1 EEST}
+ {3087162000 7200 0 EET}
+ {3099862800 10800 1 EEST}
+ {3118611600 7200 0 EET}
+ {3131917200 10800 1 EEST}
+ {3150061200 7200 0 EET}
+ {3163366800 10800 1 EEST}
+ {3181510800 7200 0 EET}
+ {3194816400 10800 1 EEST}
+ {3212960400 7200 0 EET}
+ {3226266000 10800 1 EEST}
+ {3245014800 7200 0 EET}
+ {3257715600 10800 1 EEST}
+ {3276464400 7200 0 EET}
+ {3289165200 10800 1 EEST}
+ {3307914000 7200 0 EET}
+ {3321219600 10800 1 EEST}
+ {3339363600 7200 0 EET}
+ {3352669200 10800 1 EEST}
+ {3370813200 7200 0 EET}
+ {3384118800 10800 1 EEST}
+ {3402867600 7200 0 EET}
+ {3415568400 10800 1 EEST}
+ {3434317200 7200 0 EET}
+ {3447018000 10800 1 EEST}
+ {3465766800 7200 0 EET}
+ {3479072400 10800 1 EEST}
+ {3497216400 7200 0 EET}
+ {3510522000 10800 1 EEST}
+ {3528666000 7200 0 EET}
+ {3541971600 10800 1 EEST}
+ {3560115600 7200 0 EET}
+ {3573421200 10800 1 EEST}
+ {3592170000 7200 0 EET}
+ {3604870800 10800 1 EEST}
+ {3623619600 7200 0 EET}
+ {3636320400 10800 1 EEST}
+ {3655069200 7200 0 EET}
+ {3668374800 10800 1 EEST}
+ {3686518800 7200 0 EET}
+ {3699824400 10800 1 EEST}
+ {3717968400 7200 0 EET}
+ {3731274000 10800 1 EEST}
+ {3750022800 7200 0 EET}
+ {3762723600 10800 1 EEST}
+ {3781472400 7200 0 EET}
+ {3794173200 10800 1 EEST}
+ {3812922000 7200 0 EET}
+ {3825622800 10800 1 EEST}
+ {3844371600 7200 0 EET}
+ {3857677200 10800 1 EEST}
+ {3875821200 7200 0 EET}
+ {3889126800 10800 1 EEST}
+ {3907270800 7200 0 EET}
+ {3920576400 10800 1 EEST}
+ {3939325200 7200 0 EET}
+ {3952026000 10800 1 EEST}
+ {3970774800 7200 0 EET}
+ {3983475600 10800 1 EEST}
+ {4002224400 7200 0 EET}
+ {4015530000 10800 1 EEST}
+ {4033674000 7200 0 EET}
+ {4046979600 10800 1 EEST}
+ {4065123600 7200 0 EET}
+ {4078429200 10800 1 EEST}
+ {4096573200 7200 0 EET}
+}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Luxembourg
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Luxembourg 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Luxembourg 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,313 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-
-set TZData(:Europe/Luxembourg) {
- {-9223372036854775808 1476 0 LMT}
- {-2069713476 3600 0 CET}
- {-1692496800 7200 1 CEST}
- {-1680483600 3600 0 CET}
- {-1662343200 7200 1 CEST}
- {-1650157200 3600 0 CET}
- {-1632006000 7200 1 CEST}
- {-1618700400 3600 0 CET}
- {-1612659600 0 0 WET}
- {-1604278800 3600 1 WEST}
- {-1585519200 0 0 WET}
- {-1574038800 3600 1 WEST}
- {-1552258800 0 0 WET}
- {-1539997200 3600 1 WEST}
- {-1520550000 0 0 WET}
- {-1507510800 3600 1 WEST}
- {-1490572800 0 0 WET}
- {-1473642000 3600 1 WEST}
- {-1459119600 0 0 WET}
- {-1444006800 3600 1 WEST}
- {-1427673600 0 0 WET}
- {-1411866000 3600 1 WEST}
- {-1396224000 0 0 WET}
- {-1379293200 3600 1 WEST}
- {-1364774400 0 0 WET}
- {-1348448400 3600 1 WEST}
- {-1333324800 0 0 WET}
- {-1316394000 3600 1 WEST}
- {-1301270400 0 0 WET}
- {-1284339600 3600 1 WEST}
- {-1269813600 0 0 WET}
- {-1253484000 3600 1 WEST}
- {-1238364000 0 0 WET}
- {-1221429600 3600 1 WEST}
- {-1206914400 0 0 WET}
- {-1191189600 3600 1 WEST}
- {-1175464800 0 0 WET}
- {-1160344800 3600 1 WEST}
- {-1143410400 0 0 WET}
- {-1127685600 3600 1 WEST}
- {-1111960800 0 0 WET}
- {-1096840800 3600 1 WEST}
- {-1080511200 0 0 WET}
- {-1063576800 3600 1 WEST}
- {-1049061600 0 0 WET}
- {-1033336800 3600 1 WEST}
- {-1017612000 0 0 WET}
- {-1002492000 3600 1 WEST}
- {-986162400 0 0 WET}
- {-969228000 3600 1 WEST}
- {-950479200 0 0 WET}
- {-942012000 3600 1 WEST}
- {-935186400 7200 0 WEST}
- {-857257200 3600 0 WET}
- {-844556400 7200 1 WEST}
- {-828226800 3600 0 WET}
- {-812502000 7200 1 WEST}
- {-797983200 3600 0 CET}
- {-781052400 7200 1 CEST}
- {-766623600 3600 0 CET}
- {-745455600 7200 1 CEST}
- {-733273200 3600 0 CET}
- {220921200 3600 0 CET}
- {228877200 7200 1 CEST}
- {243997200 3600 0 CET}
- {260326800 7200 1 CEST}
- {276051600 3600 0 CET}
- {291776400 7200 1 CEST}
- {307501200 3600 0 CET}
- {323830800 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}
- {449024400 7200 1 CEST}
- {465354000 3600 0 CET}
- {481078800 7200 1 CEST}
- {496803600 3600 0 CET}
- {512528400 7200 1 CEST}
- {528253200 3600 0 CET}
- {543978000 7200 1 CEST}
- {559702800 3600 0 CET}
- {575427600 7200 1 CEST}
- {591152400 3600 0 CET}
- {606877200 7200 1 CEST}
- {622602000 3600 0 CET}
- {638326800 7200 1 CEST}
- {654656400 3600 0 CET}
- {670381200 7200 1 CEST}
- {686106000 3600 0 CET}
- {701830800 7200 1 CEST}
- {717555600 3600 0 CET}
- {733280400 7200 1 CEST}
- {749005200 3600 0 CET}
- {764730000 7200 1 CEST}
- {780454800 3600 0 CET}
- {796179600 7200 1 CEST}
- {811904400 3600 0 CET}
- {828234000 7200 1 CEST}
- {846378000 3600 0 CET}
- {859683600 7200 1 CEST}
- {877827600 3600 0 CET}
- {891133200 7200 1 CEST}
- {909277200 3600 0 CET}
- {922582800 7200 1 CEST}
- {941331600 3600 0 CET}
- {954032400 7200 1 CEST}
- {972781200 3600 0 CET}
- {985482000 7200 1 CEST}
- {1004230800 3600 0 CET}
- {1017536400 7200 1 CEST}
- {1035680400 3600 0 CET}
- {1048986000 7200 1 CEST}
- {1067130000 3600 0 CET}
- {1080435600 7200 1 CEST}
- {1099184400 3600 0 CET}
- {1111885200 7200 1 CEST}
- {1130634000 3600 0 CET}
- {1143334800 7200 1 CEST}
- {1162083600 3600 0 CET}
- {1174784400 7200 1 CEST}
- {1193533200 3600 0 CET}
- {1206838800 7200 1 CEST}
- {1224982800 3600 0 CET}
- {1238288400 7200 1 CEST}
- {1256432400 3600 0 CET}
- {1269738000 7200 1 CEST}
- {1288486800 3600 0 CET}
- {1301187600 7200 1 CEST}
- {1319936400 3600 0 CET}
- {1332637200 7200 1 CEST}
- {1351386000 3600 0 CET}
- {1364691600 7200 1 CEST}
- {1382835600 3600 0 CET}
- {1396141200 7200 1 CEST}
- {1414285200 3600 0 CET}
- {1427590800 7200 1 CEST}
- {1445734800 3600 0 CET}
- {1459040400 7200 1 CEST}
- {1477789200 3600 0 CET}
- {1490490000 7200 1 CEST}
- {1509238800 3600 0 CET}
- {1521939600 7200 1 CEST}
- {1540688400 3600 0 CET}
- {1553994000 7200 1 CEST}
- {1572138000 3600 0 CET}
- {1585443600 7200 1 CEST}
- {1603587600 3600 0 CET}
- {1616893200 7200 1 CEST}
- {1635642000 3600 0 CET}
- {1648342800 7200 1 CEST}
- {1667091600 3600 0 CET}
- {1679792400 7200 1 CEST}
- {1698541200 3600 0 CET}
- {1711846800 7200 1 CEST}
- {1729990800 3600 0 CET}
- {1743296400 7200 1 CEST}
- {1761440400 3600 0 CET}
- {1774746000 7200 1 CEST}
- {1792890000 3600 0 CET}
- {1806195600 7200 1 CEST}
- {1824944400 3600 0 CET}
- {1837645200 7200 1 CEST}
- {1856394000 3600 0 CET}
- {1869094800 7200 1 CEST}
- {1887843600 3600 0 CET}
- {1901149200 7200 1 CEST}
- {1919293200 3600 0 CET}
- {1932598800 7200 1 CEST}
- {1950742800 3600 0 CET}
- {1964048400 7200 1 CEST}
- {1982797200 3600 0 CET}
- {1995498000 7200 1 CEST}
- {2014246800 3600 0 CET}
- {2026947600 7200 1 CEST}
- {2045696400 3600 0 CET}
- {2058397200 7200 1 CEST}
- {2077146000 3600 0 CET}
- {2090451600 7200 1 CEST}
- {2108595600 3600 0 CET}
- {2121901200 7200 1 CEST}
- {2140045200 3600 0 CET}
- {2153350800 7200 1 CEST}
- {2172099600 3600 0 CET}
- {2184800400 7200 1 CEST}
- {2203549200 3600 0 CET}
- {2216250000 7200 1 CEST}
- {2234998800 3600 0 CET}
- {2248304400 7200 1 CEST}
- {2266448400 3600 0 CET}
- {2279754000 7200 1 CEST}
- {2297898000 3600 0 CET}
- {2311203600 7200 1 CEST}
- {2329347600 3600 0 CET}
- {2342653200 7200 1 CEST}
- {2361402000 3600 0 CET}
- {2374102800 7200 1 CEST}
- {2392851600 3600 0 CET}
- {2405552400 7200 1 CEST}
- {2424301200 3600 0 CET}
- {2437606800 7200 1 CEST}
- {2455750800 3600 0 CET}
- {2469056400 7200 1 CEST}
- {2487200400 3600 0 CET}
- {2500506000 7200 1 CEST}
- {2519254800 3600 0 CET}
- {2531955600 7200 1 CEST}
- {2550704400 3600 0 CET}
- {2563405200 7200 1 CEST}
- {2582154000 3600 0 CET}
- {2595459600 7200 1 CEST}
- {2613603600 3600 0 CET}
- {2626909200 7200 1 CEST}
- {2645053200 3600 0 CET}
- {2658358800 7200 1 CEST}
- {2676502800 3600 0 CET}
- {2689808400 7200 1 CEST}
- {2708557200 3600 0 CET}
- {2721258000 7200 1 CEST}
- {2740006800 3600 0 CET}
- {2752707600 7200 1 CEST}
- {2771456400 3600 0 CET}
- {2784762000 7200 1 CEST}
- {2802906000 3600 0 CET}
- {2816211600 7200 1 CEST}
- {2834355600 3600 0 CET}
- {2847661200 7200 1 CEST}
- {2866410000 3600 0 CET}
- {2879110800 7200 1 CEST}
- {2897859600 3600 0 CET}
- {2910560400 7200 1 CEST}
- {2929309200 3600 0 CET}
- {2942010000 7200 1 CEST}
- {2960758800 3600 0 CET}
- {2974064400 7200 1 CEST}
- {2992208400 3600 0 CET}
- {3005514000 7200 1 CEST}
- {3023658000 3600 0 CET}
- {3036963600 7200 1 CEST}
- {3055712400 3600 0 CET}
- {3068413200 7200 1 CEST}
- {3087162000 3600 0 CET}
- {3099862800 7200 1 CEST}
- {3118611600 3600 0 CET}
- {3131917200 7200 1 CEST}
- {3150061200 3600 0 CET}
- {3163366800 7200 1 CEST}
- {3181510800 3600 0 CET}
- {3194816400 7200 1 CEST}
- {3212960400 3600 0 CET}
- {3226266000 7200 1 CEST}
- {3245014800 3600 0 CET}
- {3257715600 7200 1 CEST}
- {3276464400 3600 0 CET}
- {3289165200 7200 1 CEST}
- {3307914000 3600 0 CET}
- {3321219600 7200 1 CEST}
- {3339363600 3600 0 CET}
- {3352669200 7200 1 CEST}
- {3370813200 3600 0 CET}
- {3384118800 7200 1 CEST}
- {3402867600 3600 0 CET}
- {3415568400 7200 1 CEST}
- {3434317200 3600 0 CET}
- {3447018000 7200 1 CEST}
- {3465766800 3600 0 CET}
- {3479072400 7200 1 CEST}
- {3497216400 3600 0 CET}
- {3510522000 7200 1 CEST}
- {3528666000 3600 0 CET}
- {3541971600 7200 1 CEST}
- {3560115600 3600 0 CET}
- {3573421200 7200 1 CEST}
- {3592170000 3600 0 CET}
- {3604870800 7200 1 CEST}
- {3623619600 3600 0 CET}
- {3636320400 7200 1 CEST}
- {3655069200 3600 0 CET}
- {3668374800 7200 1 CEST}
- {3686518800 3600 0 CET}
- {3699824400 7200 1 CEST}
- {3717968400 3600 0 CET}
- {3731274000 7200 1 CEST}
- {3750022800 3600 0 CET}
- {3762723600 7200 1 CEST}
- {3781472400 3600 0 CET}
- {3794173200 7200 1 CEST}
- {3812922000 3600 0 CET}
- {3825622800 7200 1 CEST}
- {3844371600 3600 0 CET}
- {3857677200 7200 1 CEST}
- {3875821200 3600 0 CET}
- {3889126800 7200 1 CEST}
- {3907270800 3600 0 CET}
- {3920576400 7200 1 CEST}
- {3939325200 3600 0 CET}
- {3952026000 7200 1 CEST}
- {3970774800 3600 0 CET}
- {3983475600 7200 1 CEST}
- {4002224400 3600 0 CET}
- {4015530000 7200 1 CEST}
- {4033674000 3600 0 CET}
- {4046979600 7200 1 CEST}
- {4065123600 3600 0 CET}
- {4078429200 7200 1 CEST}
- {4096573200 3600 0 CET}
+if {![info exists TZData(Europe/Brussels)]} {
+ LoadTimeZoneFile Europe/Brussels
}
+set TZData(:Europe/Luxembourg) $TZData(:Europe/Brussels)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Monaco
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Monaco 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Monaco 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,315 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-
-set TZData(:Europe/Monaco) {
- {-9223372036854775808 1772 0 LMT}
- {-2448318572 561 0 PMT}
- {-1854403761 0 0 WET}
- {-1689814800 3600 1 WEST}
- {-1680397200 0 0 WET}
- {-1665363600 3600 1 WEST}
- {-1648342800 0 0 WET}
- {-1635123600 3600 1 WEST}
- {-1616893200 0 0 WET}
- {-1604278800 3600 1 WEST}
- {-1585443600 0 0 WET}
- {-1574038800 3600 1 WEST}
- {-1552266000 0 0 WET}
- {-1539997200 3600 1 WEST}
- {-1520557200 0 0 WET}
- {-1507510800 3600 1 WEST}
- {-1490576400 0 0 WET}
- {-1470618000 3600 1 WEST}
- {-1459126800 0 0 WET}
- {-1444006800 3600 1 WEST}
- {-1427677200 0 0 WET}
- {-1411952400 3600 1 WEST}
- {-1396227600 0 0 WET}
- {-1379293200 3600 1 WEST}
- {-1364778000 0 0 WET}
- {-1348448400 3600 1 WEST}
- {-1333328400 0 0 WET}
- {-1316394000 3600 1 WEST}
- {-1301274000 0 0 WET}
- {-1284339600 3600 1 WEST}
- {-1269824400 0 0 WET}
- {-1253494800 3600 1 WEST}
- {-1238374800 0 0 WET}
- {-1221440400 3600 1 WEST}
- {-1206925200 0 0 WET}
- {-1191200400 3600 1 WEST}
- {-1175475600 0 0 WET}
- {-1160355600 3600 1 WEST}
- {-1143421200 0 0 WET}
- {-1127696400 3600 1 WEST}
- {-1111971600 0 0 WET}
- {-1096851600 3600 1 WEST}
- {-1080522000 0 0 WET}
- {-1063587600 3600 1 WEST}
- {-1049072400 0 0 WET}
- {-1033347600 3600 1 WEST}
- {-1017622800 0 0 WET}
- {-1002502800 3600 1 WEST}
- {-986173200 0 0 WET}
- {-969238800 3600 1 WEST}
- {-950490000 0 0 WET}
- {-942012000 3600 1 WEST}
- {-904438800 7200 1 WEMT}
- {-891136800 3600 1 WEST}
- {-877827600 7200 1 WEMT}
- {-857257200 3600 1 WEST}
- {-844556400 7200 1 WEMT}
- {-828226800 3600 1 WEST}
- {-812502000 7200 1 WEMT}
- {-796266000 3600 1 WEST}
- {-781052400 7200 1 WEMT}
- {-766616400 3600 0 CET}
- {196819200 7200 1 CEST}
- {212540400 3600 0 CET}
- {220921200 3600 0 CET}
- {228877200 7200 1 CEST}
- {243997200 3600 0 CET}
- {260326800 7200 1 CEST}
- {276051600 3600 0 CET}
- {291776400 7200 1 CEST}
- {307501200 3600 0 CET}
- {323830800 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}
- {449024400 7200 1 CEST}
- {465354000 3600 0 CET}
- {481078800 7200 1 CEST}
- {496803600 3600 0 CET}
- {512528400 7200 1 CEST}
- {528253200 3600 0 CET}
- {543978000 7200 1 CEST}
- {559702800 3600 0 CET}
- {575427600 7200 1 CEST}
- {591152400 3600 0 CET}
- {606877200 7200 1 CEST}
- {622602000 3600 0 CET}
- {638326800 7200 1 CEST}
- {654656400 3600 0 CET}
- {670381200 7200 1 CEST}
- {686106000 3600 0 CET}
- {701830800 7200 1 CEST}
- {717555600 3600 0 CET}
- {733280400 7200 1 CEST}
- {749005200 3600 0 CET}
- {764730000 7200 1 CEST}
- {780454800 3600 0 CET}
- {796179600 7200 1 CEST}
- {811904400 3600 0 CET}
- {828234000 7200 1 CEST}
- {846378000 3600 0 CET}
- {859683600 7200 1 CEST}
- {877827600 3600 0 CET}
- {891133200 7200 1 CEST}
- {909277200 3600 0 CET}
- {922582800 7200 1 CEST}
- {941331600 3600 0 CET}
- {954032400 7200 1 CEST}
- {972781200 3600 0 CET}
- {985482000 7200 1 CEST}
- {1004230800 3600 0 CET}
- {1017536400 7200 1 CEST}
- {1035680400 3600 0 CET}
- {1048986000 7200 1 CEST}
- {1067130000 3600 0 CET}
- {1080435600 7200 1 CEST}
- {1099184400 3600 0 CET}
- {1111885200 7200 1 CEST}
- {1130634000 3600 0 CET}
- {1143334800 7200 1 CEST}
- {1162083600 3600 0 CET}
- {1174784400 7200 1 CEST}
- {1193533200 3600 0 CET}
- {1206838800 7200 1 CEST}
- {1224982800 3600 0 CET}
- {1238288400 7200 1 CEST}
- {1256432400 3600 0 CET}
- {1269738000 7200 1 CEST}
- {1288486800 3600 0 CET}
- {1301187600 7200 1 CEST}
- {1319936400 3600 0 CET}
- {1332637200 7200 1 CEST}
- {1351386000 3600 0 CET}
- {1364691600 7200 1 CEST}
- {1382835600 3600 0 CET}
- {1396141200 7200 1 CEST}
- {1414285200 3600 0 CET}
- {1427590800 7200 1 CEST}
- {1445734800 3600 0 CET}
- {1459040400 7200 1 CEST}
- {1477789200 3600 0 CET}
- {1490490000 7200 1 CEST}
- {1509238800 3600 0 CET}
- {1521939600 7200 1 CEST}
- {1540688400 3600 0 CET}
- {1553994000 7200 1 CEST}
- {1572138000 3600 0 CET}
- {1585443600 7200 1 CEST}
- {1603587600 3600 0 CET}
- {1616893200 7200 1 CEST}
- {1635642000 3600 0 CET}
- {1648342800 7200 1 CEST}
- {1667091600 3600 0 CET}
- {1679792400 7200 1 CEST}
- {1698541200 3600 0 CET}
- {1711846800 7200 1 CEST}
- {1729990800 3600 0 CET}
- {1743296400 7200 1 CEST}
- {1761440400 3600 0 CET}
- {1774746000 7200 1 CEST}
- {1792890000 3600 0 CET}
- {1806195600 7200 1 CEST}
- {1824944400 3600 0 CET}
- {1837645200 7200 1 CEST}
- {1856394000 3600 0 CET}
- {1869094800 7200 1 CEST}
- {1887843600 3600 0 CET}
- {1901149200 7200 1 CEST}
- {1919293200 3600 0 CET}
- {1932598800 7200 1 CEST}
- {1950742800 3600 0 CET}
- {1964048400 7200 1 CEST}
- {1982797200 3600 0 CET}
- {1995498000 7200 1 CEST}
- {2014246800 3600 0 CET}
- {2026947600 7200 1 CEST}
- {2045696400 3600 0 CET}
- {2058397200 7200 1 CEST}
- {2077146000 3600 0 CET}
- {2090451600 7200 1 CEST}
- {2108595600 3600 0 CET}
- {2121901200 7200 1 CEST}
- {2140045200 3600 0 CET}
- {2153350800 7200 1 CEST}
- {2172099600 3600 0 CET}
- {2184800400 7200 1 CEST}
- {2203549200 3600 0 CET}
- {2216250000 7200 1 CEST}
- {2234998800 3600 0 CET}
- {2248304400 7200 1 CEST}
- {2266448400 3600 0 CET}
- {2279754000 7200 1 CEST}
- {2297898000 3600 0 CET}
- {2311203600 7200 1 CEST}
- {2329347600 3600 0 CET}
- {2342653200 7200 1 CEST}
- {2361402000 3600 0 CET}
- {2374102800 7200 1 CEST}
- {2392851600 3600 0 CET}
- {2405552400 7200 1 CEST}
- {2424301200 3600 0 CET}
- {2437606800 7200 1 CEST}
- {2455750800 3600 0 CET}
- {2469056400 7200 1 CEST}
- {2487200400 3600 0 CET}
- {2500506000 7200 1 CEST}
- {2519254800 3600 0 CET}
- {2531955600 7200 1 CEST}
- {2550704400 3600 0 CET}
- {2563405200 7200 1 CEST}
- {2582154000 3600 0 CET}
- {2595459600 7200 1 CEST}
- {2613603600 3600 0 CET}
- {2626909200 7200 1 CEST}
- {2645053200 3600 0 CET}
- {2658358800 7200 1 CEST}
- {2676502800 3600 0 CET}
- {2689808400 7200 1 CEST}
- {2708557200 3600 0 CET}
- {2721258000 7200 1 CEST}
- {2740006800 3600 0 CET}
- {2752707600 7200 1 CEST}
- {2771456400 3600 0 CET}
- {2784762000 7200 1 CEST}
- {2802906000 3600 0 CET}
- {2816211600 7200 1 CEST}
- {2834355600 3600 0 CET}
- {2847661200 7200 1 CEST}
- {2866410000 3600 0 CET}
- {2879110800 7200 1 CEST}
- {2897859600 3600 0 CET}
- {2910560400 7200 1 CEST}
- {2929309200 3600 0 CET}
- {2942010000 7200 1 CEST}
- {2960758800 3600 0 CET}
- {2974064400 7200 1 CEST}
- {2992208400 3600 0 CET}
- {3005514000 7200 1 CEST}
- {3023658000 3600 0 CET}
- {3036963600 7200 1 CEST}
- {3055712400 3600 0 CET}
- {3068413200 7200 1 CEST}
- {3087162000 3600 0 CET}
- {3099862800 7200 1 CEST}
- {3118611600 3600 0 CET}
- {3131917200 7200 1 CEST}
- {3150061200 3600 0 CET}
- {3163366800 7200 1 CEST}
- {3181510800 3600 0 CET}
- {3194816400 7200 1 CEST}
- {3212960400 3600 0 CET}
- {3226266000 7200 1 CEST}
- {3245014800 3600 0 CET}
- {3257715600 7200 1 CEST}
- {3276464400 3600 0 CET}
- {3289165200 7200 1 CEST}
- {3307914000 3600 0 CET}
- {3321219600 7200 1 CEST}
- {3339363600 3600 0 CET}
- {3352669200 7200 1 CEST}
- {3370813200 3600 0 CET}
- {3384118800 7200 1 CEST}
- {3402867600 3600 0 CET}
- {3415568400 7200 1 CEST}
- {3434317200 3600 0 CET}
- {3447018000 7200 1 CEST}
- {3465766800 3600 0 CET}
- {3479072400 7200 1 CEST}
- {3497216400 3600 0 CET}
- {3510522000 7200 1 CEST}
- {3528666000 3600 0 CET}
- {3541971600 7200 1 CEST}
- {3560115600 3600 0 CET}
- {3573421200 7200 1 CEST}
- {3592170000 3600 0 CET}
- {3604870800 7200 1 CEST}
- {3623619600 3600 0 CET}
- {3636320400 7200 1 CEST}
- {3655069200 3600 0 CET}
- {3668374800 7200 1 CEST}
- {3686518800 3600 0 CET}
- {3699824400 7200 1 CEST}
- {3717968400 3600 0 CET}
- {3731274000 7200 1 CEST}
- {3750022800 3600 0 CET}
- {3762723600 7200 1 CEST}
- {3781472400 3600 0 CET}
- {3794173200 7200 1 CEST}
- {3812922000 3600 0 CET}
- {3825622800 7200 1 CEST}
- {3844371600 3600 0 CET}
- {3857677200 7200 1 CEST}
- {3875821200 3600 0 CET}
- {3889126800 7200 1 CEST}
- {3907270800 3600 0 CET}
- {3920576400 7200 1 CEST}
- {3939325200 3600 0 CET}
- {3952026000 7200 1 CEST}
- {3970774800 3600 0 CET}
- {3983475600 7200 1 CEST}
- {4002224400 3600 0 CET}
- {4015530000 7200 1 CEST}
- {4033674000 3600 0 CET}
- {4046979600 7200 1 CEST}
- {4065123600 3600 0 CET}
- {4078429200 7200 1 CEST}
- {4096573200 3600 0 CET}
+if {![info exists TZData(Europe/Paris)]} {
+ LoadTimeZoneFile Europe/Paris
}
+set TZData(:Europe/Monaco) $TZData(:Europe/Paris)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Oslo
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Oslo 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Oslo 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,271 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-
-set TZData(:Europe/Oslo) {
- {-9223372036854775808 2580 0 LMT}
- {-2366757780 3600 0 CET}
- {-1691884800 7200 1 CEST}
- {-1680573600 3600 0 CET}
- {-927511200 7200 0 CEST}
- {-857257200 3600 0 CET}
- {-844556400 7200 1 CEST}
- {-828226800 3600 0 CET}
- {-812502000 7200 1 CEST}
- {-796777200 3600 0 CET}
- {-781052400 7200 0 CEST}
- {-765327600 3600 0 CET}
- {-340844400 7200 1 CEST}
- {-324514800 3600 0 CET}
- {-308790000 7200 1 CEST}
- {-293065200 3600 0 CET}
- {-277340400 7200 1 CEST}
- {-261615600 3600 0 CET}
- {-245890800 7200 1 CEST}
- {-230166000 3600 0 CET}
- {-214441200 7200 1 CEST}
- {-198716400 3600 0 CET}
- {-182991600 7200 1 CEST}
- {-166662000 3600 0 CET}
- {-147913200 7200 1 CEST}
- {-135212400 3600 0 CET}
- {315529200 3600 0 CET}
- {323830800 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}
- {449024400 7200 1 CEST}
- {465354000 3600 0 CET}
- {481078800 7200 1 CEST}
- {496803600 3600 0 CET}
- {512528400 7200 1 CEST}
- {528253200 3600 0 CET}
- {543978000 7200 1 CEST}
- {559702800 3600 0 CET}
- {575427600 7200 1 CEST}
- {591152400 3600 0 CET}
- {606877200 7200 1 CEST}
- {622602000 3600 0 CET}
- {638326800 7200 1 CEST}
- {654656400 3600 0 CET}
- {670381200 7200 1 CEST}
- {686106000 3600 0 CET}
- {701830800 7200 1 CEST}
- {717555600 3600 0 CET}
- {733280400 7200 1 CEST}
- {749005200 3600 0 CET}
- {764730000 7200 1 CEST}
- {780454800 3600 0 CET}
- {796179600 7200 1 CEST}
- {811904400 3600 0 CET}
- {828234000 7200 1 CEST}
- {846378000 3600 0 CET}
- {859683600 7200 1 CEST}
- {877827600 3600 0 CET}
- {891133200 7200 1 CEST}
- {909277200 3600 0 CET}
- {922582800 7200 1 CEST}
- {941331600 3600 0 CET}
- {954032400 7200 1 CEST}
- {972781200 3600 0 CET}
- {985482000 7200 1 CEST}
- {1004230800 3600 0 CET}
- {1017536400 7200 1 CEST}
- {1035680400 3600 0 CET}
- {1048986000 7200 1 CEST}
- {1067130000 3600 0 CET}
- {1080435600 7200 1 CEST}
- {1099184400 3600 0 CET}
- {1111885200 7200 1 CEST}
- {1130634000 3600 0 CET}
- {1143334800 7200 1 CEST}
- {1162083600 3600 0 CET}
- {1174784400 7200 1 CEST}
- {1193533200 3600 0 CET}
- {1206838800 7200 1 CEST}
- {1224982800 3600 0 CET}
- {1238288400 7200 1 CEST}
- {1256432400 3600 0 CET}
- {1269738000 7200 1 CEST}
- {1288486800 3600 0 CET}
- {1301187600 7200 1 CEST}
- {1319936400 3600 0 CET}
- {1332637200 7200 1 CEST}
- {1351386000 3600 0 CET}
- {1364691600 7200 1 CEST}
- {1382835600 3600 0 CET}
- {1396141200 7200 1 CEST}
- {1414285200 3600 0 CET}
- {1427590800 7200 1 CEST}
- {1445734800 3600 0 CET}
- {1459040400 7200 1 CEST}
- {1477789200 3600 0 CET}
- {1490490000 7200 1 CEST}
- {1509238800 3600 0 CET}
- {1521939600 7200 1 CEST}
- {1540688400 3600 0 CET}
- {1553994000 7200 1 CEST}
- {1572138000 3600 0 CET}
- {1585443600 7200 1 CEST}
- {1603587600 3600 0 CET}
- {1616893200 7200 1 CEST}
- {1635642000 3600 0 CET}
- {1648342800 7200 1 CEST}
- {1667091600 3600 0 CET}
- {1679792400 7200 1 CEST}
- {1698541200 3600 0 CET}
- {1711846800 7200 1 CEST}
- {1729990800 3600 0 CET}
- {1743296400 7200 1 CEST}
- {1761440400 3600 0 CET}
- {1774746000 7200 1 CEST}
- {1792890000 3600 0 CET}
- {1806195600 7200 1 CEST}
- {1824944400 3600 0 CET}
- {1837645200 7200 1 CEST}
- {1856394000 3600 0 CET}
- {1869094800 7200 1 CEST}
- {1887843600 3600 0 CET}
- {1901149200 7200 1 CEST}
- {1919293200 3600 0 CET}
- {1932598800 7200 1 CEST}
- {1950742800 3600 0 CET}
- {1964048400 7200 1 CEST}
- {1982797200 3600 0 CET}
- {1995498000 7200 1 CEST}
- {2014246800 3600 0 CET}
- {2026947600 7200 1 CEST}
- {2045696400 3600 0 CET}
- {2058397200 7200 1 CEST}
- {2077146000 3600 0 CET}
- {2090451600 7200 1 CEST}
- {2108595600 3600 0 CET}
- {2121901200 7200 1 CEST}
- {2140045200 3600 0 CET}
- {2153350800 7200 1 CEST}
- {2172099600 3600 0 CET}
- {2184800400 7200 1 CEST}
- {2203549200 3600 0 CET}
- {2216250000 7200 1 CEST}
- {2234998800 3600 0 CET}
- {2248304400 7200 1 CEST}
- {2266448400 3600 0 CET}
- {2279754000 7200 1 CEST}
- {2297898000 3600 0 CET}
- {2311203600 7200 1 CEST}
- {2329347600 3600 0 CET}
- {2342653200 7200 1 CEST}
- {2361402000 3600 0 CET}
- {2374102800 7200 1 CEST}
- {2392851600 3600 0 CET}
- {2405552400 7200 1 CEST}
- {2424301200 3600 0 CET}
- {2437606800 7200 1 CEST}
- {2455750800 3600 0 CET}
- {2469056400 7200 1 CEST}
- {2487200400 3600 0 CET}
- {2500506000 7200 1 CEST}
- {2519254800 3600 0 CET}
- {2531955600 7200 1 CEST}
- {2550704400 3600 0 CET}
- {2563405200 7200 1 CEST}
- {2582154000 3600 0 CET}
- {2595459600 7200 1 CEST}
- {2613603600 3600 0 CET}
- {2626909200 7200 1 CEST}
- {2645053200 3600 0 CET}
- {2658358800 7200 1 CEST}
- {2676502800 3600 0 CET}
- {2689808400 7200 1 CEST}
- {2708557200 3600 0 CET}
- {2721258000 7200 1 CEST}
- {2740006800 3600 0 CET}
- {2752707600 7200 1 CEST}
- {2771456400 3600 0 CET}
- {2784762000 7200 1 CEST}
- {2802906000 3600 0 CET}
- {2816211600 7200 1 CEST}
- {2834355600 3600 0 CET}
- {2847661200 7200 1 CEST}
- {2866410000 3600 0 CET}
- {2879110800 7200 1 CEST}
- {2897859600 3600 0 CET}
- {2910560400 7200 1 CEST}
- {2929309200 3600 0 CET}
- {2942010000 7200 1 CEST}
- {2960758800 3600 0 CET}
- {2974064400 7200 1 CEST}
- {2992208400 3600 0 CET}
- {3005514000 7200 1 CEST}
- {3023658000 3600 0 CET}
- {3036963600 7200 1 CEST}
- {3055712400 3600 0 CET}
- {3068413200 7200 1 CEST}
- {3087162000 3600 0 CET}
- {3099862800 7200 1 CEST}
- {3118611600 3600 0 CET}
- {3131917200 7200 1 CEST}
- {3150061200 3600 0 CET}
- {3163366800 7200 1 CEST}
- {3181510800 3600 0 CET}
- {3194816400 7200 1 CEST}
- {3212960400 3600 0 CET}
- {3226266000 7200 1 CEST}
- {3245014800 3600 0 CET}
- {3257715600 7200 1 CEST}
- {3276464400 3600 0 CET}
- {3289165200 7200 1 CEST}
- {3307914000 3600 0 CET}
- {3321219600 7200 1 CEST}
- {3339363600 3600 0 CET}
- {3352669200 7200 1 CEST}
- {3370813200 3600 0 CET}
- {3384118800 7200 1 CEST}
- {3402867600 3600 0 CET}
- {3415568400 7200 1 CEST}
- {3434317200 3600 0 CET}
- {3447018000 7200 1 CEST}
- {3465766800 3600 0 CET}
- {3479072400 7200 1 CEST}
- {3497216400 3600 0 CET}
- {3510522000 7200 1 CEST}
- {3528666000 3600 0 CET}
- {3541971600 7200 1 CEST}
- {3560115600 3600 0 CET}
- {3573421200 7200 1 CEST}
- {3592170000 3600 0 CET}
- {3604870800 7200 1 CEST}
- {3623619600 3600 0 CET}
- {3636320400 7200 1 CEST}
- {3655069200 3600 0 CET}
- {3668374800 7200 1 CEST}
- {3686518800 3600 0 CET}
- {3699824400 7200 1 CEST}
- {3717968400 3600 0 CET}
- {3731274000 7200 1 CEST}
- {3750022800 3600 0 CET}
- {3762723600 7200 1 CEST}
- {3781472400 3600 0 CET}
- {3794173200 7200 1 CEST}
- {3812922000 3600 0 CET}
- {3825622800 7200 1 CEST}
- {3844371600 3600 0 CET}
- {3857677200 7200 1 CEST}
- {3875821200 3600 0 CET}
- {3889126800 7200 1 CEST}
- {3907270800 3600 0 CET}
- {3920576400 7200 1 CEST}
- {3939325200 3600 0 CET}
- {3952026000 7200 1 CEST}
- {3970774800 3600 0 CET}
- {3983475600 7200 1 CEST}
- {4002224400 3600 0 CET}
- {4015530000 7200 1 CEST}
- {4033674000 3600 0 CET}
- {4046979600 7200 1 CEST}
- {4065123600 3600 0 CET}
- {4078429200 7200 1 CEST}
- {4096573200 3600 0 CET}
+if {![info exists TZData(Europe/Berlin)]} {
+ LoadTimeZoneFile Europe/Berlin
}
+set TZData(:Europe/Oslo) $TZData(:Europe/Berlin)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Simferopol
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Simferopol 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Simferopol 2024-02-15 21:05:12 UTC (rev 69897)
@@ -31,18 +31,18 @@
{622594800 10800 0 MSK}
{631141200 10800 0 MSK}
{646786800 7200 0 EET}
- {694216800 7200 0 EET}
- {701820000 10800 1 EEST}
- {717541200 7200 0 EET}
- {733269600 10800 1 EEST}
- {748990800 7200 0 EET}
- {764719200 10800 1 EEST}
+ {701042400 7200 0 EET}
+ {701827200 10800 1 EEST}
+ {717552000 7200 0 EET}
+ {733276800 10800 1 EEST}
+ {749001600 7200 0 EET}
+ {764726400 10800 1 EEST}
{767743200 14400 0 MSD}
- {780436800 10800 0 MSK}
- {796165200 14400 1 MSD}
- {811886400 10800 0 MSK}
+ {780447600 10800 0 MSK}
+ {796172400 14400 1 MSD}
+ {811897200 10800 0 MSK}
{828219600 14400 1 MSD}
- {852066000 10800 0 MSK}
+ {846374400 10800 0 MSK}
{859683600 10800 0 EEST}
{877827600 7200 0 EET}
{891133200 10800 1 EEST}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Stockholm
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Stockholm 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Stockholm 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,250 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-
-set TZData(:Europe/Stockholm) {
- {-9223372036854775808 4332 0 LMT}
- {-2871681132 3614 0 SET}
- {-2208992414 3600 0 CET}
- {-1692496800 7200 1 CEST}
- {-1680483600 3600 0 CET}
- {315529200 3600 0 CET}
- {323830800 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}
- {449024400 7200 1 CEST}
- {465354000 3600 0 CET}
- {481078800 7200 1 CEST}
- {496803600 3600 0 CET}
- {512528400 7200 1 CEST}
- {528253200 3600 0 CET}
- {543978000 7200 1 CEST}
- {559702800 3600 0 CET}
- {575427600 7200 1 CEST}
- {591152400 3600 0 CET}
- {606877200 7200 1 CEST}
- {622602000 3600 0 CET}
- {638326800 7200 1 CEST}
- {654656400 3600 0 CET}
- {670381200 7200 1 CEST}
- {686106000 3600 0 CET}
- {701830800 7200 1 CEST}
- {717555600 3600 0 CET}
- {733280400 7200 1 CEST}
- {749005200 3600 0 CET}
- {764730000 7200 1 CEST}
- {780454800 3600 0 CET}
- {796179600 7200 1 CEST}
- {811904400 3600 0 CET}
- {828234000 7200 1 CEST}
- {846378000 3600 0 CET}
- {859683600 7200 1 CEST}
- {877827600 3600 0 CET}
- {891133200 7200 1 CEST}
- {909277200 3600 0 CET}
- {922582800 7200 1 CEST}
- {941331600 3600 0 CET}
- {954032400 7200 1 CEST}
- {972781200 3600 0 CET}
- {985482000 7200 1 CEST}
- {1004230800 3600 0 CET}
- {1017536400 7200 1 CEST}
- {1035680400 3600 0 CET}
- {1048986000 7200 1 CEST}
- {1067130000 3600 0 CET}
- {1080435600 7200 1 CEST}
- {1099184400 3600 0 CET}
- {1111885200 7200 1 CEST}
- {1130634000 3600 0 CET}
- {1143334800 7200 1 CEST}
- {1162083600 3600 0 CET}
- {1174784400 7200 1 CEST}
- {1193533200 3600 0 CET}
- {1206838800 7200 1 CEST}
- {1224982800 3600 0 CET}
- {1238288400 7200 1 CEST}
- {1256432400 3600 0 CET}
- {1269738000 7200 1 CEST}
- {1288486800 3600 0 CET}
- {1301187600 7200 1 CEST}
- {1319936400 3600 0 CET}
- {1332637200 7200 1 CEST}
- {1351386000 3600 0 CET}
- {1364691600 7200 1 CEST}
- {1382835600 3600 0 CET}
- {1396141200 7200 1 CEST}
- {1414285200 3600 0 CET}
- {1427590800 7200 1 CEST}
- {1445734800 3600 0 CET}
- {1459040400 7200 1 CEST}
- {1477789200 3600 0 CET}
- {1490490000 7200 1 CEST}
- {1509238800 3600 0 CET}
- {1521939600 7200 1 CEST}
- {1540688400 3600 0 CET}
- {1553994000 7200 1 CEST}
- {1572138000 3600 0 CET}
- {1585443600 7200 1 CEST}
- {1603587600 3600 0 CET}
- {1616893200 7200 1 CEST}
- {1635642000 3600 0 CET}
- {1648342800 7200 1 CEST}
- {1667091600 3600 0 CET}
- {1679792400 7200 1 CEST}
- {1698541200 3600 0 CET}
- {1711846800 7200 1 CEST}
- {1729990800 3600 0 CET}
- {1743296400 7200 1 CEST}
- {1761440400 3600 0 CET}
- {1774746000 7200 1 CEST}
- {1792890000 3600 0 CET}
- {1806195600 7200 1 CEST}
- {1824944400 3600 0 CET}
- {1837645200 7200 1 CEST}
- {1856394000 3600 0 CET}
- {1869094800 7200 1 CEST}
- {1887843600 3600 0 CET}
- {1901149200 7200 1 CEST}
- {1919293200 3600 0 CET}
- {1932598800 7200 1 CEST}
- {1950742800 3600 0 CET}
- {1964048400 7200 1 CEST}
- {1982797200 3600 0 CET}
- {1995498000 7200 1 CEST}
- {2014246800 3600 0 CET}
- {2026947600 7200 1 CEST}
- {2045696400 3600 0 CET}
- {2058397200 7200 1 CEST}
- {2077146000 3600 0 CET}
- {2090451600 7200 1 CEST}
- {2108595600 3600 0 CET}
- {2121901200 7200 1 CEST}
- {2140045200 3600 0 CET}
- {2153350800 7200 1 CEST}
- {2172099600 3600 0 CET}
- {2184800400 7200 1 CEST}
- {2203549200 3600 0 CET}
- {2216250000 7200 1 CEST}
- {2234998800 3600 0 CET}
- {2248304400 7200 1 CEST}
- {2266448400 3600 0 CET}
- {2279754000 7200 1 CEST}
- {2297898000 3600 0 CET}
- {2311203600 7200 1 CEST}
- {2329347600 3600 0 CET}
- {2342653200 7200 1 CEST}
- {2361402000 3600 0 CET}
- {2374102800 7200 1 CEST}
- {2392851600 3600 0 CET}
- {2405552400 7200 1 CEST}
- {2424301200 3600 0 CET}
- {2437606800 7200 1 CEST}
- {2455750800 3600 0 CET}
- {2469056400 7200 1 CEST}
- {2487200400 3600 0 CET}
- {2500506000 7200 1 CEST}
- {2519254800 3600 0 CET}
- {2531955600 7200 1 CEST}
- {2550704400 3600 0 CET}
- {2563405200 7200 1 CEST}
- {2582154000 3600 0 CET}
- {2595459600 7200 1 CEST}
- {2613603600 3600 0 CET}
- {2626909200 7200 1 CEST}
- {2645053200 3600 0 CET}
- {2658358800 7200 1 CEST}
- {2676502800 3600 0 CET}
- {2689808400 7200 1 CEST}
- {2708557200 3600 0 CET}
- {2721258000 7200 1 CEST}
- {2740006800 3600 0 CET}
- {2752707600 7200 1 CEST}
- {2771456400 3600 0 CET}
- {2784762000 7200 1 CEST}
- {2802906000 3600 0 CET}
- {2816211600 7200 1 CEST}
- {2834355600 3600 0 CET}
- {2847661200 7200 1 CEST}
- {2866410000 3600 0 CET}
- {2879110800 7200 1 CEST}
- {2897859600 3600 0 CET}
- {2910560400 7200 1 CEST}
- {2929309200 3600 0 CET}
- {2942010000 7200 1 CEST}
- {2960758800 3600 0 CET}
- {2974064400 7200 1 CEST}
- {2992208400 3600 0 CET}
- {3005514000 7200 1 CEST}
- {3023658000 3600 0 CET}
- {3036963600 7200 1 CEST}
- {3055712400 3600 0 CET}
- {3068413200 7200 1 CEST}
- {3087162000 3600 0 CET}
- {3099862800 7200 1 CEST}
- {3118611600 3600 0 CET}
- {3131917200 7200 1 CEST}
- {3150061200 3600 0 CET}
- {3163366800 7200 1 CEST}
- {3181510800 3600 0 CET}
- {3194816400 7200 1 CEST}
- {3212960400 3600 0 CET}
- {3226266000 7200 1 CEST}
- {3245014800 3600 0 CET}
- {3257715600 7200 1 CEST}
- {3276464400 3600 0 CET}
- {3289165200 7200 1 CEST}
- {3307914000 3600 0 CET}
- {3321219600 7200 1 CEST}
- {3339363600 3600 0 CET}
- {3352669200 7200 1 CEST}
- {3370813200 3600 0 CET}
- {3384118800 7200 1 CEST}
- {3402867600 3600 0 CET}
- {3415568400 7200 1 CEST}
- {3434317200 3600 0 CET}
- {3447018000 7200 1 CEST}
- {3465766800 3600 0 CET}
- {3479072400 7200 1 CEST}
- {3497216400 3600 0 CET}
- {3510522000 7200 1 CEST}
- {3528666000 3600 0 CET}
- {3541971600 7200 1 CEST}
- {3560115600 3600 0 CET}
- {3573421200 7200 1 CEST}
- {3592170000 3600 0 CET}
- {3604870800 7200 1 CEST}
- {3623619600 3600 0 CET}
- {3636320400 7200 1 CEST}
- {3655069200 3600 0 CET}
- {3668374800 7200 1 CEST}
- {3686518800 3600 0 CET}
- {3699824400 7200 1 CEST}
- {3717968400 3600 0 CET}
- {3731274000 7200 1 CEST}
- {3750022800 3600 0 CET}
- {3762723600 7200 1 CEST}
- {3781472400 3600 0 CET}
- {3794173200 7200 1 CEST}
- {3812922000 3600 0 CET}
- {3825622800 7200 1 CEST}
- {3844371600 3600 0 CET}
- {3857677200 7200 1 CEST}
- {3875821200 3600 0 CET}
- {3889126800 7200 1 CEST}
- {3907270800 3600 0 CET}
- {3920576400 7200 1 CEST}
- {3939325200 3600 0 CET}
- {3952026000 7200 1 CEST}
- {3970774800 3600 0 CET}
- {3983475600 7200 1 CEST}
- {4002224400 3600 0 CET}
- {4015530000 7200 1 CEST}
- {4033674000 3600 0 CET}
- {4046979600 7200 1 CEST}
- {4065123600 3600 0 CET}
- {4078429200 7200 1 CEST}
- {4096573200 3600 0 CET}
+if {![info exists TZData(Europe/Berlin)]} {
+ LoadTimeZoneFile Europe/Berlin
}
+set TZData(:Europe/Stockholm) $TZData(:Europe/Berlin)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Uzhgorod
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Uzhgorod 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Uzhgorod 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,254 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-
-set TZData(:Europe/Uzhgorod) {
- {-9223372036854775808 5352 0 LMT}
- {-2500939752 3600 0 CET}
- {-946774800 3600 0 CET}
- {-938905200 7200 1 CEST}
- {-857257200 3600 0 CET}
- {-844556400 7200 1 CEST}
- {-828226800 3600 0 CET}
- {-812502000 7200 1 CEST}
- {-796870800 7200 1 CEST}
- {-794714400 3600 0 CET}
- {-773456400 10800 0 MSD}
- {354920400 14400 1 MSD}
- {370728000 10800 0 MSK}
- {386456400 14400 1 MSD}
- {402264000 10800 0 MSK}
- {417992400 14400 1 MSD}
- {433800000 10800 0 MSK}
- {449614800 14400 1 MSD}
- {465346800 10800 0 MSK}
- {481071600 14400 1 MSD}
- {496796400 10800 0 MSK}
- {512521200 14400 1 MSD}
- {528246000 10800 0 MSK}
- {543970800 14400 1 MSD}
- {559695600 10800 0 MSK}
- {575420400 14400 1 MSD}
- {591145200 10800 0 MSK}
- {606870000 14400 1 MSD}
- {622594800 10800 0 MSK}
- {631141200 10800 0 MSK}
- {646786800 3600 0 CET}
- {670384800 7200 0 EET}
- {694216800 7200 0 EET}
- {701820000 10800 1 EEST}
- {717541200 7200 0 EET}
- {733269600 10800 1 EEST}
- {748990800 7200 0 EET}
- {764719200 10800 1 EEST}
- {780440400 7200 0 EET}
- {788911200 7200 0 EET}
- {796179600 10800 1 EEST}
- {811904400 7200 0 EET}
- {828234000 10800 1 EEST}
- {846378000 7200 0 EET}
- {859683600 10800 1 EEST}
- {877827600 7200 0 EET}
- {891133200 10800 1 EEST}
- {909277200 7200 0 EET}
- {922582800 10800 1 EEST}
- {941331600 7200 0 EET}
- {954032400 10800 1 EEST}
- {972781200 7200 0 EET}
- {985482000 10800 1 EEST}
- {1004230800 7200 0 EET}
- {1017536400 10800 1 EEST}
- {1035680400 7200 0 EET}
- {1048986000 10800 1 EEST}
- {1067130000 7200 0 EET}
- {1080435600 10800 1 EEST}
- {1099184400 7200 0 EET}
- {1111885200 10800 1 EEST}
- {1130634000 7200 0 EET}
- {1143334800 10800 1 EEST}
- {1162083600 7200 0 EET}
- {1174784400 10800 1 EEST}
- {1193533200 7200 0 EET}
- {1206838800 10800 1 EEST}
- {1224982800 7200 0 EET}
- {1238288400 10800 1 EEST}
- {1256432400 7200 0 EET}
- {1269738000 10800 1 EEST}
- {1288486800 7200 0 EET}
- {1301187600 10800 1 EEST}
- {1319936400 7200 0 EET}
- {1332637200 10800 1 EEST}
- {1351386000 7200 0 EET}
- {1364691600 10800 1 EEST}
- {1382835600 7200 0 EET}
- {1396141200 10800 1 EEST}
- {1414285200 7200 0 EET}
- {1427590800 10800 1 EEST}
- {1445734800 7200 0 EET}
- {1459040400 10800 1 EEST}
- {1477789200 7200 0 EET}
- {1490490000 10800 1 EEST}
- {1509238800 7200 0 EET}
- {1521939600 10800 1 EEST}
- {1540688400 7200 0 EET}
- {1553994000 10800 1 EEST}
- {1572138000 7200 0 EET}
- {1585443600 10800 1 EEST}
- {1603587600 7200 0 EET}
- {1616893200 10800 1 EEST}
- {1635642000 7200 0 EET}
- {1648342800 10800 1 EEST}
- {1667091600 7200 0 EET}
- {1679792400 10800 1 EEST}
- {1698541200 7200 0 EET}
- {1711846800 10800 1 EEST}
- {1729990800 7200 0 EET}
- {1743296400 10800 1 EEST}
- {1761440400 7200 0 EET}
- {1774746000 10800 1 EEST}
- {1792890000 7200 0 EET}
- {1806195600 10800 1 EEST}
- {1824944400 7200 0 EET}
- {1837645200 10800 1 EEST}
- {1856394000 7200 0 EET}
- {1869094800 10800 1 EEST}
- {1887843600 7200 0 EET}
- {1901149200 10800 1 EEST}
- {1919293200 7200 0 EET}
- {1932598800 10800 1 EEST}
- {1950742800 7200 0 EET}
- {1964048400 10800 1 EEST}
- {1982797200 7200 0 EET}
- {1995498000 10800 1 EEST}
- {2014246800 7200 0 EET}
- {2026947600 10800 1 EEST}
- {2045696400 7200 0 EET}
- {2058397200 10800 1 EEST}
- {2077146000 7200 0 EET}
- {2090451600 10800 1 EEST}
- {2108595600 7200 0 EET}
- {2121901200 10800 1 EEST}
- {2140045200 7200 0 EET}
- {2153350800 10800 1 EEST}
- {2172099600 7200 0 EET}
- {2184800400 10800 1 EEST}
- {2203549200 7200 0 EET}
- {2216250000 10800 1 EEST}
- {2234998800 7200 0 EET}
- {2248304400 10800 1 EEST}
- {2266448400 7200 0 EET}
- {2279754000 10800 1 EEST}
- {2297898000 7200 0 EET}
- {2311203600 10800 1 EEST}
- {2329347600 7200 0 EET}
- {2342653200 10800 1 EEST}
- {2361402000 7200 0 EET}
- {2374102800 10800 1 EEST}
- {2392851600 7200 0 EET}
- {2405552400 10800 1 EEST}
- {2424301200 7200 0 EET}
- {2437606800 10800 1 EEST}
- {2455750800 7200 0 EET}
- {2469056400 10800 1 EEST}
- {2487200400 7200 0 EET}
- {2500506000 10800 1 EEST}
- {2519254800 7200 0 EET}
- {2531955600 10800 1 EEST}
- {2550704400 7200 0 EET}
- {2563405200 10800 1 EEST}
- {2582154000 7200 0 EET}
- {2595459600 10800 1 EEST}
- {2613603600 7200 0 EET}
- {2626909200 10800 1 EEST}
- {2645053200 7200 0 EET}
- {2658358800 10800 1 EEST}
- {2676502800 7200 0 EET}
- {2689808400 10800 1 EEST}
- {2708557200 7200 0 EET}
- {2721258000 10800 1 EEST}
- {2740006800 7200 0 EET}
- {2752707600 10800 1 EEST}
- {2771456400 7200 0 EET}
- {2784762000 10800 1 EEST}
- {2802906000 7200 0 EET}
- {2816211600 10800 1 EEST}
- {2834355600 7200 0 EET}
- {2847661200 10800 1 EEST}
- {2866410000 7200 0 EET}
- {2879110800 10800 1 EEST}
- {2897859600 7200 0 EET}
- {2910560400 10800 1 EEST}
- {2929309200 7200 0 EET}
- {2942010000 10800 1 EEST}
- {2960758800 7200 0 EET}
- {2974064400 10800 1 EEST}
- {2992208400 7200 0 EET}
- {3005514000 10800 1 EEST}
- {3023658000 7200 0 EET}
- {3036963600 10800 1 EEST}
- {3055712400 7200 0 EET}
- {3068413200 10800 1 EEST}
- {3087162000 7200 0 EET}
- {3099862800 10800 1 EEST}
- {3118611600 7200 0 EET}
- {3131917200 10800 1 EEST}
- {3150061200 7200 0 EET}
- {3163366800 10800 1 EEST}
- {3181510800 7200 0 EET}
- {3194816400 10800 1 EEST}
- {3212960400 7200 0 EET}
- {3226266000 10800 1 EEST}
- {3245014800 7200 0 EET}
- {3257715600 10800 1 EEST}
- {3276464400 7200 0 EET}
- {3289165200 10800 1 EEST}
- {3307914000 7200 0 EET}
- {3321219600 10800 1 EEST}
- {3339363600 7200 0 EET}
- {3352669200 10800 1 EEST}
- {3370813200 7200 0 EET}
- {3384118800 10800 1 EEST}
- {3402867600 7200 0 EET}
- {3415568400 10800 1 EEST}
- {3434317200 7200 0 EET}
- {3447018000 10800 1 EEST}
- {3465766800 7200 0 EET}
- {3479072400 10800 1 EEST}
- {3497216400 7200 0 EET}
- {3510522000 10800 1 EEST}
- {3528666000 7200 0 EET}
- {3541971600 10800 1 EEST}
- {3560115600 7200 0 EET}
- {3573421200 10800 1 EEST}
- {3592170000 7200 0 EET}
- {3604870800 10800 1 EEST}
- {3623619600 7200 0 EET}
- {3636320400 10800 1 EEST}
- {3655069200 7200 0 EET}
- {3668374800 10800 1 EEST}
- {3686518800 7200 0 EET}
- {3699824400 10800 1 EEST}
- {3717968400 7200 0 EET}
- {3731274000 10800 1 EEST}
- {3750022800 7200 0 EET}
- {3762723600 10800 1 EEST}
- {3781472400 7200 0 EET}
- {3794173200 10800 1 EEST}
- {3812922000 7200 0 EET}
- {3825622800 10800 1 EEST}
- {3844371600 7200 0 EET}
- {3857677200 10800 1 EEST}
- {3875821200 7200 0 EET}
- {3889126800 10800 1 EEST}
- {3907270800 7200 0 EET}
- {3920576400 10800 1 EEST}
- {3939325200 7200 0 EET}
- {3952026000 10800 1 EEST}
- {3970774800 7200 0 EET}
- {3983475600 10800 1 EEST}
- {4002224400 7200 0 EET}
- {4015530000 10800 1 EEST}
- {4033674000 7200 0 EET}
- {4046979600 10800 1 EEST}
- {4065123600 7200 0 EET}
- {4078429200 10800 1 EEST}
- {4096573200 7200 0 EET}
+if {![info exists TZData(Europe/Kyiv)]} {
+ LoadTimeZoneFile Europe/Kyiv
}
+set TZData(:Europe/Uzhgorod) $TZData(:Europe/Kyiv)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Zaporozhye
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Zaporozhye 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Zaporozhye 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,252 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-
-set TZData(:Europe/Zaporozhye) {
- {-9223372036854775808 8440 0 LMT}
- {-2840149240 8400 0 +0220}
- {-1441160400 7200 0 EET}
- {-1247536800 10800 0 MSK}
- {-894769200 3600 0 CET}
- {-857257200 3600 0 CET}
- {-844556400 7200 1 CEST}
- {-828226800 3600 0 CET}
- {-826419600 10800 0 MSD}
- {354920400 14400 1 MSD}
- {370728000 10800 0 MSK}
- {386456400 14400 1 MSD}
- {402264000 10800 0 MSK}
- {417992400 14400 1 MSD}
- {433800000 10800 0 MSK}
- {449614800 14400 1 MSD}
- {465346800 10800 0 MSK}
- {481071600 14400 1 MSD}
- {496796400 10800 0 MSK}
- {512521200 14400 1 MSD}
- {528246000 10800 0 MSK}
- {543970800 14400 1 MSD}
- {559695600 10800 0 MSK}
- {575420400 14400 1 MSD}
- {591145200 10800 0 MSK}
- {606870000 14400 1 MSD}
- {622594800 10800 0 MSK}
- {638319600 14400 1 MSD}
- {654649200 10800 0 MSK}
- {670374000 10800 0 EEST}
- {686091600 7200 0 EET}
- {701820000 10800 1 EEST}
- {717541200 7200 0 EET}
- {733269600 10800 1 EEST}
- {748990800 7200 0 EET}
- {764719200 10800 1 EEST}
- {780440400 7200 0 EET}
- {788911200 7200 0 EET}
- {796179600 10800 1 EEST}
- {811904400 7200 0 EET}
- {828234000 10800 1 EEST}
- {846378000 7200 0 EET}
- {859683600 10800 1 EEST}
- {877827600 7200 0 EET}
- {891133200 10800 1 EEST}
- {909277200 7200 0 EET}
- {922582800 10800 1 EEST}
- {941331600 7200 0 EET}
- {954032400 10800 1 EEST}
- {972781200 7200 0 EET}
- {985482000 10800 1 EEST}
- {1004230800 7200 0 EET}
- {1017536400 10800 1 EEST}
- {1035680400 7200 0 EET}
- {1048986000 10800 1 EEST}
- {1067130000 7200 0 EET}
- {1080435600 10800 1 EEST}
- {1099184400 7200 0 EET}
- {1111885200 10800 1 EEST}
- {1130634000 7200 0 EET}
- {1143334800 10800 1 EEST}
- {1162083600 7200 0 EET}
- {1174784400 10800 1 EEST}
- {1193533200 7200 0 EET}
- {1206838800 10800 1 EEST}
- {1224982800 7200 0 EET}
- {1238288400 10800 1 EEST}
- {1256432400 7200 0 EET}
- {1269738000 10800 1 EEST}
- {1288486800 7200 0 EET}
- {1301187600 10800 1 EEST}
- {1319936400 7200 0 EET}
- {1332637200 10800 1 EEST}
- {1351386000 7200 0 EET}
- {1364691600 10800 1 EEST}
- {1382835600 7200 0 EET}
- {1396141200 10800 1 EEST}
- {1414285200 7200 0 EET}
- {1427590800 10800 1 EEST}
- {1445734800 7200 0 EET}
- {1459040400 10800 1 EEST}
- {1477789200 7200 0 EET}
- {1490490000 10800 1 EEST}
- {1509238800 7200 0 EET}
- {1521939600 10800 1 EEST}
- {1540688400 7200 0 EET}
- {1553994000 10800 1 EEST}
- {1572138000 7200 0 EET}
- {1585443600 10800 1 EEST}
- {1603587600 7200 0 EET}
- {1616893200 10800 1 EEST}
- {1635642000 7200 0 EET}
- {1648342800 10800 1 EEST}
- {1667091600 7200 0 EET}
- {1679792400 10800 1 EEST}
- {1698541200 7200 0 EET}
- {1711846800 10800 1 EEST}
- {1729990800 7200 0 EET}
- {1743296400 10800 1 EEST}
- {1761440400 7200 0 EET}
- {1774746000 10800 1 EEST}
- {1792890000 7200 0 EET}
- {1806195600 10800 1 EEST}
- {1824944400 7200 0 EET}
- {1837645200 10800 1 EEST}
- {1856394000 7200 0 EET}
- {1869094800 10800 1 EEST}
- {1887843600 7200 0 EET}
- {1901149200 10800 1 EEST}
- {1919293200 7200 0 EET}
- {1932598800 10800 1 EEST}
- {1950742800 7200 0 EET}
- {1964048400 10800 1 EEST}
- {1982797200 7200 0 EET}
- {1995498000 10800 1 EEST}
- {2014246800 7200 0 EET}
- {2026947600 10800 1 EEST}
- {2045696400 7200 0 EET}
- {2058397200 10800 1 EEST}
- {2077146000 7200 0 EET}
- {2090451600 10800 1 EEST}
- {2108595600 7200 0 EET}
- {2121901200 10800 1 EEST}
- {2140045200 7200 0 EET}
- {2153350800 10800 1 EEST}
- {2172099600 7200 0 EET}
- {2184800400 10800 1 EEST}
- {2203549200 7200 0 EET}
- {2216250000 10800 1 EEST}
- {2234998800 7200 0 EET}
- {2248304400 10800 1 EEST}
- {2266448400 7200 0 EET}
- {2279754000 10800 1 EEST}
- {2297898000 7200 0 EET}
- {2311203600 10800 1 EEST}
- {2329347600 7200 0 EET}
- {2342653200 10800 1 EEST}
- {2361402000 7200 0 EET}
- {2374102800 10800 1 EEST}
- {2392851600 7200 0 EET}
- {2405552400 10800 1 EEST}
- {2424301200 7200 0 EET}
- {2437606800 10800 1 EEST}
- {2455750800 7200 0 EET}
- {2469056400 10800 1 EEST}
- {2487200400 7200 0 EET}
- {2500506000 10800 1 EEST}
- {2519254800 7200 0 EET}
- {2531955600 10800 1 EEST}
- {2550704400 7200 0 EET}
- {2563405200 10800 1 EEST}
- {2582154000 7200 0 EET}
- {2595459600 10800 1 EEST}
- {2613603600 7200 0 EET}
- {2626909200 10800 1 EEST}
- {2645053200 7200 0 EET}
- {2658358800 10800 1 EEST}
- {2676502800 7200 0 EET}
- {2689808400 10800 1 EEST}
- {2708557200 7200 0 EET}
- {2721258000 10800 1 EEST}
- {2740006800 7200 0 EET}
- {2752707600 10800 1 EEST}
- {2771456400 7200 0 EET}
- {2784762000 10800 1 EEST}
- {2802906000 7200 0 EET}
- {2816211600 10800 1 EEST}
- {2834355600 7200 0 EET}
- {2847661200 10800 1 EEST}
- {2866410000 7200 0 EET}
- {2879110800 10800 1 EEST}
- {2897859600 7200 0 EET}
- {2910560400 10800 1 EEST}
- {2929309200 7200 0 EET}
- {2942010000 10800 1 EEST}
- {2960758800 7200 0 EET}
- {2974064400 10800 1 EEST}
- {2992208400 7200 0 EET}
- {3005514000 10800 1 EEST}
- {3023658000 7200 0 EET}
- {3036963600 10800 1 EEST}
- {3055712400 7200 0 EET}
- {3068413200 10800 1 EEST}
- {3087162000 7200 0 EET}
- {3099862800 10800 1 EEST}
- {3118611600 7200 0 EET}
- {3131917200 10800 1 EEST}
- {3150061200 7200 0 EET}
- {3163366800 10800 1 EEST}
- {3181510800 7200 0 EET}
- {3194816400 10800 1 EEST}
- {3212960400 7200 0 EET}
- {3226266000 10800 1 EEST}
- {3245014800 7200 0 EET}
- {3257715600 10800 1 EEST}
- {3276464400 7200 0 EET}
- {3289165200 10800 1 EEST}
- {3307914000 7200 0 EET}
- {3321219600 10800 1 EEST}
- {3339363600 7200 0 EET}
- {3352669200 10800 1 EEST}
- {3370813200 7200 0 EET}
- {3384118800 10800 1 EEST}
- {3402867600 7200 0 EET}
- {3415568400 10800 1 EEST}
- {3434317200 7200 0 EET}
- {3447018000 10800 1 EEST}
- {3465766800 7200 0 EET}
- {3479072400 10800 1 EEST}
- {3497216400 7200 0 EET}
- {3510522000 10800 1 EEST}
- {3528666000 7200 0 EET}
- {3541971600 10800 1 EEST}
- {3560115600 7200 0 EET}
- {3573421200 10800 1 EEST}
- {3592170000 7200 0 EET}
- {3604870800 10800 1 EEST}
- {3623619600 7200 0 EET}
- {3636320400 10800 1 EEST}
- {3655069200 7200 0 EET}
- {3668374800 10800 1 EEST}
- {3686518800 7200 0 EET}
- {3699824400 10800 1 EEST}
- {3717968400 7200 0 EET}
- {3731274000 10800 1 EEST}
- {3750022800 7200 0 EET}
- {3762723600 10800 1 EEST}
- {3781472400 7200 0 EET}
- {3794173200 10800 1 EEST}
- {3812922000 7200 0 EET}
- {3825622800 10800 1 EEST}
- {3844371600 7200 0 EET}
- {3857677200 10800 1 EEST}
- {3875821200 7200 0 EET}
- {3889126800 10800 1 EEST}
- {3907270800 7200 0 EET}
- {3920576400 10800 1 EEST}
- {3939325200 7200 0 EET}
- {3952026000 10800 1 EEST}
- {3970774800 7200 0 EET}
- {3983475600 10800 1 EEST}
- {4002224400 7200 0 EET}
- {4015530000 10800 1 EEST}
- {4033674000 7200 0 EET}
- {4046979600 10800 1 EEST}
- {4065123600 7200 0 EET}
- {4078429200 10800 1 EEST}
- {4096573200 7200 0 EET}
+if {![info exists TZData(Europe/Kyiv)]} {
+ LoadTimeZoneFile Europe/Kyiv
}
+set TZData(:Europe/Zaporozhye) $TZData(:Europe/Kyiv)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Iceland
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Iceland 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Iceland 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,5 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-if {![info exists TZData(Atlantic/Reykjavik)]} {
- LoadTimeZoneFile Atlantic/Reykjavik
+if {![info exists TZData(Africa/Abidjan)]} {
+ LoadTimeZoneFile Africa/Abidjan
}
-set TZData(:Iceland) $TZData(:Atlantic/Reykjavik)
+set TZData(:Iceland) $TZData(:Africa/Abidjan)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Indian/Christmas
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Indian/Christmas 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Indian/Christmas 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,6 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-
-set TZData(:Indian/Christmas) {
- {-9223372036854775808 25372 0 LMT}
- {-2364102172 25200 0 +07}
+if {![info exists TZData(Asia/Bangkok)]} {
+ LoadTimeZoneFile Asia/Bangkok
}
+set TZData(:Indian/Christmas) $TZData(:Asia/Bangkok)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Indian/Cocos
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Indian/Cocos 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Indian/Cocos 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,6 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-
-set TZData(:Indian/Cocos) {
- {-9223372036854775808 23260 0 LMT}
- {-2209012060 23400 0 +0630}
+if {![info exists TZData(Asia/Yangon)]} {
+ LoadTimeZoneFile Asia/Yangon
}
+set TZData(:Indian/Cocos) $TZData(:Asia/Yangon)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Indian/Kerguelen
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Indian/Kerguelen 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Indian/Kerguelen 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,6 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-
-set TZData(:Indian/Kerguelen) {
- {-9223372036854775808 0 0 -00}
- {-631152000 18000 0 +05}
+if {![info exists TZData(Indian/Maldives)]} {
+ LoadTimeZoneFile Indian/Maldives
}
+set TZData(:Indian/Kerguelen) $TZData(:Indian/Maldives)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Indian/Mahe
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Indian/Mahe 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Indian/Mahe 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,6 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-
-set TZData(:Indian/Mahe) {
- {-9223372036854775808 13308 0 LMT}
- {-1988163708 14400 0 +04}
+if {![info exists TZData(Asia/Dubai)]} {
+ LoadTimeZoneFile Asia/Dubai
}
+set TZData(:Indian/Mahe) $TZData(:Asia/Dubai)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Indian/Reunion
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Indian/Reunion 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Indian/Reunion 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,6 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-
-set TZData(:Indian/Reunion) {
- {-9223372036854775808 13312 0 LMT}
- {-1848886912 14400 0 +04}
+if {![info exists TZData(Asia/Dubai)]} {
+ LoadTimeZoneFile Asia/Dubai
}
+set TZData(:Indian/Reunion) $TZData(:Asia/Dubai)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Chuuk
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Chuuk 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Chuuk 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,11 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-
-set TZData(:Pacific/Chuuk) {
- {-9223372036854775808 -49972 0 LMT}
- {-3944628428 36428 0 LMT}
- {-2177489228 36000 0 +10}
- {-1743674400 32400 0 +09}
- {-1606813200 36000 0 +10}
- {-907408800 32400 0 +09}
- {-770634000 36000 0 +10}
+if {![info exists TZData(Pacific/Port_Moresby)]} {
+ LoadTimeZoneFile Pacific/Port_Moresby
}
+set TZData(:Pacific/Chuuk) $TZData(:Pacific/Port_Moresby)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Easter
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Easter 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Easter 2024-02-15 21:05:12 UTC (rev 69897)
@@ -110,7 +110,7 @@
{1617505200 -21600 0 -06}
{1630814400 -18000 1 -06}
{1648954800 -21600 0 -06}
- {1662264000 -18000 1 -06}
+ {1662868800 -18000 1 -06}
{1680404400 -21600 0 -06}
{1693713600 -18000 1 -06}
{1712458800 -21600 0 -06}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Fiji
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Fiji 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Fiji 2024-02-15 21:05:12 UTC (rev 69897)
@@ -31,159 +31,4 @@
{1578751200 43200 0 +12}
{1608386400 46800 1 +12}
{1610805600 43200 0 +12}
- {1668261600 46800 1 +12}
- {1673704800 43200 0 +12}
- {1699711200 46800 1 +12}
- {1705154400 43200 0 +12}
- {1731160800 46800 1 +12}
- {1736604000 43200 0 +12}
- {1762610400 46800 1 +12}
- {1768658400 43200 0 +12}
- {1794060000 46800 1 +12}
- {1800108000 43200 0 +12}
- {1826114400 46800 1 +12}
- {1831557600 43200 0 +12}
- {1857564000 46800 1 +12}
- {1863007200 43200 0 +12}
- {1889013600 46800 1 +12}
- {1894456800 43200 0 +12}
- {1920463200 46800 1 +12}
- {1925906400 43200 0 +12}
- {1951912800 46800 1 +12}
- {1957960800 43200 0 +12}
- {1983967200 46800 1 +12}
- {1989410400 43200 0 +12}
- {2015416800 46800 1 +12}
- {2020860000 43200 0 +12}
- {2046866400 46800 1 +12}
- {2052309600 43200 0 +12}
- {2078316000 46800 1 +12}
- {2083759200 43200 0 +12}
- {2109765600 46800 1 +12}
- {2115813600 43200 0 +12}
- {2141215200 46800 1 +12}
- {2147263200 43200 0 +12}
- {2173269600 46800 1 +12}
- {2178712800 43200 0 +12}
- {2204719200 46800 1 +12}
- {2210162400 43200 0 +12}
- {2236168800 46800 1 +12}
- {2241612000 43200 0 +12}
- {2267618400 46800 1 +12}
- {2273061600 43200 0 +12}
- {2299068000 46800 1 +12}
- {2305116000 43200 0 +12}
- {2330517600 46800 1 +12}
- {2336565600 43200 0 +12}
- {2362572000 46800 1 +12}
- {2368015200 43200 0 +12}
- {2394021600 46800 1 +12}
- {2399464800 43200 0 +12}
- {2425471200 46800 1 +12}
- {2430914400 43200 0 +12}
- {2456920800 46800 1 +12}
- {2462364000 43200 0 +12}
- {2488370400 46800 1 +12}
- {2494418400 43200 0 +12}
- {2520424800 46800 1 +12}
- {2525868000 43200 0 +12}
- {2551874400 46800 1 +12}
- {2557317600 43200 0 +12}
- {2583324000 46800 1 +12}
- {2588767200 43200 0 +12}
- {2614773600 46800 1 +12}
- {2620216800 43200 0 +12}
- {2646223200 46800 1 +12}
- {2652271200 43200 0 +12}
- {2677672800 46800 1 +12}
- {2683720800 43200 0 +12}
- {2709727200 46800 1 +12}
- {2715170400 43200 0 +12}
- {2741176800 46800 1 +12}
- {2746620000 43200 0 +12}
- {2772626400 46800 1 +12}
- {2778069600 43200 0 +12}
- {2804076000 46800 1 +12}
- {2809519200 43200 0 +12}
- {2835525600 46800 1 +12}
- {2841573600 43200 0 +12}
- {2867580000 46800 1 +12}
- {2873023200 43200 0 +12}
- {2899029600 46800 1 +12}
- {2904472800 43200 0 +12}
- {2930479200 46800 1 +12}
- {2935922400 43200 0 +12}
- {2961928800 46800 1 +12}
- {2967372000 43200 0 +12}
- {2993378400 46800 1 +12}
- {2999426400 43200 0 +12}
- {3024828000 46800 1 +12}
- {3030876000 43200 0 +12}
- {3056882400 46800 1 +12}
- {3062325600 43200 0 +12}
- {3088332000 46800 1 +12}
- {3093775200 43200 0 +12}
- {3119781600 46800 1 +12}
- {3125224800 43200 0 +12}
- {3151231200 46800 1 +12}
- {3156674400 43200 0 +12}
- {3182680800 46800 1 +12}
- {3188728800 43200 0 +12}
- {3214130400 46800 1 +12}
- {3220178400 43200 0 +12}
- {3246184800 46800 1 +12}
- {3251628000 43200 0 +12}
- {3277634400 46800 1 +12}
- {3283077600 43200 0 +12}
- {3309084000 46800 1 +12}
- {3314527200 43200 0 +12}
- {3340533600 46800 1 +12}
- {3345976800 43200 0 +12}
- {3371983200 46800 1 +12}
- {3378031200 43200 0 +12}
- {3404037600 46800 1 +12}
- {3409480800 43200 0 +12}
- {3435487200 46800 1 +12}
- {3440930400 43200 0 +12}
- {3466936800 46800 1 +12}
- {3472380000 43200 0 +12}
- {3498386400 46800 1 +12}
- {3503829600 43200 0 +12}
- {3529836000 46800 1 +12}
- {3535884000 43200 0 +12}
- {3561285600 46800 1 +12}
- {3567333600 43200 0 +12}
- {3593340000 46800 1 +12}
- {3598783200 43200 0 +12}
- {3624789600 46800 1 +12}
- {3630232800 43200 0 +12}
- {3656239200 46800 1 +12}
- {3661682400 43200 0 +12}
- {3687688800 46800 1 +12}
- {3693132000 43200 0 +12}
- {3719138400 46800 1 +12}
- {3725186400 43200 0 +12}
- {3751192800 46800 1 +12}
- {3756636000 43200 0 +12}
- {3782642400 46800 1 +12}
- {3788085600 43200 0 +12}
- {3814092000 46800 1 +12}
- {3819535200 43200 0 +12}
- {3845541600 46800 1 +12}
- {3850984800 43200 0 +12}
- {3876991200 46800 1 +12}
- {3883039200 43200 0 +12}
- {3908440800 46800 1 +12}
- {3914488800 43200 0 +12}
- {3940495200 46800 1 +12}
- {3945938400 43200 0 +12}
- {3971944800 46800 1 +12}
- {3977388000 43200 0 +12}
- {4003394400 46800 1 +12}
- {4008837600 43200 0 +12}
- {4034844000 46800 1 +12}
- {4040287200 43200 0 +12}
- {4066293600 46800 1 +12}
- {4072341600 43200 0 +12}
- {4097743200 46800 1 +12}
}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Funafuti
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Funafuti 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Funafuti 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,6 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-
-set TZData(:Pacific/Funafuti) {
- {-9223372036854775808 43012 0 LMT}
- {-2177495812 43200 0 +12}
+if {![info exists TZData(Pacific/Tarawa)]} {
+ LoadTimeZoneFile Pacific/Tarawa
}
+set TZData(:Pacific/Funafuti) $TZData(:Pacific/Tarawa)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Majuro
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Majuro 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Majuro 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,12 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-
-set TZData(:Pacific/Majuro) {
- {-9223372036854775808 41088 0 LMT}
- {-2177493888 39600 0 +11}
- {-1743678000 32400 0 +09}
- {-1606813200 39600 0 +11}
- {-1041418800 36000 0 +10}
- {-907408800 32400 0 +09}
- {-818067600 39600 0 +11}
- {-7988400 43200 0 +12}
+if {![info exists TZData(Pacific/Tarawa)]} {
+ LoadTimeZoneFile Pacific/Tarawa
}
+set TZData(:Pacific/Majuro) $TZData(:Pacific/Tarawa)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Pohnpei
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Pohnpei 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Pohnpei 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,12 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-
-set TZData(:Pacific/Pohnpei) {
- {-9223372036854775808 -48428 0 LMT}
- {-3944629972 37972 0 LMT}
- {-2177490772 39600 0 +11}
- {-1743678000 32400 0 +09}
- {-1606813200 39600 0 +11}
- {-1041418800 36000 0 +10}
- {-907408800 32400 0 +09}
- {-770634000 39600 0 +11}
+if {![info exists TZData(Pacific/Guadalcanal)]} {
+ LoadTimeZoneFile Pacific/Guadalcanal
}
+set TZData(:Pacific/Pohnpei) $TZData(:Pacific/Guadalcanal)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Ponape
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Ponape 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Ponape 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,5 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-if {![info exists TZData(Pacific/Pohnpei)]} {
- LoadTimeZoneFile Pacific/Pohnpei
+if {![info exists TZData(Pacific/Guadalcanal)]} {
+ LoadTimeZoneFile Pacific/Guadalcanal
}
-set TZData(:Pacific/Ponape) $TZData(:Pacific/Pohnpei)
+set TZData(:Pacific/Ponape) $TZData(:Pacific/Guadalcanal)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Truk
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Truk 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Truk 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,5 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-if {![info exists TZData(Pacific/Chuuk)]} {
- LoadTimeZoneFile Pacific/Chuuk
+if {![info exists TZData(Pacific/Port_Moresby)]} {
+ LoadTimeZoneFile Pacific/Port_Moresby
}
-set TZData(:Pacific/Truk) $TZData(:Pacific/Chuuk)
+set TZData(:Pacific/Truk) $TZData(:Pacific/Port_Moresby)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Wake
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Wake 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Wake 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,6 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-
-set TZData(:Pacific/Wake) {
- {-9223372036854775808 39988 0 LMT}
- {-2177492788 43200 0 +12}
+if {![info exists TZData(Pacific/Tarawa)]} {
+ LoadTimeZoneFile Pacific/Tarawa
}
+set TZData(:Pacific/Wake) $TZData(:Pacific/Tarawa)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Wallis
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Wallis 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Wallis 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,6 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-
-set TZData(:Pacific/Wallis) {
- {-9223372036854775808 44120 0 LMT}
- {-2177496920 43200 0 +12}
+if {![info exists TZData(Pacific/Tarawa)]} {
+ LoadTimeZoneFile Pacific/Tarawa
}
+set TZData(:Pacific/Wallis) $TZData(:Pacific/Tarawa)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Yap
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Yap 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Yap 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,5 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-if {![info exists TZData(Pacific/Chuuk)]} {
- LoadTimeZoneFile Pacific/Chuuk
+if {![info exists TZData(Pacific/Port_Moresby)]} {
+ LoadTimeZoneFile Pacific/Port_Moresby
}
-set TZData(:Pacific/Yap) $TZData(:Pacific/Chuuk)
+set TZData(:Pacific/Yap) $TZData(:Pacific/Port_Moresby)
Deleted: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/US/Pacific-New
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/US/Pacific-New 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/US/Pacific-New 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,5 +0,0 @@
-# created by tools/tclZIC.tcl - do not edit
-if {![info exists TZData(America/Los_Angeles)]} {
- LoadTimeZoneFile America/Los_Angeles
-}
-set TZData(:US/Pacific-New) $TZData(:America/Los_Angeles)
Modified: trunk/Master/tlpkg/tltcl/lib/tclConfig.sh
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tclConfig.sh 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tclConfig.sh 2024-02-15 21:05:12 UTC (rev 69897)
@@ -15,7 +15,7 @@
TCL_VERSION='8.6'
TCL_MAJOR_VERSION='8'
TCL_MINOR_VERSION='6'
-TCL_PATCH_LEVEL='.12'
+TCL_PATCH_LEVEL='.13'
# C compiler to use for compilation.
TCL_CC='x86_64-w64-mingw32-gcc'
@@ -55,11 +55,11 @@
# Top-level directory in which Tcl's platform-independent files are
# installed.
-TCL_PREFIX='/tmp/tltcl'
+TCL_PREFIX='/home/siepo/tltcl'
# Top-level directory in which Tcl's platform-specific files (e.g.
# executables) are installed.
-TCL_EXEC_PREFIX='/tmp/tltcl'
+TCL_EXEC_PREFIX='/home/siepo/tltcl'
# Flags to pass to cc when compiling the components of a shared library:
TCL_SHLIB_CFLAGS=''
@@ -68,7 +68,7 @@
TCL_CFLAGS_WARNING='-Wall -Wpointer-arith -Wdeclaration-after-statement'
# Extra flags to pass to cc:
-TCL_EXTRA_CFLAGS='-pipe'
+TCL_EXTRA_CFLAGS='-pipe -DHAVE_CPUID=1'
# Base command to use for combining object files into a shared library:
TCL_SHLIB_LD='${CC} -shared'
@@ -111,15 +111,15 @@
# String to pass to linker to pick up the Tcl library from its
# build directory.
-TCL_BUILD_LIB_SPEC='-L/tmp/siepo/tcl8.6.12/win -ltcl86'
+TCL_BUILD_LIB_SPEC='-L/tmp/siepo/tcl8.6.13/win -ltcl86'
# String to pass to linker to pick up the Tcl library from its
# installed directory.
-TCL_LIB_SPEC='-L/tmp/tltcl/lib -ltcl86'
+TCL_LIB_SPEC='-L/home/siepo/tltcl/lib -ltcl86'
# String to pass to the compiler so that an extension can
# find installed Tcl headers.
-TCL_INCLUDE_SPEC='-I/tmp/tltcl/include'
+TCL_INCLUDE_SPEC='-I/home/siepo/tltcl/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,12 +146,12 @@
# 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='/tmp/siepo/tcl8.6.12'
+TCL_SRC_DIR='/tmp/siepo/tcl8.6.13'
# List of standard directories in which to look for packages during
# "package require" commands. Contains the "prefix" directory plus also
# the "exec_prefix" directory, if it is different.
-TCL_PACKAGE_PATH='{/tmp/tltcl/lib}'
+TCL_PACKAGE_PATH='{/home/siepo/tltcl/lib}'
# Tcl supports stub.
TCL_SUPPORTS_STUBS=1
@@ -164,17 +164,17 @@
# String to pass to linker to pick up the Tcl stub library from its
# build directory.
-TCL_BUILD_STUB_LIB_SPEC='-L/tmp/siepo/tcl8.6.12/win -ltclstub86'
+TCL_BUILD_STUB_LIB_SPEC='-L/tmp/siepo/tcl8.6.13/win -ltclstub86'
# String to pass to linker to pick up the Tcl stub library from its
# installed directory.
-TCL_STUB_LIB_SPEC='-L/tmp/tltcl/lib -ltclstub86'
+TCL_STUB_LIB_SPEC='-L/home/siepo/tltcl/lib -ltclstub86'
# Path to the Tcl stub library in the build directory.
-TCL_BUILD_STUB_LIB_PATH='/tmp/siepo/tcl8.6.12/win/libtclstub86.a'
+TCL_BUILD_STUB_LIB_PATH='/tmp/siepo/tcl8.6.13/win/libtclstub86.a'
# Path to the Tcl stub library in the install directory.
-TCL_STUB_LIB_PATH='/tmp/tltcl/lib/libtclstub86.a'
+TCL_STUB_LIB_PATH='/home/siepo/tltcl/lib/libtclstub86.a'
# Flag, 1: we built Tcl with threads enabled, 0 we didn't
TCL_THREADS=1
Added: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.5/libtdbcstub115.a
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.5/libtdbcstub115.a
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbc1.1.5/libtdbcstub115.a 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tdbc1.1.5/libtdbcstub115.a 2024-02-15 21:05:12 UTC (rev 69897)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.5/libtdbcstub115.a
___________________________________________________________________
Added: svn:mime-type
## -0,0 +1 ##
+application/x-archive
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.5/pkgIndex.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbc1.1.5/pkgIndex.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tdbc1.1.5/pkgIndex.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -0,0 +1,26 @@
+# -*- tcl -*-
+# Tcl package index file, version 1.1
+#
+# Make sure that TDBC is running in a compatible version of Tcl, and
+# that TclOO is available.
+
+if {![package vsatisfies [package provide Tcl] 8.6-]} {
+ return
+}
+apply {{dir} {
+ set libraryfile [file join $dir tdbc.tcl]
+ if {![file exists $libraryfile] && [info exists ::env(TDBC_LIBRARY)]} {
+ set libraryfile [file join $::env(TDBC_LIBRARY) tdbc.tcl]
+ }
+ if {[package vsatisfies [package provide Tcl] 9.0-]} {
+ package ifneeded tdbc 1.1.5 \
+ "package require TclOO;\
+ [list load [file join $dir tcl9tdbc115.dll] [string totitle tdbc]]\;\
+ [list source $libraryfile]"
+ } else {
+ package ifneeded tdbc 1.1.5 \
+ "package require TclOO;\
+ [list load [file join $dir tdbc115.dll] [string totitle tdbc]]\;\
+ [list source $libraryfile]"
+ }
+}} $dir
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.5/pkgIndex.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.5/tdbc.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbc1.1.5/tdbc.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tdbc1.1.5/tdbc.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -0,0 +1,922 @@
+# tdbc.tcl --
+#
+# Definitions of base classes from which TDBC drivers' connections,
+# statements and result sets may inherit.
+#
+# Copyright (c) 2008 by Kevin B. Kenny
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id$
+#
+#------------------------------------------------------------------------------
+
+package require TclOO
+
+namespace eval ::tdbc {
+ namespace export connection statement resultset
+ variable generalError [list TDBC GENERAL_ERROR HY000 {}]
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::ParseConvenienceArgs --
+#
+# Parse the convenience arguments to a TDBC 'execute',
+# 'executewithdictionary', or 'foreach' call.
+#
+# Parameters:
+# argv - Arguments to the call
+# optsVar -- Name of a variable in caller's scope that will receive
+# a dictionary of the supplied options
+#
+# Results:
+# Returns any args remaining after parsing the options.
+#
+# Side effects:
+# Sets the 'opts' dictionary to the options.
+#
+#------------------------------------------------------------------------------
+
+proc tdbc::ParseConvenienceArgs {argv optsVar} {
+
+ variable generalError
+ upvar 1 $optsVar opts
+
+ set opts [dict create -as dicts]
+ set i 0
+
+ # Munch keyword options off the front of the command arguments
+
+ foreach {key value} $argv {
+ if {[string index $key 0] eq {-}} {
+ switch -regexp -- $key {
+ -as? {
+ if {$value ne {dicts} && $value ne {lists}} {
+ set errorcode $generalError
+ lappend errorcode badVarType $value
+ return -code error \
+ -errorcode $errorcode \
+ "bad variable type \"$value\":\
+ must be lists or dicts"
+ }
+ dict set opts -as $value
+ }
+ -c(?:o(?:l(?:u(?:m(?:n(?:s(?:v(?:a(?:r(?:i(?:a(?:b(?:le?)?)?)?)?)?)?)?)?)?)?)?)?) {
+ dict set opts -columnsvariable $value
+ }
+ -- {
+ incr i
+ break
+ }
+ default {
+ set errorcode $generalError
+ lappend errorcode badOption $key
+ return -code error \
+ -errorcode $errorcode \
+ "bad option \"$key\":\
+ must be -as or -columnsvariable"
+ }
+ }
+ } else {
+ break
+ }
+ incr i 2
+ }
+
+ return [lrange $argv[set argv {}] $i end]
+
+}
+
+
+
+#------------------------------------------------------------------------------
+#
+# tdbc::connection --
+#
+# Class that represents a generic connection to a database.
+#
+#-----------------------------------------------------------------------------
+
+oo::class create ::tdbc::connection {
+
+ # statementSeq is the sequence number of the last statement created.
+ # statementClass is the name of the class that implements the
+ # 'statement' API.
+ # primaryKeysStatement is the statement that queries primary keys
+ # foreignKeysStatement is the statement that queries foreign keys
+
+ variable statementSeq primaryKeysStatement foreignKeysStatement
+
+ # The base class constructor accepts no arguments. It sets up the
+ # machinery to do the bookkeeping to keep track of what statements
+ # are associated with the connection. The derived class constructor
+ # is expected to set the variable, 'statementClass' to the name
+ # of the class that represents statements, so that the 'prepare'
+ # method can invoke it.
+
+ constructor {} {
+ set statementSeq 0
+ namespace eval Stmt {}
+ }
+
+ # The 'close' method is simply an alternative syntax for destroying
+ # the connection.
+
+ method close {} {
+ my destroy
+ }
+
+ # The 'prepare' method creates a new statement against the connection,
+ # giving its constructor the current statement and the SQL code to
+ # prepare. It uses the 'statementClass' variable set by the constructor
+ # to get the class to instantiate.
+
+ method prepare {sqlcode} {
+ return [my statementCreate Stmt::[incr statementSeq] [self] $sqlcode]
+ }
+
+ # The 'statementCreate' method delegates to the constructor
+ # of the class specified by the 'statementClass' variable. It's
+ # intended for drivers designed before tdbc 1.0b10. Current ones
+ # should forward this method to the constructor directly.
+
+ method statementCreate {name instance sqlcode} {
+ my variable statementClass
+ return [$statementClass create $name $instance $sqlcode]
+ }
+
+ # Derived classes are expected to implement the 'prepareCall' method,
+ # and have it call 'prepare' as needed (or do something else and
+ # install the resulting statement)
+
+ # The 'statements' method lists the statements active against this
+ # connection.
+
+ method statements {} {
+ info commands Stmt::*
+ }
+
+ # The 'resultsets' method lists the result sets active against this
+ # connection.
+
+ method resultsets {} {
+ set retval {}
+ foreach statement [my statements] {
+ foreach resultset [$statement resultsets] {
+ lappend retval $resultset
+ }
+ }
+ return $retval
+ }
+
+ # The 'transaction' method executes a block of Tcl code as an
+ # ACID transaction against the database.
+
+ method transaction {script} {
+ my begintransaction
+ set status [catch {uplevel 1 $script} result options]
+ if {$status in {0 2 3 4}} {
+ set status2 [catch {my commit} result2 options2]
+ if {$status2 == 1} {
+ set status 1
+ set result $result2
+ set options $options2
+ }
+ }
+ switch -exact -- $status {
+ 0 {
+ # do nothing
+ }
+ 2 - 3 - 4 {
+ set options [dict merge {-level 1} $options[set options {}]]
+ dict incr options -level
+ }
+ default {
+ my rollback
+ }
+ }
+ return -options $options $result
+ }
+
+ # The 'allrows' method prepares a statement, then executes it with
+ # a given set of substituents, returning a list of all the rows
+ # that the statement returns. Optionally, it stores the names of
+ # the columns in '-columnsvariable'.
+ # Usage:
+ # $db allrows ?-as lists|dicts? ?-columnsvariable varName? ?--?
+ # sql ?dictionary?
+
+ method allrows args {
+
+ variable ::tdbc::generalError
+
+ # Grab keyword-value parameters
+
+ set args [::tdbc::ParseConvenienceArgs $args[set args {}] opts]
+
+ # Check postitional parameters
+
+ set cmd [list [self] prepare]
+ if {[llength $args] == 1} {
+ set sqlcode [lindex $args 0]
+ } elseif {[llength $args] == 2} {
+ lassign $args sqlcode dict
+ } else {
+ set errorcode $generalError
+ lappend errorcode wrongNumArgs
+ return -code error -errorcode $errorcode \
+ "wrong # args: should be [lrange [info level 0] 0 1]\
+ ?-option value?... ?--? sqlcode ?dictionary?"
+ }
+ lappend cmd $sqlcode
+
+ # Prepare the statement
+
+ set stmt [uplevel 1 $cmd]
+
+ # Delegate to the statement to accumulate the results
+
+ set cmd [list $stmt allrows {*}$opts --]
+ if {[info exists dict]} {
+ lappend cmd $dict
+ }
+ set status [catch {
+ uplevel 1 $cmd
+ } result options]
+
+ # Destroy the statement
+
+ catch {
+ $stmt close
+ }
+
+ return -options $options $result
+ }
+
+ # The 'foreach' method prepares a statement, then executes it with
+ # a supplied set of substituents. For each row of the result,
+ # it sets a variable to the row and invokes a script in the caller's
+ # scope.
+ #
+ # Usage:
+ # $db foreach ?-as lists|dicts? ?-columnsVariable varName? ?--?
+ # varName sql ?dictionary? script
+
+ method foreach args {
+
+ variable ::tdbc::generalError
+
+ # Grab keyword-value parameters
+
+ set args [::tdbc::ParseConvenienceArgs $args[set args {}] opts]
+
+ # Check postitional parameters
+
+ set cmd [list [self] prepare]
+ if {[llength $args] == 3} {
+ lassign $args varname sqlcode script
+ } elseif {[llength $args] == 4} {
+ lassign $args varname sqlcode dict script
+ } else {
+ set errorcode $generalError
+ lappend errorcode wrongNumArgs
+ return -code error -errorcode $errorcode \
+ "wrong # args: should be [lrange [info level 0] 0 1]\
+ ?-option value?... ?--? varname sqlcode ?dictionary? script"
+ }
+ lappend cmd $sqlcode
+
+ # Prepare the statement
+
+ set stmt [uplevel 1 $cmd]
+
+ # Delegate to the statement to iterate over the results
+
+ set cmd [list $stmt foreach {*}$opts -- $varname]
+ if {[info exists dict]} {
+ lappend cmd $dict
+ }
+ lappend cmd $script
+ set status [catch {
+ uplevel 1 $cmd
+ } result options]
+
+ # Destroy the statement
+
+ catch {
+ $stmt close
+ }
+
+ # Adjust return level in the case that the script [return]s
+
+ if {$status == 2} {
+ set options [dict merge {-level 1} $options[set options {}]]
+ dict incr options -level
+ }
+ return -options $options $result
+ }
+
+ # The 'BuildPrimaryKeysStatement' method builds a SQL statement to
+ # retrieve the primary keys from a database. (It executes once the
+ # first time the 'primaryKeys' method is executed, and retains the
+ # prepared statement for reuse.)
+
+ method BuildPrimaryKeysStatement {} {
+
+ # On some databases, CONSTRAINT_CATALOG is always NULL and
+ # JOINing to it fails. Check for this case and include that
+ # JOIN only if catalog names are supplied.
+
+ set catalogClause {}
+ if {[lindex [set count [my allrows -as lists {
+ SELECT COUNT(*)
+ FROM INFORMATION_SCHEMA.TABLE_CONSTRAINTS
+ WHERE CONSTRAINT_CATALOG IS NOT NULL}]] 0 0] != 0} {
+ set catalogClause \
+ {AND xtable.CONSTRAINT_CATALOG = xcolumn.CONSTRAINT_CATALOG}
+ }
+ set primaryKeysStatement [my prepare "
+ SELECT xtable.TABLE_SCHEMA AS \"tableSchema\",
+ xtable.TABLE_NAME AS \"tableName\",
+ xtable.CONSTRAINT_CATALOG AS \"constraintCatalog\",
+ xtable.CONSTRAINT_SCHEMA AS \"constraintSchema\",
+ xtable.CONSTRAINT_NAME AS \"constraintName\",
+ xcolumn.COLUMN_NAME AS \"columnName\",
+ xcolumn.ORDINAL_POSITION AS \"ordinalPosition\"
+ FROM INFORMATION_SCHEMA.TABLE_CONSTRAINTS xtable
+ INNER JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE xcolumn
+ ON xtable.CONSTRAINT_SCHEMA = xcolumn.CONSTRAINT_SCHEMA
+ AND xtable.TABLE_NAME = xcolumn.TABLE_NAME
+ AND xtable.CONSTRAINT_NAME = xcolumn.CONSTRAINT_NAME
+ $catalogClause
+ WHERE xtable.TABLE_NAME = :tableName
+ AND xtable.CONSTRAINT_TYPE = 'PRIMARY KEY'
+ "]
+ }
+
+ # The default implementation of the 'primarykeys' method uses the
+ # SQL INFORMATION_SCHEMA to retrieve primary key information. Databases
+ # that might not have INFORMATION_SCHEMA must overload this method.
+
+ method primarykeys {tableName} {
+ if {![info exists primaryKeysStatement]} {
+ my BuildPrimaryKeysStatement
+ }
+ tailcall $primaryKeysStatement allrows [list tableName $tableName]
+ }
+
+ # The 'BuildForeignKeysStatements' method builds a SQL statement to
+ # retrieve the foreign keys from a database. (It executes once the
+ # first time the 'foreignKeys' method is executed, and retains the
+ # prepared statements for reuse.)
+
+ method BuildForeignKeysStatement {} {
+
+ # On some databases, CONSTRAINT_CATALOG is always NULL and
+ # JOINing to it fails. Check for this case and include that
+ # JOIN only if catalog names are supplied.
+
+ set catalogClause1 {}
+ set catalogClause2 {}
+ if {[lindex [set count [my allrows -as lists {
+ SELECT COUNT(*)
+ FROM INFORMATION_SCHEMA.TABLE_CONSTRAINTS
+ WHERE CONSTRAINT_CATALOG IS NOT NULL}]] 0 0] != 0} {
+ set catalogClause1 \
+ {AND fkc.CONSTRAINT_CATALOG = rc.CONSTRAINT_CATALOG}
+ set catalogClause2 \
+ {AND pkc.CONSTRAINT_CATALOG = rc.CONSTRAINT_CATALOG}
+ }
+
+ foreach {exists1 clause1} {
+ 0 {}
+ 1 { AND pkc.TABLE_NAME = :primary}
+ } {
+ foreach {exists2 clause2} {
+ 0 {}
+ 1 { AND fkc.TABLE_NAME = :foreign}
+ } {
+ set stmt [my prepare "
+ SELECT rc.CONSTRAINT_CATALOG AS \"foreignConstraintCatalog\",
+ rc.CONSTRAINT_SCHEMA AS \"foreignConstraintSchema\",
+ rc.CONSTRAINT_NAME AS \"foreignConstraintName\",
+ rc.UNIQUE_CONSTRAINT_CATALOG
+ AS \"primaryConstraintCatalog\",
+ rc.UNIQUE_CONSTRAINT_SCHEMA AS \"primaryConstraintSchema\",
+ rc.UNIQUE_CONSTRAINT_NAME AS \"primaryConstraintName\",
+ rc.UPDATE_RULE AS \"updateAction\",
+ rc.DELETE_RULE AS \"deleteAction\",
+ pkc.TABLE_CATALOG AS \"primaryCatalog\",
+ pkc.TABLE_SCHEMA AS \"primarySchema\",
+ pkc.TABLE_NAME AS \"primaryTable\",
+ pkc.COLUMN_NAME AS \"primaryColumn\",
+ fkc.TABLE_CATALOG AS \"foreignCatalog\",
+ fkc.TABLE_SCHEMA AS \"foreignSchema\",
+ fkc.TABLE_NAME AS \"foreignTable\",
+ fkc.COLUMN_NAME AS \"foreignColumn\",
+ pkc.ORDINAL_POSITION AS \"ordinalPosition\"
+ FROM INFORMATION_SCHEMA.REFERENTIAL_CONSTRAINTS rc
+ INNER JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE fkc
+ ON fkc.CONSTRAINT_NAME = rc.CONSTRAINT_NAME
+ AND fkc.CONSTRAINT_SCHEMA = rc.CONSTRAINT_SCHEMA
+ $catalogClause1
+ INNER JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE pkc
+ ON pkc.CONSTRAINT_NAME = rc.UNIQUE_CONSTRAINT_NAME
+ AND pkc.CONSTRAINT_SCHEMA = rc.UNIQUE_CONSTRAINT_SCHEMA
+ $catalogClause2
+ AND pkc.ORDINAL_POSITION = fkc.ORDINAL_POSITION
+ WHERE 1=1
+ $clause1
+ $clause2
+ ORDER BY \"foreignConstraintCatalog\", \"foreignConstraintSchema\", \"foreignConstraintName\", \"ordinalPosition\"
+"]
+ dict set foreignKeysStatement $exists1 $exists2 $stmt
+ }
+ }
+ }
+
+ # The default implementation of the 'foreignkeys' method uses the
+ # SQL INFORMATION_SCHEMA to retrieve primary key information. Databases
+ # that might not have INFORMATION_SCHEMA must overload this method.
+
+ method foreignkeys {args} {
+
+ variable ::tdbc::generalError
+
+ # Check arguments
+
+ set argdict {}
+ if {[llength $args] % 2 != 0} {
+ set errorcode $generalError
+ lappend errorcode wrongNumArgs
+ return -code error -errorcode $errorcode \
+ "wrong # args: should be [lrange [info level 0] 0 1]\
+ ?-option value?..."
+ }
+ foreach {key value} $args {
+ if {$key ni {-primary -foreign}} {
+ set errorcode $generalError
+ lappend errorcode badOption
+ return -code error -errorcode $errorcode \
+ "bad option \"$key\", must be -primary or -foreign"
+ }
+ set key [string range $key 1 end]
+ if {[dict exists $argdict $key]} {
+ set errorcode $generalError
+ lappend errorcode dupOption
+ return -code error -errorcode $errorcode \
+ "duplicate option \"$key\" supplied"
+ }
+ dict set argdict $key $value
+ }
+
+ # Build the statements that query foreign keys. There are four
+ # of them, one for each combination of whether -primary
+ # and -foreign is specified.
+
+ if {![info exists foreignKeysStatement]} {
+ my BuildForeignKeysStatement
+ }
+ set stmt [dict get $foreignKeysStatement \
+ [dict exists $argdict primary] \
+ [dict exists $argdict foreign]]
+ tailcall $stmt allrows $argdict
+ }
+
+ # Derived classes are expected to implement the 'begintransaction',
+ # 'commit', and 'rollback' methods.
+
+ # Derived classes are expected to implement 'tables' and 'columns' method.
+
+}
+
+#------------------------------------------------------------------------------
+#
+# Class: tdbc::statement
+#
+# Class that represents a SQL statement in a generic database
+#
+#------------------------------------------------------------------------------
+
+oo::class create tdbc::statement {
+
+ # resultSetSeq is the sequence number of the last result set created.
+ # resultSetClass is the name of the class that implements the 'resultset'
+ # API.
+
+ variable resultSetClass resultSetSeq
+
+ # The base class constructor accepts no arguments. It initializes
+ # the machinery for tracking the ownership of result sets. The derived
+ # constructor is expected to invoke the base constructor, and to
+ # set a variable 'resultSetClass' to the fully-qualified name of the
+ # class that represents result sets.
+
+ constructor {} {
+ set resultSetSeq 0
+ namespace eval ResultSet {}
+ }
+
+ # The 'execute' method on a statement runs the statement with
+ # a particular set of substituted variables. It actually works
+ # by creating the result set object and letting that objects
+ # constructor do the work of running the statement. The creation
+ # is wrapped in an [uplevel] call because the substitution proces
+ # may need to access variables in the caller's scope.
+
+ # WORKAROUND: Take out the '0 &&' from the next line when
+ # Bug 2649975 is fixed
+ if {0 && [package vsatisfies [package provide Tcl] 8.6]} {
+ method execute args {
+ tailcall my resultSetCreate \
+ [namespace current]::ResultSet::[incr resultSetSeq] \
+ [self] {*}$args
+ }
+ } else {
+ method execute args {
+ return \
+ [uplevel 1 \
+ [list \
+ [self] resultSetCreate \
+ [namespace current]::ResultSet::[incr resultSetSeq] \
+ [self] {*}$args]]
+ }
+ }
+
+ # The 'ResultSetCreate' method is expected to be a forward to the
+ # appropriate result set constructor. If it's missing, the driver must
+ # have been designed for tdbc 1.0b9 and earlier, and the 'resultSetClass'
+ # variable holds the class name.
+
+ method resultSetCreate {name instance args} {
+ return [uplevel 1 [list $resultSetClass create \
+ $name $instance {*}$args]]
+ }
+
+ # The 'resultsets' method returns a list of result sets produced by
+ # the current statement
+
+ method resultsets {} {
+ info commands ResultSet::*
+ }
+
+ # The 'allrows' method executes a statement with a given set of
+ # substituents, and returns a list of all the rows that the statement
+ # returns. Optionally, it stores the names of columns in
+ # '-columnsvariable'.
+ #
+ # Usage:
+ # $statement allrows ?-as lists|dicts? ?-columnsvariable varName? ?--?
+ # ?dictionary?
+
+
+ method allrows args {
+
+ variable ::tdbc::generalError
+
+ # Grab keyword-value parameters
+
+ set args [::tdbc::ParseConvenienceArgs $args[set args {}] opts]
+
+ # Check postitional parameters
+
+ set cmd [list [self] execute]
+ if {[llength $args] == 0} {
+ # do nothing
+ } elseif {[llength $args] == 1} {
+ lappend cmd [lindex $args 0]
+ } else {
+ set errorcode $generalError
+ lappend errorcode wrongNumArgs
+ return -code error -errorcode $errorcode \
+ "wrong # args: should be [lrange [info level 0] 0 1]\
+ ?-option value?... ?--? ?dictionary?"
+ }
+
+ # Get the result set
+
+ set resultSet [uplevel 1 $cmd]
+
+ # Delegate to the result set's [allrows] method to accumulate
+ # the rows of the result.
+
+ set cmd [list $resultSet allrows {*}$opts]
+ set status [catch {
+ uplevel 1 $cmd
+ } result options]
+
+ # Destroy the result set
+
+ catch {
+ rename $resultSet {}
+ }
+
+ # Adjust return level in the case that the script [return]s
+
+ if {$status == 2} {
+ set options [dict merge {-level 1} $options[set options {}]]
+ dict incr options -level
+ }
+ return -options $options $result
+ }
+
+ # The 'foreach' method executes a statement with a given set of
+ # substituents. It runs the supplied script, substituting the supplied
+ # named variable. Optionally, it stores the names of columns in
+ # '-columnsvariable'.
+ #
+ # Usage:
+ # $statement foreach ?-as lists|dicts? ?-columnsvariable varName? ?--?
+ # variableName ?dictionary? script
+
+ method foreach args {
+
+ variable ::tdbc::generalError
+
+ # Grab keyword-value parameters
+
+ set args [::tdbc::ParseConvenienceArgs $args[set args {}] opts]
+
+ # Check positional parameters
+
+ set cmd [list [self] execute]
+ if {[llength $args] == 2} {
+ lassign $args varname script
+ } elseif {[llength $args] == 3} {
+ lassign $args varname dict script
+ lappend cmd $dict
+ } else {
+ set errorcode $generalError
+ lappend errorcode wrongNumArgs
+ return -code error -errorcode $errorcode \
+ "wrong # args: should be [lrange [info level 0] 0 1]\
+ ?-option value?... ?--? varName ?dictionary? script"
+ }
+
+ # Get the result set
+
+ set resultSet [uplevel 1 $cmd]
+
+ # Delegate to the result set's [foreach] method to evaluate
+ # the script for each row of the result.
+
+ set cmd [list $resultSet foreach {*}$opts -- $varname $script]
+ set status [catch {
+ uplevel 1 $cmd
+ } result options]
+
+ # Destroy the result set
+
+ catch {
+ rename $resultSet {}
+ }
+
+ # Adjust return level in the case that the script [return]s
+
+ if {$status == 2} {
+ set options [dict merge {-level 1} $options[set options {}]]
+ dict incr options -level
+ }
+ return -options $options $result
+ }
+
+ # The 'close' method is syntactic sugar for invoking the destructor
+
+ method close {} {
+ my destroy
+ }
+
+ # Derived classes are expected to implement their own constructors,
+ # plus the following methods:
+
+ # paramtype paramName ?direction? type ?scale ?precision??
+ # Declares the type of a parameter in the statement
+
+}
+
+#------------------------------------------------------------------------------
+#
+# Class: tdbc::resultset
+#
+# Class that represents a result set in a generic database.
+#
+#------------------------------------------------------------------------------
+
+oo::class create tdbc::resultset {
+
+ constructor {} { }
+
+ # The 'allrows' method returns a list of all rows that a given
+ # result set returns.
+
+ method allrows args {
+
+ variable ::tdbc::generalError
+
+ # Parse args
+
+ set args [::tdbc::ParseConvenienceArgs $args[set args {}] opts]
+ if {[llength $args] != 0} {
+ set errorcode $generalError
+ lappend errorcode wrongNumArgs
+ return -code error -errorcode $errorcode \
+ "wrong # args: should be [lrange [info level 0] 0 1]\
+ ?-option value?... ?--? varName script"
+ }
+
+ # Do -columnsvariable if requested
+
+ if {[dict exists $opts -columnsvariable]} {
+ upvar 1 [dict get $opts -columnsvariable] columns
+ }
+
+ # Assemble the results
+
+ if {[dict get $opts -as] eq {lists}} {
+ set delegate nextlist
+ } else {
+ set delegate nextdict
+ }
+ set results [list]
+ while {1} {
+ set columns [my columns]
+ while {[my $delegate row]} {
+ lappend results $row
+ }
+ if {![my nextresults]} break
+ }
+ return $results
+
+ }
+
+ # The 'foreach' method runs a script on each row from a result set.
+
+ method foreach args {
+
+ variable ::tdbc::generalError
+
+ # Grab keyword-value parameters
+
+ set args [::tdbc::ParseConvenienceArgs $args[set args {}] opts]
+
+ # Check positional parameters
+
+ if {[llength $args] != 2} {
+ set errorcode $generalError
+ lappend errorcode wrongNumArgs
+ return -code error -errorcode $errorcode \
+ "wrong # args: should be [lrange [info level 0] 0 1]\
+ ?-option value?... ?--? varName script"
+ }
+
+ # Do -columnsvariable if requested
+
+ if {[dict exists $opts -columnsvariable]} {
+ upvar 1 [dict get $opts -columnsvariable] columns
+ }
+
+ # Iterate over the groups of results
+ while {1} {
+
+ # Export column names to caller
+
+ set columns [my columns]
+
+ # Iterate over the rows of one group of results
+
+ upvar 1 [lindex $args 0] row
+ if {[dict get $opts -as] eq {lists}} {
+ set delegate nextlist
+ } else {
+ set delegate nextdict
+ }
+ while {[my $delegate row]} {
+ set status [catch {
+ uplevel 1 [lindex $args 1]
+ } result options]
+ switch -exact -- $status {
+ 0 - 4 { # OK or CONTINUE
+ }
+ 2 { # RETURN
+ set options \
+ [dict merge {-level 1} $options[set options {}]]
+ dict incr options -level
+ return -options $options $result
+ }
+ 3 { # BREAK
+ set broken 1
+ break
+ }
+ default { # ERROR or unknown status
+ return -options $options $result
+ }
+ }
+ }
+
+ # Advance to the next group of results if there is one
+
+ if {[info exists broken] || ![my nextresults]} {
+ break
+ }
+ }
+
+ return
+ }
+
+
+ # The 'nextrow' method retrieves a row in the form of either
+ # a list or a dictionary.
+
+ method nextrow {args} {
+
+ variable ::tdbc::generalError
+
+ set opts [dict create -as dicts]
+ set i 0
+
+ # Munch keyword options off the front of the command arguments
+
+ foreach {key value} $args {
+ if {[string index $key 0] eq {-}} {
+ switch -regexp -- $key {
+ -as? {
+ dict set opts -as $value
+ }
+ -- {
+ incr i
+ break
+ }
+ default {
+ set errorcode $generalError
+ lappend errorcode badOption $key
+ return -code error -errorcode $errorcode \
+ "bad option \"$key\":\
+ must be -as or -columnsvariable"
+ }
+ }
+ } else {
+ break
+ }
+ incr i 2
+ }
+
+ set args [lrange $args $i end]
+ if {[llength $args] != 1} {
+ set errorcode $generalError
+ lappend errorcode wrongNumArgs
+ return -code error -errorcode $errorcode \
+ "wrong # args: should be [lrange [info level 0] 0 1]\
+ ?-option value?... ?--? varName"
+ }
+ upvar 1 [lindex $args 0] row
+ if {[dict get $opts -as] eq {lists}} {
+ set delegate nextlist
+ } else {
+ set delegate nextdict
+ }
+ return [my $delegate row]
+ }
+
+ # Derived classes must override 'nextresults' if a single
+ # statement execution can yield multiple sets of results
+
+ method nextresults {} {
+ return 0
+ }
+
+ # Derived classes must override 'outputparams' if statements can
+ # have output parameters.
+
+ method outputparams {} {
+ return {}
+ }
+
+ # The 'close' method is syntactic sugar for destroying the result set.
+
+ method close {} {
+ my destroy
+ }
+
+ # Derived classes are expected to implement the following methods:
+
+ # constructor and destructor.
+ # Constructor accepts a statement and an optional
+ # a dictionary of substituted parameters and
+ # executes the statement against the database. If
+ # the dictionary is not supplied, then the default
+ # is to get params from variables in the caller's scope).
+ # columns
+ # -- Returns a list of the names of the columns in the result.
+ # nextdict variableName
+ # -- Stores the next row of the result set in the given variable
+ # in caller's scope, in the form of a dictionary that maps
+ # column names to values.
+ # nextlist variableName
+ # -- Stores the next row of the result set in the given variable
+ # in caller's scope, in the form of a list of cells.
+ # rowcount
+ # -- Returns a count of rows affected by the statement, or -1
+ # if the count of rows has not been determined.
+
+}
\ No newline at end of file
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.5/tdbc.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.5/tdbc115.dll
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.5/tdbc115.dll
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbc1.1.5/tdbc115.dll 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tdbc1.1.5/tdbc115.dll 2024-02-15 21:05:12 UTC (rev 69897)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.5/tdbc115.dll
___________________________________________________________________
Added: svn:mime-type
## -0,0 +1 ##
+application/vnd.microsoft.portable-executable
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.5/tdbcConfig.sh
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbc1.1.5/tdbcConfig.sh (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tdbc1.1.5/tdbcConfig.sh 2024-02-15 21:05:12 UTC (rev 69897)
@@ -0,0 +1,81 @@
+# tdbcConfig.sh --
+#
+# This shell script (for sh) is generated automatically by TDBC's configure
+# script. It will create shell variables for most of the configuration options
+# discovered by the configure script. This script is intended to be included
+# by the configure scripts for TDBC extensions so that they don't have to
+# figure this all out for themselves.
+#
+# The information in this file is specific to a single platform.
+#
+# RCS: @(#) $Id$
+
+# TDBC's version number
+tdbc_VERSION=1.1.5
+TDBC_VERSION=1.1.5
+
+# Name of the TDBC library - may be either a static or shared library
+tdbc_LIB_FILE=tdbc115.dll
+TDBC_LIB_FILE=tdbc115.dll
+
+# String to pass to the linker to pick up the TDBC library from its build dir
+tdbc_BUILD_LIB_SPEC="-L/tmp/siepo/tcl8.6.13/win/pkgs/tdbc1.1.5 -ltdbc115"
+TDBC_BUILD_LIB_SPEC="-L/tmp/siepo/tcl8.6.13/win/pkgs/tdbc1.1.5 -ltdbc115"
+
+# String to pass to the linker to pick up the TDBC library from its installed
+# dir.
+tdbc_LIB_SPEC="-L/home/siepo/tltcl/lib/tdbc1.1.5 -ltdbc115"
+TDBC_LIB_SPEC="-L/home/siepo/tltcl/lib/tdbc1.1.5 -ltdbc115"
+
+# Name of the TBDC stub library
+tdbc_STUB_LIB_FILE="libtdbcstub115.a"
+TDBC_STUB_LIB_FILE="libtdbcstub115.a"
+
+# String to pass to the linker to pick up the TDBC stub library from its
+# build directory
+tdbc_BUILD_STUB_LIB_SPEC="-L/tmp/siepo/tcl8.6.13/win/pkgs/tdbc1.1.5 -ltdbcstub115"
+TDBC_BUILD_STUB_LIB_SPEC="-L/tmp/siepo/tcl8.6.13/win/pkgs/tdbc1.1.5 -ltdbcstub115"
+
+# String to pass to the linker to pick up the TDBC stub library from its
+# installed directory
+tdbc_STUB_LIB_SPEC="-L/home/siepo/tltcl/lib/tdbc1.1.5 -ltdbcstub115"
+TDBC_STUB_LIB_SPEC="-L/home/siepo/tltcl/lib/tdbc1.1.5 -ltdbcstub115"
+
+# Path name of the TDBC stub library in its build directory
+tdbc_BUILD_STUB_LIB_PATH="/tmp/siepo/tcl8.6.13/win/pkgs/tdbc1.1.5/libtdbcstub115.a"
+TDBC_BUILD_STUB_LIB_PATH="/tmp/siepo/tcl8.6.13/win/pkgs/tdbc1.1.5/libtdbcstub115.a"
+
+# Path name of the TDBC stub library in its installed directory
+tdbc_STUB_LIB_PATH="/home/siepo/tltcl/lib/tdbc1.1.5/libtdbcstub115.a"
+TDBC_STUB_LIB_PATH="/home/siepo/tltcl/lib/tdbc1.1.5/libtdbcstub115.a"
+
+# Location of the top-level source directories from which TDBC was built.
+# This is the directory that contains doc/, generic/ and so on. If TDBC
+# was compiled in a directory other than the source directory, this still
+# points to the location of the sources, not the location where TDBC was
+# compiled.
+tdbc_SRC_DIR="/tmp/siepo/tcl8.6.13/pkgs/tdbc1.1.5"
+TDBC_SRC_DIR="/tmp/siepo/tcl8.6.13/pkgs/tdbc1.1.5"
+
+# String to pass to the compiler so that an extension can find installed TDBC
+# headers
+tdbc_INCLUDE_SPEC="-I/home/siepo/tltcl/include"
+TDBC_INCLUDE_SPEC="-I/home/siepo/tltcl/include"
+
+# String to pass to the compiler so that an extension can find TDBC headers
+# in the source directory
+tdbc_BUILD_INCLUDE_SPEC="-I/tmp/siepo/tcl8.6.13/pkgs/tdbc1.1.5/generic"
+TDBC_BUILD_INCLUDE_SPEC="-I/tmp/siepo/tcl8.6.13/pkgs/tdbc1.1.5/generic"
+
+# Path name where .tcl files in the tdbc package appear at run time.
+tdbc_LIBRARY_PATH="/home/siepo/tltcl/lib/tdbc1.1.5"
+TDBC_LIBRARY_PATH="/home/siepo/tltcl/lib/tdbc1.1.5"
+
+# Path name where .tcl files in the tdbc package appear at build time.
+tdbc_BUILD_LIBRARY_PATH="/tmp/siepo/tcl8.6.13/pkgs/tdbc1.1.5/library"
+TDBC_BUILD_LIBRARY_PATH="/tmp/siepo/tcl8.6.13/pkgs/tdbc1.1.5/library"
+
+# Additional flags that must be passed to the C compiler to use tdbc
+tdbc_CFLAGS=
+TDBC_CFLAGS=
+
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.5/tdbcConfig.sh
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.5/pkgIndex.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.5/pkgIndex.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.5/pkgIndex.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -0,0 +1,14 @@
+# Index file to load the TDBC MySQL package.
+
+if {![package vsatisfies [package provide Tcl] 8.6-]} {
+ return
+}
+if {[package vsatisfies [package provide Tcl] 9.0-]} {
+ package ifneeded tdbc::mysql 1.1.5 \
+ "[list source [file join $dir tdbcmysql.tcl]]\;\
+ [list load [file join $dir tcl9tdbcmysql115.dll] [string totitle tdbcmysql]]"
+} else {
+ package ifneeded tdbc::mysql 1.1.5 \
+ "[list source [file join $dir tdbcmysql.tcl]]\;\
+ [list load [file join $dir tdbcmysql115.dll] [string totitle tdbcmysql]]"
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.5/pkgIndex.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.5/tdbcmysql.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.5/tdbcmysql.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.5/tdbcmysql.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -0,0 +1,193 @@
+# tdbcmysql.tcl --
+#
+# Class definitions and Tcl-level methods for the tdbc::mysql bridge.
+#
+# Copyright (c) 2008 by Kevin B. Kenny
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: tdbcmysql.tcl,v 1.47 2008/02/27 02:08:27 kennykb Exp $
+#
+#------------------------------------------------------------------------------
+
+package require tdbc
+
+::namespace eval ::tdbc::mysql {
+
+ namespace export connection datasources drivers
+
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::mysql::connection --
+#
+# Class representing a connection to a database through MYSQL.
+#
+#-------------------------------------------------------------------------------
+
+::oo::class create ::tdbc::mysql::connection {
+
+ superclass ::tdbc::connection
+
+ # The constructor is written in C. It takes alternating keywords
+ # and values pairs as its argumenta. (See the manual page for the
+ # available options.)
+
+ variable foreignKeysStatement
+
+ # The 'statementCreate' method delegates to the constructor of the
+ # statement class
+
+ forward statementCreate ::tdbc::mysql::statement create
+
+ # The 'columns' method returns a dictionary describing the tables
+ # in the database
+
+ method columns {table {pattern %}} {
+
+ # To return correct lengths of CHARACTER and BINARY columns,
+ # we need to know the maximum lengths of characters in each
+ # collation. We cache this information only once, on the first
+ # call to 'columns'.
+
+ if {[my NeedCollationInfo]} {
+ my SetCollationInfo {*}[my allrows -as lists {
+ SELECT coll.id, cs.maxlen
+ FROM INFORMATION_SCHEMA.COLLATIONS coll,
+ INFORMATION_SCHEMA.CHARACTER_SETS cs
+ WHERE cs.CHARACTER_SET_NAME = coll.CHARACTER_SET_NAME
+ ORDER BY coll.id DESC
+ }]
+ }
+
+ return [my Columns $table $pattern]
+ }
+
+ # The 'preparecall' method gives a portable interface to prepare
+ # calls to stored procedures. It delegates to 'prepare' to do the
+ # actual work.
+
+ method preparecall {call} {
+ regexp {^[[:space:]]*(?:([A-Za-z_][A-Za-z_0-9]*)[[:space:]]*=)?(.*)} \
+ $call -> varName rest
+ if {$varName eq {}} {
+ my prepare "CALL $rest"
+ } else {
+ my prepare \\{:$varName=$rest\\}
+ }
+ }
+
+ # The 'init', 'begintransaction', 'commit, 'rollback', 'tables'
+ # 'NeedCollationInfo', 'SetCollationInfo', and 'Columns' methods
+ # are implemented in C.
+
+ # The 'BuildForeignKeysStatements' method builds a SQL statement to
+ # retrieve the foreign keys from a database. (It executes once the
+ # first time the 'foreignKeys' method is executed, and retains the
+ # prepared statements for reuse.) It is slightly nonstandard because
+ # MYSQL doesn't name the PRIMARY constraints uniquely.
+
+ method BuildForeignKeysStatement {} {
+
+ foreach {exists1 clause1} {
+ 0 {}
+ 1 { AND fkc.REFERENCED_TABLE_NAME = :primary}
+ } {
+ foreach {exists2 clause2} {
+ 0 {}
+ 1 { AND fkc.TABLE_NAME = :foreign}
+ } {
+ set stmt [my prepare "
+ SELECT rc.CONSTRAINT_SCHEMA AS \"foreignConstraintSchema\",
+ rc.CONSTRAINT_NAME AS \"foreignConstraintName\",
+ rc.UPDATE_RULE AS \"updateAction\",
+ rc.DELETE_RULE AS \"deleteAction\",
+ fkc.REFERENCED_TABLE_SCHEMA AS \"primarySchema\",
+ fkc.REFERENCED_TABLE_NAME AS \"primaryTable\",
+ fkc.REFERENCED_COLUMN_NAME AS \"primaryColumn\",
+ fkc.TABLE_SCHEMA AS \"foreignSchema\",
+ fkc.TABLE_NAME AS \"foreignTable\",
+ fkc.COLUMN_NAME AS \"foreignColumn\",
+ fkc.ORDINAL_POSITION AS \"ordinalPosition\"
+ FROM INFORMATION_SCHEMA.REFERENTIAL_CONSTRAINTS rc
+ INNER JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE fkc
+ ON fkc.CONSTRAINT_NAME = rc.CONSTRAINT_NAME
+ AND fkc.CONSTRAINT_SCHEMA = rc.CONSTRAINT_SCHEMA
+ WHERE 1=1
+ $clause1
+ $clause2
+"]
+ dict set foreignKeysStatement $exists1 $exists2 $stmt
+ }
+ }
+ }
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::mysql::statement --
+#
+# The class 'tdbc::mysql::statement' models one statement against a
+# database accessed through an MYSQL connection
+#
+#------------------------------------------------------------------------------
+
+::oo::class create ::tdbc::mysql::statement {
+
+ superclass ::tdbc::statement
+
+ # The 'resultSetCreate' method forwards to the constructor of the
+ # result set.
+
+ forward resultSetCreate ::tdbc::mysql::resultset create
+
+ # Methods implemented in C:
+ #
+ # constructor connection SQLCode
+ # The constructor accepts the handle to the connection and the SQL code
+ # for the statement to prepare. It creates a subordinate namespace to
+ # hold the statement's active result sets, and then delegates to the
+ # 'init' method, written in C, to do the actual work of preparing the
+ # statement.
+ # params
+ # Returns descriptions of the parameters of a statement.
+ # paramtype paramname ?direction? type ?precision ?scale??
+ # Declares the type of a parameter in the statement
+
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::mysql::resultset --
+#
+# The class 'tdbc::mysql::resultset' models the result set that is
+# produced by executing a statement against an MYSQL database.
+#
+#------------------------------------------------------------------------------
+
+::oo::class create ::tdbc::mysql::resultset {
+
+ superclass ::tdbc::resultset
+
+ # Methods implemented in C include:
+
+ # constructor statement ?dictionary?
+ # -- Executes the statement against the database, optionally providing
+ # a dictionary of substituted parameters (default is to get params
+ # from variables in the caller's scope).
+ # columns
+ # -- Returns a list of the names of the columns in the result.
+ # nextdict
+ # -- Stores the next row of the result set in the given variable in
+ # the caller's scope as a dictionary whose keys are
+ # column names and whose values are column values, or else
+ # as a list of cells.
+ # nextlist
+ # -- Stores the next row of the result set in the given variable in
+ # the caller's scope as a list of cells.
+ # rowcount
+ # -- Returns a count of rows affected by the statement, or -1
+ # if the count of rows has not been determined.
+
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.5/tdbcmysql.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.5/tdbcmysql115.dll
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.5/tdbcmysql115.dll
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.5/tdbcmysql115.dll 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.5/tdbcmysql115.dll 2024-02-15 21:05:12 UTC (rev 69897)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.5/tdbcmysql115.dll
___________________________________________________________________
Added: svn:mime-type
## -0,0 +1 ##
+application/vnd.microsoft.portable-executable
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.5/pkgIndex.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.5/pkgIndex.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.5/pkgIndex.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -0,0 +1,14 @@
+# Index file to load the TDBC ODBC package.
+
+if {![package vsatisfies [package provide Tcl] 8.6-]} {
+ return
+}
+if {[package vsatisfies [package provide Tcl] 9.0-]} {
+ package ifneeded tdbc::odbc 1.1.5 \
+ "[list source [file join $dir tdbcodbc.tcl]]\;\
+ [list load [file join $dir tcl9tdbcodbc115.dll] [string totitle tdbcodbc]]"
+} else {
+ package ifneeded tdbc::odbc 1.1.5 \
+ "[list source [file join $dir tdbcodbc.tcl]]\;\
+ [list load [file join $dir tdbcodbc115.dll] [string totitle tdbcodbc]]"
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.5/pkgIndex.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.5/tdbcodbc.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.5/tdbcodbc.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.5/tdbcodbc.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -0,0 +1,554 @@
+# tdbcodbc.tcl --
+#
+# Class definitions and Tcl-level methods for the tdbc::odbc bridge.
+#
+# Copyright (c) 2008 by Kevin B. Kenny
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: tdbcodbc.tcl,v 1.47 2008/02/27 02:08:27 kennykb Exp $
+#
+#------------------------------------------------------------------------------
+
+package require tdbc
+
+::namespace eval ::tdbc::odbc {
+
+ namespace export connection datasources drivers
+
+ # Data types that are predefined in ODBC
+
+ variable sqltypes [dict create \
+ 1 char \
+ 2 numeric \
+ 3 decimal \
+ 4 integer \
+ 5 smallint \
+ 6 float \
+ 7 real \
+ 8 double \
+ 9 datetime \
+ 12 varchar \
+ 91 date \
+ 92 time \
+ 93 timestamp \
+ -1 longvarchar \
+ -2 binary \
+ -3 varbinary \
+ -4 longvarbinary \
+ -5 bigint \
+ -6 tinyint \
+ -7 bit \
+ -8 wchar \
+ -9 wvarchar \
+ -10 wlongvarchar \
+ -11 guid]
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::odbc::connection --
+#
+# Class representing a connection to a database through ODBC.
+#
+#-------------------------------------------------------------------------------
+
+::oo::class create ::tdbc::odbc::connection {
+
+ superclass ::tdbc::connection
+
+ variable statementSeq typemap
+
+ # The constructor is written in C. It takes the connection string
+ # as its argument It sets up a namespace to hold the statements
+ # associated with the connection, and then delegates to the 'init'
+ # method (written in C) to do the actual work of attaching to the
+ # database. When that comes back, it sets up a statement to query
+ # the support types, makes a dictionary to enumerate them, and
+ # calls back to set a flag if WVARCHAR is seen (If WVARCHAR is
+ # seen, the database supports Unicode.)
+
+ # The 'statementCreate' method forwards to the constructor of the
+ # statement class
+
+ forward statementCreate ::tdbc::odbc::statement create
+
+ # The 'tables' method returns a dictionary describing the tables
+ # in the database
+
+ method tables {{pattern %}} {
+ set stmt [::tdbc::odbc::tablesStatement create \
+ Stmt::[incr statementSeq] [self] $pattern]
+ set status [catch {
+ set retval {}
+ $stmt foreach -as dicts row {
+ if {[dict exists $row TABLE_NAME]} {
+ dict set retval [dict get $row TABLE_NAME] $row
+ }
+ }
+ set retval
+ } result options]
+ catch {rename $stmt {}}
+ return -level 0 -options $options $result
+ }
+
+ # The 'columns' method returns a dictionary describing the tables
+ # in the database
+
+ method columns {table {pattern %}} {
+ # Make sure that the type map is initialized
+ my typemap
+
+ # Query the columns from the database
+
+ set stmt [::tdbc::odbc::columnsStatement create \
+ Stmt::[incr statementSeq] [self] $table $pattern]
+ set status [catch {
+ set retval {}
+ $stmt foreach -as dicts origrow {
+
+ # Map the type, precision, scale and nullable indicators
+ # to tdbc's notation
+
+ set row {}
+ dict for {key value} $origrow {
+ dict set row [string tolower $key] $value
+ }
+ if {[dict exists $row column_name]} {
+ if {[dict exists $typemap \
+ [dict get $row data_type]]} {
+ dict set row type \
+ [dict get $typemap \
+ [dict get $row data_type]]
+ } else {
+ dict set row type [dict get $row type_name]
+ }
+ if {[dict exists $row column_size]} {
+ dict set row precision \
+ [dict get $row column_size]
+ }
+ if {[dict exists $row decimal_digits]} {
+ dict set row scale \
+ [dict get $row decimal_digits]
+ }
+ if {![dict exists $row nullable]} {
+ dict set row nullable \
+ [expr {!![string trim [dict get $row is_nullable]]}]
+ }
+ dict set retval [dict get $row column_name] $row
+ }
+ }
+ set retval
+ } result options]
+ catch {rename $stmt {}}
+ return -level 0 -options $options $result
+ }
+
+ # The 'primarykeys' method returns a dictionary describing the primary
+ # keys of a table
+
+ method primarykeys {tableName} {
+ set stmt [::tdbc::odbc::primarykeysStatement create \
+ Stmt::[incr statementSeq] [self] $tableName]
+ set status [catch {
+ set retval {}
+ $stmt foreach -as dicts row {
+ foreach {odbcKey tdbcKey} {
+ TABLE_CAT tableCatalog
+ TABLE_SCHEM tableSchema
+ TABLE_NAME tableName
+ COLUMN_NAME columnName
+ KEY_SEQ ordinalPosition
+ PK_NAME constraintName
+ } {
+ if {[dict exists $row $odbcKey]} {
+ dict set row $tdbcKey [dict get $row $odbcKey]
+ dict unset row $odbcKey
+ }
+ }
+ lappend retval $row
+ }
+ set retval
+ } result options]
+ catch {rename $stmt {}}
+ return -level 0 -options $options $result
+ }
+
+ # The 'foreignkeys' method returns a dictionary describing the foreign
+ # keys of a table
+
+ method foreignkeys {args} {
+ set stmt [::tdbc::odbc::foreignkeysStatement create \
+ Stmt::[incr statementSeq] [self] {*}$args]
+ set status [catch {
+ set fkseq 0
+ set retval {}
+ $stmt foreach -as dicts row {
+ foreach {odbcKey tdbcKey} {
+ PKTABLE_CAT primaryCatalog
+ PKTABLE_SCHEM primarySchema
+ PKTABLE_NAME primaryTable
+ PKCOLUMN_NAME primaryColumn
+ FKTABLE_CAT foreignCatalog
+ FKTABLE_SCHEM foreignSchema
+ FKTABLE_NAME foreignTable
+ FKCOLUMN_NAME foreignColumn
+ UPDATE_RULE updateRule
+ DELETE_RULE deleteRule
+ DEFERRABILITY deferrable
+ KEY_SEQ ordinalPosition
+ FK_NAME foreignConstraintName
+ } {
+ if {[dict exists $row $odbcKey]} {
+ dict set row $tdbcKey [dict get $row $odbcKey]
+ dict unset row $odbcKey
+ }
+ }
+ # Horrible kludge: If the driver doesn't report FK_NAME,
+ # make one up.
+ if {![dict exists $row foreignConstraintName]} {
+ if {![dict exists $row ordinalPosition]
+ || [dict get $row ordinalPosition] == 1} {
+ set fkname ?[dict get $row foreignTable]?[incr fkseq]
+ }
+ dict set row foreignConstraintName $fkname
+ }
+ lappend retval $row
+ }
+ set retval
+ } result options]
+ catch {rename $stmt {}}
+ return -level 0 -options $options $result
+ }
+
+ # The 'evaldirect' evaluates driver-native SQL code without preparing it,
+ # and returns a list of dicts (similar to '$connection allrows -as dicts').
+
+ method evaldirect {sqlStatement} {
+ set stmt [::tdbc::odbc::evaldirectStatement create \
+ Stmt::[incr statementSeq] [self] $sqlStatement]
+ set status [catch {
+ $stmt allrows -as dicts
+ } result options]
+ catch {rename $stmt {}}
+ return -level 0 -options $options $result
+ }
+
+ # The 'prepareCall' method gives a portable interface to prepare
+ # calls to stored procedures. It delegates to 'prepare' to do the
+ # actual work.
+
+ method preparecall {call} {
+
+ regexp {^[[:space:]]*(?:([A-Za-z_][A-Za-z_0-9]*)[[:space:]]*=)?(.*)} \
+ $call -> varName rest
+ if {$varName eq {}} {
+ my prepare \\{CALL $rest\\}
+ } else {
+ my prepare \\{:$varName=CALL $rest\\}
+ }
+
+ if 0 {
+ # Kevin thinks this is going to be
+
+ if {![regexp -expanded {
+ ^\s* # leading whitespace
+ (?::([[:alpha:]_][[:alnum:]_]*)\s*=\s*) # possible variable name
+ (?:(?:([[:alpha:]_][[:alnum:]_]*)\s*[.]\s*)? # catalog
+ ([[:alpha:]_][[:alnum:]_]*)\s*[.]\s*)? # schema
+ ([[:alpha:]_][[:alnum:]_]*)\s* # procedure
+ (.*)$ # argument list
+ } $call -> varName catalog schema procedure arglist]} {
+ return -code error \
+ -errorCode [list TDBC \
+ SYNTAX_ERROR_OR_ACCESS_RULE_VIOLATION \
+ 42000 ODBC -1] \
+ "Syntax error in stored procedure call"
+ } else {
+ my PrepareCall $varName $catalog $schema $procedure $arglist
+ }
+
+ # at least if making all parameters 'inout' doesn't work.
+
+ }
+
+ }
+
+ # The 'typemap' method returns the type map
+
+ method typemap {} {
+ if {![info exists typemap]} {
+ set typemap $::tdbc::odbc::sqltypes
+ set typesStmt [tdbc::odbc::typesStatement new [self]]
+ $typesStmt foreach row {
+ set typeNum [dict get $row DATA_TYPE]
+ if {![dict exists $typemap $typeNum]} {
+ dict set typemap $typeNum [string tolower \
+ [dict get $row TYPE_NAME]]
+ }
+ switch -exact -- $typeNum {
+ -9 {
+ [self] HasWvarchar 1
+ }
+ -5 {
+ [self] HasBigint 1
+ }
+ }
+ }
+ rename $typesStmt {}
+ }
+ return $typemap
+ }
+
+ # The 'begintransaction', 'commit' and 'rollback' methods are
+ # implemented in C.
+
+}
+
+#-------------------------------------------------------------------------------
+#
+# tdbc::odbc::statement --
+#
+# The class 'tdbc::odbc::statement' models one statement against a
+# database accessed through an ODBC connection
+#
+#-------------------------------------------------------------------------------
+
+::oo::class create ::tdbc::odbc::statement {
+
+ superclass ::tdbc::statement
+
+ # The constructor is implemented in C. It accepts the handle to
+ # the connection and the SQL code for the statement to prepare.
+ # It creates a subordinate namespace to hold the statement's
+ # active result sets, and then delegates to the 'init' method,
+ # written in C, to do the actual work of preparing the statement.
+
+ # The 'resultSetCreate' method forwards to the result set constructor
+
+ forward resultSetCreate ::tdbc::odbc::resultset create
+
+ # The 'params' method describes the parameters to the statement
+
+ method params {} {
+ set typemap [[my connection] typemap]
+ set result {}
+ foreach {name flags typeNum precision scale nullable} [my ParamList] {
+ set lst [dict create \
+ name $name \
+ direction [lindex {unknown in out inout} \
+ [expr {($flags & 0x06) >> 1}]] \
+ type [dict get $typemap $typeNum] \
+ precision $precision \
+ scale $scale]
+ if {$nullable in {0 1}} {
+ dict set list nullable $nullable
+ }
+ dict set result $name $lst
+ }
+ return $result
+ }
+
+ # Methods implemented in C:
+ # init statement ?dictionary?
+ # Does the heavy lifting for the constructor
+ # connection
+ # Returns the connection handle to which this statement belongs
+ # paramtype paramname ?direction? type ?precision ?scale??
+ # Declares the type of a parameter in the statement
+
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::odbc::tablesStatement --
+#
+# The class 'tdbc::odbc::tablesStatement' represents the special
+# statement that queries the tables in a database through an ODBC
+# connection.
+#
+#------------------------------------------------------------------------------
+
+oo::class create ::tdbc::odbc::tablesStatement {
+
+ superclass ::tdbc::statement
+
+ # The constructor is written in C. It accepts the handle to the
+ # connection and a pattern to match table names. It works in all
+ # ways like the constructor of the 'statement' class except that
+ # its 'init' method sets up to enumerate tables and not run a SQL
+ # query.
+
+ # The 'resultSetCreate' method forwards to the result set constructor
+
+ forward resultSetCreate ::tdbc::odbc::resultset create
+
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::odbc::columnsStatement --
+#
+# The class 'tdbc::odbc::tablesStatement' represents the special
+# statement that queries the columns of a table or view
+# in a database through an ODBC connection.
+#
+#------------------------------------------------------------------------------
+
+oo::class create ::tdbc::odbc::columnsStatement {
+
+ superclass ::tdbc::statement
+
+ # The constructor is written in C. It accepts the handle to the
+ # connection, a table name, and a pattern to match column
+ # names. It works in all ways like the constructor of the
+ # 'statement' class except that its 'init' method sets up to
+ # enumerate tables and not run a SQL query.
+
+ # The 'resultSetCreate' class forwards to the constructor of the
+ # result set
+
+ forward resultSetCreate ::tdbc::odbc::resultset create
+
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::odbc::primarykeysStatement --
+#
+# The class 'tdbc::odbc::primarykeysStatement' represents the special
+# statement that queries the primary keys on a table through an ODBC
+# connection.
+#
+#------------------------------------------------------------------------------
+
+oo::class create ::tdbc::odbc::primarykeysStatement {
+
+ superclass ::tdbc::statement
+
+ # The constructor is written in C. It accepts the handle to the
+ # connection and a table name. It works in all
+ # ways like the constructor of the 'statement' class except that
+ # its 'init' method sets up to enumerate primary keys and not run a SQL
+ # query.
+
+ # The 'resultSetCreate' method forwards to the result set constructor
+
+ forward resultSetCreate ::tdbc::odbc::resultset create
+
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::odbc::foreignkeysStatement --
+#
+# The class 'tdbc::odbc::foreignkeysStatement' represents the special
+# statement that queries the foreign keys on a table through an ODBC
+# connection.
+#
+#------------------------------------------------------------------------------
+
+oo::class create ::tdbc::odbc::foreignkeysStatement {
+
+ superclass ::tdbc::statement
+
+ # The constructor is written in C. It accepts the handle to the
+ # connection and the -primary and -foreign options. It works in all
+ # ways like the constructor of the 'statement' class except that
+ # its 'init' method sets up to enumerate foreign keys and not run a SQL
+ # query.
+
+ # The 'resultSetCreate' method forwards to the result set constructor
+
+ forward resultSetCreate ::tdbc::odbc::resultset create
+
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::odbc::evaldirectStatement --
+#
+# The class 'tdbc::odbc::evaldirectStatement' provides a mechanism to
+# execute driver-name SQL code through an ODBC connection. The SQL code
+# is not prepared and no tokenization or variable substitution is done.
+#
+#------------------------------------------------------------------------------
+
+oo::class create ::tdbc::odbc::evaldirectStatement {
+
+ superclass ::tdbc::statement
+
+ # The constructor is written in C. It accepts the handle to the
+ # connection and a SQL statement. It works in all
+ # ways like the constructor of the 'statement' class except that
+ # its 'init' method does not tokenize or prepare the SQL statement, and
+ # sets up to run the SQL query without performing variable substitution.
+
+ # The 'resultSetCreate' method forwards to the result set constructor
+
+ forward resultSetCreate ::tdbc::odbc::resultset create
+
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::odbc::typesStatement --
+#
+# The class 'tdbc::odbc::typesStatement' represents the special
+# statement that queries the types available in a database through
+# an ODBC connection.
+#
+#------------------------------------------------------------------------------
+
+
+oo::class create ::tdbc::odbc::typesStatement {
+
+ superclass ::tdbc::statement
+
+ # The constructor is written in C. It accepts the handle to the
+ # connection, and (optionally) a data type number. It works in all
+ # ways like the constructor of the 'statement' class except that
+ # its 'init' method sets up to enumerate types and not run a SQL
+ # query.
+
+ # The 'resultSetCreate' method forwards to the constructor of result sets
+
+ forward resultSetCreate ::tdbc::odbc::resultset create
+
+ # The C code contains a variant implementation of the 'init' method.
+
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::odbc::resultset --
+#
+# The class 'tdbc::odbc::resultset' models the result set that is
+# produced by executing a statement against an ODBC database.
+#
+#------------------------------------------------------------------------------
+
+::oo::class create ::tdbc::odbc::resultset {
+
+ superclass ::tdbc::resultset
+
+ # Methods implemented in C include:
+
+ # constructor statement ?dictionary?
+ # -- Executes the statement against the database, optionally providing
+ # a dictionary of substituted parameters (default is to get params
+ # from variables in the caller's scope).
+ # columns
+ # -- Returns a list of the names of the columns in the result.
+ # nextdict
+ # -- Stores the next row of the result set in the given variable in
+ # the caller's scope as a dictionary whose keys are
+ # column names and whose values are column values.
+ # nextlist
+ # -- Stores the next row of the result set in the given variable in
+ # the caller's scope as a list of cells.
+ # rowcount
+ # -- Returns a count of rows affected by the statement, or -1
+ # if the count of rows has not been determined.
+
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.5/tdbcodbc.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.5/tdbcodbc115.dll
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.5/tdbcodbc115.dll
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.5/tdbcodbc115.dll 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.5/tdbcodbc115.dll 2024-02-15 21:05:12 UTC (rev 69897)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.5/tdbcodbc115.dll
___________________________________________________________________
Added: svn:mime-type
## -0,0 +1 ##
+application/vnd.microsoft.portable-executable
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.5/pkgIndex.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.5/pkgIndex.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.5/pkgIndex.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -0,0 +1,14 @@
+# Index file to load the TDBC Postgres package.
+
+if {![package vsatisfies [package provide Tcl] 8.6-]} {
+ return
+}
+if {[package vsatisfies [package provide Tcl] 9.0-]} {
+ package ifneeded tdbc::postgres 1.1.5 \
+ "[list source [file join $dir tdbcpostgres.tcl]]\;\
+ [list load [file join $dir tcl9tdbcpostgres115.dll] [string totitle tdbcpostgres]]"
+} else {
+ package ifneeded tdbc::postgres 1.1.5 \
+ "[list source [file join $dir tdbcpostgres.tcl]]\;\
+ [list load [file join $dir tdbcpostgres115.dll] [string totitle tdbcpostgres]]"
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.5/pkgIndex.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.5/tdbcpostgres.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.5/tdbcpostgres.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.5/tdbcpostgres.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -0,0 +1,135 @@
+# tdbcpostgres.tcl --
+#
+# Class definitions and Tcl-level methods for the tdbc::postgres bridge.
+#
+# Copyright (c) 2009 by Slawomir Cygan
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#------------------------------------------------------------------------------
+
+package require tdbc
+
+::namespace eval ::tdbc::mypostgres {
+
+ namespace export connection datasources drivers
+
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::postgres::connection --
+#
+# Class representing a connection to a Postgres database.
+#
+#-------------------------------------------------------------------------------
+
+::oo::class create ::tdbc::postgres::connection {
+
+ superclass ::tdbc::connection
+
+ # The constructor is written in C. It takes alternating keywords
+ # and values pairs as its arguments. (See the manual page for the
+ # available options.)
+
+ # The 'statementCreate' method delegates to the constructor of the
+ # statement class
+
+ forward statementCreate ::tdbc::postgres::statement create
+
+
+ # The 'prepareCall' method gives a portable interface to prepare
+ # calls to stored procedures. It delegates to 'prepare' to do the
+ # actual work.
+
+ method preparecall {call} {
+ regexp {^[[:space:]]*(?:([A-Za-z_][A-Za-z_0-9]*)[[:space:]]*=)?(.*)} \
+ $call -> varName rest
+ if {$varName eq {}} {
+ my prepare \\{$rest\\}
+ } else {
+ my prepare \\{:$varName=$rest\\}
+ }
+ }
+
+ # The 'init', 'begintransaction', 'commit, 'rollback', 'tables'
+ # and 'columns' methods are implemented in C.
+
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::postgres::statement --
+#
+# The class 'tdbc::postgres::statement' models one statement against a
+# database accessed through a Postgres connection
+#
+#------------------------------------------------------------------------------
+
+::oo::class create ::tdbc::postgres::statement {
+
+ superclass ::tdbc::statement
+
+ # The 'resultSetCreate' method forwards to the constructor of the
+ # result set.
+
+ forward resultSetCreate ::tdbc::postgres::resultset create
+
+ # Methods implemented in C:
+ #
+ # constructor connection SQLCode
+ # The constructor accepts the handle to the connection and the SQL code
+ # for the statement to prepare. It creates a subordinate namespace to
+ # hold the statement's active result sets, and then delegates to the
+ # 'init' method, written in C, to do the actual work of preparing the
+ # statement.
+ # params
+ # Returns descriptions of the parameters of a statement.
+ # paramtype paramname ?direction? type ?precision ?scale??
+ # Declares the type of a parameter in the statement
+
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::postgres::resultset --
+#
+# The class 'tdbc::postgres::resultset' models the result set that is
+# produced by executing a statement against a Postgres database.
+#
+#------------------------------------------------------------------------------
+
+::oo::class create ::tdbc::postgres::resultset {
+
+ superclass ::tdbc::resultset
+
+ # The 'nextresults' method is stubbed out; tdbcpostgres does not
+ # allow a single call to return multiple results.
+
+ method nextresults {} {
+ while {[my nextdict rubbish]} {}
+ return 0
+ }
+
+ # Methods implemented in C include:
+
+ # constructor statement ?dictionary?
+ # -- Executes the statement against the database, optionally providing
+ # a dictionary of substituted parameters (default is to get params
+ # from variables in the caller's scope).
+ # columns
+ # -- Returns a list of the names of the columns in the result.
+ # nextdict
+ # -- Stores the next row of the result set in the given variable in
+ # the caller's scope as a dictionary whose keys are
+ # column names and whose values are column values, or else
+ # as a list of cells.
+ # nextlist
+ # -- Stores the next row of the result set in the given variable in
+ # the caller's scope as a list of cells.
+ # rowcount
+ # -- Returns a count of rows affected by the statement, or -1
+ # if the count of rows has not been determined.
+
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.5/tdbcpostgres.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.5/tdbcpostgres115.dll
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.5/tdbcpostgres115.dll
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.5/tdbcpostgres115.dll 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.5/tdbcpostgres115.dll 2024-02-15 21:05:12 UTC (rev 69897)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.5/tdbcpostgres115.dll
___________________________________________________________________
Added: svn:mime-type
## -0,0 +1 ##
+application/vnd.microsoft.portable-executable
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/thread2.8.8/pkgIndex.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/thread2.8.8/pkgIndex.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/thread2.8.8/pkgIndex.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -0,0 +1,68 @@
+# -*- tcl -*-
+# Tcl package index file, version 1.1
+#
+
+if {![package vsatisfies [package provide Tcl] 8.4]} {
+ # Pre-8.4 Tcl interps we dont support at all. Bye!
+ # 9.0+ Tcl interps are only supported on 32-bit platforms.
+ if {![package vsatisfies [package provide Tcl] 9.0]
+ || ($::tcl_platform(pointerSize) != 4)} {
+ return
+ }
+}
+
+# All Tcl 8.4+ interps can [load] Thread 2.8.8
+#
+# For interps that are not thread-enabled, we still call [package ifneeded].
+# This is contrary to the usual convention, but is a good idea because we
+# cannot imagine any other version of Thread that might succeed in a
+# thread-disabled interp. There's nothing to gain by yielding to other
+# competing callers of [package ifneeded Thread]. On the other hand,
+# deferring the error has the advantage that a script calling
+# [package require Thread] in a thread-disabled interp gets an error message
+# about a thread-disabled interp, instead of the message
+# "can't find package Thread".
+
+package ifneeded Thread 2.8.8 [list load [file join $dir thread288.dll] [string totitle thread]]
+
+# package Ttrace uses some support machinery.
+
+# In Tcl 8.4 interps we use some older interfaces
+if {![package vsatisfies [package provide Tcl] 8.5]} {
+ package ifneeded Ttrace 2.8.8 "
+ [list proc thread_source {dir} {
+ if {[info exists ::env(TCL_THREAD_LIBRARY)] &&
+ [file readable $::env(TCL_THREAD_LIBRARY)/ttrace.tcl]} {
+ source $::env(TCL_THREAD_LIBRARY)/ttrace.tcl
+ } elseif {[file readable [file join $dir .. lib ttrace.tcl]]} {
+ source [file join $dir .. lib ttrace.tcl]
+ } elseif {[file readable [file join $dir ttrace.tcl]]} {
+ source [file join $dir ttrace.tcl]
+ }
+ if {[namespace which ::ttrace::update] ne ""} {
+ ::ttrace::update
+ }
+ }]
+ [list thread_source $dir]
+ [list rename thread_source {}]"
+ return
+}
+
+# In Tcl 8.5+ interps; use [::apply]
+
+package ifneeded Ttrace 2.8.8 [list ::apply {{dir} {
+ if {[info exists ::env(TCL_THREAD_LIBRARY)] &&
+ [file readable $::env(TCL_THREAD_LIBRARY)/ttrace.tcl]} {
+ source $::env(TCL_THREAD_LIBRARY)/ttrace.tcl
+ } elseif {[file readable [file join $dir .. lib ttrace.tcl]]} {
+ source [file join $dir .. lib ttrace.tcl]
+ } elseif {[file readable [file join $dir ttrace.tcl]]} {
+ source [file join $dir ttrace.tcl]
+ }
+ if {[namespace which ::ttrace::update] ne ""} {
+ ::ttrace::update
+ }
+}} $dir]
+
+
+
Property changes on: trunk/Master/tlpkg/tltcl/lib/thread2.8.8/pkgIndex.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/thread2.8.8/thread288.dll
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/thread2.8.8/thread288.dll
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/thread2.8.8/thread288.dll 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/thread2.8.8/thread288.dll 2024-02-15 21:05:12 UTC (rev 69897)
Property changes on: trunk/Master/tlpkg/tltcl/lib/thread2.8.8/thread288.dll
___________________________________________________________________
Added: svn:mime-type
## -0,0 +1 ##
+application/vnd.microsoft.portable-executable
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/thread2.8.8/ttrace.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/thread2.8.8/ttrace.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/thread2.8.8/ttrace.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -0,0 +1,942 @@
+#
+# ttrace.tcl --
+#
+# Copyright (C) 2003 Zoran Vasiljevic, Archiware GmbH. All Rights Reserved.
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# ----------------------------------------------------------------------------
+#
+# User level commands:
+#
+# ttrace::eval top-level wrapper (ttrace-savvy eval)
+# ttrace::enable activates registered Tcl command traces
+# ttrace::disable terminates tracing of Tcl commands
+# ttrace::isenabled returns true if ttrace is enabled
+# ttrace::cleanup bring the interp to a pristine state
+# ttrace::update update interp to the latest trace epoch
+# ttrace::config setup some configuration options
+# ttrace::getscript returns a script for initializing interps
+#
+# Commands used for/from trace callbacks:
+#
+# ttrace::atenable register callback to be done at trace enable
+# ttrace::atdisable register callback to be done at trace disable
+# ttrace::addtrace register user-defined tracer callback
+# ttrace::addscript register user-defined script generator
+# ttrace::addresolver register user-defined command resolver
+# ttrace::addcleanup register user-defined cleanup procedures
+# ttrace::addentry adds one entry into the named trace store
+# ttrace::getentry returns the entry value from the named store
+# ttrace::delentry removes the entry from the named store
+# ttrace::getentries returns all entries from the named store
+# ttrace::preload register procedures to be preloaded always
+#
+#
+# Limitations:
+#
+# o. [namespace forget] is still not implemented
+# o. [namespace origin cmd] breaks if cmd is not already defined
+#
+# I left this deliberately. I didn't want to override the [namespace]
+# command in order to avoid potential slowdown.
+#
+
+namespace eval ttrace {
+
+ # Setup some compatibility wrappers
+ if {[info commands nsv_set] != ""} {
+ variable tvers 0
+ variable mutex ns_mutex
+ variable elock [$mutex create traceepochmutex]
+ # Import the underlying API; faster than recomputing
+ interp alias {} [namespace current]::_array {} nsv_array
+ interp alias {} [namespace current]::_incr {} nsv_incr
+ interp alias {} [namespace current]::_lappend {} nsv_lappend
+ interp alias {} [namespace current]::_names {} nsv_names
+ interp alias {} [namespace current]::_set {} nsv_set
+ interp alias {} [namespace current]::_unset {} nsv_unset
+ } elseif {![catch {
+ variable tvers [package require Thread]
+ }]} {
+ variable mutex thread::mutex
+ variable elock [$mutex create]
+ # Import the underlying API; faster than recomputing
+ interp alias {} [namespace current]::_array {} tsv::array
+ interp alias {} [namespace current]::_incr {} tsv::incr
+ interp alias {} [namespace current]::_lappend {} tsv::lappend
+ interp alias {} [namespace current]::_names {} tsv::names
+ interp alias {} [namespace current]::_set {} tsv::set
+ interp alias {} [namespace current]::_unset {} tsv::unset
+ } else {
+ error "requires NaviServer/AOLserver or Tcl threading extension"
+ }
+
+ # Keep in sync with the Thread package
+ package provide Ttrace 2.8.8
+
+ # Package variables
+ variable resolvers "" ; # List of registered resolvers
+ variable tracers "" ; # List of registered cmd tracers
+ variable scripts "" ; # List of registered script makers
+ variable enables "" ; # List of trace-enable callbacks
+ variable disables "" ; # List of trace-disable callbacks
+ variable preloads "" ; # List of procedure names to preload
+ variable enabled 0 ; # True if trace is enabled
+ variable config ; # Array with config options
+
+ variable epoch -1 ; # The initialization epoch
+ variable cleancnt 0 ; # Counter of registered cleaners
+
+ # Package private namespaces
+ namespace eval resolve "" ; # Commands for resolving commands
+ namespace eval trace "" ; # Commands registered for tracing
+ namespace eval enable "" ; # Commands invoked at trace enable
+ namespace eval disable "" ; # Commands invoked at trace disable
+ namespace eval script "" ; # Commands for generating scripts
+
+ # Exported commands
+ namespace export unknown
+
+ # Initialize ttrace shared state
+ if {[_array exists ttrace] == 0} {
+ _set ttrace lastepoch $epoch
+ _set ttrace epochlist ""
+ }
+
+ # Initially, allow creation of epochs
+ set config(-doepochs) 1
+
+ proc eval {cmd args} {
+ enable
+ set code [catch {uplevel 1 [concat $cmd $args]} result]
+ disable
+ if {$code == 0} {
+ if {[llength [info commands ns_ictl]]} {
+ ns_ictl save [getscript]
+ } else {
+ thread::broadcast {
+ package require Ttrace
+ ttrace::update
+ }
+ }
+ }
+ return -code $code \
+ -errorinfo $::errorInfo -errorcode $::errorCode $result
+ }
+
+ proc config {args} {
+ variable config
+ if {[llength $args] == 0} {
+ array get config
+ } elseif {[llength $args] == 1} {
+ set opt [lindex $args 0]
+ set config($opt)
+ } else {
+ set opt [lindex $args 0]
+ set val [lindex $args 1]
+ set config($opt) $val
+ }
+ }
+
+ proc enable {} {
+ variable config
+ variable tracers
+ variable enables
+ variable enabled
+ incr enabled 1
+ if {$enabled > 1} {
+ return
+ }
+ if {$config(-doepochs) != 0} {
+ variable epoch [_newepoch]
+ }
+ set nsp [namespace current]
+ foreach enabler $enables {
+ enable::_$enabler
+ }
+ foreach trace $tracers {
+ if {[info commands $trace] != ""} {
+ trace add execution $trace leave ${nsp}::trace::_$trace
+ }
+ }
+ }
+
+ proc disable {} {
+ variable enabled
+ variable tracers
+ variable disables
+ incr enabled -1
+ if {$enabled > 0} {
+ return
+ }
+ set nsp [namespace current]
+ foreach disabler $disables {
+ disable::_$disabler
+ }
+ foreach trace $tracers {
+ if {[info commands $trace] != ""} {
+ trace remove execution $trace leave ${nsp}::trace::_$trace
+ }
+ }
+ }
+
+ proc isenabled {} {
+ variable enabled
+ expr {$enabled > 0}
+ }
+
+ proc update {{from -1}} {
+ if {$from == -1} {
+ variable epoch [_set ttrace lastepoch]
+ } else {
+ if {[lsearch [_set ttrace epochlist] $from] == -1} {
+ error "no such epoch: $from"
+ }
+ variable epoch $from
+ }
+ uplevel 1 [getscript]
+ }
+
+ proc getscript {} {
+ variable preloads
+ variable epoch
+ variable scripts
+ append script [_serializensp] \n
+ append script "::namespace eval [namespace current] {" \n
+ append script "::namespace export unknown" \n
+ append script "_useepoch $epoch" \n
+ append script "}" \n
+ foreach cmd $preloads {
+ append script [_serializeproc $cmd] \n
+ }
+ foreach maker $scripts {
+ append script [script::_$maker]
+ }
+ return $script
+ }
+
+ proc cleanup {args} {
+ foreach cmd [info commands resolve::cleaner_*] {
+ uplevel 1 $cmd $args
+ }
+ }
+
+ proc preload {cmd} {
+ variable preloads
+ if {[lsearch $preloads $cmd] == -1} {
+ lappend preloads $cmd
+ }
+ }
+
+ proc atenable {cmd arglist body} {
+ variable enables
+ if {[lsearch $enables $cmd] == -1} {
+ lappend enables $cmd
+ set cmd [namespace current]::enable::_$cmd
+ proc $cmd $arglist $body
+ return $cmd
+ }
+ }
+
+ proc atdisable {cmd arglist body} {
+ variable disables
+ if {[lsearch $disables $cmd] == -1} {
+ lappend disables $cmd
+ set cmd [namespace current]::disable::_$cmd
+ proc $cmd $arglist $body
+ return $cmd
+ }
+ }
+
+ proc addtrace {cmd arglist body} {
+ variable tracers
+ if {[lsearch $tracers $cmd] == -1} {
+ lappend tracers $cmd
+ set tracer [namespace current]::trace::_$cmd
+ proc $tracer $arglist $body
+ if {[isenabled]} {
+ trace add execution $cmd leave $tracer
+ }
+ return $tracer
+ }
+ }
+
+ proc addscript {cmd body} {
+ variable scripts
+ if {[lsearch $scripts $cmd] == -1} {
+ lappend scripts $cmd
+ set cmd [namespace current]::script::_$cmd
+ proc $cmd args $body
+ return $cmd
+ }
+ }
+
+ proc addresolver {cmd arglist body} {
+ variable resolvers
+ if {[lsearch $resolvers $cmd] == -1} {
+ lappend resolvers $cmd
+ set cmd [namespace current]::resolve::$cmd
+ proc $cmd $arglist $body
+ return $cmd
+ }
+ }
+
+ proc addcleanup {body} {
+ variable cleancnt
+ set cmd [namespace current]::resolve::cleaner_[incr cleancnt]
+ proc $cmd args $body
+ return $cmd
+ }
+
+ proc addentry {cmd var val} {
+ variable epoch
+ _set ${epoch}-$cmd $var $val
+ }
+
+ proc delentry {cmd var} {
+ variable epoch
+ set ei $::errorInfo
+ set ec $::errorCode
+ catch {_unset ${epoch}-$cmd $var}
+ set ::errorInfo $ei
+ set ::errorCode $ec
+ }
+
+ proc getentry {cmd var} {
+ variable epoch
+ set ei $::errorInfo
+ set ec $::errorCode
+ if {[catch {_set ${epoch}-$cmd $var} val]} {
+ set ::errorInfo $ei
+ set ::errorCode $ec
+ set val ""
+ }
+ return $val
+ }
+
+ proc getentries {cmd {pattern *}} {
+ variable epoch
+ _array names ${epoch}-$cmd $pattern
+ }
+
+ proc unknown {args} {
+ set cmd [lindex $args 0]
+ if {[uplevel 1 ttrace::_resolve [list $cmd]]} {
+ set c [catch {uplevel 1 $cmd [lrange $args 1 end]} r]
+ } else {
+ set c [catch {uplevel 1 ::tcl::unknown $args} r]
+ }
+ return -code $c -errorcode $::errorCode -errorinfo $::errorInfo $r
+ }
+
+ proc _resolve {cmd} {
+ variable resolvers
+ foreach resolver $resolvers {
+ if {[uplevel 1 [info comm resolve::$resolver] [list $cmd]]} {
+ return 1
+ }
+ }
+ return 0
+ }
+
+ proc _getthread {} {
+ if {[info commands ns_thread] == ""} {
+ thread::id
+ } else {
+ ns_thread getid
+ }
+ }
+
+ proc _getthreads {} {
+ if {[info commands ns_thread] == ""} {
+ return [thread::names]
+ } else {
+ foreach entry [ns_info threads] {
+ lappend threads [lindex $entry 2]
+ }
+ return $threads
+ }
+ }
+
+ proc _newepoch {} {
+ variable elock
+ variable mutex
+ $mutex lock $elock
+ set old [_set ttrace lastepoch]
+ set new [_incr ttrace lastepoch]
+ _lappend ttrace $new [_getthread]
+ if {$old >= 0} {
+ _copyepoch $old $new
+ _delepochs
+ }
+ _lappend ttrace epochlist $new
+ $mutex unlock $elock
+ return $new
+ }
+
+ proc _copyepoch {old new} {
+ foreach var [_names $old-*] {
+ set cmd [lindex [split $var -] 1]
+ _array reset $new-$cmd [_array get $var]
+ }
+ }
+
+ proc _delepochs {} {
+ set tlist [_getthreads]
+ set elist ""
+ foreach epoch [_set ttrace epochlist] {
+ if {[_dropepoch $epoch $tlist] == 0} {
+ lappend elist $epoch
+ } else {
+ _unset ttrace $epoch
+ }
+ }
+ _set ttrace epochlist $elist
+ }
+
+ proc _dropepoch {epoch threads} {
+ set self [_getthread]
+ foreach tid [_set ttrace $epoch] {
+ if {$tid != $self && [lsearch $threads $tid] >= 0} {
+ lappend alive $tid
+ }
+ }
+ if {[info exists alive]} {
+ _set ttrace $epoch $alive
+ return 0
+ } else {
+ foreach var [_names $epoch-*] {
+ _unset $var
+ }
+ return 1
+ }
+ }
+
+ proc _useepoch {epoch} {
+ if {$epoch >= 0} {
+ set tid [_getthread]
+ if {[lsearch [_set ttrace $epoch] $tid] == -1} {
+ _lappend ttrace $epoch $tid
+ }
+ }
+ }
+
+ proc _serializeproc {cmd} {
+ set dargs [info args $cmd]
+ set pbody [info body $cmd]
+ set pargs ""
+ foreach arg $dargs {
+ if {![info default $cmd $arg def]} {
+ lappend pargs $arg
+ } else {
+ lappend pargs [list $arg $def]
+ }
+ }
+ set nsp [namespace qual $cmd]
+ if {$nsp == ""} {
+ set nsp "::"
+ }
+ append res [list ::namespace eval $nsp] " {" \n
+ append res [list ::proc [namespace tail $cmd] $pargs $pbody] \n
+ append res "}" \n
+ }
+
+ proc _serializensp {{nsp ""} {result _}} {
+ upvar $result res
+ if {$nsp == ""} {
+ set nsp [namespace current]
+ }
+ append res [list ::namespace eval $nsp] " {" \n
+ foreach var [info vars ${nsp}::*] {
+ set vname [namespace tail $var]
+ if {[array exists $var] == 0} {
+ append res [list ::variable $vname [set $var]] \n
+ } else {
+ append res [list ::variable $vname] \n
+ append res [list ::array set $vname [array get $var]] \n
+ }
+ }
+ foreach cmd [info procs ${nsp}::*] {
+ append res [_serializeproc $cmd] \n
+ }
+ append res "}" \n
+ foreach nn [namespace children $nsp] {
+ _serializensp $nn res
+ }
+ return $res
+ }
+}
+
+#
+# The code below is ment to be run once during the application start. It
+# provides implementation of tracing callbacks for some Tcl commands. Users
+# can supply their own tracer implementations on-the-fly.
+#
+# The code below will create traces for the following Tcl commands:
+# "namespace", "variable", "load", "proc" and "rename"
+#
+# Also, the Tcl object extension XOTcl 1.1.0 is handled and all XOTcl related
+# things, like classes and objects are traced (many thanks to Gustaf Neumann
+# from XOTcl for his kind help and support).
+#
+
+eval {
+
+ #
+ # Register the "load" trace. This will create the following key/value pair
+ # in the "load" store:
+ #
+ # --- key ---- --- value ---
+ # <path_of_loaded_image> <name_of_the_init_proc>
+ #
+ # We normally need only the name_of_the_init_proc for being able to load
+ # the package in other interpreters, but we store the path to the image
+ # file as well.
+ #
+
+ ttrace::addtrace load {cmdline code args} {
+ if {$code != 0} {
+ return
+ }
+ set image [lindex $cmdline 1]
+ set initp [lindex $cmdline 2]
+ if {$initp == ""} {
+ foreach pkg [info loaded] {
+ if {[lindex $pkg 0] == $image} {
+ set initp [lindex $pkg 1]
+ }
+ }
+ }
+ ttrace::addentry load $image $initp
+ }
+
+ ttrace::addscript load {
+ append res "\n"
+ foreach entry [ttrace::getentries load] {
+ set initp [ttrace::getentry load $entry]
+ append res "::load {} $initp" \n
+ }
+ return $res
+ }
+
+ #
+ # Register the "namespace" trace. This will create the following key/value
+ # entry in "namespace" store:
+ #
+ # --- key ---- --- value ---
+ # ::fully::qualified::namespace 1
+ #
+ # It will also fill the "proc" store for procedures and commands imported
+ # in this namespace with following:
+ #
+ # --- key ---- --- value ---
+ # ::fully::qualified::proc [list <ns> "" ""]
+ #
+ # The <ns> is the name of the namespace where the command or procedure is
+ # imported from.
+ #
+
+ ttrace::addtrace namespace {cmdline code args} {
+ if {$code != 0} {
+ return
+ }
+ set nop [lindex $cmdline 1]
+ set cns [uplevel 1 namespace current]
+ if {$cns == "::"} {
+ set cns ""
+ }
+ switch -glob $nop {
+ eva* {
+ set nsp [lindex $cmdline 2]
+ if {![string match "::*" $nsp]} {
+ set nsp ${cns}::$nsp
+ }
+ ttrace::addentry namespace $nsp 1
+ }
+ imp* {
+ # - parse import arguments (skip opt "-force")
+ set opts [lrange $cmdline 2 end]
+ if {[string match "-fo*" [lindex $opts 0]]} {
+ set opts [lrange $cmdline 3 end]
+ }
+ # - register all imported procs and commands
+ foreach opt $opts {
+ if {![string match "::*" [::namespace qual $opt]]} {
+ set opt ${cns}::$opt
+ }
+ # - first import procs
+ foreach entry [ttrace::getentries proc $opt] {
+ set cmd ${cns}::[::namespace tail $entry]
+ set nsp [::namespace qual $entry]
+ set done($cmd) 1
+ set entry [list 0 $nsp "" ""]
+ ttrace::addentry proc $cmd $entry
+ }
+
+ # - then import commands
+ foreach entry [info commands $opt] {
+ set cmd ${cns}::[::namespace tail $entry]
+ set nsp [::namespace qual $entry]
+ if {[info exists done($cmd)] == 0} {
+ set entry [list 0 $nsp "" ""]
+ ttrace::addentry proc $cmd $entry
+ }
+ }
+ }
+ }
+ }
+ }
+
+ ttrace::addscript namespace {
+ append res \n
+ foreach entry [ttrace::getentries namespace] {
+ append res "::namespace eval $entry {}" \n
+ }
+ return $res
+ }
+
+ #
+ # Register the "variable" trace. This will create the following key/value
+ # entry in the "variable" store:
+ #
+ # --- key ---- --- value ---
+ # ::fully::qualified::variable 1
+ #
+ # The variable value itself is ignored at the time of
+ # trace/collection. Instead, we take the real value at the time of script
+ # generation.
+ #
+
+ ttrace::addtrace variable {cmdline code args} {
+ if {$code != 0} {
+ return
+ }
+ set opts [lrange $cmdline 1 end]
+ if {[llength $opts]} {
+ set cns [uplevel 1 namespace current]
+ if {$cns == "::"} {
+ set cns ""
+ }
+ foreach {var val} $opts {
+ if {![string match "::*" $var]} {
+ set var ${cns}::$var
+ }
+ ttrace::addentry variable $var 1
+ }
+ }
+ }
+
+ ttrace::addscript variable {
+ append res \n
+ foreach entry [ttrace::getentries variable] {
+ set cns [namespace qual $entry]
+ set var [namespace tail $entry]
+ append res "::namespace eval $cns {" \n
+ append res "::variable $var"
+ if {[array exists $entry]} {
+ append res "\n::array set $var [list [array get $entry]]" \n
+ } elseif {[info exists $entry]} {
+ append res " [list [set $entry]]" \n
+ } else {
+ append res \n
+ }
+ append res "}" \n
+ }
+ return $res
+ }
+
+
+ #
+ # Register the "rename" trace. It will create the following key/value pair
+ # in "rename" store:
+ #
+ # --- key ---- --- value ---
+ # ::fully::qualified::old ::fully::qualified::new
+ #
+ # The "new" value may be empty, for commands that have been deleted. In
+ # such cases we also remove any traced procedure definitions.
+ #
+
+ ttrace::addtrace rename {cmdline code args} {
+ if {$code != 0} {
+ return
+ }
+ set cns [uplevel 1 namespace current]
+ if {$cns == "::"} {
+ set cns ""
+ }
+ set old [lindex $cmdline 1]
+ if {![string match "::*" $old]} {
+ set old ${cns}::$old
+ }
+ set new [lindex $cmdline 2]
+ if {$new != ""} {
+ if {![string match "::*" $new]} {
+ set new ${cns}::$new
+ }
+ ttrace::addentry rename $old $new
+ } else {
+ ttrace::delentry proc $old
+ }
+ }
+
+ ttrace::addscript rename {
+ append res \n
+ foreach old [ttrace::getentries rename] {
+ set new [ttrace::getentry rename $old]
+ append res "::rename $old {$new}" \n
+ }
+ return $res
+ }
+
+ #
+ # Register the "proc" trace. This will create the following key/value pair
+ # in the "proc" store:
+ #
+ # --- key ---- --- value ---
+ # ::fully::qualified::proc [list <epoch> <ns> <arglist> <body>]
+ #
+ # The <epoch> chages anytime one (re)defines a proc. The <ns> is the
+ # namespace where the command was imported from. If empty, the <arglist>
+ # and <body> will hold the actual procedure definition. See the
+ # "namespace" tracer implementation also.
+ #
+
+ ttrace::addtrace proc {cmdline code args} {
+ if {$code != 0} {
+ return
+ }
+ set cns [uplevel 1 namespace current]
+ if {$cns == "::"} {
+ set cns ""
+ }
+ set cmd [lindex $cmdline 1]
+ if {![string match "::*" $cmd]} {
+ set cmd ${cns}::$cmd
+ }
+ set dargs [info args $cmd]
+ set pbody [info body $cmd]
+ set pargs ""
+ foreach arg $dargs {
+ if {![info default $cmd $arg def]} {
+ lappend pargs $arg
+ } else {
+ lappend pargs [list $arg $def]
+ }
+ }
+ set pdef [ttrace::getentry proc $cmd]
+ if {$pdef == ""} {
+ set epoch -1 ; # never traced before
+ } else {
+ set epoch [lindex $pdef 0]
+ }
+ ttrace::addentry proc $cmd [list [incr epoch] "" $pargs $pbody]
+ }
+
+ ttrace::addscript proc {
+ return {
+ if {[info command ::tcl::unknown] == ""} {
+ rename ::unknown ::tcl::unknown
+ namespace import -force ::ttrace::unknown
+ }
+ if {[info command ::tcl::info] == ""} {
+ rename ::info ::tcl::info
+ }
+ proc ::info args {
+ set cmd [lindex $args 0]
+ set hit [lsearch -glob {commands procs args default body} $cmd*]
+ if {$hit > 1} {
+ if {[catch {uplevel 1 ::tcl::info $args}]} {
+ uplevel 1 ttrace::_resolve [list [lindex $args 1]]
+ }
+ return [uplevel 1 ::tcl::info $args]
+ }
+ if {$hit == -1} {
+ return [uplevel 1 ::tcl::info $args]
+ }
+ set cns [uplevel 1 namespace current]
+ if {$cns == "::"} {
+ set cns ""
+ }
+ set pat [lindex $args 1]
+ if {![string match "::*" $pat]} {
+ set pat ${cns}::$pat
+ }
+ set fns [ttrace::getentries proc $pat]
+ if {[string match $cmd* commands]} {
+ set fns [concat $fns [ttrace::getentries xotcl $pat]]
+ }
+ foreach entry $fns {
+ if {$cns != [namespace qual $entry]} {
+ set lazy($entry) 1
+ } else {
+ set lazy([namespace tail $entry]) 1
+ }
+ }
+ foreach entry [uplevel 1 ::tcl::info $args] {
+ set lazy($entry) 1
+ }
+ array names lazy
+ }
+ }
+ }
+
+ #
+ # Register procedure resolver. This will try to resolve the command in the
+ # current namespace first, and if not found, in global namespace. It also
+ # handles commands imported from other namespaces.
+ #
+
+ ttrace::addresolver resolveprocs {cmd {export 0}} {
+ set cns [uplevel 1 namespace current]
+ set name [namespace tail $cmd]
+ if {$cns == "::"} {
+ set cns ""
+ }
+ if {![string match "::*" $cmd]} {
+ set ncmd ${cns}::$cmd
+ set gcmd ::$cmd
+ } else {
+ set ncmd $cmd
+ set gcmd $cmd
+ }
+ set pdef [ttrace::getentry proc $ncmd]
+ if {$pdef == ""} {
+ set pdef [ttrace::getentry proc $gcmd]
+ if {$pdef == ""} {
+ return 0
+ }
+ set cmd $gcmd
+ } else {
+ set cmd $ncmd
+ }
+ set epoch [lindex $pdef 0]
+ set pnsp [lindex $pdef 1]
+ if {$pnsp != ""} {
+ set nsp [namespace qual $cmd]
+ if {$nsp == ""} {
+ set nsp ::
+ }
+ set cmd ${pnsp}::$name
+ if {[resolveprocs $cmd 1] == 0 && [info commands $cmd] == ""} {
+ return 0
+ }
+ namespace eval $nsp "namespace import -force $cmd"
+ } else {
+ uplevel 0 [list ::proc $cmd [lindex $pdef 2] [lindex $pdef 3]]
+ if {$export} {
+ set nsp [namespace qual $cmd]
+ if {$nsp == ""} {
+ set nsp ::
+ }
+ namespace eval $nsp "namespace export $name"
+ }
+ }
+ variable resolveproc
+ set resolveproc($cmd) $epoch
+ return 1
+ }
+
+ #
+ # For XOTcl, the entire item introspection/tracing is delegated to XOTcl
+ # itself. The xotcl store is filled with this:
+ #
+ # --- key ---- --- value ---
+ # ::fully::qualified::item <body>
+ #
+ # The <body> is the script used to generate the entire item (class,
+ # object). Note that we do not fill in this during code tracing. It is
+ # done during the script generation. In this step, only the placeholder is
+ # set.
+ #
+ # NOTE: we assume all XOTcl commands are imported in global namespace
+ #
+
+ ttrace::atenable XOTclEnabler {args} {
+ if {[info commands ::xotcl::Class] == ""} {
+ return
+ }
+ if {[info commands ::xotcl::_creator] == ""} {
+ ::xotcl::Class create ::xotcl::_creator -instproc create {args} {
+ set result [next]
+ if {![string match ::xotcl::_* $result]} {
+ ttrace::addentry xotcl $result ""
+ }
+ return $result
+ }
+ }
+ ::xotcl::Class instmixin ::xotcl::_creator
+ }
+
+ ttrace::atdisable XOTclDisabler {args} {
+ if { [info commands ::xotcl::Class] == ""
+ || [info commands ::xotcl::_creator] == ""} {
+ return
+ }
+ ::xotcl::Class instmixin ""
+ ::xotcl::_creator destroy
+ }
+
+ set resolver [ttrace::addresolver resolveclasses {classname} {
+ set cns [uplevel 1 namespace current]
+ set script [ttrace::getentry xotcl $classname]
+ if {$script == ""} {
+ set name [namespace tail $classname]
+ if {$cns == "::"} {
+ set script [ttrace::getentry xotcl ::$name]
+ } else {
+ set script [ttrace::getentry xotcl ${cns}::$name]
+ if {$script == ""} {
+ set script [ttrace::getentry xotcl ::$name]
+ }
+ }
+ if {$script == ""} {
+ return 0
+ }
+ }
+ uplevel 1 [list namespace eval $cns $script]
+ return 1
+ }]
+
+ ttrace::addscript xotcl [subst -nocommands {
+ if {![catch {Serializer new} ss]} {
+ foreach entry [ttrace::getentries xotcl] {
+ if {[ttrace::getentry xotcl \$entry] == ""} {
+ ttrace::addentry xotcl \$entry [\$ss serialize \$entry]
+ }
+ }
+ \$ss destroy
+ return {::xotcl::Class proc __unknown name {$resolver \$name}}
+ }
+ }]
+
+ #
+ # Register callback to be called on cleanup. This will trash lazily loaded
+ # procs which have changed since.
+ #
+
+ ttrace::addcleanup {
+ variable resolveproc
+ foreach cmd [array names resolveproc] {
+ set def [ttrace::getentry proc $cmd]
+ if {$def != ""} {
+ set new [lindex $def 0]
+ set old $resolveproc($cmd)
+ if {[info command $cmd] != "" && $new != $old} {
+ catch {rename $cmd ""}
+ }
+ }
+ }
+ }
+}
+
+# EOF
+return
+
+# Local Variables:
+# mode: tcl
+# fill-column: 78
+# tab-width: 8
+# indent-tabs-mode: nil
+# End:
Property changes on: trunk/Master/tlpkg/tltcl/lib/thread2.8.8/ttrace.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/clrpick.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/clrpick.tcl 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/clrpick.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -316,7 +316,7 @@
# Accelerator bindings
bind $lab <<AltUnderlined>> [list focus $ent]
- bind $w <KeyPress-Escape> [list tk::ButtonInvoke $data(cancelBtn)]
+ bind $w <Escape> [list tk::ButtonInvoke $data(cancelBtn)]
bind $w <Alt-Key> [list tk::AltKeyInDialog $w %A]
wm protocol $w WM_DELETE_WINDOW [list tk::dialog::color::CancelCmd $w]
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/console.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/console.tcl 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/console.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -91,29 +91,29 @@
AmpMenuArgs .menubar.edit add separator
if {$::tk::console::useFontchooser} {
- if {[tk windowingsystem] eq "aqua"} {
- .menubar.edit add command -label tk_choose_font_marker
- set index [.menubar.edit index tk_choose_font_marker]
- .menubar.edit entryconfigure $index \
- -label [mc "Show Fonts"]\
- -accelerator "$mod-T"\
- -command [list ::tk::console::FontchooserToggle]
- bind Console <<TkFontchooserVisibility>> \
- [list ::tk::console::FontchooserVisibility $index]
+ if {[tk windowingsystem] eq "aqua"} {
+ .menubar.edit add command -label tk_choose_font_marker
+ set index [.menubar.edit index tk_choose_font_marker]
+ .menubar.edit entryconfigure $index \
+ -label [mc "Show Fonts"]\
+ -accelerator "$mod-T"\
+ -command [list ::tk::console::FontchooserToggle]
+ bind Console <<TkFontchooserVisibility>> \
+ [list ::tk::console::FontchooserVisibility $index]
::tk::console::FontchooserVisibility $index
- } else {
- AmpMenuArgs .menubar.edit add command -label [mc "&Font..."] \
- -command [list ::tk::console::FontchooserToggle]
- }
+ } else {
+ AmpMenuArgs .menubar.edit add command -label [mc "&Font..."] \
+ -command [list ::tk::console::FontchooserToggle]
+ }
bind Console <FocusIn> [list ::tk::console::FontchooserFocus %W 1]
bind Console <FocusOut> [list ::tk::console::FontchooserFocus %W 0]
}
AmpMenuArgs .menubar.edit add command -label [mc "&Increase Font Size"] \
- -accel "$mod++" -command {event generate .console <<Console_FontSizeIncr>>}
+ -accel "$mod++" -command {event generate .console <<Console_FontSizeIncr>>}
AmpMenuArgs .menubar.edit add command -label [mc "&Decrease Font Size"] \
- -accel "$mod+-" -command {event generate .console <<Console_FontSizeDecr>>}
+ -accel "$mod+-" -command {event generate .console <<Console_FontSizeDecr>>}
AmpMenuArgs .menubar.edit add command -label [mc "Fit To Screen Width"] \
- -command {event generate .console <<Console_FitScreenWidth>>}
+ -command {event generate .console <<Console_FitScreenWidth>>}
if {[tk windowingsystem] eq "aqua"} {
.menubar add cascade -label [mc Window] -menu [menu .menubar.window]
@@ -126,31 +126,31 @@
catch {font create TkConsoleFont {*}[font configure TkFixedFont]}
set families [font families]
switch -exact -- [tk windowingsystem] {
- aqua { set preferred {Monaco 10} }
- win32 { set preferred {ProFontWindows 8 Consolas 8} }
- default { set preferred {} }
+ aqua { set preferred {Monaco 10} }
+ win32 { set preferred {ProFontWindows 8 Consolas 8} }
+ default { set preferred {} }
}
foreach {family size} $preferred {
- if {$family in $families} {
- font configure TkConsoleFont -family $family -size $size
- break
- }
+ if {$family in $families} {
+ font configure TkConsoleFont -family $family -size $size
+ break
+ }
}
# Provide the right border for the text widget (platform dependent).
::ttk::style layout ConsoleFrame {
- Entry.field -sticky news -border 1 -children {
- ConsoleFrame.padding -sticky news
- }
+ Entry.field -sticky news -border 1 -children {
+ ConsoleFrame.padding -sticky news
+ }
}
::ttk::frame .consoleframe -style ConsoleFrame
set con [text .console -yscrollcommand [list .sb set] -setgrid true \
- -borderwidth 0 -highlightthickness 0 -font TkConsoleFont]
+ -borderwidth 0 -highlightthickness 0 -font TkConsoleFont]
if {[tk windowingsystem] eq "aqua"} {
- scrollbar .sb -command [list $con yview]
+ scrollbar .sb -command [list $con yview]
} else {
- ::ttk::scrollbar .sb -command [list $con yview]
+ ::ttk::scrollbar .sb -command [list $con yview]
}
pack .sb -in .consoleframe -fill both -side right -padx 1 -pady 1
pack $con -in .consoleframe -fill both -expand 1 -side left -padx 1 -pady 1
@@ -215,7 +215,7 @@
[list [mc "Tcl Scripts"] .tcl] \
[list [mc "All Files"] *]]]
if {$filename ne ""} {
- set cmd [list source $filename]
+ set cmd [list source $filename]
if {[catch {consoleinterp eval $cmd} result]} {
ConsoleOutput stderr "$result\n"
}
@@ -273,7 +273,7 @@
variable HistNum
switch $cmd {
- prev {
+ prev {
incr HistNum -1
if {$HistNum == 0} {
set cmd {history event [expr {[history nextid] -1}]}
@@ -280,15 +280,15 @@
} else {
set cmd "history event $HistNum"
}
- if {[catch {consoleinterp eval $cmd} cmd]} {
- incr HistNum
- return
- }
+ if {[catch {consoleinterp eval $cmd} cmd]} {
+ incr HistNum
+ return
+ }
.console delete promptEnd end
- .console insert promptEnd $cmd {input stdin}
+ .console insert promptEnd $cmd {input stdin}
.console see end
- }
- next {
+ }
+ next {
incr HistNum
if {$HistNum == 0} {
set cmd {history event [expr {[history nextid] -1}]}
@@ -304,10 +304,10 @@
.console delete promptEnd end
.console insert promptEnd $cmd {input stdin}
.console see end
- }
- reset {
- set HistNum 1
- }
+ }
+ reset {
+ set HistNum 1
+ }
}
}
@@ -324,19 +324,19 @@
if {$partial eq "normal"} {
set temp [$w index "end - 1 char"]
$w mark set output end
- if {[consoleinterp eval "info exists tcl_prompt1"]} {
- consoleinterp eval "eval \[set tcl_prompt1\]"
- } else {
- puts -nonewline [EvalAttached $::tk::console::defaultPrompt]
- }
+ if {[consoleinterp eval "info exists tcl_prompt1"]} {
+ consoleinterp eval "eval \[set tcl_prompt1\]"
+ } else {
+ puts -nonewline [EvalAttached $::tk::console::defaultPrompt]
+ }
} else {
set temp [$w index output]
$w mark set output end
- if {[consoleinterp eval "info exists tcl_prompt2"]} {
- consoleinterp eval "eval \[set tcl_prompt2\]"
- } else {
+ if {[consoleinterp eval "info exists tcl_prompt2"]} {
+ consoleinterp eval "eval \[set tcl_prompt2\]"
+ } else {
puts -nonewline "> "
- }
+ }
}
flush stdout
$w mark set output $temp
@@ -350,8 +350,8 @@
# Copy selected text from the console
proc ::tk::console::Copy {w} {
if {![catch {set data [$w get sel.first sel.last]}]} {
- clipboard clear -displayof $w
- clipboard append -displayof $w $data
+ clipboard clear -displayof $w
+ clipboard append -displayof $w $data
}
}
# Copies selected text. If the selection is within the current active edit
@@ -358,10 +358,10 @@
# region then it will be cut, if not it is only copied.
proc ::tk::console::Cut {w} {
if {![catch {set data [$w get sel.first sel.last]}]} {
- clipboard clear -displayof $w
- clipboard append -displayof $w $data
- if {[$w compare sel.first >= output]} {
- $w delete sel.first sel.last
+ clipboard clear -displayof $w
+ clipboard append -displayof $w $data
+ if {[$w compare sel.first >= output]} {
+ $w delete sel.first sel.last
}
}
}
@@ -368,15 +368,15 @@
# Paste text from the clipboard
proc ::tk::console::Paste {w} {
catch {
- set clip [::tk::GetSelection $w CLIPBOARD]
- set list [split $clip \n\r]
- tk::ConsoleInsert $w [lindex $list 0]
- foreach x [lrange $list 1 end] {
- $w mark set insert {end - 1c}
- tk::ConsoleInsert $w "\n"
- tk::ConsoleInvoke
- tk::ConsoleInsert $w $x
- }
+ set clip [::tk::GetSelection $w CLIPBOARD]
+ set list [split $clip \n\r]
+ tk::ConsoleInsert $w [lindex $list 0]
+ foreach x [lrange $list 1 end] {
+ $w mark set insert {end - 1c}
+ tk::ConsoleInsert $w "\n"
+ tk::ConsoleInvoke
+ tk::ConsoleInsert $w $x
+ }
}
}
@@ -388,14 +388,14 @@
set fit 0
array set fi [font configure TkConsoleFont]
while {$s < 0} {
- set fi(-size) $s
- set f [font create {*}[array get fi]]
- set c [font measure $f "eM"]
- font delete $f
- if {$c * $cwidth < 1.667 * $width} {
- font configure TkConsoleFont -size $s
- break
- }
+ set fi(-size) $s
+ set f [font create {*}[array get fi]]
+ set c [font measure $f "eM"]
+ font delete $f
+ if {$c * $cwidth < 1.667 * $width} {
+ font configure TkConsoleFont -size $s
+ break
+ }
incr s 2
}
}
@@ -416,13 +416,13 @@
bind Console $ev [bind Text $ev]
}
## We really didn't want the newline insertion...
- bind Console <Control-Key-o> {}
+ bind Console <Control-o> {}
## ...or any Control-v binding (would block <<Paste>>)
- bind Console <Control-Key-v> {}
+ bind Console <Control-v> {}
# For the moment, transpose isn't enabled until the console
# gets and overhaul of how it handles input -- hobbs
- bind Console <Control-Key-t> {}
+ bind Console <Control-t> {}
# Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
# Otherwise, if a widget binding for one of these is defined, the
@@ -429,33 +429,37 @@
# <Keypress> class binding will also fire and insert the character
# which is wrong.
- bind Console <Alt-KeyPress> {# nothing }
- bind Console <Meta-KeyPress> {# nothing}
- bind Console <Control-KeyPress> {# nothing}
+ bind Console <Alt-Key> {# nothing }
+ bind Console <Meta-Key> {# nothing}
+ bind Console <Control-Key> {# nothing}
+ if {[tk windowingsystem] eq "aqua"} {
+ bind Console <Command-Key> {# nothing}
+ bind Console <Mod4-Key> {# nothing}
+ }
foreach {ev key} {
- <<Console_NextImmediate>> <Control-Key-n>
- <<Console_PrevImmediate>> <Control-Key-p>
- <<Console_PrevSearch>> <Control-Key-r>
- <<Console_NextSearch>> <Control-Key-s>
+ <<Console_NextImmediate>> <Control-n>
+ <<Console_PrevImmediate>> <Control-p>
+ <<Console_PrevSearch>> <Control-r>
+ <<Console_NextSearch>> <Control-s>
- <<Console_Expand>> <Key-Tab>
- <<Console_Expand>> <Key-Escape>
- <<Console_ExpandFile>> <Control-Shift-Key-F>
- <<Console_ExpandProc>> <Control-Shift-Key-P>
- <<Console_ExpandVar>> <Control-Shift-Key-V>
- <<Console_Tab>> <Control-Key-i>
- <<Console_Tab>> <Meta-Key-i>
- <<Console_Eval>> <Key-Return>
- <<Console_Eval>> <Key-KP_Enter>
+ <<Console_Expand>> <Tab>
+ <<Console_Expand>> <Escape>
+ <<Console_ExpandFile>> <Control-Shift-F>
+ <<Console_ExpandProc>> <Control-Shift-P>
+ <<Console_ExpandVar>> <Control-Shift-V>
+ <<Console_Tab>> <Control-i>
+ <<Console_Tab>> <Meta-i>
+ <<Console_Eval>> <Return>
+ <<Console_Eval>> <KP_Enter>
- <<Console_Clear>> <Control-Key-l>
- <<Console_KillLine>> <Control-Key-k>
- <<Console_Transpose>> <Control-Key-t>
- <<Console_ClearLine>> <Control-Key-u>
- <<Console_SaveCommand>> <Control-Key-z>
- <<Console_FontSizeIncr>> <Control-Key-plus>
- <<Console_FontSizeDecr>> <Control-Key-minus>
+ <<Console_Clear>> <Control-l>
+ <<Console_KillLine>> <Control-k>
+ <<Console_Transpose>> <Control-t>
+ <<Console_ClearLine>> <Control-u>
+ <<Console_SaveCommand>> <Control-z>
+ <<Console_FontSizeIncr>> <Control-plus>
+ <<Console_FontSizeDecr>> <Control-minus>
} {
event add $ev $key
bind Console $key {}
@@ -462,14 +466,14 @@
}
if {[tk windowingsystem] eq "aqua"} {
foreach {ev key} {
- <<Console_FontSizeIncr>> <Command-Key-plus>
- <<Console_FontSizeDecr>> <Command-Key-minus>
+ <<Console_FontSizeIncr>> <Command-plus>
+ <<Console_FontSizeDecr>> <Command-minus>
} {
event add $ev $key
bind Console $key {}
}
if {$::tk::console::useFontchooser} {
- bind Console <Command-Key-t> [list ::tk::console::FontchooserToggle]
+ bind Console <Command-t> [list ::tk::console::FontchooserToggle]
}
}
bind Console <<Console_Expand>> {
@@ -587,7 +591,7 @@
bind Console <Insert> {
catch {tk::ConsoleInsert %W [::tk::GetSelection %W PRIMARY]}
}
- bind Console <KeyPress> {
+ bind Console <Key> {
tk::ConsoleInsert %W %A
}
bind Console <F9> {
@@ -604,20 +608,20 @@
bind Console <<Paste>> { ::tk::console::Paste %W }
bind Console <<Console_FontSizeIncr>> {
- set size [font configure TkConsoleFont -size]
- if {$size < 0} {set sign -1} else {set sign 1}
- set size [expr {(abs($size) + 1) * $sign}]
- font configure TkConsoleFont -size $size
+ set size [font configure TkConsoleFont -size]
+ if {$size < 0} {set sign -1} else {set sign 1}
+ set size [expr {(abs($size) + 1) * $sign}]
+ font configure TkConsoleFont -size $size
if {$::tk::console::useFontchooser} {
tk fontchooser configure -font TkConsoleFont
}
}
bind Console <<Console_FontSizeDecr>> {
- set size [font configure TkConsoleFont -size]
- if {abs($size) < 2} { return }
- if {$size < 0} {set sign -1} else {set sign 1}
- set size [expr {(abs($size) - 1) * $sign}]
- font configure TkConsoleFont -size $size
+ set size [font configure TkConsoleFont -size]
+ if {abs($size) < 2} { return }
+ if {$size < 0} {set sign -1} else {set sign 1}
+ set size [expr {(abs($size) - 1) * $sign}]
+ font configure TkConsoleFont -size $size
if {$::tk::console::useFontchooser} {
tk fontchooser configure -font TkConsoleFont
}
@@ -629,28 +633,28 @@
##
## Bindings for doing special things based on certain keys
##
- bind PostConsole <Key-parenright> {
+ bind PostConsole <parenright> {
if {"\\" ne [%W get insert-2c]} {
::tk::console::MatchPair %W \( \) promptEnd
}
}
- bind PostConsole <Key-bracketright> {
+ bind PostConsole <bracketright> {
if {"\\" ne [%W get insert-2c]} {
::tk::console::MatchPair %W \[ \] promptEnd
}
}
- bind PostConsole <Key-braceright> {
+ bind PostConsole <braceright> {
if {"\\" ne [%W get insert-2c]} {
::tk::console::MatchPair %W \{ \} promptEnd
}
}
- bind PostConsole <Key-quotedbl> {
+ bind PostConsole <quotedbl> {
if {"\\" ne [%W get insert-2c]} {
::tk::console::MatchQuote %W promptEnd
}
}
- bind PostConsole <KeyPress> {
+ bind PostConsole <Key> {
if {"%A" ne ""} {
::tk::console::TagProc %W
}
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/cscroll.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/cscroll.tcl 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/cscroll.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -25,7 +25,7 @@
pack $btns -side bottom -fill x
frame $w.grid
-scrollbar $w.hscroll -orient horiz -command "$c xview"
+scrollbar $w.hscroll -orient horizontal -command "$c xview"
scrollbar $w.vscroll -command "$c yview"
canvas $c -relief sunken -borderwidth 2 -scrollregion {-11c -11c 50c 20c} \
-xscrollcommand "$w.hscroll set" \
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/entry2.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/entry2.tcl 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/entry2.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -27,15 +27,15 @@
pack $w.frame -side top -fill x -expand 1
entry $w.frame.e1 -xscrollcommand "$w.frame.s1 set"
-ttk::scrollbar $w.frame.s1 -orient horiz -command \
+ttk::scrollbar $w.frame.s1 -orient horizontal -command \
"$w.frame.e1 xview"
frame $w.frame.spacer1 -width 20 -height 10
entry $w.frame.e2 -xscrollcommand "$w.frame.s2 set"
-ttk::scrollbar $w.frame.s2 -orient horiz -command \
+ttk::scrollbar $w.frame.s2 -orient horizontal -command \
"$w.frame.e2 xview"
frame $w.frame.spacer2 -width 20 -height 10
entry $w.frame.e3 -xscrollcommand "$w.frame.s3 set"
-ttk::scrollbar $w.frame.s3 -orient horiz -command \
+ttk::scrollbar $w.frame.s3 -orient horizontal -command \
"$w.frame.e3 xview"
pack $w.frame.e1 $w.frame.s1 $w.frame.spacer1 $w.frame.e2 $w.frame.s2 \
$w.frame.spacer2 $w.frame.e3 $w.frame.s3 -side top -fill x
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/floor.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/floor.tcl 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/floor.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -333,195 +333,195 @@
proc fg1 {w color} {
global floorLabels floorItems
- set i [$w create polygon 375 246 375 172 341 172 341 246 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 375 246 375 172 341 172 341 246 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 101
set {floorItems(101)} $i
$w create text 358 209 -text 101 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 307 240 339 240 339 206 307 206 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 307 240 339 240 339 206 307 206 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) {Pub Lift1}
set {floorItems(Pub Lift1)} $i
$w create text 323 223 -text {Pub Lift1} -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 339 205 307 205 307 171 339 171 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 339 205 307 205 307 171 339 171 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) {Priv Lift1}
set {floorItems(Priv Lift1)} $i
$w create text 323 188 -text {Priv Lift1} -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 42 389 42 337 1 337 1 389 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 42 389 42 337 1 337 1 389 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 110
set {floorItems(110)} $i
$w create text 21.5 363 -text 110 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 59 389 59 385 90 385 90 337 44 337 44 389 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 59 389 59 385 90 385 90 337 44 337 44 389 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 109
set {floorItems(109)} $i
$w create text 67 363 -text 109 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 51 300 51 253 6 253 6 300 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 51 300 51 253 6 253 6 300 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 111
set {floorItems(111)} $i
$w create text 28.5 276.5 -text 111 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 98 248 98 309 79 309 79 248 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 98 248 98 309 79 309 79 248 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 117B
set {floorItems(117B)} $i
$w create text 88.5 278.5 -text 117B -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 51 251 51 204 6 204 6 251 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 51 251 51 204 6 204 6 251 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 112
set {floorItems(112)} $i
$w create text 28.5 227.5 -text 112 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 6 156 51 156 51 203 6 203 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 6 156 51 156 51 203 6 203 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 113
set {floorItems(113)} $i
$w create text 28.5 179.5 -text 113 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 85 169 79 169 79 192 85 192 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 85 169 79 169 79 192 85 192 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 117A
set {floorItems(117A)} $i
$w create text 82 180.5 -text 117A -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 77 302 77 168 53 168 53 302 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 77 302 77 168 53 168 53 302 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 117
set {floorItems(117)} $i
$w create text 65 235 -text 117 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 51 155 51 115 6 115 6 155 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 51 155 51 115 6 115 6 155 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 114
set {floorItems(114)} $i
$w create text 28.5 135 -text 114 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 95 115 53 115 53 168 95 168 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 95 115 53 115 53 168 95 168 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 115
set {floorItems(115)} $i
$w create text 74 141.5 -text 115 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 87 113 87 27 10 27 10 113 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 87 113 87 27 10 27 10 113 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 116
set {floorItems(116)} $i
$w create text 48.5 70 -text 116 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 89 91 128 91 128 113 89 113 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 89 91 128 91 128 113 89 113 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 118
set {floorItems(118)} $i
$w create text 108.5 102 -text 118 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 178 128 178 132 216 132 216 91 163 91 163 112 149 112 149 128 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 178 128 178 132 216 132 216 91 163 91 163 112 149 112 149 128 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 120
set {floorItems(120)} $i
$w create text 189.5 111.5 -text 120 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 79 193 87 193 87 169 136 169 136 192 156 192 156 169 175 169 175 246 79 246 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 79 193 87 193 87 169 136 169 136 192 156 192 156 169 175 169 175 246 79 246 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 122
set {floorItems(122)} $i
$w create text 131 207.5 -text 122 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 138 169 154 169 154 191 138 191 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 138 169 154 169 154 191 138 191 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 121
set {floorItems(121)} $i
$w create text 146 180 -text 121 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 99 300 126 300 126 309 99 309 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 99 300 126 300 126 309 99 309 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 106A
set {floorItems(106A)} $i
$w create text 112.5 304.5 -text 106A -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 128 299 128 309 150 309 150 248 99 248 99 299 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 128 299 128 309 150 309 150 248 99 248 99 299 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 105
set {floorItems(105)} $i
$w create text 124.5 278.5 -text 105 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 174 309 174 300 152 300 152 309 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 174 309 174 300 152 300 152 309 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 106B
set {floorItems(106B)} $i
$w create text 163 304.5 -text 106B -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 176 299 176 309 216 309 216 248 152 248 152 299 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 176 299 176 309 216 309 216 248 152 248 152 299 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 104
set {floorItems(104)} $i
$w create text 184 278.5 -text 104 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 138 385 138 337 91 337 91 385 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 138 385 138 337 91 337 91 385 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 108
set {floorItems(108)} $i
$w create text 114.5 361 -text 108 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 256 337 140 337 140 385 256 385 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 256 337 140 337 140 385 256 385 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 107
set {floorItems(107)} $i
$w create text 198 361 -text 107 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 300 353 300 329 260 329 260 353 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 300 353 300 329 260 329 260 353 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) Smoking
set {floorItems(Smoking)} $i
$w create text 280 341 -text Smoking -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 314 135 314 170 306 170 306 246 177 246 177 135 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 314 135 314 170 306 170 306 246 177 246 177 135 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 123
set {floorItems(123)} $i
$w create text 245.5 190.5 -text 123 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 217 248 301 248 301 326 257 326 257 310 217 310 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 217 248 301 248 301 326 257 326 257 310 217 310 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 103
set {floorItems(103)} $i
$w create text 259 287 -text 103 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 396 188 377 188 377 169 316 169 316 131 396 131 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 396 188 377 188 377 169 316 169 316 131 396 131 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 124
set {floorItems(124)} $i
$w create text 356 150 -text 124 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 397 226 407 226 407 189 377 189 377 246 397 246 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 397 226 407 226 407 189 377 189 377 246 397 246 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 125
set {floorItems(125)} $i
$w create text 392 217.5 -text 125 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 399 187 409 187 409 207 474 207 474 164 399 164 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 399 187 409 187 409 207 474 207 474 164 399 164 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 126
set {floorItems(126)} $i
$w create text 436.5 185.5 -text 126 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 409 209 409 229 399 229 399 253 486 253 486 239 474 239 474 209 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 409 209 409 229 399 229 399 253 486 253 486 239 474 239 474 209 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 127
set {floorItems(127)} $i
$w create text 436.5 231 -text 127 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 501 164 501 174 495 174 495 188 490 188 490 204 476 204 476 164 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 501 164 501 174 495 174 495 188 490 188 490 204 476 204 476 164 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) MShower
set {floorItems(MShower)} $i
$w create text 488.5 184 -text MShower -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 497 176 513 176 513 204 492 204 492 190 497 190 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 497 176 513 176 513 204 492 204 492 190 497 190 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) Closet
set {floorItems(Closet)} $i
$w create text 502.5 190 -text Closet -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 476 237 476 206 513 206 513 254 488 254 488 237 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 476 237 476 206 513 206 513 254 488 254 488 237 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) WShower
set {floorItems(WShower)} $i
$w create text 494.5 230 -text WShower -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 486 131 558 131 558 135 724 135 724 166 697 166 697 275 553 275 531 254 515 254 515 174 503 174 503 161 486 161 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 486 131 558 131 558 135 724 135 724 166 697 166 697 275 553 275 531 254 515 254 515 174 503 174 503 161 486 161 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 130
set {floorItems(130)} $i
$w create text 638.5 205 -text 130 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 308 242 339 242 339 248 342 248 342 246 397 246 397 276 393 276 393 309 300 309 300 248 308 248 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 308 242 339 242 339 248 342 248 342 246 397 246 397 276 393 276 393 309 300 309 300 248 308 248 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 102
set {floorItems(102)} $i
$w create text 367.5 278.5 -text 102 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 397 255 486 255 486 276 397 276 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 397 255 486 255 486 276 397 276 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 128
set {floorItems(128)} $i
$w create text 441.5 265.5 -text 128 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 510 309 486 309 486 255 530 255 552 277 561 277 561 325 510 325 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 510 309 486 309 486 255 530 255 552 277 561 277 561 325 510 325 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 129
set {floorItems(129)} $i
$w create text 535.5 293 -text 129 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 696 281 740 281 740 387 642 387 642 389 561 389 561 277 696 277 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 696 281 740 281 740 387 642 387 642 389 561 389 561 277 696 277 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 133
set {floorItems(133)} $i
$w create text 628.5 335 -text 133 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 742 387 742 281 800 281 800 387 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 742 387 742 281 800 281 800 387 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 132
set {floorItems(132)} $i
$w create text 771 334 -text 132 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 800 168 800 280 699 280 699 168 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 800 168 800 280 699 280 699 168 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 134
set {floorItems(134)} $i
$w create text 749.5 224 -text 134 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 726 131 726 166 800 166 800 131 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 726 131 726 166 800 166 800 131 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 135
set {floorItems(135)} $i
$w create text 763 148.5 -text 135 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 340 360 335 363 331 365 326 366 304 366 304 312 396 312 396 288 400 288 404 288 409 290 413 292 418 297 421 302 422 309 421 318 417 325 411 330 405 332 397 333 344 333 340 334 336 336 335 338 332 342 331 347 332 351 334 354 336 357 341 359 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 340 360 335 363 331 365 326 366 304 366 304 312 396 312 396 288 400 288 404 288 409 290 413 292 418 297 421 302 422 309 421 318 417 325 411 330 405 332 397 333 344 333 340 334 336 336 335 338 332 342 331 347 332 351 334 354 336 357 341 359 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) {Ramona Stair}
set {floorItems(Ramona Stair)} $i
$w create text 368 323 -text {Ramona Stair} -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 30 23 30 5 93 5 98 5 104 7 110 10 116 16 119 20 122 28 123 32 123 68 220 68 220 87 90 87 90 23 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 30 23 30 5 93 5 98 5 104 7 110 10 116 16 119 20 122 28 123 32 123 68 220 68 220 87 90 87 90 23 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) {University Stair}
set {floorItems(University Stair)} $i
$w create text 155 77.5 -text {University Stair} -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 282 37 295 40 312 49 323 56 337 70 352 56 358 48 363 39 365 29 348 25 335 22 321 14 300 5 283 1 260 0 246 0 242 2 236 4 231 8 227 13 223 17 221 22 220 34 260 34 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 282 37 295 40 312 49 323 56 337 70 352 56 358 48 363 39 365 29 348 25 335 22 321 14 300 5 283 1 260 0 246 0 242 2 236 4 231 8 227 13 223 17 221 22 220 34 260 34 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) {Plaza Stair}
set {floorItems(Plaza Stair)} $i
$w create text 317.5 28.5 -text {Plaza Stair} -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 220 34 260 34 282 37 295 40 312 49 323 56 337 70 350 83 365 94 377 100 386 104 386 128 220 128 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 220 34 260 34 282 37 295 40 312 49 323 56 337 70 350 83 365 94 377 100 386 104 386 128 220 128 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) {Plaza Deck}
set {floorItems(Plaza Deck)} $i
$w create text 303 81 -text {Plaza Deck} -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 257 336 77 336 6 336 6 301 77 301 77 310 257 310 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 257 336 77 336 6 336 6 301 77 301 77 310 257 310 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 106
set {floorItems(106)} $i
$w create text 131.5 318.5 -text 106 -fill $color -anchor c -tags {floor1 label}
- set i [$w create polygon 146 110 162 110 162 91 130 91 130 115 95 115 95 128 114 128 114 151 157 151 157 153 112 153 112 130 97 130 97 168 175 168 175 131 146 131 -outline {} -tags {floor1 room}]
+ set i [$w create polygon 146 110 162 110 162 91 130 91 130 115 95 115 95 128 114 128 114 151 157 151 157 153 112 153 112 130 97 130 97 168 175 168 175 131 146 131 -fill {} -outline {} -tags {floor1 room}]
set floorLabels($i) 119
set {floorItems(119)} $i
$w create text 143.5 133 -text 119 -fill $color -anchor c -tags {floor1 label}
@@ -696,207 +696,207 @@
proc fg2 {w color} {
global floorLabels floorItems
- set i [$w create polygon 748 188 755 188 755 205 758 205 758 222 800 222 800 168 748 168 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 748 188 755 188 755 205 758 205 758 222 800 222 800 168 748 168 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 238
set {floorItems(238)} $i
$w create text 774 195 -text 238 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 726 188 746 188 746 166 800 166 800 131 726 131 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 726 188 746 188 746 166 800 166 800 131 726 131 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 237
set {floorItems(237)} $i
$w create text 763 148.5 -text 237 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 497 187 497 204 559 204 559 324 641 324 643 324 643 291 641 291 641 205 696 205 696 291 694 291 694 314 715 314 715 291 715 205 755 205 755 190 724 190 724 187 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 497 187 497 204 559 204 559 324 641 324 643 324 643 291 641 291 641 205 696 205 696 291 694 291 694 314 715 314 715 291 715 205 755 205 755 190 724 190 724 187 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 246
set {floorItems(246)} $i
$w create text 600 264 -text 246 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 694 279 643 279 643 314 694 314 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 694 279 643 279 643 314 694 314 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 247
set {floorItems(247)} $i
$w create text 668.5 296.5 -text 247 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 232 250 308 250 308 242 339 242 339 246 397 246 397 255 476 255 476 250 482 250 559 250 559 274 482 274 482 278 396 278 396 274 232 274 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 232 250 308 250 308 242 339 242 339 246 397 246 397 255 476 255 476 250 482 250 559 250 559 274 482 274 482 278 396 278 396 274 232 274 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 202
set {floorItems(202)} $i
$w create text 285.5 260 -text 202 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 53 228 53 338 176 338 233 338 233 196 306 196 306 180 175 180 175 169 156 169 156 196 176 196 176 228 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 53 228 53 338 176 338 233 338 233 196 306 196 306 180 175 180 175 169 156 169 156 196 176 196 176 228 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 206
set {floorItems(206)} $i
$w create text 143 267 -text 206 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 51 277 6 277 6 338 51 338 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 51 277 6 277 6 338 51 338 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 212
set {floorItems(212)} $i
$w create text 28.5 307.5 -text 212 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 557 276 486 276 486 309 510 309 510 325 557 325 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 557 276 486 276 486 309 510 309 510 325 557 325 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 245
set {floorItems(245)} $i
$w create text 521.5 300.5 -text 245 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 560 389 599 389 599 326 560 326 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 560 389 599 389 599 326 560 326 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 244
set {floorItems(244)} $i
$w create text 579.5 357.5 -text 244 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 601 389 601 326 643 326 643 389 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 601 389 601 326 643 326 643 389 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 243
set {floorItems(243)} $i
$w create text 622 357.5 -text 243 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 688 316 645 316 645 365 688 365 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 688 316 645 316 645 365 688 365 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 242
set {floorItems(242)} $i
$w create text 666.5 340.5 -text 242 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 802 367 759 367 759 226 802 226 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 802 367 759 367 759 226 802 226 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) {Barbecue Deck}
set {floorItems(Barbecue Deck)} $i
$w create text 780.5 296.5 -text {Barbecue Deck} -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 755 262 755 314 717 314 717 262 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 755 262 755 314 717 314 717 262 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 240
set {floorItems(240)} $i
$w create text 736 288 -text 240 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 755 316 689 316 689 365 755 365 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 755 316 689 316 689 365 755 365 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 241
set {floorItems(241)} $i
$w create text 722 340.5 -text 241 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 755 206 717 206 717 261 755 261 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 755 206 717 206 717 261 755 261 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 239
set {floorItems(239)} $i
$w create text 736 233.5 -text 239 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 695 277 643 277 643 206 695 206 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 695 277 643 277 643 206 695 206 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 248
set {floorItems(248)} $i
$w create text 669 241.5 -text 248 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 676 135 676 185 724 185 724 135 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 676 135 676 185 724 185 724 135 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 236
set {floorItems(236)} $i
$w create text 700 160 -text 236 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 675 135 635 135 635 145 628 145 628 185 675 185 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 675 135 635 135 635 145 628 145 628 185 675 185 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 235
set {floorItems(235)} $i
$w create text 651.5 160 -text 235 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 626 143 633 143 633 135 572 135 572 143 579 143 579 185 626 185 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 626 143 633 143 633 135 572 135 572 143 579 143 579 185 626 185 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 234
set {floorItems(234)} $i
$w create text 606 160 -text 234 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 557 135 571 135 571 145 578 145 578 185 527 185 527 131 557 131 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 557 135 571 135 571 145 578 145 578 185 527 185 527 131 557 131 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 233
set {floorItems(233)} $i
$w create text 552.5 158 -text 233 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 476 249 557 249 557 205 476 205 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 476 249 557 249 557 205 476 205 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 230
set {floorItems(230)} $i
$w create text 516.5 227 -text 230 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 476 164 486 164 486 131 525 131 525 185 476 185 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 476 164 486 164 486 131 525 131 525 185 476 185 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 232
set {floorItems(232)} $i
$w create text 500.5 158 -text 232 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 476 186 495 186 495 204 476 204 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 476 186 495 186 495 204 476 204 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 229
set {floorItems(229)} $i
$w create text 485.5 195 -text 229 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 474 207 409 207 409 187 399 187 399 164 474 164 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 474 207 409 207 409 187 399 187 399 164 474 164 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 227
set {floorItems(227)} $i
$w create text 436.5 185.5 -text 227 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 399 228 399 253 474 253 474 209 409 209 409 228 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 399 228 399 253 474 253 474 209 409 209 409 228 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 228
set {floorItems(228)} $i
$w create text 436.5 231 -text 228 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 397 246 397 226 407 226 407 189 377 189 377 246 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 397 246 397 226 407 226 407 189 377 189 377 246 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 226
set {floorItems(226)} $i
$w create text 392 217.5 -text 226 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 377 169 316 169 316 131 397 131 397 188 377 188 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 377 169 316 169 316 131 397 131 397 188 377 188 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 225
set {floorItems(225)} $i
$w create text 356.5 150 -text 225 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 234 198 306 198 306 249 234 249 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 234 198 306 198 306 249 234 249 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 224
set {floorItems(224)} $i
$w create text 270 223.5 -text 224 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 270 179 306 179 306 170 314 170 314 135 270 135 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 270 179 306 179 306 170 314 170 314 135 270 135 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 223
set {floorItems(223)} $i
$w create text 292 157 -text 223 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 268 179 221 179 221 135 268 135 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 268 179 221 179 221 135 268 135 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 222
set {floorItems(222)} $i
$w create text 244.5 157 -text 222 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 177 179 219 179 219 135 177 135 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 177 179 219 179 219 135 177 135 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 221
set {floorItems(221)} $i
$w create text 198 157 -text 221 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 299 327 349 327 349 284 341 284 341 276 299 276 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 299 327 349 327 349 284 341 284 341 276 299 276 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 204
set {floorItems(204)} $i
$w create text 324 301.5 -text 204 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 234 276 297 276 297 327 257 327 257 338 234 338 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 234 276 297 276 297 327 257 327 257 338 234 338 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 205
set {floorItems(205)} $i
$w create text 265.5 307 -text 205 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 256 385 256 340 212 340 212 385 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 256 385 256 340 212 340 212 385 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 207
set {floorItems(207)} $i
$w create text 234 362.5 -text 207 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 210 340 164 340 164 385 210 385 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 210 340 164 340 164 385 210 385 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 208
set {floorItems(208)} $i
$w create text 187 362.5 -text 208 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 115 340 162 340 162 385 115 385 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 115 340 162 340 162 385 115 385 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 209
set {floorItems(209)} $i
$w create text 138.5 362.5 -text 209 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 89 228 89 156 53 156 53 228 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 89 228 89 156 53 156 53 228 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 217
set {floorItems(217)} $i
$w create text 71 192 -text 217 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 89 169 97 169 97 190 89 190 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 89 169 97 169 97 190 89 190 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 217A
set {floorItems(217A)} $i
$w create text 93 179.5 -text 217A -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 89 156 89 168 95 168 95 135 53 135 53 156 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 89 156 89 168 95 168 95 135 53 135 53 156 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 216
set {floorItems(216)} $i
$w create text 71 145.5 -text 216 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 51 179 51 135 6 135 6 179 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 51 179 51 135 6 135 6 179 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 215
set {floorItems(215)} $i
$w create text 28.5 157 -text 215 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 51 227 6 227 6 180 51 180 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 51 227 6 227 6 180 51 180 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 214
set {floorItems(214)} $i
$w create text 28.5 203.5 -text 214 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 51 275 6 275 6 229 51 229 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 51 275 6 275 6 229 51 229 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 213
set {floorItems(213)} $i
$w create text 28.5 252 -text 213 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 114 340 67 340 67 385 114 385 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 114 340 67 340 67 385 114 385 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 210
set {floorItems(210)} $i
$w create text 90.5 362.5 -text 210 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 59 389 59 385 65 385 65 340 1 340 1 389 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 59 389 59 385 65 385 65 340 1 340 1 389 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 211
set {floorItems(211)} $i
$w create text 33 364.5 -text 211 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 393 309 350 309 350 282 342 282 342 276 393 276 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 393 309 350 309 350 282 342 282 342 276 393 276 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 203
set {floorItems(203)} $i
$w create text 367.5 292.5 -text 203 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 99 191 91 191 91 226 174 226 174 198 154 198 154 192 109 192 109 169 99 169 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 99 191 91 191 91 226 174 226 174 198 154 198 154 192 109 192 109 169 99 169 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 220
set {floorItems(220)} $i
$w create text 132.5 208.5 -text 220 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 339 205 307 205 307 171 339 171 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 339 205 307 205 307 171 339 171 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) {Priv Lift2}
set {floorItems(Priv Lift2)} $i
$w create text 323 188 -text {Priv Lift2} -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 307 240 339 240 339 206 307 206 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 307 240 339 240 339 206 307 206 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) {Pub Lift 2}
set {floorItems(Pub Lift 2)} $i
$w create text 323 223 -text {Pub Lift 2} -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 175 168 97 168 97 131 175 131 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 175 168 97 168 97 131 175 131 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 218
set {floorItems(218)} $i
$w create text 136 149.5 -text 218 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 154 191 111 191 111 169 154 169 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 154 191 111 191 111 169 154 169 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 219
set {floorItems(219)} $i
$w create text 132.5 180 -text 219 -fill $color -anchor c -tags {floor2 label}
- set i [$w create polygon 375 246 375 172 341 172 341 246 -outline {} -tags {floor2 room}]
+ set i [$w create polygon 375 246 375 172 341 172 341 246 -fill {} -outline {} -tags {floor2 room}]
set floorLabels($i) 201
set {floorItems(201)} $i
$w create text 358 209 -text 201 -fill $color -anchor c -tags {floor2 label}
@@ -1066,135 +1066,135 @@
proc fg3 {w color} {
global floorLabels floorItems
- set i [$w create polygon 89 228 89 180 70 180 70 228 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 89 228 89 180 70 180 70 228 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) 316
set {floorItems(316)} $i
$w create text 79.5 204 -text 316 -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 115 368 162 368 162 323 115 323 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 115 368 162 368 162 323 115 323 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) 309
set {floorItems(309)} $i
$w create text 138.5 345.5 -text 309 -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 164 323 164 368 211 368 211 323 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 164 323 164 368 211 368 211 323 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) 308
set {floorItems(308)} $i
$w create text 187.5 345.5 -text 308 -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 256 368 212 368 212 323 256 323 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 256 368 212 368 212 323 256 323 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) 307
set {floorItems(307)} $i
$w create text 234 345.5 -text 307 -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 244 276 297 276 297 327 260 327 260 321 244 321 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 244 276 297 276 297 327 260 327 260 321 244 321 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) 305
set {floorItems(305)} $i
$w create text 270.5 301.5 -text 305 -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 251 219 251 203 244 203 244 219 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 251 219 251 203 244 203 244 219 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) 324B
set {floorItems(324B)} $i
$w create text 247.5 211 -text 324B -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 251 249 244 249 244 232 251 232 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 251 249 244 249 244 232 251 232 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) 324A
set {floorItems(324A)} $i
$w create text 247.5 240.5 -text 324A -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 223 135 223 179 177 179 177 135 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 223 135 223 179 177 179 177 135 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) 320
set {floorItems(320)} $i
$w create text 200 157 -text 320 -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 114 368 114 323 67 323 67 368 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 114 368 114 323 67 323 67 368 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) 310
set {floorItems(310)} $i
$w create text 90.5 345.5 -text 310 -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 23 277 23 321 68 321 68 277 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 23 277 23 321 68 321 68 277 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) 312
set {floorItems(312)} $i
$w create text 45.5 299 -text 312 -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 23 229 68 229 68 275 23 275 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 23 229 68 229 68 275 23 275 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) 313
set {floorItems(313)} $i
$w create text 45.5 252 -text 313 -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 68 227 23 227 23 180 68 180 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 68 227 23 227 23 180 68 180 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) 314
set {floorItems(314)} $i
$w create text 45.5 203.5 -text 314 -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 95 179 95 135 23 135 23 179 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 95 179 95 135 23 135 23 179 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) 315
set {floorItems(315)} $i
$w create text 59 157 -text 315 -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 99 226 99 204 91 204 91 226 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 99 226 99 204 91 204 91 226 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) 316B
set {floorItems(316B)} $i
$w create text 95 215 -text 316B -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 91 202 99 202 99 180 91 180 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 91 202 99 202 99 180 91 180 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) 316A
set {floorItems(316A)} $i
$w create text 95 191 -text 316A -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 97 169 109 169 109 192 154 192 154 198 174 198 174 226 101 226 101 179 97 179 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 97 169 109 169 109 192 154 192 154 198 174 198 174 226 101 226 101 179 97 179 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) 319
set {floorItems(319)} $i
$w create text 141.5 209 -text 319 -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 65 368 58 368 58 389 1 389 1 333 23 333 23 323 65 323 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 65 368 58 368 58 389 1 389 1 333 23 333 23 323 65 323 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) 311
set {floorItems(311)} $i
$w create text 29.5 361 -text 311 -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 154 191 111 191 111 169 154 169 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 154 191 111 191 111 169 154 169 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) 318
set {floorItems(318)} $i
$w create text 132.5 180 -text 318 -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 175 168 97 168 97 131 175 131 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 175 168 97 168 97 131 175 131 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) 317
set {floorItems(317)} $i
$w create text 136 149.5 -text 317 -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 274 194 274 221 306 221 306 194 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 274 194 274 221 306 221 306 194 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) 323
set {floorItems(323)} $i
$w create text 290 207.5 -text 323 -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 306 222 274 222 274 249 306 249 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 306 222 274 222 274 249 306 249 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) 325
set {floorItems(325)} $i
$w create text 290 235.5 -text 325 -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 263 179 224 179 224 135 263 135 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 263 179 224 179 224 135 263 135 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) 321
set {floorItems(321)} $i
$w create text 243.5 157 -text 321 -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 314 169 306 169 306 192 273 192 264 181 264 135 314 135 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 314 169 306 169 306 192 273 192 264 181 264 135 314 135 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) 322
set {floorItems(322)} $i
$w create text 293.5 163.5 -text 322 -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 307 240 339 240 339 206 307 206 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 307 240 339 240 339 206 307 206 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) {Pub Lift3}
set {floorItems(Pub Lift3)} $i
$w create text 323 223 -text {Pub Lift3} -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 339 205 307 205 307 171 339 171 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 339 205 307 205 307 171 339 171 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) {Priv Lift3}
set {floorItems(Priv Lift3)} $i
$w create text 323 188 -text {Priv Lift3} -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 350 284 376 284 376 276 397 276 397 309 350 309 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 350 284 376 284 376 276 397 276 397 309 350 309 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) 303
set {floorItems(303)} $i
$w create text 373.5 292.5 -text 303 -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 272 203 272 249 252 249 252 230 244 230 244 221 252 221 252 203 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 272 203 272 249 252 249 252 230 244 230 244 221 252 221 252 203 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) 324
set {floorItems(324)} $i
$w create text 262 226 -text 324 -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 299 276 299 327 349 327 349 284 341 284 341 276 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 299 276 299 327 349 327 349 284 341 284 341 276 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) 304
set {floorItems(304)} $i
$w create text 324 301.5 -text 304 -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 375 246 375 172 341 172 341 246 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 375 246 375 172 341 172 341 246 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) 301
set {floorItems(301)} $i
$w create text 358 209 -text 301 -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 397 246 377 246 377 185 397 185 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 397 246 377 246 377 185 397 185 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) 327
set {floorItems(327)} $i
$w create text 387 215.5 -text 327 -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 316 131 316 169 377 169 377 185 397 185 397 131 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 316 131 316 169 377 169 377 185 397 185 397 131 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) 326
set {floorItems(326)} $i
$w create text 356.5 150 -text 326 -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 308 251 242 251 242 274 342 274 342 282 375 282 375 274 397 274 397 248 339 248 339 242 308 242 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 308 251 242 251 242 274 342 274 342 282 375 282 375 274 397 274 397 248 339 248 339 242 308 242 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) 302
set {floorItems(302)} $i
$w create text 319.5 261 -text 302 -fill $color -anchor c -tags {floor3 label}
- set i [$w create polygon 70 321 242 321 242 200 259 200 259 203 272 203 272 193 263 180 242 180 175 180 175 169 156 169 156 196 177 196 177 228 107 228 70 228 70 275 107 275 107 248 160 248 160 301 107 301 107 275 70 275 -outline {} -tags {floor3 room}]
+ set i [$w create polygon 70 321 242 321 242 200 259 200 259 203 272 203 272 193 263 180 242 180 175 180 175 169 156 169 156 196 177 196 177 228 107 228 70 228 70 275 107 275 107 248 160 248 160 301 107 301 107 275 70 275 -fill {} -outline {} -tags {floor3 room}]
set floorLabels($i) 306
set {floorItems(306)} $i
$w create text 200.5 284.5 -text 306 -fill $color -anchor c -tags {floor3 label}
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/goldberg.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/goldberg.tcl 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/goldberg.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -77,7 +77,6 @@
# Colors for everything
set C(fg) black
-set C(bg) gray75
set C(bg) cornflowerblue
set C(0) white; set C(1a) darkgreen; set C(1b) yellow
@@ -92,6 +91,7 @@
set C(20) cyan; set C(21) gray65; set C(22) $C(20)
set C(23a) blue; set C(23b) red; set C(23c) yellow
set C(24a) red; set C(24b) white;
+set C(24c) black; set C(26) $C(0);
proc DoDisplay {w} {
global S C
@@ -136,7 +136,7 @@
ttk::labelframe $w.message -text "Message"
ttk::entry $w.message.e -textvariable S(message) -justify center
ttk::labelframe $w.speed -text "Speed: 0"
- ttk::scale $w.speed.scale -orient h -from 1 -to 10 -variable S(speed)
+ ttk::scale $w.speed.scale -orient horizontal -from 1 -to 10 -variable S(speed)
ttk::button $w.about -text About -command [list About $w]
grid $w.start -in $w.ctrl -row 0 -sticky ew
@@ -1586,6 +1586,7 @@
-width 10 -smooth 1
set msg [subst $S(message)]
$w.c create text [Centroid $w I24] -text $msg -tag {I24 I24t} \
+ -fill $::C(24c) \
-justify center -font {{Times Roman} 18 bold}
return 1
}
@@ -1619,6 +1620,7 @@
if {$step >= 3} {
$w.c delete I24 I26
$w.c create text 430 755 -anchor s -tag I26 \
+ -fill $::C(26) \
-text "click to continue" -font {{Times Roman} 24 bold}
bind $w.c <Button-1> [list Reset $w]
return 4
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/images/earth.gif
===================================================================
(Binary files differ)
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/items.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/items.tcl 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/items.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -32,7 +32,7 @@
-xscrollcommand "$w.frame.hscroll set" \
-yscrollcommand "$w.frame.vscroll set"
ttk::scrollbar $w.frame.vscroll -command "$c yview"
-ttk::scrollbar $w.frame.hscroll -orient horiz -command "$c xview"
+ttk::scrollbar $w.frame.hscroll -orient horizontal -command "$c xview"
grid $c -in $w.frame \
-row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/menu.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/menu.tcl 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/menu.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -18,7 +18,6 @@
label $w.msg -font $font -wraplength 4i -justify left
if {[tk windowingsystem] eq "aqua"} {
- catch {set origUseCustomMDEF $::tk::mac::useCustomMDEF; set ::tk::mac::useCustomMDEF 1}
$w.msg configure -text "This window has a menubar with cascaded menus. You can invoke entries with an accelerator by typing Command+x, where \"x\" is the character next to the command key symbol. The rightmost menu can be torn off into a palette by selecting the first item in the menu."
} else {
$w.msg configure -text "This window contains a menubar with cascaded menus. You can post a menu from the keyboard by typing Alt+x, where \"x\" is the character underlined on the menu. You can then traverse among the menus using the arrow keys. When a menu is posted, you can invoke the current entry by typing space, or you can invoke any entry by typing its underlined character. If a menu entry has an accelerator, you can invoke the entry without posting the menu just by typing the accelerator. The rightmost menu can be torn off into a palette by selecting the first item in the menu."
@@ -56,7 +55,7 @@
$m add command -label "Long entry that does nothing"
if {[tk windowingsystem] eq "aqua"} {
set modifier Command
-} elseif {[tk windowingsystem] == "win32"} {
+} elseif {[tk windowingsystem] eq "win32"} {
set modifier Control
} else {
set modifier Meta
@@ -176,5 +175,3 @@
set menustatus $label
update idletasks
}
-
-if {[tk windowingsystem] eq "aqua"} {catch {set ::tk::mac::useCustomMDEF $origUseCustomMDEF}}
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/menubu.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/menubu.tcl 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/menubu.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -18,7 +18,6 @@
frame $w.body
pack $w.body -expand 1 -fill both
-if {[tk windowingsystem] eq "aqua"} {catch {set origUseCustomMDEF $::tk::mac::useCustomMDEF; set ::tk::mac::useCustomMDEF 1}}
menubutton $w.body.below -text "Below" -underline 0 -direction below -menu $w.body.below.m -relief raised
menu $w.body.below.m -tearoff 0
@@ -86,5 +85,3 @@
}
pack $body.buttons.colors -side left -padx 25 -pady 25
-
-if {[tk windowingsystem] eq "aqua"} {catch {set ::tk::mac::useCustomMDEF $origUseCustomMDEF}}
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/puzzle.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/puzzle.tcl 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/puzzle.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -11,7 +11,7 @@
# puzzleSwitch --
# This procedure is invoked when the user clicks on a particular button;
-# if the button is next to the empty space, it moves the button into th
+# if the button is next to the empty space, it moves the button into the
# empty space.
proc puzzleSwitch {w num} {
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/entry.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/entry.tcl 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/entry.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -211,6 +211,7 @@
bind Entry <Next> {# nothing}
if {[tk windowingsystem] eq "aqua"} {
bind Entry <Command-Key> {# nothing}
+ bind Entry <Mod4-Key> {# nothing}
}
# Tk-on-Cocoa generates characters for these two keys. [Bug 2971663]
bind Entry <<NextLine>> {# nothing}
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/fontchooser.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/fontchooser.tcl 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/fontchooser.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -12,35 +12,49 @@
variable S
set S(W) .__tk__fontchooser
- set S(fonts) [lsort -dictionary [font families]]
+ set S(fonts) [lsort -dictionary -unique [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
set S(under) 0
set S(first) 1
- set S(sampletext) [::msgcat::mc "AaBbYyZz01"]
set S(-parent) .
- set S(-title) [::msgcat::mc "Font"]
+ set S(-title) {}
set S(-command) ""
set S(-font) TkDefaultFont
+ set S(bad) [list ]
}
-proc ::tk::fontchooser::Setup {} {
+proc ::tk::fontchooser::Canonical {} {
variable S
+ foreach style $S(styles) {
+ lappend S(styles,lcase) [string tolower $style]
+ }
+ set S(sizes,lcase) $S(sizes)
+ set S(sampletext) [::msgcat::mc "AaBbYyZz01"]
+
# 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]}
- set S(sizes,lcase) $S(sizes)
+ foreach style $S(styles) {
+ lappend S(styles,lcase) [string tolower $style]
+ }
+}
+proc ::tk::fontchooser::Setup {} {
+ variable S
+
+ Canonical
+
::ttk::style layout FontchooserFrame {
Entry.field -sticky news -border true -children {
FontchooserFrame.padding -sticky news
@@ -47,8 +61,8 @@
}
}
bind [winfo class .] <<ThemeChanged>> \
- [list +ttk::style layout FontchooserFrame \
- [ttk::style layout FontchooserFrame]]
+ [list +ttk::style layout FontchooserFrame \
+ [ttk::style layout FontchooserFrame]]
namespace ensemble create -map {
show ::tk::fontchooser::Show
@@ -60,14 +74,24 @@
proc ::tk::fontchooser::Show {} {
variable S
+
+ Canonical
+
if {![winfo exists $S(W)]} {
Create
wm transient $S(W) [winfo toplevel $S(-parent)]
tk::PlaceWindow $S(W) widget $S(-parent)
+ if {[string trim $S(-title)] eq ""} {
+ wm title $S(W) [::msgcat::mc "Font"]
+ } else {
+ wm title $S(W) $S(-title)
+ }
}
- set S(fonts) [lsort -dictionary [font families]]
+ set S(fonts) [lsort -dictionary -unique [font families]]
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]
+ }
wm deiconify $S(W)
}
@@ -91,10 +115,10 @@
foreach spec $specs {
foreach {name xx yy default} $spec break
lappend result $name \
- [expr {[info exists S($name)] ? $S($name) : $default}]
+ [expr {[info exists S($name)] ? $S($name) : $default}]
}
lappend result -visible \
- [expr {[winfo exists $S(W)] && [winfo ismapped $S(W)]}]
+ [expr {[winfo exists $S(W)] && [winfo ismapped $S(W)]}]
return $result
}
if {[llength $args] == 1} {
@@ -105,26 +129,33 @@
return $S($option)
}
return -code error -errorcode [list TK LOOKUP OPTION $option] \
- "bad option \"$option\": must be\
- -command, -font, -parent, -title or -visible"
+ "bad option \"$option\": must be\
+ -command, -font, -parent, -title or -visible"
}
-
set cache [dict create -parent $S(-parent) -title $S(-title) \
- -font $S(-font) -command $S(-command)]
+ -font $S(-font) -command $S(-command)]
set r [tclParseConfigSpec [namespace which -variable S] $specs DONTSETDEFAULTS $args]
if {![winfo exists $S(-parent)]} {
- set code [list TK LOOKUP WINDOW $S(-parent)]
+ set code [list TK LOOKUP WINDOW $S(-parent)]
set err "bad window path name \"$S(-parent)\""
array set S $cache
return -code error -errorcode $code $err
}
- if {[string trim $S(-title)] eq ""} {
- set S(-title) [::msgcat::mc "Font"]
+
+ if {[winfo exists $S(W)]} {
+ if {{-font} in $args} {
+ Init $S(-font)
+ event generate $S(-parent) <<TkFontchooserFontChanged>>
+ }
+
+ if {[string trim $S(-title)] eq {}} {
+ wm title $S(W) [::msgcat::mc Font]
+ } else {
+ wm title $S(W) $S(-title)
+ }
+ $S(W).ok configure -state $S(nstate)
+ $S(W).apply configure -state $S(nstate)
}
- if {[winfo exists $S(W)] && ("-font" in $args)} {
- Init $S(-font)
- event generate $S(-parent) <<TkFontchooserFontChanged>>
- }
return $r
}
@@ -140,7 +171,9 @@
# Now build the dialog
if {![winfo exists $S(W)]} {
toplevel $S(W) -class TkFontDialog
- if {[package provide tcltest] ne {}} {set ::tk_dialog $S(W)}
+ if {[package provide tcltest] ne {}} {
+ set ::tk_dialog $S(W)
+ }
wm withdraw $S(W)
wm title $S(W) $S(-title)
wm transient $S(W) [winfo toplevel $S(-parent)]
@@ -153,40 +186,40 @@
::tk::AmpWidget ::ttk::label $S(W).style -text [::msgcat::mc "Font st&yle:"]
::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)
+ -textvariable [namespace which -variable S](font)
ttk::entry $S(W).estyle -width 10 \
- -textvariable [namespace which -variable S](style)
+ -textvariable [namespace which -variable S](style)
ttk::entry $S(W).esize -textvariable [namespace which -variable S](size) \
- -width 3 -validate key -validatecommand {string is double %P}
+ -width 3 -validate key -validatecommand {regexp -- {^-*[0-9]*$} %P}
ttk_slistbox $S(W).lfonts -height 7 -exportselection 0 \
- -selectmode browse -activestyle none \
- -listvariable [namespace which -variable S](fonts)
+ -selectmode browse -activestyle none \
+ -listvariable [namespace which -variable S](fonts)
ttk_slistbox $S(W).lstyles -width 5 -height 7 -exportselection 0 \
- -selectmode browse -activestyle none \
- -listvariable [namespace which -variable S](styles)
+ -selectmode browse -activestyle none \
+ -listvariable [namespace which -variable S](styles)
ttk_slistbox $S(W).lsizes -width 4 -height 7 -exportselection 0 \
- -selectmode browse -activestyle none \
- -listvariable [namespace which -variable S](sizes)
+ -selectmode browse -activestyle none \
+ -listvariable [namespace which -variable S](sizes)
set WE $S(W).effects
::ttk::labelframe $WE -text [::msgcat::mc "Effects"]
::tk::AmpWidget ::ttk::checkbutton $WE.strike \
- -variable [namespace which -variable S](strike) \
- -text [::msgcat::mc "Stri&keout"] \
- -command [namespace code [list Click strike]]
+ -variable [namespace which -variable S](strike) \
+ -text [::msgcat::mc "Stri&keout"] \
+ -command [namespace code [list Click strike]]
::tk::AmpWidget ::ttk::checkbutton $WE.under \
- -variable [namespace which -variable S](under) \
- -text [::msgcat::mc "&Underline"] \
- -command [namespace code [list Click under]]
+ -variable [namespace which -variable S](under) \
+ -text [::msgcat::mc "&Underline"] \
+ -command [namespace code [list Click under]]
set bbox [::ttk::frame $S(W).bbox]
::ttk::button $S(W).ok -text [::msgcat::mc OK] -default active\
- -command [namespace code [list Done 1]]
+ -command [namespace code [list Done 1]]
::ttk::button $S(W).cancel -text [::msgcat::mc Cancel] \
- -command [namespace code [list Done 0]]
+ -command [namespace code [list Done 0]]
::tk::AmpWidget ::ttk::button $S(W).apply -text [::msgcat::mc "&Apply"] \
- -command [namespace code [list Apply]]
+ -command [namespace code [list Apply]]
wm protocol $S(W) WM_DELETE_WINDOW [namespace code [list Done 0]]
# Calculate minimum sizes
@@ -196,13 +229,15 @@
set minsize(gap) 10
set minsize(bbox) [winfo reqwidth $S(W).ok]
set minsize(fonts) \
- [expr {[font measure TkDefaultFont "Helvetica"] + $scroll_width}]
+ [expr {[font measure TkDefaultFont "Helvetica"] + $scroll_width}]
set minsize(styles) \
- [expr {[font measure TkDefaultFont "Bold Italic"] + $scroll_width}]
+ [expr {[font measure TkDefaultFont "Bold Italic"] + $scroll_width}]
set minsize(sizes) \
- [expr {[font measure TkDefaultFont "-99"] + $scroll_width}]
+ [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) <Return> [namespace code [list Done 1]]
@@ -224,7 +259,7 @@
set WS $S(W).sample
::ttk::labelframe $WS -text [::msgcat::mc "Sample"]
::ttk::label $WS.sample -relief sunken -anchor center \
- -textvariable [namespace which -variable S](sampletext)
+ -textvariable [namespace which -variable S](sampletext)
set S(sample) $WS.sample
grid $WS.sample -sticky news -padx 6 -pady 4
grid rowconfigure $WS 0 -weight 1
@@ -233,9 +268,7 @@
grid $S(W).ok -in $bbox -sticky new -pady {0 2}
grid $S(W).cancel -in $bbox -sticky new -pady 2
- if {$S(-command) ne ""} {
- grid $S(W).apply -in $bbox -sticky new -pady 2
- }
+ grid $S(W).apply -in $bbox -sticky new -pady 2
grid columnconfigure $bbox 0 -weight 1
grid $WE.strike -sticky w -padx 10
@@ -262,15 +295,19 @@
Init $S(-font)
trace add variable [namespace which -variable S](size) \
- write [namespace code [list Tracer]]
+ write [namespace code [list Tracer]]
trace add variable [namespace which -variable S](style) \
- write [namespace code [list Tracer]]
+ write [namespace code [list Tracer]]
trace add variable [namespace which -variable S](font) \
- write [namespace code [list Tracer]]
- } else {
- Init $S(-font)
+ write [namespace code [list Tracer]]
+ trace add variable [namespace which -variable S](strike) \
+ write [namespace code [list Tracer]]
+ trace add variable [namespace which -variable S](under) \
+ write [namespace code [list Tracer]]
}
+ Init $S(-font)
+
return
}
@@ -290,9 +327,14 @@
trace vdelete S(size) w [namespace code [list Tracer]]
trace vdelete S(style) w [namespace code [list Tracer]]
trace vdelete S(font) w [namespace code [list Tracer]]
+ trace vdelete S(strike) w [namespace code [list Tracer]]
+ trace vdelete S(under) w [namespace code [list Tracer]]
destroy $S(W)
- if {$ok && $S(-command) ne ""} {
- uplevel #0 $S(-command) [list $S(result)]
+ if {$ok} {
+ if {$S(-command) ne ""} {
+ uplevel #0 $S(-command) [list $S(result)]
+ }
+ event generate $S(-parent) <<TkFontchooserFontChanged>>
}
}
@@ -322,6 +364,7 @@
variable S
if {$S(first) || $defaultFont ne ""} {
+ Canonical
if {$defaultFont eq ""} {
set defaultFont [[entry .___e] cget -font]
destroy .___e
@@ -328,10 +371,10 @@
}
array set F [font actual $defaultFont]
set S(font) $F(-family)
+ set S(style) [::msgcat::mc "Regular"]
set S(size) $F(-size)
set S(strike) $F(-overstrike)
set S(under) $F(-underline)
- set S(style) [::msgcat::mc "Regular"]
if {$F(-weight) eq "bold" && $F(-slant) eq "italic"} {
set S(style) [::msgcat::mc "Bold Italic"]
} elseif {$F(-weight) eq "bold"} {
@@ -339,12 +382,8 @@
} elseif {$F(-slant) eq "italic"} {
set S(style) [::msgcat::mc "Italic"]
}
-
set S(first) 0
}
-
- Tracer a b c
- Update
}
# ::tk::fontchooser::Click --
@@ -356,7 +395,6 @@
#
proc ::tk::fontchooser::Click {who} {
variable S
-
if {$who eq "font"} {
set S(font) [$S(W).lfonts get [$S(W).lfonts curselection]]
} elseif {$who eq "style"} {
@@ -364,7 +402,6 @@
} elseif {$who eq "size"} {
set S(size) [$S(W).lsizes get [$S(W).lsizes curselection]]
}
- Update
}
# ::tk::fontchooser::Tracer --
@@ -376,32 +413,43 @@
#
proc ::tk::fontchooser::Tracer {var1 var2 op} {
variable S
-
- set bad 0
- set nstate normal
- # Make selection in each listbox
- foreach var {font style size} {
- set value [string tolower $S($var)]
- $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
+ # We don't need to process strike and under
+ if {$var2 ni [list strike under]} {
+ # Make selection in listbox
+ set value [string tolower $S($var2)]
+ $S(W).l${var2}s selection clear 0 end
+ set n [lsearch -exact $S(${var2}s,lcase) $value]
+ $S(W).l${var2}s selection set $n
if {$n >= 0} {
- set S($var) [lindex $S(${var}s) $n]
- $S(W).e$var icursor end
- $S(W).e$var selection clear
- } else { ;# No match, try prefix
- # Size is weird: valid numbers are legal but don't display
- # unless in the font size list
- set n [lsearch -glob $S(${var}s,lcase) "$value*"]
- set bad 1
- if {$var ne "size" || ! [string is double -strict $value]} {
- set nstate disabled
+ set S($var2) [lindex $S(${var2}s) $n]
+ $S(W).e$var2 icursor end
+ $S(W).e$var2 selection clear
+ if {[set i [lsearch $S(bad) $var2]] >= 0} {
+ set S(bad) [lreplace $S(bad) $i $i]
}
+ } else {
+ # No match, try prefix
+ set n [lsearch -glob $S(${var2}s,lcase) "$value*"]
+ if {$var2 ne "size" || !([regexp -- {^(-[0-9]+|[0-9]+)$} $value] && $value >= -4096 && $value <= 4096)} {
+ if {[lsearch $S(bad) $var2] < 0} {
+ lappend S(bad) $var2
+ }
+ } else {
+ if {[set i [lsearch $S(bad) $var2]] >= 0} {
+ set S(bad) [lreplace $S(bad) $i $i]
+ }
+ }
}
- $S(W).l${var}s see $n
+ $S(W).l${var2}s see $n
}
- if {!$bad} {Update}
- $S(W).ok configure -state $nstate
+ if {[llength $S(bad)] == 0} {
+ set S(nstate) normal
+ Update
+ } else {
+ set S(nstate) disabled
+ }
+ $S(W).ok configure -state $S(nstate)
+ $S(W).apply configure -state $S(nstate)
}
# ::tk::fontchooser::Update --
@@ -412,13 +460,24 @@
variable S
set S(result) [list $S(font) $S(size)]
- 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}
+ 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)
+ set S(-font) $S(result)
}
# ::tk::fontchooser::Visibility --
@@ -432,7 +491,7 @@
}
}
-# ::tk::fontchooser::ttk_listbox --
+# ::tk::fontchooser::ttk_slistbox --
#
# Create a properly themed scrolled listbox.
# This is exactly right on XP but may need adjusting on other platforms.
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/iconlist.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/iconlist.tcl 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/iconlist.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -338,8 +338,8 @@
set i_dy [expr {($dy - $iH)/2}]
set t_dy [expr {($dy - $tH)/2}]
- $canvas coords $iTag $x [expr {$y + $i_dy}]
- $canvas coords $tTag [expr {$x + $shift}] [expr {$y + $t_dy}]
+ $canvas coords $iTag $x [expr {$y + $i_dy}]
+ $canvas coords $tTag [expr {$x + $shift}] [expr {$y + $t_dy}]
$canvas coords $rTag $x $y [expr {$x+$dx}] [expr {$y+$dy}]
incr y $dy
@@ -433,11 +433,11 @@
#
bind $canvas <Configure> [namespace code {my WhenIdle Arrange}]
- bind $canvas <1> [namespace code {my Btn1 %x %y}]
+ bind $canvas <Button-1> [namespace code {my Btn1 %x %y}]
bind $canvas <B1-Motion> [namespace code {my Motion1 %x %y}]
bind $canvas <B1-Leave> [namespace code {my Leave1 %x %y}]
- bind $canvas <Control-1> [namespace code {my CtrlBtn1 %x %y}]
- bind $canvas <Shift-1> [namespace code {my ShiftBtn1 %x %y}]
+ bind $canvas <Control-Button-1> [namespace code {my CtrlBtn1 %x %y}]
+ bind $canvas <Shift-Button-1> [namespace code {my ShiftBtn1 %x %y}]
bind $canvas <B1-Enter> [list tk::CancelRepeat]
bind $canvas <ButtonRelease-1> [list tk::CancelRepeat]
bind $canvas <Double-ButtonRelease-1> \
@@ -449,12 +449,14 @@
if {[tk windowingsystem] eq "aqua"} {
bind $canvas <Shift-MouseWheel> [namespace code {my MouseWheel [expr {40 * (%D)}]}]
bind $canvas <Option-Shift-MouseWheel> [namespace code {my MouseWheel [expr {400 * (%D)}]}]
+ bind $canvas <Command-Key> {# nothing}
+ bind $canvas <Mod4-Key> {# nothing}
} else {
bind $canvas <Shift-MouseWheel> [namespace code {my MouseWheel %D}]
}
if {[tk windowingsystem] eq "x11"} {
- bind $canvas <Shift-4> [namespace code {my MouseWheel 120}]
- bind $canvas <Shift-5> [namespace code {my MouseWheel -120}]
+ bind $canvas <Shift-Button-4> [namespace code {my MouseWheel 120}]
+ bind $canvas <Shift-Button-5> [namespace code {my MouseWheel -120}]
}
bind $canvas <<PrevLine>> [namespace code {my UpDown -1}]
@@ -462,9 +464,10 @@
bind $canvas <<PrevChar>> [namespace code {my LeftRight -1}]
bind $canvas <<NextChar>> [namespace code {my LeftRight 1}]
bind $canvas <Return> [namespace code {my ReturnKey}]
- bind $canvas <KeyPress> [namespace code {my KeyPress %A}]
- bind $canvas <Control-KeyPress> ";"
- bind $canvas <Alt-KeyPress> ";"
+ bind $canvas <Key> [namespace code {my KeyPress %A}]
+ bind $canvas <Alt-Key> {# nothing}
+ bind $canvas <Meta-Key> {# nothing}
+ bind $canvas <Control-Key> {# nothing}
bind $canvas <FocusIn> [namespace code {my FocusIn}]
bind $canvas <FocusOut> [namespace code {my FocusOut}]
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/menu.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/menu.tcl 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/menu.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -168,7 +168,7 @@
bind Menu <<NextLine>> {
tk::MenuDownArrow %W
}
-bind Menu <KeyPress> {
+bind Menu <Key> {
tk::TraverseWithinMenu %W %A
break
}
@@ -177,7 +177,7 @@
# implement keyboard menu traversal.
if {[tk windowingsystem] eq "x11"} {
- bind all <Alt-KeyPress> {
+ bind all <Alt-Key> {
tk::TraverseToMenu %W %A
}
@@ -185,7 +185,7 @@
tk::FirstMenu %W
}
} else {
- bind Menubutton <Alt-KeyPress> {
+ bind Menubutton <Alt-Key> {
tk::TraverseToMenu %W %A
}
@@ -285,7 +285,7 @@
GenerateMenuSelect $menu
update idletasks
- if {[catch {PostMenubuttonMenu $w $menu} msg opt]} {
+ if {[catch {PostMenubuttonMenu $w $menu $x $y} msg opt]} {
# Error posting menu (e.g. bogus -postcommand). Unpost it and
# reflect the error.
MenuUnpost {}
@@ -1138,7 +1138,7 @@
# side. On other platforms the entry is centered over the button.
if {[tk windowingsystem] eq "aqua"} {
- proc ::tk::PostMenubuttonMenu {button menu} {
+ proc ::tk::PostMenubuttonMenu {button menu cx cy} {
set entry ""
if {[$button cget -indicatoron]} {
set entry [MenuFindName $menu [$button cget -text]]
@@ -1163,7 +1163,7 @@
right {
incr x [winfo width $button]
}
- default {
+ default { # flush
incr x [expr {[winfo width $button] - [winfo reqwidth $menu] - 5}]
}
}
@@ -1170,7 +1170,7 @@
PostOverPoint $menu $x $y $entry
}
} else {
- proc ::tk::PostMenubuttonMenu {button menu} {
+ proc ::tk::PostMenubuttonMenu {button menu cx cy} {
set entry ""
if {[$button cget -indicatoron]} {
set entry [MenuFindName $menu [$button cget -text]]
@@ -1201,22 +1201,24 @@
set entry {}
}
left {
- # It is not clear why this is needed.
- if {[tk windowingsystem] eq "win32"} {
- incr x [expr {-4 - [winfo reqwidth $button] / 2}]
- }
incr x [expr {- [winfo reqwidth $menu]}]
}
right {
incr x [expr {[winfo width $button]}]
}
- default {
- if {[$button cget -indicatoron]} {
- incr x [expr {([winfo width $button] - \
- [winfo reqwidth $menu])/ 2}]
- } else {
- incr y [winfo height $button]
- }
+ default { # flush
+ if {[$button cget -indicatoron]} {
+ if {$cx ne ""} {
+ set x [expr {$cx - [winfo reqwidth $menu] / 2}]
+ set l [font metrics [$menu cget -font] -linespace]
+ set y [expr {$cy - $l/2 - 2}]
+ } else {
+ incr x [expr {([winfo width $button] - \
+ [winfo reqwidth $menu])/ 2}]
+ }
+ } else {
+ incr y [winfo height $button]
+ }
}
}
PostOverPoint $menu $x $y $entry
@@ -1242,7 +1244,8 @@
proc ::tk::PostOverPoint {menu x y {entry {}}} {
if {$entry ne ""} {
$menu post $x $y $entry
- if {[$menu entrycget $entry -state] ne "disabled"} {
+ if {[$menu type $entry] ni {separator tearoff} &&
+ [$menu entrycget $entry -state] ne "disabled"} {
$menu activate $entry
GenerateMenuSelect $menu
}
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/msgs/eo.msg
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/msgs/eo.msg 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/msgs/eo.msg 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,20 +1,20 @@
namespace eval ::tk {
- ::msgcat::mcset eo "&Abort" "&\u0108esigo"
+ ::msgcat::mcset eo "&Abort" "&\u0108esigu"
::msgcat::mcset eo "&About..." "Pri..."
- ::msgcat::mcset eo "All Files" "\u0108ioj dosieroj"
- ::msgcat::mcset eo "Application Error" "Aplikoerraro"
+ ::msgcat::mcset eo "All Files" "\u0108iuj dosieroj"
+ ::msgcat::mcset eo "Application Error" "Aplikoeraro"
::msgcat::mcset eo "&Blue" "&Blua"
::msgcat::mcset eo "Cancel" "Rezignu"
::msgcat::mcset eo "&Cancel" "&Rezignu"
- ::msgcat::mcset eo "Cannot change to the directory \"%1\$s\".\nPermission denied." "Neeble \u0109angi al dosierulon \"%1\$s\".\nVi ne rajtas tion."
- ::msgcat::mcset eo "Choose Directory" "Elektu Dosierujo"
- ::msgcat::mcset eo "Cl&ear" "&Klaru"
- ::msgcat::mcset eo "&Clear Console" "&Klaru konzolon"
- ::msgcat::mcset eo "Color" "Farbo"
+ ::msgcat::mcset eo "Cannot change to the directory \"%1\$s\".\nPermission denied." "Neeble \u015dan\u011di al dosierujo \"%1\$s\".\nVi ne rajtas tion."
+ ::msgcat::mcset eo "Choose Directory" "Elektu Dosierujon"
+ ::msgcat::mcset eo "Cl&ear" "&Vakigu"
+ ::msgcat::mcset eo "&Clear Console" "&Vakigu konzolon"
+ ::msgcat::mcset eo "Color" "Koloro"
::msgcat::mcset eo "Console" "Konzolo"
::msgcat::mcset eo "&Copy" "&Kopiu"
- ::msgcat::mcset eo "Cu&t" "&Enpo\u015digu"
- ::msgcat::mcset eo "&Delete" "&Forprenu"
+ ::msgcat::mcset eo "Cu&t" "&Eltondu"
+ ::msgcat::mcset eo "&Delete" "&Forigu"
::msgcat::mcset eo "Details >>" "Detaloj >>"
::msgcat::mcset eo "Directory \"%1\$s\" does not exist." "La dosierujo \"%1\$s\" ne ekzistas."
::msgcat::mcset eo "&Directory:" "&Dosierujo:"
@@ -22,12 +22,12 @@
::msgcat::mcset eo "Error: %1\$s" "Eraro: %1\$s"
::msgcat::mcset eo "E&xit" "&Eliru"
::msgcat::mcset eo "&File" "&Dosiero"
- ::msgcat::mcset eo "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "La dosiero \"%1\$s\" jam ekzistas.\n\u0108u vi volas anstata\u00fbigi la dosieron?"
- ::msgcat::mcset eo "File \"%1\$s\" already exists.\n\n" "La dosiero \"%1\$s\" jam egzistas. \n\n"
- ::msgcat::mcset eo "File \"%1\$s\" does not exist." "La dosierp \"%1\$s\" ne estas."
+ ::msgcat::mcset eo "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "La dosiero \"%1\$s\" jam ekzistas.\n\u0108u vi volas anstata\u016digi la dosieron?"
+ ::msgcat::mcset eo "File \"%1\$s\" already exists.\n\n" "La dosiero \"%1\$s\" jam ekzistas. \n\n"
+ ::msgcat::mcset eo "File \"%1\$s\" does not exist." "La dosiero \"%1\$s\" ne ekzistas."
::msgcat::mcset eo "File &name:" "Dosiero&nomo:"
::msgcat::mcset eo "File &names:" "Dosiero&nomoj:"
- ::msgcat::mcset eo "Files of &type:" "Dosieroj de &Typo:"
+ ::msgcat::mcset eo "Files of &type:" "Dosieroj de &Tipo:"
::msgcat::mcset eo "Fi&les:" "Do&sieroj:"
::msgcat::mcset eo "&Filter" "&Filtrilo"
::msgcat::mcset eo "Fil&ter:" "&Filtrilo:"
@@ -37,39 +37,39 @@
::msgcat::mcset eo "&Hide Console" "&Ka\u015du konzolon"
::msgcat::mcset eo "&Ignore" "&Ignoru"
::msgcat::mcset eo "Invalid file name \"%1\$s\"." "Malvalida dosieronomo \"%1\$s\"."
- ::msgcat::mcset eo "Log Files" "Protokolo"
+ ::msgcat::mcset eo "Log Files" "Protokolaj dosieroj"
::msgcat::mcset eo "&No" "&Ne"
- ::msgcat::mcset eo "&OK"
- ::msgcat::mcset eo "OK"
- ::msgcat::mcset eo "Ok"
+ ::msgcat::mcset eo "&OK" "&Bone"
+ ::msgcat::mcset eo "OK" "Bone"
+ ::msgcat::mcset eo "Ok" "Bone"
::msgcat::mcset eo "Open" "Malfermu"
::msgcat::mcset eo "&Open" "&Malfermu"
- ::msgcat::mcset eo "Open Multiple Files" "Melfermu multan dosierojn"
- ::msgcat::mcset eo "P&aste" "&Elpo\u015digi"
- ::msgcat::mcset eo "&Quit" "&Finigu"
- ::msgcat::mcset eo "&Red" "&Rosa"
- ::msgcat::mcset eo "Replace existing file?" "\u0108u anstata\u00fbu ekzistantan dosieron?"
- ::msgcat::mcset eo "&Retry" "&Ripetu"
- ::msgcat::mcset eo "&Save" "&Savu"
- ::msgcat::mcset eo "Save As" "Savu kiel"
- ::msgcat::mcset eo "Save To Log" "Savu en protokolon"
+ ::msgcat::mcset eo "Open Multiple Files" "Malfermu plurajn dosierojn"
+ ::msgcat::mcset eo "P&aste" "&Algluu"
+ ::msgcat::mcset eo "&Quit" "&Forlasu"
+ ::msgcat::mcset eo "&Red" "&Ru\u011da"
+ ::msgcat::mcset eo "Replace existing file?" "\u0108u anstata\u016digi ekzistantan dosieron?"
+ ::msgcat::mcset eo "&Retry" "&Reprovu"
+ ::msgcat::mcset eo "&Save" "&Konservu"
+ ::msgcat::mcset eo "Save As" "Konservu kiel"
+ ::msgcat::mcset eo "Save To Log" "Konservu en protokolon"
::msgcat::mcset eo "Select Log File" "Elektu prokolodosieron"
::msgcat::mcset eo "Select a file to source" "Elektu dosieron por interpreti"
::msgcat::mcset eo "&Selection:" "&Elekto:"
- ::msgcat::mcset eo "Skip Messages" "transsaltu pluajn mesa\u011dojn"
+ ::msgcat::mcset eo "Skip Messages" "transsaltu mesa\u011dojn"
::msgcat::mcset eo "&Source..." "&Fontoprogramo..."
::msgcat::mcset eo "Tcl Scripts" "Tcl-skriptoj"
- ::msgcat::mcset eo "Tcl for Windows" "Tcl por vindoso"
- ::msgcat::mcset eo "Text Files" "Tekstodosierojn"
+ ::msgcat::mcset eo "Tcl for Windows" "Tcl por Vindozo"
+ ::msgcat::mcset eo "Text Files" "Tekstodosieroj"
::msgcat::mcset eo "&Yes" "&Jes"
- ::msgcat::mcset eo "abort" "\u0109esigo"
+ ::msgcat::mcset eo "abort" "\u0109esigu"
::msgcat::mcset eo "blue" "blua"
::msgcat::mcset eo "cancel" "rezignu"
- ::msgcat::mcset eo "extension" "ekspansio"
- ::msgcat::mcset eo "extensions" "ekspansioj"
+ ::msgcat::mcset eo "extension" "kromprogramo"
+ ::msgcat::mcset eo "extensions" "kromprogramoj"
::msgcat::mcset eo "green" "verda"
- ::msgcat::mcset eo "ignore" "ignorieren"
+ ::msgcat::mcset eo "ignore" "ignoru"
::msgcat::mcset eo "red" "ru\u011da"
- ::msgcat::mcset eo "retry" "ripetu"
+ ::msgcat::mcset eo "retry" "reprovu"
::msgcat::mcset eo "yes" "jes"
}
Added: trunk/Master/tlpkg/tltcl/lib/tk8.6/msgs/fi.msg
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/msgs/fi.msg (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/msgs/fi.msg 2024-02-15 21:05:12 UTC (rev 69897)
@@ -0,0 +1,89 @@
+namespace eval ::tk {
+ ::msgcat::mcset fi "&Abort" "&Keskeyt\u00e4"
+ ::msgcat::mcset fi "&About..." "&Tietoja..."
+ ::msgcat::mcset fi "All Files" "Kaikki tiedostot"
+ ::msgcat::mcset fi "Application Error" "Ohjelmavirhe"
+ ::msgcat::mcset fi "&Apply" "K\u00e4&yt\u00e4"
+ ::msgcat::mcset fi "Bold" "Lihavoitu"
+ ::msgcat::mcset fi "Bold Italic" "Lihavoitu, kursivoitu"
+ ::msgcat::mcset fi "&Blue" "&Sininen"
+ ::msgcat::mcset fi "Cancel" "Peruuta"
+ ::msgcat::mcset fi "&Cancel" "&Peruuta"
+ ::msgcat::mcset fi "Cannot change to the directory \"%1\$s\".\nPermission denied." "Ei voitu vaihtaa hakemistoon \"%1\$s\".\nLupa ev\u00e4tty."
+ ::msgcat::mcset fi "Choose Directory" "Valitse hakemisto"
+ ::msgcat::mcset fi "Cl&ear" "&Tyhjenn\u00e4"
+ ::msgcat::mcset fi "&Clear Console" "&Tyhjenn\u00e4 konsoli"
+ ::msgcat::mcset fi "Color" "V\u00e4ri"
+ ::msgcat::mcset fi "Console" "Konsoli"
+ ::msgcat::mcset fi "&Copy" "K&opioi"
+ ::msgcat::mcset fi "Cu&t" "&Leikkaa"
+ ::msgcat::mcset fi "&Delete" "&Poista"
+ ::msgcat::mcset fi "Details >>" "Lis\u00e4tiedot >>"
+ ::msgcat::mcset fi "Directory \"%1\$s\" does not exist." "Hakemistoa \"%1\$s\" ei ole olemassa."
+ ::msgcat::mcset fi "&Directory:" "&Hakemisto:"
+ ::msgcat::mcset fi "&Edit" "&Muokkaa"
+ ::msgcat::mcset fi "Effects" "Tehosteet"
+ ::msgcat::mcset fi "Error: %1\$s" "Virhe: %1\$s"
+ ::msgcat::mcset fi "E&xit" "&Lopeta"
+ ::msgcat::mcset fi "&File" "&Tiedosto"
+ ::msgcat::mcset fi "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "Tiedosto \"%1\$s\" on jo olemassa.\nHaluatko korvata sen?"
+ ::msgcat::mcset fi "File \"%1\$s\" already exists.\n\n" "Tiedosto \"%1\$s\" on jo olemassa.\n\n"
+ ::msgcat::mcset fi "File \"%1\$s\" does not exist." "Tiedostoa \"%1\$s\" ei ole olemassa."
+ ::msgcat::mcset fi "File &name:" "Tiedosto&nimi:"
+ ::msgcat::mcset fi "File &names:" "Tiedosto&nimet:"
+ ::msgcat::mcset fi "Files of &type:" "T&yyppi:"
+ ::msgcat::mcset fi "Fi&les:" "Ti&edostot:"
+ ::msgcat::mcset fi "&Filter" "&Suodata"
+ ::msgcat::mcset fi "Fil&ter:" "Suo&data:"
+ ::msgcat::mcset fi "Font" "Kirjasin"
+ ::msgcat::mcset fi "&Font:" "&Kirjasin:"
+ ::msgcat::mcset fi "Font st&yle:" "Kirjasint&yyli:"
+ ::msgcat::mcset fi "&Green" "&Vihre\u00e4"
+ ::msgcat::mcset fi "&Help" "&Ohje"
+ ::msgcat::mcset fi "Hi" "Hei"
+ ::msgcat::mcset fi "&Hide Console" "P&iilota konsoli"
+ ::msgcat::mcset fi "&Ignore" "&Ohita"
+ ::msgcat::mcset fi "Invalid file name \"%1\$s\"." "Virheellinen tiedostonimi \"%1\$s\"."
+ ::msgcat::mcset fi "Italic" "Kursivoitu"
+ ::msgcat::mcset fi "Log Files" "Lokitiedostot"
+ ::msgcat::mcset fi "&No" "&Ei"
+ ::msgcat::mcset fi "&OK"
+ ::msgcat::mcset fi "OK"
+ ::msgcat::mcset fi "Ok" "OK"
+ ::msgcat::mcset fi "Open" "Avaa"
+ ::msgcat::mcset fi "&Open" "&Avaa"
+ ::msgcat::mcset fi "Open Multiple Files" "Avaa monta tiedostoa"
+ ::msgcat::mcset fi "P&aste" "L&iit\u00e4"
+ ::msgcat::mcset fi "&Quit" "&Lopeta"
+ ::msgcat::mcset fi "&Red" "&Punainen"
+ ::msgcat::mcset fi "Regular" "Tavallinen"
+ ::msgcat::mcset fi "Replace existing file?" "Korvataanko olemassaoleva tiedosto?"
+ ::msgcat::mcset fi "&Retry" "&Yrit\u00e4 uudelleen"
+ ::msgcat::mcset fi "Sample" "Malli"
+ ::msgcat::mcset fi "&Save" "&Tallenna"
+ ::msgcat::mcset fi "Save As" "Tallenna nimell\u00e4"
+ ::msgcat::mcset fi "Save To Log" "Tallenna lokiin"
+ ::msgcat::mcset fi "Select Log File" "Valitse lokitiedosto"
+ ::msgcat::mcset fi "Select a file to source" "Valitse l\u00e4hdetiedosto"
+ ::msgcat::mcset fi "&Selection:" "&Valinta:"
+ ::msgcat::mcset fi "&Size:" "K&oko:"
+ ::msgcat::mcset fi "Skip Messages" "J\u00e4t\u00e4 viestit huomiotta"
+ ::msgcat::mcset fi "&Source..." "L&\u00e4hde..."
+ ::msgcat::mcset fi "Stri&keout" "&Yliviivaa"
+ ::msgcat::mcset fi "Tcl Scripts" "Tcl-skriptit"
+ ::msgcat::mcset fi "Tcl for Windows" "Tcl Windowsille"
+ ::msgcat::mcset fi "Text Files" "Tekstitiedostot"
+ ::msgcat::mcset fi "&Underline" "&Alleviivaa"
+ ::msgcat::mcset fi "&Yes" "&Kyll\u00e4"
+ ::msgcat::mcset fi "abort" "keskeyt\u00e4"
+ ::msgcat::mcset fi "blue" "sininen"
+ ::msgcat::mcset fi "cancel" "peruuta"
+ ::msgcat::mcset fi "extension" "lis\u00e4osa"
+ ::msgcat::mcset fi "extensions" "lis\u00e4osat"
+ ::msgcat::mcset fi "green" "vihre\u00e4"
+ ::msgcat::mcset fi "ignore" "ohita"
+ ::msgcat::mcset fi "ok"
+ ::msgcat::mcset fi "red" "punainen"
+ ::msgcat::mcset fi "retry" "yrit\u00e4 uudelleen"
+ ::msgcat::mcset fi "yes" "kyll\u00e4"
+}
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk8.6/msgs/fi.msg
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/msgs/ru.msg
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/msgs/ru.msg 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/msgs/ru.msg 2024-02-15 21:05:12 UTC (rev 69897)
@@ -3,13 +3,17 @@
::msgcat::mcset ru "&About..." "\u041f\u0440\u043e..."
::msgcat::mcset ru "All Files" "\u0412\u0441\u0435 \u0444\u0430\u0439\u043b\u044b"
::msgcat::mcset ru "Application Error" "\u041e\u0448\u0438\u0431\u043a\u0430 \u0432 \u043f\u0440\u043e\u0433\u0440\u0430\u043c\u043c\u0435"
+ ::msgcat::mcset ru "&Apply" "&\u041f\u0440\u0438\u043c\u0435\u043d\u0438\u0442\u044c"
+ ::msgcat::mcset ru "Bold" "Bold"
+ ::msgcat::mcset ru "Bold Italic" "Bold Italic"
::msgcat::mcset ru "&Blue" " &\u0413\u043e\u043b\u0443\u0431\u043e\u0439"
- ::msgcat::mcset ru "Cancel" "\u041e\u0442&\u043c\u0435\u043d\u0430"
+ ::msgcat::mcset ru "Cancel" "\u041e\u0442\u043c\u0435\u043d\u0430"
::msgcat::mcset ru "&Cancel" "\u041e\u0442&\u043c\u0435\u043d\u0430"
::msgcat::mcset ru "Cannot change to the directory \"%1\$s\".\nPermission denied." \
"\u041d\u0435 \u043c\u043e\u0433\u0443 \u043f\u0435\u0440\u0435\u0439\u0442\u0438 \u0432 \u043a\u0430\u0442\u0430\u043b\u043e\u0433 \"%1\$s\".\n\u041d\u0435\u0434\u043e\u0441\u0442\u0430\u0442\u043e\u0447\u043d\u043e \u043f\u0440\u0430\u0432 \u0434\u043e\u0441\u0442\u0443\u043f\u0430"
::msgcat::mcset ru "Choose Directory" "\u0412\u044b\u0431\u0435\u0440\u0438\u0442\u0435 \u043a\u0430\u0442\u0430\u043b\u043e\u0433"
::msgcat::mcset ru "Cl&ear" "\u041e\u0447\u0438\u0441\u0442\u0438\u0442\u044c"
+ ::msgcat::mcset ru "&Clear Console" "&Clear Console"
::msgcat::mcset ru "Color" "\u0426\u0432\u0435\u0442"
::msgcat::mcset ru "Console" "\u041a\u043e\u043d\u0441\u043e\u043b\u044c"
::msgcat::mcset ru "&Copy" "\u041a\u043e\u043f\u0438\u0440\u043e\u0432\u0430\u0442\u044c"
@@ -18,8 +22,11 @@
::msgcat::mcset ru "Details >>" "\u041f\u043e\u0434\u0440\u043e\u0431\u043d\u0435\u0435 >>"
::msgcat::mcset ru "Directory \"%1\$s\" does not exist." "\u041a\u0430\u0442\u0430\u043b\u043e\u0433\u0430 \"%1\$s\" \u043d\u0435 \u0441\u0443\u0449\u0435\u0441\u0442\u0432\u0443\u0435\u0442."
::msgcat::mcset ru "&Directory:" "&\u041a\u0430\u0442\u0430\u043b\u043e\u0433:"
+ ::msgcat::mcset ru "&Edit" "&Edit"
+ ::msgcat::mcset ru "Effects" "\u042d\u0444\u0444\u0435\u043a\u0442\u044b"
::msgcat::mcset ru "Error: %1\$s" "\u041e\u0448\u0438\u0431\u043a\u0430: %1\$s"
::msgcat::mcset ru "E&xit" "\u0412\u044b\u0445\u043e\u0434"
+ ::msgcat::mcset ru "&File" "&File"
::msgcat::mcset ru "File \"%1\$s\" already exists.\nDo you want to overwrite it?" \
"\u0424\u0430\u0439\u043b \"%1\$s\" \u0443\u0436\u0435 \u0441\u0443\u0449\u0435\u0441\u0442\u0432\u0443\u0435\u0442.\n\u0417\u0430\u043c\u0435\u043d\u0438\u0442\u044c \u0435\u0433\u043e?"
::msgcat::mcset ru "File \"%1\$s\" already exists.\n\n" "\u0424\u0430\u0439\u043b \"%1\$s\" \u0443\u0436\u0435 \u0441\u0443\u0449\u0435\u0441\u0442\u0432\u0443\u0435\u0442.\n\n"
@@ -30,11 +37,16 @@
::msgcat::mcset ru "Fi&les:" "\u0424\u0430\u0439&\u043b\u044b:"
::msgcat::mcset ru "&Filter" "&\u0424\u0438\u043b\u044c\u0442\u0440"
::msgcat::mcset ru "Fil&ter:" "\u0424\u0438\u043b\u044c&\u0442\u0440:"
+ ::msgcat::mcset ru "Font" "\u0428\u0440\u0438\u0444\u0442"
+ ::msgcat::mcset ru "&Font:" "&\u0428\u0440\u0438\u0444\u0442"
+ ::msgcat::mcset ru "Font st&yle:" "&\u0421\u0442\u0438\u043b\u044c \u0448\u0440\u0438\u0444\u0442\u0430:"
::msgcat::mcset ru "&Green" " &\u0417\u0435\u043b\u0435\u043d\u044b\u0439"
+ ::msgcat::mcset ru "&Help" "&Help"
::msgcat::mcset ru "Hi" "\u041f\u0440\u0438\u0432\u0435\u0442"
::msgcat::mcset ru "&Hide Console" "\u0421\u043f\u0440\u044f\u0442\u0430\u0442\u044c \u043a\u043e\u043d\u0441\u043e\u043b\u044c"
::msgcat::mcset ru "&Ignore" "&\u0418\u0433\u043d\u043e\u0440\u0438\u0440\u043e\u0432\u0430\u0442\u044c"
::msgcat::mcset ru "Invalid file name \"%1\$s\"." "\u041d\u0435\u0432\u0435\u0440\u043d\u043e\u0435 \u0438\u043c\u044f \u0444\u0430\u0439\u043b\u0430 \"%1\$s\"."
+ ::msgcat::mcset ru "Italic" "Italic"
::msgcat::mcset ru "Log Files" "\u0424\u0430\u0439\u043b\u044b \u0436\u0443\u0440\u043d\u0430\u043b\u0430"
::msgcat::mcset ru "&No" "&\u041d\u0435\u0442"
::msgcat::mcset ru "&OK" "&\u041e\u041a"
@@ -46,19 +58,26 @@
::msgcat::mcset ru "P&aste" "\u0412\u0441\u0442\u0430\u0432\u0438\u0442\u044c"
::msgcat::mcset ru "&Quit" "\u0412\u044b\u0445\u043e\u0434"
::msgcat::mcset ru "&Red" " &\u041a\u0440\u0430\u0441\u043d\u044b\u0439"
+ ::msgcat::mcset ru "Regular" "Regular"
::msgcat::mcset ru "Replace existing file?" "\u0417\u0430\u043c\u0435\u043d\u0438\u0442\u044c \u0441\u0443\u0449\u0435\u0441\u0442\u0432\u0443\u044e\u0449\u0438\u0439 \u0444\u0430\u0439\u043b?"
::msgcat::mcset ru "&Retry" "&\u041f\u043e\u0432\u0442\u043e\u0440\u0438\u0442\u044c"
+ ::msgcat::mcset ru "Sample" "\u041f\u0440\u0438\u043c\u0435\u0440"
::msgcat::mcset ru "&Save" "&\u0421\u043e\u0445\u0440\u0430\u043d\u0438\u0442\u044c"
::msgcat::mcset ru "Save As" "\u0421\u043e\u0445\u0440\u0430\u043d\u0438\u0442\u044c \u043a\u0430\u043a"
::msgcat::mcset ru "Save To Log" "\u0421\u043e\u0445\u0440\u0430\u043d\u0438\u0442\u044c \u0432 \u0436\u0443\u0440\u043d\u0430\u043b"
::msgcat::mcset ru "Select Log File" "\u0412\u044b\u0431\u0440\u0430\u0442\u044c \u0436\u0443\u0440\u043d\u0430\u043b"
::msgcat::mcset ru "Select a file to source" "\u0412\u044b\u0431\u0435\u0440\u0438\u0442\u0435 \u0444\u0430\u0439\u043b \u0434\u043b\u044f \u0438\u043d\u0442\u0435\u0440\u043f\u0440\u0435\u0442\u0430\u0446\u0438\u0438"
- ::msgcat::mcset ru "&Selection:"
+ ::msgcat::mcset ru "&Selection:" "&Selection:"
+ ::msgcat::mcset ru "&Size:" "&\u0420\u0430\u0437\u043c\u0435\u0440:"
+ ::msgcat::mcset ru "Show &Hidden Directories" "Show &Hidden Directories"
+ ::msgcat::mcset ru "Show &Hidden Files and Directories" "Show &Hidden Files and Directories"
::msgcat::mcset ru "Skip Messages" "\u041f\u0440\u043e\u043f\u0443\u0441\u0442\u0438\u0442\u044c \u0441\u043e\u043e\u0431\u0449\u0435\u043d\u0438\u044f"
::msgcat::mcset ru "&Source..." "\u0418\u043d\u0442\u0435\u0440\u043f\u0440\u0435\u0442\u0438\u0440\u043e\u0432\u0430\u0442\u044c \u0444\u0430\u0439\u043b..."
+ ::msgcat::mcset ru "Stri&keout" "\u041f&\u0435\u0440\u0435\u0447\u0451\u0440\u043a\u043d\u0443\u0442\u044b\u0439"
::msgcat::mcset ru "Tcl Scripts" "\u041f\u0440\u043e\u0433\u0440\u0430\u043c\u043c\u0430 \u043d\u0430 \u044f\u0437\u044b\u043a\u0435 TCL"
::msgcat::mcset ru "Tcl for Windows" "TCL \u0434\u043b\u044f Windows"
::msgcat::mcset ru "Text Files" "\u0422\u0435\u043a\u0441\u0442\u043e\u0432\u044b\u0435 \u0444\u0430\u0439\u043b\u044b"
+ ::msgcat::mcset ru "&Underline" "\u041f\u043e&\u0434\u0447\u0435\u0440\u043a\u043d\u0443\u0442\u044b\u0439"
::msgcat::mcset ru "&Yes" "&\u0414\u0430"
::msgcat::mcset ru "abort" "\u043e\u0442\u043c\u0435\u043d\u0430"
::msgcat::mcset ru "blue" " \u0433\u043e\u043b\u0443\u0431\u043e\u0439"
@@ -72,4 +91,3 @@
::msgcat::mcset ru "retry" "\u043f\u043e\u0432\u0442\u043e\u0440\u0438\u0442\u044c"
::msgcat::mcset ru "yes" "\u0434\u0430"
}
-
Added: trunk/Master/tlpkg/tltcl/lib/tk8.6/msgs/zh_cn.msg
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/msgs/zh_cn.msg (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/msgs/zh_cn.msg 2024-02-15 21:05:12 UTC (rev 69897)
@@ -0,0 +1,92 @@
+namespace eval ::tk {
+ ::msgcat::mcset zh_cn "&Abort" "&中止"
+ ::msgcat::mcset zh_cn "&About..." "&关于……"
+ ::msgcat::mcset zh_cn "All Files" "所有文件"
+ ::msgcat::mcset zh_cn "Application Error" "应用程序错误"
+ ::msgcat::mcset zh_cn "&Apply" "&添加"
+ ::msgcat::mcset zh_cn "Bold" "粗体"
+ ::msgcat::mcset zh_cn "Bold Italic" "加粗斜体"
+ ::msgcat::mcset zh_cn "&Blue" "&蓝色"
+ ::msgcat::mcset zh_cn "Cancel" "取消"
+ ::msgcat::mcset zh_cn "&Cancel" "&取消"
+ ::msgcat::mcset zh_cn "Cannot change to the directory \"%1\$s\".\nPermission denied." "无法更改目录 \"%1\$s\"。\n访问被拒绝。"
+ ::msgcat::mcset zh_cn "Choose Directory" "选择文件夹"
+ ::msgcat::mcset zh_cn "Cl&ear" "清&除"
+ ::msgcat::mcset zh_cn "&Clear Console" "&清除终端"
+ ::msgcat::mcset zh_cn "Color" "颜色"
+ ::msgcat::mcset zh_cn "Console" "终端"
+ ::msgcat::mcset zh_cn "&Copy" "&复制"
+ ::msgcat::mcset zh_cn "Cu&t" "剪&切"
+ ::msgcat::mcset zh_cn "&Delete" "&删除"
+ ::msgcat::mcset zh_cn "Details >>" "详细信息 >>"
+ ::msgcat::mcset zh_cn "Directory \"%1\$s\" does not exist." "目录 \"%1\$s\" 不存在。"
+ ::msgcat::mcset zh_cn "&Directory:" "&目录："
+ ::msgcat::mcset zh_cn "&Edit" "&编辑"
+ ::msgcat::mcset zh_cn "Effects" "效果"
+ ::msgcat::mcset zh_cn "Error: %1\$s" "错误： %1\$s"
+ ::msgcat::mcset zh_cn "E&xit" "退&出"
+ ::msgcat::mcset zh_cn "&File" "&文件"
+ ::msgcat::mcset zh_cn "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "文件 \"%1\$s\" 已经存在。\n您想要覆盖它吗？"
+ ::msgcat::mcset zh_cn "File \"%1\$s\" already exists.\n\n" "文件 \"%1\$s\" 已经存在。\n\n"
+ ::msgcat::mcset zh_cn "File \"%1\$s\" does not exist." "文件 \"%1\$s\" 不存在。"
+ ::msgcat::mcset zh_cn "File &name:" "文件&名："
+ ::msgcat::mcset zh_cn "File &names:" "文件&名："
+ ::msgcat::mcset zh_cn "Files of &type:" "文件&类型："
+ ::msgcat::mcset zh_cn "Fi&les:" "文&件："
+ ::msgcat::mcset zh_cn "&Filter" "&过滤"
+ ::msgcat::mcset zh_cn "Fil&ter:" "过&滤："
+ ::msgcat::mcset zh_cn "Font" "字体"
+ ::msgcat::mcset zh_cn "&Font:" "&字体："
+ ::msgcat::mcset zh_cn "Font st&yle:" "字体&样式："
+ ::msgcat::mcset zh_cn "&Green" "&绿色"
+ ::msgcat::mcset zh_cn "&Help" "&帮助"
+ ::msgcat::mcset zh_cn "Hi" "你好"
+ ::msgcat::mcset zh_cn "&Hide Console" "&隐藏终端"
+ ::msgcat::mcset zh_cn "&Ignore" "&忽略"
+ ::msgcat::mcset zh_cn "Invalid file name \"%1\$s\"." "无效的文件名 \"%1\$s\"。"
+ ::msgcat::mcset zh_cn "Italic" "斜体"
+ ::msgcat::mcset zh_cn "Log Files" "日志文件"
+ ::msgcat::mcset zh_cn "&No" "&取消"
+ ::msgcat::mcset zh_cn "&OK" "&确定"
+ ::msgcat::mcset zh_cn "OK" "确定"
+ ::msgcat::mcset zh_cn "Ok" "确定"
+ ::msgcat::mcset zh_cn "Open" "打开"
+ ::msgcat::mcset zh_cn "&Open" "&打开"
+ ::msgcat::mcset zh_cn "Open Multiple Files" "打开多个文件"
+ ::msgcat::mcset zh_cn "P&aste" "粘&贴"
+ ::msgcat::mcset zh_cn "&Quit" "&退出"
+ ::msgcat::mcset zh_cn "&Red" "红色"
+ ::msgcat::mcset zh_cn "Regular" "规则"
+ ::msgcat::mcset zh_cn "Replace existing file?" "替换已有文件？"
+ ::msgcat::mcset zh_cn "&Retry" "&重试"
+ ::msgcat::mcset zh_cn "Sample" "样式"
+ ::msgcat::mcset zh_cn "&Save" "&保存"
+ ::msgcat::mcset zh_cn "Save As" "另存为"
+ ::msgcat::mcset zh_cn "Save To Log" "保存到日志"
+ ::msgcat::mcset zh_cn "Select Log File" "选择日志文件"
+ ::msgcat::mcset zh_cn "Select a file to source" "选择一个源文件"
+ ::msgcat::mcset zh_cn "&Selection:" "&选择："
+ ::msgcat::mcset zh_cn "&Size:" "&大小："
+ ::msgcat::mcset zh_cn "Show &Hidden Directories" "显示&隐藏目录"
+ ::msgcat::mcset zh_cn "Show &Hidden Files and Directories" "显示&隐藏文件和目录"
+ ::msgcat::mcset zh_cn "Skip Messages" "跳过信息"
+ ::msgcat::mcset zh_cn "&Source..." "&来源……"
+ ::msgcat::mcset zh_cn "Stri&keout" "删&除线"
+ ::msgcat::mcset zh_cn "Tcl Scripts" "Tcl脚本"
+ ::msgcat::mcset zh_cn "Tcl for Windows" "适用于Windows的Tcl"
+ ::msgcat::mcset zh_cn "Text Files" "文本文档"
+ ::msgcat::mcset zh_cn "&Underline" "&下划线"
+ ::msgcat::mcset zh_cn "&Yes" "&确定"
+ ::msgcat::mcset zh_cn "abort" "中止"
+ ::msgcat::mcset zh_cn "blue" "蓝色"
+ ::msgcat::mcset zh_cn "cancel" "取消"
+ ::msgcat::mcset zh_cn "extension" "拓展"
+ ::msgcat::mcset zh_cn "extensions" "拓展"
+ ::msgcat::mcset zh_cn "green" "绿色"
+ ::msgcat::mcset zh_cn "ignore" "忽略"
+ ::msgcat::mcset zh_cn "ok" "确定"
+ ::msgcat::mcset zh_cn "red" "红色"
+ ::msgcat::mcset zh_cn "retry" "重试"
+ ::msgcat::mcset zh_cn "yes" "确认"
+}
+
Property changes on: trunk/Master/tlpkg/tltcl/lib/tk8.6/msgs/zh_cn.msg
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/pkgIndex.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/pkgIndex.tcl 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/pkgIndex.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -1,7 +1,7 @@
if {![package vsatisfies [package provide Tcl] 8.6.0]} return
if {($::tcl_platform(platform) eq "unix") && ([info exists ::env(DISPLAY)]
|| ([info exists ::argv] && ("-display" in $::argv)))} {
- package ifneeded Tk 8.6.12 [list load [file normalize [file join $dir .. .. bin libtk8.6.dll]]]
+ package ifneeded Tk 8.6.13 [list load [file normalize [file join $dir .. .. bin libtk8.6.dll]]]
} else {
- package ifneeded Tk 8.6.12 [list load [file normalize [file join $dir .. .. bin tk86.dll]]]
+ package ifneeded Tk 8.6.13 [list load [file normalize [file join $dir .. .. bin tk86.dll]]]
}
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/scale.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/scale.tcl 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/scale.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -210,7 +210,20 @@
proc ::tk::ScaleIncrement {w dir big repeat} {
variable ::tk::Priv
+
if {![winfo exists $w]} return
+
+ # give the cancel callback a chance to be serviced if the execution time of
+ # the -command script lasts longer than -repeatdelay
+ set clockms [clock milliseconds]
+ if {$repeat eq "again" &&
+ [expr {$clockms - $Priv(clockms)}] > [expr {[$w cget -repeatinterval] * 1.1}]} {
+ set Priv(clockms) $clockms
+ set Priv(afterId) [after [$w cget -repeatinterval] \
+ [list tk::ScaleIncrement $w $dir $big again]]
+ return
+ }
+
if {$big eq "big"} {
set inc [$w cget -bigincrement]
if {$inc == 0} {
@@ -231,14 +244,18 @@
set inc [expr {-$inc}]
}
}
+ # this will run the -command script (if any) during the redrawing
+ # of the scale at idle time
$w set [expr {[$w get] + $inc}]
if {$repeat eq "again"} {
+ set Priv(clockms) $clockms
set Priv(afterId) [after [$w cget -repeatinterval] \
[list tk::ScaleIncrement $w $dir $big again]]
} elseif {$repeat eq "initial"} {
set delay [$w cget -repeatdelay]
if {$delay > 0} {
+ set Priv(clockms) $clockms
set Priv(afterId) [after $delay \
[list tk::ScaleIncrement $w $dir $big again]]
}
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/spinbox.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/spinbox.tcl 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/spinbox.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -200,18 +200,18 @@
bind Spinbox <<SelectNone>> {
%W selection clear
}
-bind Spinbox <KeyPress> {
+bind Spinbox <Key> {
::tk::EntryInsert %W %A
}
-# Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
+# Ignore all Alt, Meta, Control, and Mod4 keypresses unless explicitly bound.
# Otherwise, if a widget binding for one of these is defined, the
-# <KeyPress> class binding will also fire and insert the character,
+# <Key> class binding will also fire and insert the character,
# which is wrong. Ditto for Escape, Return, and Tab.
-bind Spinbox <Alt-KeyPress> {# nothing}
-bind Spinbox <Meta-KeyPress> {# nothing}
-bind Spinbox <Control-KeyPress> {# nothing}
+bind Spinbox <Alt-Key> {# nothing}
+bind Spinbox <Meta-Key> {# nothing}
+bind Spinbox <Control-Key> {# nothing}
bind Spinbox <Escape> {# nothing}
bind Spinbox <Return> {# nothing}
bind Spinbox <KP_Enter> {# nothing}
@@ -219,7 +219,8 @@
bind Spinbox <Prior> {# nothing}
bind Spinbox <Next> {# nothing}
if {[tk windowingsystem] eq "aqua"} {
- bind Spinbox <Command-KeyPress> {# nothing}
+ bind Spinbox <Command-Key> {# nothing}
+ bind Spinbox <Mod4-Key> {# nothing}
}
# On Windows, paste is done using Shift-Insert. Shift-Insert already
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/text.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/text.tcl 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/text.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -292,22 +292,23 @@
bind Text <Insert> {
catch {tk::TextInsert %W [::tk::GetSelection %W PRIMARY]}
}
-bind Text <KeyPress> {
+bind Text <Key> {
tk::TextInsert %W %A
}
# Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
# Otherwise, if a widget binding for one of these is defined, the
-# <KeyPress> class binding will also fire and insert the character,
+# <Key> class binding will also fire and insert the character,
# which is wrong. Ditto for <Escape>.
-bind Text <Alt-KeyPress> {# nothing }
-bind Text <Meta-KeyPress> {# nothing}
-bind Text <Control-KeyPress> {# nothing}
+bind Text <Alt-Key> {# nothing }
+bind Text <Meta-Key> {# nothing}
+bind Text <Control-Key> {# nothing}
bind Text <Escape> {# nothing}
bind Text <KP_Enter> {# nothing}
if {[tk windowingsystem] eq "aqua"} {
- bind Text <Command-KeyPress> {# nothing}
+ bind Text <Command-Key> {# nothing}
+ bind Text <Mod4-Key> {# nothing}
}
# Additional emacs-like bindings:
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/tk.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/tk.tcl 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/tk.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -11,7 +11,7 @@
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Verify that we have Tk binary and script components from the same release
-package require -exact Tk 8.6.12
+package require -exact Tk 8.6.13
# Create a ::tk namespace
namespace eval ::tk {
@@ -675,16 +675,7 @@
return $maxlen
}
-# For now, turn off the custom mdef proc for the Mac:
-
if {[tk windowingsystem] eq "aqua"} {
- namespace eval ::tk::mac {
- set useCustomMDEF 0
- }
-}
-
-
-if {[tk windowingsystem] eq "aqua"} {
#stub procedures to respond to "do script" Apple Events
proc ::tk::mac::DoScriptFile {file} {
uplevel #0 $file
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/tkfbox.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/tkfbox.tcl 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/tkfbox.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -463,7 +463,7 @@
wm protocol $w WM_DELETE_WINDOW [list ::tk::dialog::file::CancelCmd $w]
$data(upBtn) configure -command [list ::tk::dialog::file::UpDirCmd $w]
$data(cancelBtn) configure -command [list ::tk::dialog::file::CancelCmd $w]
- bind $w <KeyPress-Escape> [list $data(cancelBtn) invoke]
+ bind $w <Escape> [list $data(cancelBtn) invoke]
bind $w <Alt-Key> [list tk::AltKeyInDialog $w %A]
# Set up event handlers specific to File or Directory Dialogs
@@ -581,9 +581,9 @@
# so the user may still click and cause havoc ...
#
set entCursor [$data(ent) cget -cursor]
- set dlgCursor [$w cget -cursor]
+ set dlgCursor [$w cget -cursor]
$data(ent) configure -cursor watch
- $w configure -cursor watch
+ $w configure -cursor watch
update idletasks
$data(icons) deleteall
@@ -633,7 +633,7 @@
# turn off the busy cursor.
#
$data(ent) configure -cursor $entCursor
- $w configure -cursor $dlgCursor
+ $w configure -cursor $dlgCursor
}
# ::tk::dialog::file::SetPathSilently --
@@ -909,15 +909,15 @@
}
}
PATH {
- tk_messageBox -icon warning -type ok -parent $w \
- -message [mc "Directory \"%1\$s\" does not exist." $path]
+ tk_messageBox -icon warning -type ok -parent $w -message \
+ [mc "Directory \"%1\$s\" does not exist." $path]
$data(ent) selection range 0 end
$data(ent) icursor end
}
CHDIR {
tk_messageBox -type ok -parent $w -icon warning -message \
- [mc "Cannot change to the directory\
- \"%1\$s\".\nPermission denied." $path]
+ [mc "Cannot change to the directory\
+ \"%1\$s\".\nPermission denied." $path]
$data(ent) selection range 0 end
$data(ent) icursor end
}
@@ -1121,8 +1121,7 @@
} then {
upvar #0 $data(-typevariable) typeVariable
set typeVariable [lindex $data(origfiletypes) \
- [lsearch -exact $data(-filetypes) $data(filterType)] 0]
-
+ [lsearch -exact $data(-filetypes) $data(filterType)] 0]
}
}
bind $data(okBtn) <Destroy> {}
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/cursors.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/cursors.tcl 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/cursors.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -99,23 +99,20 @@
}
"aqua" {
- if {[package vsatisfies [package provide Tk] 8.5]} {
- # appeared 2007-04-23, Tk 8.5a6
- array set Cursors {
- standard arrow
- text ibeam
- link pointinghand
- crosshair crosshair
- busy watch
- forbidden notallowed
+ array set Cursors {
+ standard arrow
+ text ibeam
+ link pointinghand
+ crosshair crosshair
+ busy watch
+ forbidden notallowed
- hresize resizeleftright
- vresize resizeupdown
- nresize resizeup
- sresize resizedown
- wresize resizeleft
- eresize resizeright
- }
+ hresize resizeleftright
+ vresize resizeupdown
+ nresize resizeup
+ sresize resizedown
+ wresize resizeleft
+ eresize resizeright
}
}
}
@@ -201,7 +198,7 @@
if {[info exists argv0] && $argv0 eq [info script]} {
wm title . "[array size ::ttk::Cursors] cursors"
pack [ttk::CursorSampler .f] -expand true -fill both
- bind . <KeyPress-Escape> [list destroy .]
+ bind . <Escape> [list destroy .]
focus .f
}
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/entry.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/entry.tcl 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/entry.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -141,6 +141,7 @@
# as a Command modifier.
if {[tk windowingsystem] eq "aqua"} {
bind TEntry <Command-Key> {# nothing}
+ bind TEntry <Mod4-Key> {# nothing}
}
# Tk-on-Cocoa generates characters for these two keys. [Bug 2971663]
bind TEntry <<PrevLine>> {# nothing}
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/menubutton.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/menubutton.tcl 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/menubutton.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -82,7 +82,6 @@
set bbh [expr {[winfo height $mb]} + $bevelPad]
set mw [winfo reqwidth $menu]
set bw [winfo width $mb]
- set dF [expr {[winfo width $mb] - [winfo reqwidth $menu] - $menuPad}]
set entry [::tk::MenuFindName $menu [$mb cget -text]]
if {$entry < 0} {
set entry 0
@@ -106,7 +105,7 @@
incr y $menuPad
incr x $bw
}
- default {
+ default { # flush
incr y $bbh
}
}
@@ -118,7 +117,6 @@
set bh [expr {[winfo height $mb]}]
set mw [expr {[winfo reqwidth $menu]}]
set bw [expr {[winfo width $mb]}]
- set dF [expr {[winfo width $mb] - [winfo reqwidth $menu]}]
if {[tk windowingsystem] eq "win32"} {
incr mh 6
incr mw 16
@@ -154,13 +152,8 @@
right {
incr x $bw
}
- default {
- if {[$mb cget -style] eq ""} {
- incr x [expr {([winfo width $mb] - \
- [winfo reqwidth $menu])/ 2}]
- } else {
- incr y $bh
- }
+ default { # flush
+ incr x [expr {([winfo width $mb] - [winfo reqwidth $menu])/ 2}]
}
}
return [list $x $y $entry]
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/panedwindow.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/panedwindow.tcl 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/panedwindow.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -45,9 +45,9 @@
proc ttk::panedwindow::Drag {w x y} {
variable State
if {!$State(pressed)} { return }
- switch -- [$w cget -orient] {
- horizontal { set delta [expr {$x - $State(pressX)}] }
- vertical { set delta [expr {$y - $State(pressY)}] }
+ switch -glob -- [$w cget -orient] {
+ h* { set delta [expr {$x - $State(pressX)}] }
+ v* { set delta [expr {$y - $State(pressY)}] }
}
$w sashpos $State(sash) [expr {$State(sashPos) + $delta}]
}
@@ -80,9 +80,9 @@
set cursor $State(userConfCursor)
if {[llength [$w identify $x $y]]} {
# Assume we're over a sash.
- switch -- [$w cget -orient] {
- horizontal { set cursor hresize }
- vertical { set cursor vresize }
+ switch -glob -- [$w cget -orient] {
+ h* { set cursor hresize }
+ v* { set cursor vresize }
}
}
ttk::setCursor $w $cursor
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/utils.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/utils.tcl 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/utils.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -236,8 +236,8 @@
after cancel $Repeat(timer)
set script [uplevel 1 [list namespace code $args]]
set Repeat(script) $script
+ set Repeat(timer) [after $Repeat(delay) ttk::Repeat]
uplevel #0 $script
- set Repeat(timer) [after $Repeat(delay) ttk::Repeat]
}
## Repeat --
@@ -245,8 +245,8 @@
#
proc ttk::Repeat {} {
variable Repeat
+ set Repeat(timer) [after $Repeat(interval) ttk::Repeat]
uplevel #0 $Repeat(script)
- set Repeat(timer) [after $Repeat(interval) ttk::Repeat]
}
## ttk::CancelRepeat --
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/xmfbox.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/xmfbox.tcl 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/xmfbox.tcl 2024-02-15 21:05:12 UTC (rev 69897)
@@ -83,9 +83,9 @@
MotifFDialog_Config $dataName $type $argList
if {$data(-parent) eq "."} {
- set w .$dataName
+ set w .$dataName
} else {
- set w $data(-parent).$dataName
+ set w $data(-parent).$dataName
}
# (re)create the dialog box if necessary
@@ -549,7 +549,7 @@
$data(fEnt) delete 0 end
$data(fEnt) insert 0 \
- [::tk::dialog::file::JoinFile $data(selectPath) $data(filter)]
+ [::tk::dialog::file::JoinFile $data(selectPath) $data(filter)]
$data(sEnt) delete 0 end
$data(sEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) \
$data(selectFile)]
@@ -597,15 +597,15 @@
if {[file isdir ./$f]} {
lappend dlist $f
} else {
- foreach pat $data(filter) {
- if {[string match $pat $f]} {
+ foreach pat $data(filter) {
+ if {[string match $pat $f]} {
if {[string match .* $f]} {
incr top
}
lappend flist $f
- break
+ break
}
- }
+ }
}
}
eval [list $data(dList) insert end] [lsort -dictionary $dlist]
@@ -907,9 +907,9 @@
}
proc ::tk::ListBoxKeyAccel_Set {w} {
- bind Listbox <Any-KeyPress> ""
+ bind Listbox <Any-Key> ""
bind $w <Destroy> [list tk::ListBoxKeyAccel_Unset $w]
- bind $w <Any-KeyPress> [list tk::ListBoxKeyAccel_Key $w %A]
+ bind $w <Any-Key> [list tk::ListBoxKeyAccel_Key $w %A]
}
proc ::tk::ListBoxKeyAccel_Unset {w} {
Modified: trunk/Master/tlpkg/tltcl/lib/tkConfig.sh
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tkConfig.sh 2024-02-15 02:23:51 UTC (rev 69896)
+++ trunk/Master/tlpkg/tltcl/lib/tkConfig.sh 2024-02-15 21:05:12 UTC (rev 69897)
@@ -17,7 +17,7 @@
TK_VERSION='8.6'
TK_MAJOR_VERSION='8'
TK_MINOR_VERSION='6'
-TK_PATCH_LEVEL='.12'
+TK_PATCH_LEVEL='.13'
# -D flags for use with the C compiler.
TK_DEFS='-DPACKAGE_NAME=\"tk\" -DPACKAGE_TARNAME=\"tk\" -DPACKAGE_VERSION=\"8.6\" -DPACKAGE_STRING=\"tk\ 8.6\" -DPACKAGE_BUGREPORT=\"\" -DSTDC_HEADERS=1 -DTCL_THREADS=1 -DUSE_THREAD_ALLOC=1 -DMODULE_SCOPE=extern -DTCL_CFG_DO64BIT=1 -DHAVE_NO_SEH=1 -DHAVE_CAST_TO_UNION=1 -DHAVE_SYS_TYPES_H=1 -DHAVE_SYS_STAT_H=1 -DHAVE_STDLIB_H=1 -DHAVE_STRING_H=1 -DHAVE_MEMORY_H=1 -DHAVE_STRINGS_H=1 -DHAVE_INTTYPES_H=1 -DHAVE_STDINT_H=1 -DHAVE_UNISTD_H=1 -DHAVE_INTPTR_T=1 -DHAVE_UINTPTR_T=1 -DHAVE_UXTHEME_H=1 -DHAVE_VSSYM32_H=1 -DNDEBUG=1 -DTCL_CFG_OPTIMIZED=1 '
@@ -36,11 +36,11 @@
# Top-level directory in which Tcl's platform-independent files are
# installed.
-TK_PREFIX='/tmp/tltcl'
+TK_PREFIX='/home/siepo/tltcl'
# Top-level directory in which Tcl's platform-specific files (e.g.
# executables) are installed.
-TK_EXEC_PREFIX='/tmp/tltcl'
+TK_EXEC_PREFIX='/home/siepo/tltcl'
# -l flag to pass to the linker to pick up the Tcl library
TK_LIB_FLAG='-ltk86'
@@ -47,11 +47,11 @@
# String to pass to linker to pick up the Tk library from its
# build directory.
-TK_BUILD_LIB_SPEC='-L/tmp/siepo/tk8.6.12/win -ltk86'
+TK_BUILD_LIB_SPEC='-L/tmp/siepo/tk8.6.13/win -ltk86'
# String to pass to linker to pick up the Tk library from its
# installed directory.
-TK_LIB_SPEC='-L/tmp/tltcl/lib -ltk86'
+TK_LIB_SPEC='-L/home/siepo/tltcl/lib -ltk86'
# Location of the top-level source directory from which Tk was built.
# This is the directory that contains a README file as well as
@@ -59,7 +59,7 @@
# different place than the directory containing the source files, this
# points to the location of the sources, not the location where Tk was
# compiled.
-TK_SRC_DIR='/tmp/siepo/tk8.6.12'
+TK_SRC_DIR='/tmp/siepo/tk8.6.13'
# Needed if you want to make a 'fat' shared library library
# containing tk objects or link a different wish.
@@ -74,14 +74,14 @@
# String to pass to linker to pick up the Tk stub library from its
# build directory.
-TK_BUILD_STUB_LIB_SPEC='-L/tmp/siepo/tk8.6.12/win -ltkstub86'
+TK_BUILD_STUB_LIB_SPEC='-L/tmp/siepo/tk8.6.13/win -ltkstub86'
# String to pass to linker to pick up the Tk stub library from its
# installed directory.
-TK_STUB_LIB_SPEC='-L/tmp/tltcl/lib -ltkstub86'
+TK_STUB_LIB_SPEC='-L/home/siepo/tltcl/lib -ltkstub86'
# Path to the Tk stub library in the build directory.
-TK_BUILD_STUB_LIB_PATH='/tmp/siepo/tk8.6.12/win/libtkstub86.a'
+TK_BUILD_STUB_LIB_PATH='/tmp/siepo/tk8.6.13/win/libtkstub86.a'
# Path to the Tk stub library in the install directory.
-TK_STUB_LIB_PATH='/tmp/tltcl/lib/libtkstub86.a'
+TK_STUB_LIB_PATH='/home/siepo/tltcl/lib/libtkstub86.a'
More information about the tex-live-commits
mailing list.