texlive[58056] Master/tlpkg/tltcl: Updated Tcl/Tk
commits+siepo at tug.org
commits+siepo at tug.org
Tue Mar 2 17:29:38 CET 2021
Revision: 58056
http://tug.org/svn/texlive?view=revision&revision=58056
Author: siepo
Date: 2021-03-02 17:29:37 +0100 (Tue, 02 Mar 2021)
Log Message:
-----------
Updated Tcl/Tk
Modified Paths:
--------------
trunk/Master/tlpkg/tltcl/bin/tcl86.dll
trunk/Master/tlpkg/tltcl/bin/tclsh.exe
trunk/Master/tlpkg/tltcl/bin/tk86.dll
trunk/Master/tlpkg/tltcl/bin/wish.exe
trunk/Master/tlpkg/tltcl/bin/zlib1.dll
trunk/Master/tlpkg/tltcl/lib/dde1.4/pkgIndex.tcl
trunk/Master/tlpkg/tltcl/lib/dde1.4/tcldde14.dll
trunk/Master/tlpkg/tltcl/lib/libtclstub86.a
trunk/Master/tlpkg/tltcl/lib/libtkstub86.a
trunk/Master/tlpkg/tltcl/lib/reg1.3/pkgIndex.tcl
trunk/Master/tlpkg/tltcl/lib/reg1.3/tclreg13.dll
trunk/Master/tlpkg/tltcl/lib/tcl8/8.5/msgcat-1.6.1.tm
trunk/Master/tlpkg/tltcl/lib/tcl8.6/auto.tcl
trunk/Master/tlpkg/tltcl/lib/tcl8.6/clock.tcl
trunk/Master/tlpkg/tltcl/lib/tcl8.6/encoding/tis-620.enc
trunk/Master/tlpkg/tltcl/lib/tcl8.6/init.tcl
trunk/Master/tlpkg/tltcl/lib/tcl8.6/opt0.4/optparse.tcl
trunk/Master/tlpkg/tltcl/lib/tcl8.6/opt0.4/pkgIndex.tcl
trunk/Master/tlpkg/tltcl/lib/tcl8.6/package.tcl
trunk/Master/tlpkg/tltcl/lib/tcl8.6/safe.tcl
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tm.tcl
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Africa/Accra
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Africa/Algiers
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Africa/Casablanca
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Africa/El_Aaiun
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Africa/Lagos
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Africa/Nairobi
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Belize
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Dawson
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Godthab
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Grand_Turk
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Nassau
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Whitehorse
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Antarctica/Casey
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Antarctica/Macquarie
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/Jerusalem
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Shanghai
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Atlantic/Bermuda
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Adelaide
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Brisbane
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Broken_Hill
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Currie
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Darwin
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Eucla
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Hobart
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Lindeman
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Melbourne
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Perth
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Sydney
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Budapest
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Monaco
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Paris
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Volgograd
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Indian/Mahe
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Efate
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Fiji
trunk/Master/tlpkg/tltcl/lib/tcl8.6/word.tcl
trunk/Master/tlpkg/tltcl/lib/tclConfig.sh
trunk/Master/tlpkg/tltcl/lib/tk8.6/bgerror.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/clrpick.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/comdlg.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/console.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/arrow.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/bind.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/colors.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/cscroll.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/ctext.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/dialog1.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/entry1.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/entry2.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/entry3.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/floor.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/fontchoose.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/goldberg.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/image2.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/items.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/ixset
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/knightstour.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/menu.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/pendulum.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/plot.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/ruler.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/tclIndex
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/tcolor
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/text.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/tree.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/twind.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/unicodeout.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/widget
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/listbox.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/megawidget.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/menu.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/pkgIndex.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/safetk.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/spinbox.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/tearoff.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/tkAppInit.c
trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/aquaTheme.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/button.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/clamTheme.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/combobox.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/cursors.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/defaults.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/entry.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/fonts.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/menubutton.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/notebook.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/panedwindow.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/scale.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/scrollbar.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/sizegrip.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/spinbox.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/treeview.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/ttk.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/utils.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/vistaTheme.tcl
trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/xpTheme.tcl
trunk/Master/tlpkg/tltcl/lib/tkConfig.sh
Added Paths:
-----------
trunk/Master/tlpkg/tltcl/bin/tclsh86.exe
trunk/Master/tlpkg/tltcl/bin/wish86.exe
trunk/Master/tlpkg/tltcl/lib/dde1.4/libtcldde14.dll.a
trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/
trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/itcl.tcl
trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/itcl421.dll
trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/itclConfig.sh
trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/itclHullCmds.tcl
trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/itclWidget.tcl
trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/libitclstub421.a
trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/pkgIndex.tcl
trunk/Master/tlpkg/tltcl/lib/libtcl86.dll.a
trunk/Master/tlpkg/tltcl/lib/libtk86.dll.a
trunk/Master/tlpkg/tltcl/lib/reg1.3/libtclreg13.dll.a
trunk/Master/tlpkg/tltcl/lib/sqlite3.34.0/
trunk/Master/tlpkg/tltcl/lib/sqlite3.34.0/pkgIndex.tcl
trunk/Master/tlpkg/tltcl/lib/sqlite3.34.0/sqlite3340.dll
trunk/Master/tlpkg/tltcl/lib/tcl8/8.4/platform-1.0.15.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.2.tm
trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Nuuk
trunk/Master/tlpkg/tltcl/lib/tdbc1.1.2/
trunk/Master/tlpkg/tltcl/lib/tdbc1.1.2/libtdbcstub112.a
trunk/Master/tlpkg/tltcl/lib/tdbc1.1.2/pkgIndex.tcl
trunk/Master/tlpkg/tltcl/lib/tdbc1.1.2/tdbc.tcl
trunk/Master/tlpkg/tltcl/lib/tdbc1.1.2/tdbc112.dll
trunk/Master/tlpkg/tltcl/lib/tdbc1.1.2/tdbcConfig.sh
trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.2/
trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.2/pkgIndex.tcl
trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.2/tdbcmysql.tcl
trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.2/tdbcmysql112.dll
trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.2/
trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.2/pkgIndex.tcl
trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.2/tdbcodbc.tcl
trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.2/tdbcodbc112.dll
trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.2/
trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.2/pkgIndex.tcl
trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.2/tdbcpostgres.tcl
trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.2/tdbcpostgres112.dll
trunk/Master/tlpkg/tltcl/lib/thread2.8.6/
trunk/Master/tlpkg/tltcl/lib/thread2.8.6/pkgIndex.tcl
trunk/Master/tlpkg/tltcl/lib/thread2.8.6/thread286.dll
trunk/Master/tlpkg/tltcl/lib/thread2.8.6/ttrace.tcl
Removed Paths:
-------------
trunk/Master/tlpkg/tltcl/lib/dde1.4/libtcldde14.a
trunk/Master/tlpkg/tltcl/lib/itcl4.2.0/
trunk/Master/tlpkg/tltcl/lib/libtcl86.a
trunk/Master/tlpkg/tltcl/lib/libtk86.a
trunk/Master/tlpkg/tltcl/lib/reg1.3/libtclreg13.a
trunk/Master/tlpkg/tltcl/lib/sqlite3.30.1.2/
trunk/Master/tlpkg/tltcl/lib/tcl8/8.4/platform-1.0.14.tm
trunk/Master/tlpkg/tltcl/lib/tcl8/8.5/tcltest-2.5.1.tm
trunk/Master/tlpkg/tltcl/lib/tcl8/8.6/http-2.9.1.tm
trunk/Master/tlpkg/tltcl/lib/tcl8/8.6/tdbc/sqlite3-1.1.1.tm
trunk/Master/tlpkg/tltcl/lib/tdbc1.1.1/
trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.1/
trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.1/
trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.1/
trunk/Master/tlpkg/tltcl/lib/thread2.8.5/
Modified: trunk/Master/tlpkg/tltcl/bin/tcl86.dll
===================================================================
(Binary files differ)
Modified: trunk/Master/tlpkg/tltcl/bin/tclsh.exe
===================================================================
(Binary files differ)
Added: trunk/Master/tlpkg/tltcl/bin/tclsh86.exe
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/bin/tclsh86.exe
===================================================================
--- trunk/Master/tlpkg/tltcl/bin/tclsh86.exe 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/bin/tclsh86.exe 2021-03-02 16:29:37 UTC (rev 58056)
Property changes on: trunk/Master/tlpkg/tltcl/bin/tclsh86.exe
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+application/x-dosexec
\ No newline at end of property
Modified: trunk/Master/tlpkg/tltcl/bin/tk86.dll
===================================================================
(Binary files differ)
Modified: trunk/Master/tlpkg/tltcl/bin/wish.exe
===================================================================
(Binary files differ)
Added: trunk/Master/tlpkg/tltcl/bin/wish86.exe
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/bin/wish86.exe
===================================================================
--- trunk/Master/tlpkg/tltcl/bin/wish86.exe 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/bin/wish86.exe 2021-03-02 16:29:37 UTC (rev 58056)
Property changes on: trunk/Master/tlpkg/tltcl/bin/wish86.exe
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+application/x-dosexec
\ No newline at end of property
Modified: trunk/Master/tlpkg/tltcl/bin/zlib1.dll
===================================================================
(Binary files differ)
Deleted: trunk/Master/tlpkg/tltcl/lib/dde1.4/libtcldde14.a
===================================================================
(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 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/dde1.4/libtcldde14.dll.a 2021-03-02 16:29:37 UTC (rev 58056)
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/pkgIndex.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/dde1.4/pkgIndex.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/dde1.4/pkgIndex.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -1,7 +1,7 @@
if {![package vsatisfies [package provide Tcl] 8.5]} return
if {[info sharedlibextension] != ".dll"} return
if {[::tcl::pkgconfig get debug]} {
- package ifneeded dde 1.4.2 [list load [file join $dir tcldde14g.dll] dde]
+ package ifneeded dde 1.4.3 [list load [file join $dir tcldde14g.dll] Dde]
} else {
- package ifneeded dde 1.4.2 [list load [file join $dir tcldde14.dll] dde]
+ package ifneeded dde 1.4.3 [list load [file join $dir tcldde14.dll] Dde]
}
Modified: trunk/Master/tlpkg/tltcl/lib/dde1.4/tcldde14.dll
===================================================================
(Binary files differ)
Added: trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/itcl.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/itcl.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/itcl.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -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.1/itcl.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/itcl421.dll
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/itcl421.dll
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/itcl421.dll 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/itcl421.dll 2021-03-02 16:29:37 UTC (rev 58056)
Property changes on: trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/itcl421.dll
___________________________________________________________________
Added: svn:mime-type
## -0,0 +1 ##
+application/x-dosexec
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/itclConfig.sh
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/itclConfig.sh (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/itclConfig.sh 2021-03-02 16:29:37 UTC (rev 58056)
@@ -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.1'
+ITCL_VERSION='4.2.1'
+
+# The name of the Itcl library (may be either a .a file or a shared library):
+itcl_LIB_FILE=itcl421.dll
+ITCL_LIB_FILE=itcl421.dll
+
+# String to pass to linker to pick up the Itcl library from its
+# build directory.
+itcl_BUILD_LIB_SPEC='-L/home/siepo/xdrive/tltcl/tcl8.6.11/win/pkgs/itcl4.2.1 -litcl421'
+ITCL_BUILD_LIB_SPEC='-L/home/siepo/xdrive/tltcl/tcl8.6.11/win/pkgs/itcl4.2.1 -litcl421'
+
+# 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.1 -litcl421'
+ITCL_LIB_SPEC='-L/home/siepo/tltcl/lib/itcl4.2.1 -litcl421'
+
+# The name of the Itcl stub library (a .a file):
+itcl_STUB_LIB_FILE=libitclstub421.a
+ITCL_STUB_LIB_FILE=libitclstub421.a
+
+# String to pass to linker to pick up the Itcl stub library from its
+# build directory.
+itcl_BUILD_STUB_LIB_SPEC='-L/home/siepo/xdrive/tltcl/tcl8.6.11/win/pkgs/itcl4.2.1 -litclstub421'
+ITCL_BUILD_STUB_LIB_SPEC='-L/home/siepo/xdrive/tltcl/tcl8.6.11/win/pkgs/itcl4.2.1 -litclstub421'
+
+# 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.1 -litclstub421'
+ITCL_STUB_LIB_SPEC='-L/home/siepo/tltcl/lib/itcl4.2.1 -litclstub421'
+
+# String to pass to linker to pick up the Itcl stub library from its
+# build directory.
+itcl_BUILD_STUB_LIB_PATH='/home/siepo/xdrive/tltcl/tcl8.6.11/win/pkgs/itcl4.2.1/libitclstub421.a'
+ITCL_BUILD_STUB_LIB_PATH='/home/siepo/xdrive/tltcl/tcl8.6.11/win/pkgs/itcl4.2.1/libitclstub421.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.1/libitclstub421.a'
+ITCL_STUB_LIB_PATH='/home/siepo/tltcl/lib/itcl4.2.1/libitclstub421.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='/home/siepo/xdrive/tltcl/tcl8.6.11/pkgs/itcl4.2.1'
+ITCL_SRC_DIR='/home/siepo/xdrive/tltcl/tcl8.6.11/pkgs/itcl4.2.1'
+
+# String to pass to the compiler so that an extension can
+# find installed Itcl headers.
+itcl_INCLUDE_SPEC='-I/home/siepo/xdrive/tltcl/tcl8.6.11/pkgs/itcl4.2.1/generic'
+ITCL_INCLUDE_SPEC='-I/home/siepo/xdrive/tltcl/tcl8.6.11/pkgs/itcl4.2.1/generic'
Property changes on: trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/itclConfig.sh
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/itclHullCmds.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/itclHullCmds.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/itclHullCmds.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -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.1/itclHullCmds.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/itclWidget.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/itclWidget.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/itclWidget.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -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.1/itclWidget.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/libitclstub421.a
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/libitclstub421.a
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/libitclstub421.a 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/libitclstub421.a 2021-03-02 16:29:37 UTC (rev 58056)
Property changes on: trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/libitclstub421.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.1/pkgIndex.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/pkgIndex.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/pkgIndex.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -0,0 +1,21 @@
+# Tcl package index file, version 1.0
+#
+# Do NOT try this command
+#
+# if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
+#
+# as a way to accept working with all of Tcl 8.6, Tcl 8.X, X>6, and
+# Tcl Y, for Y > 8.
+# Itcl is a binary package, added to an interp with [load].
+# There is no libitcl.so that will [load] into both Tcl 8 and Tcl 9.
+# The indexed libitcl.so was built to [load] into one or the other.
+# Thus the pkgIndex.tcl should only accept the version of Tcl for which
+# the indexed itcl421.dll was built.
+#
+# More work replacing the literal "8.6" below with the proper value substituted
+# by configure is the right way forward.
+
+if {![package vsatisfies [package provide Tcl] 8.6]} {return}
+
+package ifneeded itcl 4.2.1 [list load [file join $dir "itcl421.dll"] Itcl]
+package ifneeded Itcl 4.2.1 [list load [file join $dir "itcl421.dll"] Itcl]
Property changes on: trunk/Master/tlpkg/tltcl/lib/itcl4.2.1/pkgIndex.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Deleted: trunk/Master/tlpkg/tltcl/lib/libtcl86.a
===================================================================
(Binary files differ)
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 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/libtcl86.dll.a 2021-03-02 16:29:37 UTC (rev 58056)
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
Modified: trunk/Master/tlpkg/tltcl/lib/libtclstub86.a
===================================================================
(Binary files differ)
Deleted: trunk/Master/tlpkg/tltcl/lib/libtk86.a
===================================================================
(Binary files differ)
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 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/libtk86.dll.a 2021-03-02 16:29:37 UTC (rev 58056)
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
Modified: trunk/Master/tlpkg/tltcl/lib/libtkstub86.a
===================================================================
(Binary files differ)
Deleted: trunk/Master/tlpkg/tltcl/lib/reg1.3/libtclreg13.a
===================================================================
(Binary files differ)
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 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/reg1.3/libtclreg13.dll.a 2021-03-02 16:29:37 UTC (rev 58056)
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/pkgIndex.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/reg1.3/pkgIndex.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/reg1.3/pkgIndex.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -1,9 +1,9 @@
if {![package vsatisfies [package provide Tcl] 8.5]} return
if {[info sharedlibextension] != ".dll"} return
if {[::tcl::pkgconfig get debug]} {
- package ifneeded registry 1.3.4 \
- [list load [file join $dir tclreg13g.dll] registry]
+ package ifneeded registry 1.3.5 \
+ [list load [file join $dir tclreg13g.dll] Registry]
} else {
- package ifneeded registry 1.3.4 \
- [list load [file join $dir tclreg13.dll] registry]
+ package ifneeded registry 1.3.5 \
+ [list load [file join $dir tclreg13.dll] Registry]
}
Modified: trunk/Master/tlpkg/tltcl/lib/reg1.3/tclreg13.dll
===================================================================
(Binary files differ)
Added: trunk/Master/tlpkg/tltcl/lib/sqlite3.34.0/pkgIndex.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/sqlite3.34.0/pkgIndex.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/sqlite3.34.0/pkgIndex.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -0,0 +1,7 @@
+#
+# Tcl package index file
+#
+# Note sqlite*3* init specifically
+#
+package ifneeded sqlite3 3.34.0 \
+ [list load [file join $dir sqlite3340.dll] Sqlite3]
Property changes on: trunk/Master/tlpkg/tltcl/lib/sqlite3.34.0/pkgIndex.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/sqlite3.34.0/sqlite3340.dll
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/sqlite3.34.0/sqlite3340.dll
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/sqlite3.34.0/sqlite3340.dll 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/sqlite3.34.0/sqlite3340.dll 2021-03-02 16:29:37 UTC (rev 58056)
Property changes on: trunk/Master/tlpkg/tltcl/lib/sqlite3.34.0/sqlite3340.dll
___________________________________________________________________
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Added: svn:mime-type
## -0,0 +1 ##
+application/x-dosexec
\ No newline at end of property
Deleted: trunk/Master/tlpkg/tltcl/lib/tcl8/8.4/platform-1.0.14.tm
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8/8.4/platform-1.0.14.tm 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8/8.4/platform-1.0.14.tm 2021-03-02 16:29:37 UTC (rev 58056)
@@ -1,397 +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
-# % arm* -> arm
-# % sun4* -> sparc
-# % intel -> ix86
-# % i*86* -> ix86
-# % Power* -> powerpc
-# % x86_64 + wordSize 4 => x86 code
-#
-# OS specific
-# % AIX are always powerpc machines
-# % HP-UX 9000/800 etc means parisc
-# % linux has to take glibc version into account
-# % sunos -> solaris, and keep version number
-#
-# NOTE: A platform like linux glibc 2.3, which can use glibc 2.2 stuff
-# has to provide all possible allowed platform identifiers when
-# searching search. Ditto a solaris 2.8 platform can use solaris 2.6
-# packages. Etc. This is handled by the other procedure, see below.
-
-# ### ### ### ######### ######### #########
-## Requirements
-
-namespace eval ::platform {}
-
-# ### ### ### ######### ######### #########
-## Implementation
-
-# -- platform::generic
-#
-# Assembles an identifier for the generic platform. It leaves out
-# details like kernel version, libc version, etc.
-
-proc ::platform::generic {} {
- global tcl_platform
-
- set plat [string tolower [lindex $tcl_platform(os) 0]]
- set cpu $tcl_platform(machine)
-
- switch -glob -- $cpu {
- sun4* {
- set cpu sparc
- }
- intel -
- i*86* {
- set cpu ix86
- }
- x86_64 {
- if {$tcl_platform(wordSize) == 4} {
- # See Example <1> at the top of this file.
- set cpu ix86
- }
- }
- "Power*" {
- set cpu powerpc
- }
- "arm*" {
- set cpu arm
- }
- ia64 {
- if {$tcl_platform(wordSize) == 4} {
- append cpu _32
- }
- }
- }
-
- switch -glob -- $plat {
- cygwin* {
- set plat cygwin
- }
- 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
- }
- }
-
- 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 > 8} {
- incr major -4
- append plat 10.$major
- 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+
- if {[regexp {macosx([^-]*)-(.*)} $id -> v cpu]} {
-
- switch -exact -- $cpu {
- ix86 {
- lappend alt i386-x86_64
- lappend alt universal
- }
- x86_64 { lappend alt i386-x86_64 }
- default { set alt {} }
- }
-
- if {$v ne ""} {
- foreach {major minor} [split $v .] break
-
- # Add 10.5 to 10.minor to patterns.
- set res {}
- for {set j $minor} {$j >= 5} {incr j -1} {
- 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.14
-
-# ### ### ### ######### ######### #########
-## 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.15.tm
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8/8.4/platform-1.0.15.tm (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8/8.4/platform-1.0.15.tm 2021-03-02 16:29:37 UTC (rev 58056)
@@ -0,0 +1,423 @@
+# -*- tcl -*-
+# ### ### ### ######### ######### #########
+## Overview
+
+# Heuristics to assemble a platform identifier from publicly available
+# information. The identifier describes the platform of the currently
+# running tcl shell. This is a mixture of the runtime environment and
+# of build-time properties of the executable itself.
+#
+# Examples:
+# <1> A tcl shell executing on a x86_64 processor, but having a
+# wordsize of 4 was compiled for the x86 environment, i.e. 32
+# bit, and loaded packages have to match that, and not the
+# actual cpu.
+#
+# <2> The hp/solaris 32/64 bit builds of the core cannot be
+# distinguished by looking at tcl_platform. As packages have to
+# match the 32/64 information we have to look in more places. In
+# this case we inspect the executable itself (magic numbers,
+# i.e. fileutil::magic::filetype).
+#
+# The basic information used comes out of the 'os' and 'machine'
+# entries of the 'tcl_platform' array. A number of general and
+# os/machine specific transformation are applied to get a canonical
+# result.
+#
+# General
+# Only the first element of 'os' is used - we don't care whether we
+# are on "Windows NT" or "Windows XP" or whatever.
+#
+# Machine specific
+# % arm* -> arm
+# % sun4* -> sparc
+# % intel -> ix86
+# % i*86* -> ix86
+# % Power* -> powerpc
+# % x86_64 + wordSize 4 => x86 code
+#
+# OS specific
+# % AIX are always powerpc machines
+# % HP-UX 9000/800 etc means parisc
+# % linux has to take glibc version into account
+# % sunos -> solaris, and keep version number
+#
+# NOTE: A platform like linux glibc 2.3, which can use glibc 2.2 stuff
+# has to provide all possible allowed platform identifiers when
+# searching search. Ditto a solaris 2.8 platform can use solaris 2.6
+# packages. Etc. This is handled by the other procedure, see below.
+
+# ### ### ### ######### ######### #########
+## Requirements
+
+namespace eval ::platform {}
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+# -- platform::generic
+#
+# Assembles an identifier for the generic platform. It leaves out
+# details like kernel version, libc version, etc.
+
+proc ::platform::generic {} {
+ global tcl_platform
+
+ set plat [string tolower [lindex $tcl_platform(os) 0]]
+ set cpu $tcl_platform(machine)
+
+ switch -glob -- $cpu {
+ sun4* {
+ set cpu sparc
+ }
+ intel -
+ i*86* {
+ set cpu ix86
+ }
+ x86_64 {
+ if {$tcl_platform(wordSize) == 4} {
+ # See Example <1> at the top of this file.
+ set cpu ix86
+ }
+ }
+ "Power*" {
+ set cpu powerpc
+ }
+ "arm*" {
+ set cpu arm
+ }
+ ia64 {
+ if {$tcl_platform(wordSize) == 4} {
+ append cpu _32
+ }
+ }
+ }
+
+ switch -glob -- $plat {
+ windows {
+ if {$tcl_platform(platform) == "unix"} {
+ set plat cygwin
+ } else {
+ set plat win32
+ }
+ if {$cpu eq "amd64"} {
+ # Do not check wordSize, win32-x64 is an IL32P64 platform.
+ set cpu x86_64
+ }
+ }
+ sunos {
+ set plat solaris
+ if {[string match "ix86" $cpu]} {
+ if {$tcl_platform(wordSize) == 8} {
+ set cpu x86_64
+ }
+ } elseif {![string match "ia64*" $cpu]} {
+ # sparc
+ if {$tcl_platform(wordSize) == 8} {
+ append cpu 64
+ }
+ }
+ }
+ darwin {
+ set plat macosx
+ # Correctly identify the cpu when running as a 64bit
+ # process on a machine with a 32bit kernel
+ if {$cpu eq "ix86"} {
+ if {$tcl_platform(wordSize) == 8} {
+ set cpu x86_64
+ }
+ }
+ }
+ aix {
+ set cpu powerpc
+ if {$tcl_platform(wordSize) == 8} {
+ append cpu 64
+ }
+ }
+ hp-ux {
+ set plat hpux
+ if {![string match "ia64*" $cpu]} {
+ set cpu parisc
+ if {$tcl_platform(wordSize) == 8} {
+ append cpu 64
+ }
+ }
+ }
+ osf1 {
+ set plat tru64
+ }
+ default {
+ set plat [lindex [split $plat _-] 0]
+ }
+ }
+
+ return "${plat}-${cpu}"
+}
+
+# -- platform::identify
+#
+# Assembles an identifier for the exact platform, by extending the
+# generic identifier. I.e. it adds in details like kernel version,
+# libc version, etc., if they are relevant for the loading of
+# packages on the platform.
+
+proc ::platform::identify {} {
+ global tcl_platform
+
+ set id [generic]
+ regexp {^([^-]+)-([^-]+)$} $id -> plat cpu
+
+ switch -- $plat {
+ solaris {
+ regsub {^5} $tcl_platform(osVersion) 2 text
+ append plat $text
+ return "${plat}-${cpu}"
+ }
+ macosx {
+ set major [lindex [split $tcl_platform(osVersion) .] 0]
+ if {$major > 19} {
+ incr major -20
+ append plat 11.$major
+ } else {
+ incr major -4
+ append plat 10.$major
+ return "${plat}-${cpu}"
+ }
+ return "${plat}-${cpu}"
+ }
+ linux {
+ # Look for the libc*.so and determine its version
+ # (libc5/6, libc6 further glibc 2.X)
+
+ set v unknown
+
+ # Determine in which directory to look. /lib, or /lib64.
+ # For that we use the tcl_platform(wordSize).
+ #
+ # We could use the 'cpu' info, per the equivalence below,
+ # that however would be restricted to intel. And this may
+ # be a arm, mips, etc. system. The wordsize is more
+ # fundamental.
+ #
+ # ix86 <=> (wordSize == 4) <=> 32 bit ==> /lib
+ # x86_64 <=> (wordSize == 8) <=> 64 bit ==> /lib64
+ #
+ # Do not look into /lib64 even if present, if the cpu
+ # doesn't fit.
+
+ # TODO: Determine the prefixes (i386, x86_64, ...) for
+ # other cpus. The path after the generic one is utterly
+ # specific to intel right now. Ok, on Ubuntu, possibly
+ # other Debian systems we may apparently be able to query
+ # the necessary CPU code. If we can't we simply use the
+ # hardwired fallback.
+
+ switch -exact -- $tcl_platform(wordSize) {
+ 4 {
+ lappend bases /lib
+ if {[catch {
+ exec dpkg-architecture -qDEB_HOST_MULTIARCH
+ } res]} {
+ lappend bases /lib/i386-linux-gnu
+ } else {
+ # dpkg-arch returns the full tripled, not just cpu.
+ lappend bases /lib/$res
+ }
+ }
+ 8 {
+ lappend bases /lib64
+ if {[catch {
+ exec dpkg-architecture -qDEB_HOST_MULTIARCH
+ } res]} {
+ lappend bases /lib/x86_64-linux-gnu
+ } else {
+ # dpkg-arch returns the full tripled, not just cpu.
+ lappend bases /lib/$res
+ }
+ }
+ default {
+ return -code error "Bad wordSize $tcl_platform(wordSize), expected 4 or 8"
+ }
+ }
+
+ foreach base $bases {
+ if {[LibcVersion $base -> v]} break
+ }
+
+ append plat -$v
+ return "${plat}-${cpu}"
+ }
+ }
+
+ return $id
+}
+
+proc ::platform::LibcVersion {base _->_ vv} {
+ upvar 1 $vv v
+ set libclist [lsort [glob -nocomplain -directory $base libc*]]
+
+ if {![llength $libclist]} { return 0 }
+
+ set libc [lindex $libclist 0]
+
+ # Try executing the library first. This should suceed
+ # for a glibc library, and return the version
+ # information.
+
+ if {![catch {
+ set vdata [lindex [split [exec $libc] \n] 0]
+ }]} {
+ regexp {version ([0-9]+(\.[0-9]+)*)} $vdata -> v
+ foreach {major minor} [split $v .] break
+ set v glibc${major}.${minor}
+ return 1
+ } else {
+ # We had trouble executing the library. We are now
+ # inspecting its name to determine the version
+ # number. This code by Larry McVoy.
+
+ if {[regexp -- {libc-([0-9]+)\.([0-9]+)} $libc -> major minor]} {
+ set v glibc${major}.${minor}
+ return 1
+ }
+ }
+ return 0
+}
+
+# -- platform::patterns
+#
+# Given an exact platform identifier, i.e. _not_ the generic
+# identifier it assembles a list of exact platform identifier
+# describing platform which should be compatible with the
+# input.
+#
+# I.e. packages for all platforms in the result list should be
+# loadable on the specified platform.
+
+# << Should we add the generic identifier to the list as well ? In
+# general it is not compatible I believe. So better not. In many
+# cases the exact identifier is identical to the generic one
+# anyway.
+# >>
+
+proc ::platform::patterns {id} {
+ set res [list $id]
+ if {$id eq "tcl"} {return $res}
+
+ switch -glob -- $id {
+ solaris*-* {
+ if {[regexp {solaris([^-]*)-(.*)} $id -> v cpu]} {
+ if {$v eq ""} {return $id}
+ foreach {major minor} [split $v .] break
+ incr minor -1
+ for {set j $minor} {$j >= 6} {incr j -1} {
+ lappend res solaris${major}.${j}-${cpu}
+ }
+ }
+ }
+ linux*-* {
+ if {[regexp {linux-glibc([^-]*)-(.*)} $id -> v cpu]} {
+ foreach {major minor} [split $v .] break
+ incr minor -1
+ for {set j $minor} {$j >= 0} {incr j -1} {
+ lappend res linux-glibc${major}.${j}-${cpu}
+ }
+ }
+ }
+ macosx-powerpc {
+ lappend res macosx-universal
+ }
+ macosx-x86_64 {
+ lappend res macosx-i386-x86_64
+ }
+ macosx-ix86 {
+ lappend res macosx-universal macosx-i386-x86_64
+ }
+ macosx*-* {
+ # 10.5+,11.0+
+ if {[regexp {macosx([^-]*)-(.*)} $id -> v cpu]} {
+
+ switch -exact -- $cpu {
+ ix86 {
+ lappend alt i386-x86_64
+ lappend alt universal
+ }
+ x86_64 {
+ if {[lindex [split $::tcl_platform(osVersion) .] 0] < 19} {
+ set alt i386-x86_64
+ } else {
+ set alt {}
+ }
+ }
+ arm {
+ lappend alt x86_64
+ }
+ default { set alt {} }
+ }
+
+ if {$v ne ""} {
+ foreach {major minor} [split $v .] break
+
+ set res {}
+ if {$major eq 11} {
+ # Add 11.0 to 11.minor to patterns.
+ for {set j $minor} {$j >= 0} {incr j -1} {
+ lappend res macosx${major}.${j}-${cpu}
+ foreach a $alt {
+ lappend res macosx${major}.${j}-$a
+ }
+ }
+ set major 10
+ set minor 15
+ }
+ # Add 10.5 to 10.minor to patterns.
+ for {set j $minor} {$j >= 5} {incr j -1} {
+ if {$cpu ne "arm"} {
+ lappend res macosx${major}.${j}-${cpu}
+ }
+ foreach a $alt {
+ lappend res macosx${major}.${j}-$a
+ }
+ }
+
+ # Add unversioned patterns for 10.3/10.4 builds.
+ lappend res macosx-${cpu}
+ foreach a $alt {
+ lappend res macosx-$a
+ }
+ } else {
+ # No version, just do unversioned patterns.
+ foreach a $alt {
+ lappend res macosx-$a
+ }
+ }
+ } else {
+ # no v, no cpu ... nothing
+ }
+ }
+ }
+ lappend res tcl ; # Pure tcl packages are always compatible.
+ return $res
+}
+
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide platform 1.0.15
+
+# ### ### ### ######### ######### #########
+## Demo application
+
+if {[info exists argv0] && ($argv0 eq [info script])} {
+ puts ====================================
+ parray tcl_platform
+ puts ====================================
+ puts Generic\ identification:\ [::platform::generic]
+ puts Exact\ identification:\ \ \ [::platform::identify]
+ puts ====================================
+ puts Search\ patterns:
+ puts *\ [join [::platform::patterns [::platform::identify]] \n*\ ]
+ puts ====================================
+ exit 0
+}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8/8.5/msgcat-1.6.1.tm
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8/8.5/msgcat-1.6.1.tm 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8/8.5/msgcat-1.6.1.tm 2021-03-02 16:29:37 UTC (rev 58056)
@@ -4,9 +4,9 @@
# message catalog facility for Tcl programs. It should be
# loaded with the command "package require msgcat".
#
-# Copyright (c) 2010-2015 by Harald Oehlmann.
-# Copyright (c) 1998-2000 by Ajuba Solutions.
-# Copyright (c) 1998 by Mark Harrison.
+# Copyright (c) 2010-2015 Harald Oehlmann.
+# Copyright (c) 1998-2000 Ajuba Solutions.
+# Copyright (c) 1998 Mark Harrison.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
Deleted: trunk/Master/tlpkg/tltcl/lib/tcl8/8.5/tcltest-2.5.1.tm
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8/8.5/tcltest-2.5.1.tm 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8/8.5/tcltest-2.5.1.tm 2021-03-02 16:29:37 UTC (rev 58056)
@@ -1,3446 +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 by Scriptics Corporation.
-# Copyright (c) 2000 by 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.1
-
- # 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)
- 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 {[lsearch -exact $Option(-verbose) $level] != -1}]
- }
-
- # 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 loadIntoSlaveInterpreter {slave args} {
- variable Version
- interp eval $slave [package ifneeded tcltest $Version]
- interp eval $slave "tcltest::configure {*}{$args}"
- interp alias $slave ::tcltest::ReportToMaster \
- {} ::tcltest::ReportedFromSlave
- }
- proc ReportedFromSlave {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 && $value}} 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 {chan configure $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
- set code [catch {uplevel 1 $setup} setupMsg]
- if {$code == 1} {
- set errorInfo(setup) $::errorInfo
- set errorCodeRes(setup) $::errorCode
- }
- set setupFailure [expr {$code != 0}]
-
- # Only run the test body if the setup was successful
- if {!$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
- }
- }
-
- # check if the return code matched the expected return code
- set codeFailure 0
- if {!$setupFailure && ($returnCode ni $returnCodes)} {
- set codeFailure 1
- }
- set errorCodeFailure 0
- if {!$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 {[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 {[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 {$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
- 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 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 {$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
-}
-
-# 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} {
- if {[IsVerbose skip]} {
- puts [outputChannel] "++++ $name SKIPPED: $constraints"
- }
-
- if {$testLevel == 1} {
- incr numTests(Skipped)
- AddToSkippedBecause $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
- }
-
- 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]::ReportToMaster]]} {
- ReportToMaster $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
- set failFilesAccum {}
-
- 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]} {
- incr numTestFiles
- uplevel 1 [list ::source $file]
- } 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
- lappend failFilesAccum $testFile
- }
- } 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] || [llength $failFilesAccum]}]
-}
-
-#####################################################################
-
-# 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]
- chan configure $fd -translation lf
- 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]
- set filesMade [lreplace $filesMade $idx $idx]
- if {$idx == -1} {
- DebugDo 1 {
- Warn "removeFile removing \"$fullName\":\n not created by makeFile"
- }
- }
- 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 == -1} {
- 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]
- 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.
-#
-# Arguments:
-# string being converted
-#
-# Results:
-# result fom encoding
-#
-# Side effects:
-# None
-
-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.3.tm
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8/8.5/tcltest-2.5.3.tm (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8/8.5/tcltest-2.5.3.tm 2021-03-02 16:29:37 UTC (rev 58056)
@@ -0,0 +1,3515 @@
+# tcltest.tcl --
+#
+# This file contains support code for the Tcl test suite. It
+# defines the tcltest namespace and finds and defines the output
+# directory, constraints available, output and error channels,
+# etc. used by Tcl tests. See the tcltest man page for more
+# details.
+#
+# This design was based on the Tcl testing approach designed and
+# initially implemented by Mary Ann May-Pumphrey of Sun
+# Microsystems.
+#
+# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 Scriptics Corporation.
+# Copyright (c) 2000 Ajuba Solutions
+# Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
+# All rights reserved.
+
+package require Tcl 8.5- ;# -verbose line uses [info frame]
+namespace eval tcltest {
+
+ # When the version number changes, be sure to update the pkgIndex.tcl file,
+ # and the install directory in the Makefiles. When the minor version
+ # changes (new feature) be sure to update the man page as well.
+ variable Version 2.5.3
+
+ # Compatibility support for dumb variables defined in tcltest 1
+ # Do not use these. Call [package provide Tcl] and [info patchlevel]
+ # yourself. You don't need tcltest to wrap it for you.
+ variable version [package provide Tcl]
+ variable patchLevel [info patchlevel]
+
+##### Export the public tcltest procs; several categories
+ #
+ # Export the main functional commands that do useful things
+ namespace export cleanupTests loadTestedCommands makeDirectory \
+ makeFile removeDirectory removeFile runAllTests test
+
+ # Export configuration commands that control the functional commands
+ namespace export configure customMatch errorChannel interpreter \
+ outputChannel testConstraint
+
+ # Export commands that are duplication (candidates for deprecation)
+ if {![package vsatisfies [package provide Tcl] 8.7-]} {
+ namespace export bytestring ;# dups [encoding convertfrom identity]
+ }
+ namespace export debug ;# [configure -debug]
+ namespace export errorFile ;# [configure -errfile]
+ namespace export limitConstraints ;# [configure -limitconstraints]
+ namespace export loadFile ;# [configure -loadfile]
+ namespace export loadScript ;# [configure -load]
+ namespace export match ;# [configure -match]
+ namespace export matchFiles ;# [configure -file]
+ namespace export matchDirectories ;# [configure -relateddir]
+ namespace export normalizeMsg ;# application of [customMatch]
+ namespace export normalizePath ;# [file normalize] (8.4)
+ namespace export outputFile ;# [configure -outfile]
+ namespace export preserveCore ;# [configure -preservecore]
+ namespace export singleProcess ;# [configure -singleproc]
+ namespace export skip ;# [configure -skip]
+ namespace export skipFiles ;# [configure -notfile]
+ namespace export skipDirectories ;# [configure -asidefromdir]
+ namespace export temporaryDirectory ;# [configure -tmpdir]
+ namespace export testsDirectory ;# [configure -testdir]
+ namespace export verbose ;# [configure -verbose]
+ namespace export viewFile ;# binary encoding [read]
+ namespace export workingDirectory ;# [cd] [pwd]
+
+ # Export deprecated commands for tcltest 1 compatibility
+ namespace export getMatchingFiles mainThread restoreState saveState \
+ threadReap
+
+ # tcltest::normalizePath --
+ #
+ # This procedure resolves any symlinks in the path thus creating
+ # a path without internal redirection. It assumes that the
+ # incoming path is absolute.
+ #
+ # Arguments
+ # pathVar - name of variable containing path to modify.
+ #
+ # Results
+ # The path is modified in place.
+ #
+ # Side Effects:
+ # None.
+ #
+ proc normalizePath {pathVar} {
+ upvar 1 $pathVar path
+ set oldpwd [pwd]
+ catch {cd $path}
+ set path [pwd]
+ cd $oldpwd
+ return $path
+ }
+
+##### Verification commands used to test values of variables and options
+ #
+ # Verification command that accepts everything
+ proc AcceptAll {value} {
+ return $value
+ }
+
+ # Verification command that accepts valid Tcl lists
+ proc AcceptList { list } {
+ return [lrange $list 0 end]
+ }
+
+ # Verification command that accepts a glob pattern
+ proc AcceptPattern { pattern } {
+ return [AcceptAll $pattern]
+ }
+
+ # Verification command that accepts integers
+ proc AcceptInteger { level } {
+ return [incr level 0]
+ }
+
+ # Verification command that accepts boolean values
+ proc AcceptBoolean { boolean } {
+ return [expr {$boolean && $boolean}]
+ }
+
+ # Verification command that accepts (syntactically) valid Tcl scripts
+ proc AcceptScript { script } {
+ if {![info complete $script]} {
+ return -code error "invalid Tcl script: $script"
+ }
+ return $script
+ }
+
+ # Verification command that accepts (converts to) absolute pathnames
+ proc AcceptAbsolutePath { path } {
+ return [file join [pwd] $path]
+ }
+
+ # Verification command that accepts existing readable directories
+ proc AcceptReadable { path } {
+ if {![file readable $path]} {
+ return -code error "\"$path\" is not readable"
+ }
+ return $path
+ }
+ proc AcceptDirectory { directory } {
+ set directory [AcceptAbsolutePath $directory]
+ if {![file exists $directory]} {
+ return -code error "\"$directory\" does not exist"
+ }
+ if {![file isdir $directory]} {
+ return -code error "\"$directory\" is not a directory"
+ }
+ return [AcceptReadable $directory]
+ }
+
+##### Initialize internal arrays of tcltest, but only if the caller
+ # has not already pre-initialized them. This is done to support
+ # compatibility with older tests that directly access internals
+ # rather than go through command interfaces.
+ #
+ proc ArrayDefault {varName value} {
+ variable $varName
+ if {[array exists $varName]} {
+ return
+ }
+ if {[info exists $varName]} {
+ # Pre-initialized value is a scalar: destroy it!
+ unset $varName
+ }
+ array set $varName $value
+ }
+
+ # save the original environment so that it can be restored later
+ ArrayDefault originalEnv [array get ::env]
+
+ # initialize numTests array to keep track of the number of tests
+ # that pass, fail, and are skipped.
+ ArrayDefault numTests [list Total 0 Passed 0 Skipped 0 Failed 0]
+
+ # createdNewFiles will store test files as indices and the list of
+ # files (that should not have been) left behind by the test files
+ # as values.
+ ArrayDefault createdNewFiles {}
+
+ # initialize skippedBecause array to keep track of constraints that
+ # kept tests from running; a constraint name of "userSpecifiedSkip"
+ # means that the test appeared on the list of tests that matched the
+ # -skip value given to the flag; "userSpecifiedNonMatch" means that
+ # the test didn't match the argument given to the -match flag; both
+ # of these constraints are counted only if tcltest::debug is set to
+ # true.
+ ArrayDefault skippedBecause {}
+
+ # initialize the testConstraints array to keep track of valid
+ # predefined constraints (see the explanation for the
+ # InitConstraints proc for more details).
+ ArrayDefault testConstraints {}
+
+##### Initialize internal variables of tcltest, but only if the caller
+ # has not already pre-initialized them. This is done to support
+ # compatibility with older tests that directly access internals
+ # rather than go through command interfaces.
+ #
+ proc Default {varName value {verify AcceptAll}} {
+ variable $varName
+ if {![info exists $varName]} {
+ variable $varName [$verify $value]
+ } else {
+ variable $varName [$verify [set $varName]]
+ }
+ }
+
+ # Save any arguments that we might want to pass through to other
+ # programs. This is used by the -args flag.
+ # FINDUSER
+ Default parameters {}
+
+ # Count the number of files tested (0 if runAllTests wasn't called).
+ # runAllTests will set testSingleFile to false, so stats will
+ # not be printed until runAllTests calls the cleanupTests proc.
+ # The currentFailure var stores the boolean value of whether the
+ # current test file has had any failures. The failFiles list
+ # stores the names of test files that had failures.
+ Default numTestFiles 0 AcceptInteger
+ Default testSingleFile true AcceptBoolean
+ Default currentFailure false AcceptBoolean
+ Default failFiles {} AcceptList
+
+ # Tests should remove all files they create. The test suite will
+ # check the current working dir for files created by the tests.
+ # filesMade keeps track of such files created using the makeFile and
+ # makeDirectory procedures. filesExisted stores the names of
+ # pre-existing files.
+ #
+ # Note that $filesExisted lists only those files that exist in
+ # the original [temporaryDirectory].
+ Default filesMade {} AcceptList
+ Default filesExisted {} AcceptList
+ proc FillFilesExisted {} {
+ variable filesExisted
+
+ # Save the names of files that already exist in the scratch directory.
+ foreach file [glob -nocomplain -directory [temporaryDirectory] *] {
+ lappend filesExisted [file tail $file]
+ }
+
+ # After successful filling, turn this into a no-op.
+ proc FillFilesExisted args {}
+ }
+
+ # Kept only for compatibility
+ Default constraintsSpecified {} AcceptList
+ trace add variable constraintsSpecified read [namespace code {
+ set constraintsSpecified [array names testConstraints] ;#}]
+
+ # tests that use threads need to know which is the main thread
+ Default mainThread 1
+ variable mainThread
+ if {[info commands thread::id] ne {}} {
+ set mainThread [thread::id]
+ } elseif {[info commands testthread] ne {}} {
+ set mainThread [testthread id]
+ }
+
+ # Set workingDirectory to [pwd]. The default output directory for
+ # Tcl tests is the working directory. Whenever this value changes
+ # change to that directory.
+ variable workingDirectory
+ trace add variable workingDirectory write \
+ [namespace code {cd $workingDirectory ;#}]
+
+ Default workingDirectory [pwd] AcceptAbsolutePath
+ proc workingDirectory { {dir ""} } {
+ variable workingDirectory
+ if {[llength [info level 0]] == 1} {
+ return $workingDirectory
+ }
+ set workingDirectory [AcceptAbsolutePath $dir]
+ }
+
+ # Set the location of the execuatble
+ Default tcltest [info nameofexecutable]
+ trace add variable tcltest write [namespace code {testConstraint stdio \
+ [eval [ConstraintInitializer stdio]] ;#}]
+
+ # save the platform information so it can be restored later
+ Default originalTclPlatform [array get ::tcl_platform]
+
+ # If a core file exists, save its modification time.
+ if {[file exists [file join [workingDirectory] core]]} {
+ Default coreModTime \
+ [file mtime [file join [workingDirectory] core]]
+ }
+
+ # stdout and stderr buffers for use when we want to store them
+ Default outData {}
+ Default errData {}
+
+ # keep track of test level for nested test commands
+ variable testLevel 0
+
+ # the variables and procs that existed when saveState was called are
+ # stored in a variable of the same name
+ Default saveState {}
+
+ # Internationalization support -- used in [SetIso8859_1_Locale] and
+ # [RestoreLocale]. Those commands are used in cmdIL.test.
+
+ if {![info exists [namespace current]::isoLocale]} {
+ variable isoLocale fr
+ switch -- $::tcl_platform(platform) {
+ "unix" {
+
+ # Try some 'known' values for some platforms:
+
+ switch -exact -- $::tcl_platform(os) {
+ "FreeBSD" {
+ set isoLocale fr_FR.ISO_8859-1
+ }
+ HP-UX {
+ set isoLocale fr_FR.iso88591
+ }
+ Linux -
+ IRIX {
+ set isoLocale fr
+ }
+ default {
+
+ # Works on SunOS 4 and Solaris, and maybe
+ # others... Define it to something else on your
+ # system if you want to test those.
+
+ set isoLocale iso_8859_1
+ }
+ }
+ }
+ "windows" {
+ set isoLocale French
+ }
+ }
+ }
+
+ variable ChannelsWeOpened; array set ChannelsWeOpened {}
+ # output goes to stdout by default
+ Default outputChannel stdout
+ proc outputChannel { {filename ""} } {
+ variable outputChannel
+ variable ChannelsWeOpened
+
+ # This is very subtle and tricky, so let me try to explain.
+ # (Hopefully this longer comment will be clear when I come
+ # back in a few months, unlike its predecessor :) )
+ #
+ # The [outputChannel] command (and underlying variable) have to
+ # be kept in sync with the [configure -outfile] configuration
+ # option ( and underlying variable Option(-outfile) ). This is
+ # accomplished with a write trace on Option(-outfile) that will
+ # update [outputChannel] whenver a new value is written. That
+ # much is easy.
+ #
+ # The trick is that in order to maintain compatibility with
+ # version 1 of tcltest, we must allow every configuration option
+ # to get its inital value from command line arguments. This is
+ # accomplished by setting initial read traces on all the
+ # configuration options to parse the command line option the first
+ # time they are read. These traces are cancelled whenever the
+ # program itself calls [configure].
+ #
+ # OK, then so to support tcltest 1 compatibility, it seems we want
+ # to get the return from [outputFile] to trigger the read traces,
+ # just in case.
+ #
+ # BUT! A little known feature of Tcl variable traces is that
+ # traces are disabled during the handling of other traces. So,
+ # if we trigger read traces on Option(-outfile) and that triggers
+ # command line parsing which turns around and sets an initial
+ # value for Option(-outfile) -- <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 {[lsearch -exact $Option(-verbose) $level] >= 0}]
+ }
+
+ # Default verbosity is to show bodies of failed tests
+ Option -verbose {body error} {
+ Takes any combination of the values 'p', 's', 'b', 't', 'e' and 'l'.
+ Test suite will display all passed tests if 'p' is specified, all
+ skipped tests if 's' is specified, the bodies of failed tests if
+ 'b' is specified, and when tests start if 't' is specified.
+ ErrorInfo is displayed if 'e' is specified. Source file line
+ information of failed tests is displayed if 'l' is specified.
+ } AcceptVerbose verbose
+
+ # Match and skip patterns default to the empty list, except for
+ # matchFiles, which defaults to all .test files in the
+ # testsDirectory and matchDirectories, which defaults to all
+ # directories.
+ Option -match * {
+ Run all tests within the specified files that match one of the
+ list of glob patterns given.
+ } AcceptList match
+
+ Option -skip {} {
+ Skip all tests within the specified tests (via -match) and files
+ that match one of the list of glob patterns given.
+ } AcceptList skip
+
+ Option -file *.test {
+ Run tests in all test files that match the glob pattern given.
+ } AcceptPattern matchFiles
+
+ # By default, skip files that appear to be SCCS lock files.
+ Option -notfile l.*.test {
+ Skip all test files that match the glob pattern given.
+ } AcceptPattern skipFiles
+
+ Option -relateddir * {
+ Run tests in directories that match the glob pattern given.
+ } AcceptPattern matchDirectories
+
+ Option -asidefromdir {} {
+ Skip tests in directories that match the glob pattern given.
+ } AcceptPattern skipDirectories
+
+ # By default, don't save core files
+ Option -preservecore 0 {
+ If 2, save any core files produced during testing in the directory
+ specified by -tmpdir. If 1, notify the user if core files are
+ created.
+ } AcceptInteger preserveCore
+
+ # debug output doesn't get printed by default; debug level 1 spits
+ # up only the tests that were skipped because they didn't match or
+ # were specifically skipped. A debug level of 2 would spit up the
+ # tcltest variables and flags provided; a debug level of 3 causes
+ # some additional output regarding operations of the test harness.
+ # The tcltest package currently implements only up to debug level 3.
+ Option -debug 0 {
+ Internal debug level
+ } AcceptInteger debug
+
+ proc SetSelectedConstraints args {
+ variable Option
+ foreach c $Option(-constraints) {
+ testConstraint $c 1
+ }
+ }
+ Option -constraints {} {
+ Do not skip the listed constraints listed in -constraints.
+ } AcceptList
+ trace add variable Option(-constraints) write \
+ [namespace code {SetSelectedConstraints ;#}]
+
+ # Don't run only the "-constraint" specified tests by default
+ proc ClearUnselectedConstraints args {
+ variable Option
+ variable testConstraints
+ if {!$Option(-limitconstraints)} {return}
+ foreach c [array names testConstraints] {
+ if {$c ni $Option(-constraints)} {
+ testConstraint $c 0
+ }
+ }
+ }
+ Option -limitconstraints 0 {
+ whether to run only tests with the constraints
+ } AcceptBoolean limitConstraints
+ trace add variable Option(-limitconstraints) write \
+ [namespace code {ClearUnselectedConstraints ;#}]
+
+ # A test application has to know how to load the tested commands
+ # into the interpreter.
+ Option -load {} {
+ Specifies the script to load the tested commands.
+ } AcceptScript loadScript
+
+ # Default is to run each test file in a separate process
+ Option -singleproc 0 {
+ whether to run all tests in one process
+ } AcceptBoolean singleProcess
+
+ proc AcceptTemporaryDirectory { directory } {
+ set directory [AcceptAbsolutePath $directory]
+ if {![file exists $directory]} {
+ file mkdir $directory
+ }
+ set directory [AcceptDirectory $directory]
+ if {![file writable $directory]} {
+ if {[workingDirectory] eq $directory} {
+ # Special exception: accept the default value
+ # even if the directory is not writable
+ return $directory
+ }
+ return -code error "\"$directory\" is not writeable"
+ }
+ return $directory
+ }
+
+ # Directory where files should be created
+ Option -tmpdir [workingDirectory] {
+ Save temporary files in the specified directory.
+ } AcceptTemporaryDirectory temporaryDirectory
+ trace add variable Option(-tmpdir) write \
+ [namespace code {normalizePath Option(-tmpdir) ;#}]
+
+ # Tests should not rely on the current working directory.
+ # Files that are part of the test suite should be accessed relative
+ # to [testsDirectory]
+ Option -testdir [workingDirectory] {
+ Search tests in the specified directory.
+ } AcceptDirectory testsDirectory
+ trace add variable Option(-testdir) write \
+ [namespace code {normalizePath Option(-testdir) ;#}]
+
+ proc AcceptLoadFile { file } {
+ if {$file eq {}} {return $file}
+ set file [file join [temporaryDirectory] $file]
+ return [AcceptReadable $file]
+ }
+ proc ReadLoadScript {args} {
+ variable Option
+ if {$Option(-loadfile) eq {}} {return}
+ set tmp [open $Option(-loadfile) r]
+ loadScript [read $tmp]
+ close $tmp
+ }
+ Option -loadfile {} {
+ Read the script to load the tested commands from the specified file.
+ } AcceptLoadFile loadFile
+ trace add variable Option(-loadfile) write [namespace code ReadLoadScript]
+
+ proc AcceptOutFile { file } {
+ if {[string equal stderr $file]} {return $file}
+ if {[string equal stdout $file]} {return $file}
+ return [file join [temporaryDirectory] $file]
+ }
+
+ # output goes to stdout by default
+ Option -outfile stdout {
+ Send output from test runs to the specified file.
+ } AcceptOutFile outputFile
+ trace add variable Option(-outfile) write \
+ [namespace code {outputChannel $Option(-outfile) ;#}]
+
+ # errors go to stderr by default
+ Option -errfile stderr {
+ Send errors from test runs to the specified file.
+ } AcceptOutFile errorFile
+ trace add variable Option(-errfile) write \
+ [namespace code {errorChannel $Option(-errfile) ;#}]
+
+ proc loadIntoChildInterpreter {child args} {
+ variable Version
+ interp eval $child [package ifneeded tcltest $Version]
+ interp eval $child "tcltest::configure {*}{$args}"
+ interp alias $child ::tcltest::ReportToParent \
+ {} ::tcltest::ReportedFromChild
+ }
+ proc ReportedFromChild {total passed skipped failed because newfiles} {
+ variable numTests
+ variable skippedBecause
+ variable createdNewFiles
+ incr numTests(Total) $total
+ incr numTests(Passed) $passed
+ incr numTests(Skipped) $skipped
+ incr numTests(Failed) $failed
+ foreach {constraint count} $because {
+ incr skippedBecause($constraint) $count
+ }
+ foreach {testfile created} $newfiles {
+ lappend createdNewFiles($testfile) {*}$created
+ }
+ return
+ }
+}
+
+#####################################################################
+
+# tcltest::Debug* --
+#
+# Internal helper procedures to write out debug information
+# dependent on the chosen level. A test shell may overide
+# them, f.e. to redirect the output into a different
+# channel, or even into a GUI.
+
+# tcltest::DebugPuts --
+#
+# Prints the specified string if the current debug level is
+# higher than the provided level argument.
+#
+# Arguments:
+# level The lowest debug level triggering the output
+# string The string to print out.
+#
+# Results:
+# Prints the string. Nothing else is allowed.
+#
+# Side Effects:
+# None.
+#
+
+proc tcltest::DebugPuts {level string} {
+ variable debug
+ if {$debug >= $level} {
+ puts $string
+ }
+ return
+}
+
+# tcltest::DebugPArray --
+#
+# Prints the contents of the specified array if the current
+# debug level is higher than the provided level argument
+#
+# Arguments:
+# level The lowest debug level triggering the output
+# arrayvar The name of the array to print out.
+#
+# Results:
+# Prints the contents of the array. Nothing else is allowed.
+#
+# Side Effects:
+# None.
+#
+
+proc tcltest::DebugPArray {level arrayvar} {
+ variable debug
+
+ if {$debug >= $level} {
+ catch {upvar 1 $arrayvar $arrayvar}
+ parray $arrayvar
+ }
+ return
+}
+
+# Define our own [parray] in ::tcltest that will inherit use of the [puts]
+# defined in ::tcltest. NOTE: Ought to construct with [info args] and
+# [info default], but can't be bothered now. If [parray] changes, then
+# this will need changing too.
+auto_load ::parray
+proc tcltest::parray {a {pattern *}} [info body ::parray]
+
+# tcltest::DebugDo --
+#
+# Executes the script if the current debug level is greater than
+# the provided level argument
+#
+# Arguments:
+# level The lowest debug level triggering the execution.
+# script The tcl script executed upon a debug level high enough.
+#
+# Results:
+# Arbitrary side effects, dependent on the executed script.
+#
+# Side Effects:
+# None.
+#
+
+proc tcltest::DebugDo {level script} {
+ variable debug
+
+ if {$debug >= $level} {
+ uplevel 1 $script
+ }
+ return
+}
+
+#####################################################################
+
+proc tcltest::Warn {msg} {
+ puts [outputChannel] "WARNING: $msg"
+}
+
+# tcltest::mainThread
+#
+# Accessor command for tcltest variable mainThread.
+#
+proc tcltest::mainThread { {new ""} } {
+ variable mainThread
+ if {[llength [info level 0]] == 1} {
+ return $mainThread
+ }
+ set mainThread $new
+}
+
+# tcltest::testConstraint --
+#
+# sets a test constraint to a value; to do multiple constraints,
+# call this proc multiple times. also returns the value of the
+# named constraint if no value was supplied.
+#
+# Arguments:
+# constraint - name of the constraint
+# value - new value for constraint (should be boolean) - if not
+# supplied, this is a query
+#
+# Results:
+# content of tcltest::testConstraints($constraint)
+#
+# Side effects:
+# none
+
+proc tcltest::testConstraint {constraint {value ""}} {
+ variable testConstraints
+ variable Option
+ DebugPuts 3 "entering testConstraint $constraint $value"
+ if {[llength [info level 0]] == 2} {
+ return $testConstraints($constraint)
+ }
+ # Check for boolean values
+ if {[catch {expr {$value && 1}} msg]} {
+ return -code error $msg
+ }
+ if {[limitConstraints] && ($constraint ni $Option(-constraints))} {
+ set value 0
+ }
+ set testConstraints($constraint) $value
+}
+
+# tcltest::interpreter --
+#
+# the interpreter name stored in tcltest::tcltest
+#
+# Arguments:
+# executable name
+#
+# Results:
+# content of tcltest::tcltest
+#
+# Side effects:
+# None.
+
+proc tcltest::interpreter { {interp ""} } {
+ variable tcltest
+ if {[llength [info level 0]] == 1} {
+ return $tcltest
+ }
+ set tcltest $interp
+}
+
+#####################################################################
+
+# tcltest::AddToSkippedBecause --
+#
+# Increments the variable used to track how many tests were
+# skipped because of a particular constraint.
+#
+# Arguments:
+# constraint The name of the constraint to be modified
+#
+# Results:
+# Modifies tcltest::skippedBecause; sets the variable to 1 if
+# didn't previously exist - otherwise, it just increments it.
+#
+# Side effects:
+# None.
+
+proc tcltest::AddToSkippedBecause { constraint {value 1}} {
+ # add the constraint to the list of constraints that kept tests
+ # from running
+ variable skippedBecause
+
+ if {[info exists skippedBecause($constraint)]} {
+ incr skippedBecause($constraint) $value
+ } else {
+ set skippedBecause($constraint) $value
+ }
+ return
+}
+
+# tcltest::PrintError --
+#
+# Prints errors to tcltest::errorChannel and then flushes that
+# channel, making sure that all messages are < 80 characters per
+# line.
+#
+# Arguments:
+# errorMsg String containing the error to be printed
+#
+# Results:
+# None.
+#
+# Side effects:
+# None.
+
+proc tcltest::PrintError {errorMsg} {
+ set InitialMessage "Error: "
+ set InitialMsgLen [string length $InitialMessage]
+ puts -nonewline [errorChannel] $InitialMessage
+
+ # Keep track of where the end of the string is.
+ set endingIndex [string length $errorMsg]
+
+ if {$endingIndex < (80 - $InitialMsgLen)} {
+ puts [errorChannel] $errorMsg
+ } else {
+ # Print up to 80 characters on the first line, including the
+ # InitialMessage.
+ set beginningIndex [string last " " [string range $errorMsg 0 \
+ [expr {80 - $InitialMsgLen}]]]
+ puts [errorChannel] [string range $errorMsg 0 $beginningIndex]
+
+ while {$beginningIndex ne "end"} {
+ puts -nonewline [errorChannel] \
+ [string repeat " " $InitialMsgLen]
+ if {($endingIndex - $beginningIndex)
+ < (80 - $InitialMsgLen)} {
+ puts [errorChannel] [string trim \
+ [string range $errorMsg $beginningIndex end]]
+ break
+ } else {
+ set newEndingIndex [expr {[string last " " \
+ [string range $errorMsg $beginningIndex \
+ [expr {$beginningIndex
+ + (80 - $InitialMsgLen)}]
+ ]] + $beginningIndex}]
+ if {($newEndingIndex <= 0)
+ || ($newEndingIndex <= $beginningIndex)} {
+ set newEndingIndex end
+ }
+ puts [errorChannel] [string trim \
+ [string range $errorMsg \
+ $beginningIndex $newEndingIndex]]
+ set beginningIndex $newEndingIndex
+ }
+ }
+ }
+ flush [errorChannel]
+ return
+}
+
+# tcltest::SafeFetch --
+#
+# The following trace procedure makes it so that we can safely
+# refer to non-existent members of the testConstraints array
+# without causing an error. Instead, reading a non-existent
+# member will return 0. This is necessary because tests are
+# allowed to use constraint "X" without ensuring that
+# testConstraints("X") is defined.
+#
+# Arguments:
+# n1 - name of the array (testConstraints)
+# n2 - array key value (constraint name)
+# op - operation performed on testConstraints (generally r)
+#
+# Results:
+# none
+#
+# Side effects:
+# sets testConstraints($n2) to 0 if it's referenced but never
+# before used
+
+proc tcltest::SafeFetch {n1 n2 op} {
+ variable testConstraints
+ DebugPuts 3 "entering SafeFetch $n1 $n2 $op"
+ if {$n2 eq {}} {return}
+ if {![info exists testConstraints($n2)]} {
+ if {[catch {testConstraint $n2 [eval [ConstraintInitializer $n2]]}]} {
+ testConstraint $n2 0
+ }
+ }
+}
+
+# tcltest::ConstraintInitializer --
+#
+# Get or set a script that when evaluated in the tcltest namespace
+# will return a boolean value with which to initialize the
+# associated constraint.
+#
+# Arguments:
+# constraint - name of the constraint initialized by the script
+# script - the initializer script
+#
+# Results
+# boolean value of the constraint - enabled or disabled
+#
+# Side effects:
+# Constraint is initialized for future reference by [test]
+proc tcltest::ConstraintInitializer {constraint {script ""}} {
+ variable ConstraintInitializer
+ DebugPuts 3 "entering ConstraintInitializer $constraint $script"
+ if {[llength [info level 0]] == 2} {
+ return $ConstraintInitializer($constraint)
+ }
+ # Check for boolean values
+ if {![info complete $script]} {
+ return -code error "ConstraintInitializer must be complete script"
+ }
+ set ConstraintInitializer($constraint) $script
+}
+
+# tcltest::InitConstraints --
+#
+# Call all registered constraint initializers to force initialization
+# of all known constraints.
+# See the tcltest man page for the list of built-in constraints defined
+# in this procedure.
+#
+# Arguments:
+# none
+#
+# Results:
+# The testConstraints array is reset to have an index for each
+# built-in test constraint.
+#
+# Side Effects:
+# None.
+#
+
+proc tcltest::InitConstraints {} {
+ variable ConstraintInitializer
+ initConstraintsHook
+ foreach constraint [array names ConstraintInitializer] {
+ testConstraint $constraint
+ }
+}
+
+proc tcltest::DefineConstraintInitializers {} {
+ ConstraintInitializer singleTestInterp {singleProcess}
+
+ # All the 'pc' constraints are here for backward compatibility and
+ # are not documented. They have been replaced with equivalent 'win'
+ # constraints.
+
+ ConstraintInitializer unixOnly \
+ {string equal $::tcl_platform(platform) unix}
+ ConstraintInitializer macOnly \
+ {string equal $::tcl_platform(platform) macintosh}
+ ConstraintInitializer pcOnly \
+ {string equal $::tcl_platform(platform) windows}
+ ConstraintInitializer winOnly \
+ {string equal $::tcl_platform(platform) windows}
+
+ ConstraintInitializer unix {testConstraint unixOnly}
+ ConstraintInitializer mac {testConstraint macOnly}
+ ConstraintInitializer pc {testConstraint pcOnly}
+ ConstraintInitializer win {testConstraint winOnly}
+
+ ConstraintInitializer unixOrPc \
+ {expr {[testConstraint unix] || [testConstraint pc]}}
+ ConstraintInitializer macOrPc \
+ {expr {[testConstraint mac] || [testConstraint pc]}}
+ ConstraintInitializer unixOrWin \
+ {expr {[testConstraint unix] || [testConstraint win]}}
+ ConstraintInitializer macOrWin \
+ {expr {[testConstraint mac] || [testConstraint win]}}
+ ConstraintInitializer macOrUnix \
+ {expr {[testConstraint mac] || [testConstraint unix]}}
+
+ ConstraintInitializer nt {string equal $::tcl_platform(os) "Windows NT"}
+ ConstraintInitializer 95 {string equal $::tcl_platform(os) "Windows 95"}
+ ConstraintInitializer 98 {string equal $::tcl_platform(os) "Windows 98"}
+
+ # The following Constraints switches are used to mark tests that
+ # should work, but have been temporarily disabled on certain
+ # platforms because they don't and we haven't gotten around to
+ # fixing the underlying problem.
+
+ ConstraintInitializer tempNotPc {expr {![testConstraint pc]}}
+ ConstraintInitializer tempNotWin {expr {![testConstraint win]}}
+ ConstraintInitializer tempNotMac {expr {![testConstraint mac]}}
+ ConstraintInitializer tempNotUnix {expr {![testConstraint unix]}}
+
+ # The following Constraints switches are used to mark tests that
+ # crash on certain platforms, so that they can be reactivated again
+ # when the underlying problem is fixed.
+
+ ConstraintInitializer pcCrash {expr {![testConstraint pc]}}
+ ConstraintInitializer winCrash {expr {![testConstraint win]}}
+ ConstraintInitializer macCrash {expr {![testConstraint mac]}}
+ ConstraintInitializer unixCrash {expr {![testConstraint unix]}}
+
+ # Skip empty tests
+
+ ConstraintInitializer emptyTest {format 0}
+
+ # By default, tests that expose known bugs are skipped.
+
+ ConstraintInitializer knownBug {format 0}
+
+ # By default, non-portable tests are skipped.
+
+ ConstraintInitializer nonPortable {format 0}
+
+ # Some tests require user interaction.
+
+ ConstraintInitializer userInteraction {format 0}
+
+ # Some tests must be skipped if the interpreter is not in
+ # interactive mode
+
+ ConstraintInitializer interactive \
+ {expr {[info exists ::tcl_interactive] && $::tcl_interactive}}
+
+ # Some tests can only be run if the installation came from a CD
+ # image instead of a web image. Some tests must be skipped if you
+ # are running as root on Unix. Other tests can only be run if you
+ # are running as root on Unix.
+
+ ConstraintInitializer root {expr \
+ {($::tcl_platform(platform) eq "unix") &&
+ ($::tcl_platform(user) in {root {}})}}
+ ConstraintInitializer notRoot {expr {![testConstraint root]}}
+
+ # Set nonBlockFiles constraint: 1 means this platform supports
+ # setting files into nonblocking mode.
+
+ ConstraintInitializer nonBlockFiles {
+ set code [expr {[catch {set f [open defs r]}]
+ || [catch {fconfigure $f -blocking off}]}]
+ catch {close $f}
+ set code
+ }
+
+ # Set asyncPipeClose constraint: 1 means this platform supports
+ # async flush and async close on a pipe.
+ #
+ # Test for SCO Unix - cannot run async flushing tests because a
+ # potential problem with select is apparently interfering.
+ # (Mark Diekhans).
+
+ ConstraintInitializer asyncPipeClose {expr {
+ !([string equal unix $::tcl_platform(platform)]
+ && ([catch {exec uname -X | fgrep {Release = 3.2v}}] == 0))}}
+
+ # Test to see if we have a broken version of sprintf with respect
+ # to the "e" format of floating-point numbers.
+
+ ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05}
+
+ # Test to see if execed commands such as cat, echo, rm and so forth
+ # are present on this machine.
+
+ ConstraintInitializer unixExecs {
+ set code 1
+ if {$::tcl_platform(platform) eq "macintosh"} {
+ set code 0
+ }
+ if {$::tcl_platform(platform) eq "windows"} {
+ if {[catch {
+ set file _tcl_test_remove_me.txt
+ makeFile {hello} $file
+ }]} {
+ set code 0
+ } elseif {
+ [catch {exec cat $file}] ||
+ [catch {exec echo hello}] ||
+ [catch {exec sh -c echo hello}] ||
+ [catch {exec wc $file}] ||
+ [catch {exec sleep 1}] ||
+ [catch {exec echo abc > $file}] ||
+ [catch {exec chmod 644 $file}] ||
+ [catch {exec rm $file}] ||
+ [llength [auto_execok mkdir]] == 0 ||
+ [llength [auto_execok fgrep]] == 0 ||
+ [llength [auto_execok grep]] == 0 ||
+ [llength [auto_execok ps]] == 0
+ } {
+ set code 0
+ }
+ removeFile $file
+ }
+ set code
+ }
+
+ ConstraintInitializer stdio {
+ set code 0
+ if {![catch {set f [open "|[list [interpreter]]" w]}]} {
+ if {![catch {puts $f exit}]} {
+ if {![catch {close $f}]} {
+ set code 1
+ }
+ }
+ }
+ set code
+ }
+
+ # Deliberately call socket with the wrong number of arguments. The
+ # error message you get will indicate whether sockets are available
+ # on this system.
+
+ ConstraintInitializer socket {
+ catch {socket} msg
+ string compare $msg "sockets are not available on this system"
+ }
+
+ # Check for internationalization
+ ConstraintInitializer hasIsoLocale {
+ if {[llength [info commands testlocale]] == 0} {
+ set code 0
+ } else {
+ set code [string length [SetIso8859_1_Locale]]
+ RestoreLocale
+ }
+ set code
+ }
+
+}
+#####################################################################
+
+# Usage and command line arguments processing.
+
+# tcltest::PrintUsageInfo
+#
+# Prints out the usage information for package tcltest. This can
+# be customized with the redefinition of [PrintUsageInfoHook].
+#
+# Arguments:
+# none
+#
+# Results:
+# none
+#
+# Side Effects:
+# none
+proc tcltest::PrintUsageInfo {} {
+ puts [Usage]
+ PrintUsageInfoHook
+}
+
+proc tcltest::Usage { {option ""} } {
+ variable Usage
+ variable Verify
+ if {[llength [info level 0]] == 1} {
+ set msg "Usage: [file tail [info nameofexecutable]] script "
+ append msg "?-help? ?flag value? ... \n"
+ append msg "Available flags (and valid input values) are:"
+
+ set max 0
+ set allOpts [concat -help [Configure]]
+ foreach opt $allOpts {
+ set foo [Usage $opt]
+ lassign $foo x type($opt) usage($opt)
+ set line($opt) " $opt $type($opt) "
+ set length($opt) [string length $line($opt)]
+ if {$length($opt) > $max} {set max $length($opt)}
+ }
+ set rest [expr {72 - $max}]
+ foreach opt $allOpts {
+ append msg \n$line($opt)
+ append msg [string repeat " " [expr {$max - $length($opt)}]]
+ set u [string trim $usage($opt)]
+ catch {append u " (default: \[[Configure $opt]])"}
+ regsub -all {\s*\n\s*} $u " " u
+ while {[string length $u] > $rest} {
+ set break [string wordstart $u $rest]
+ if {$break == 0} {
+ set break [string wordend $u 0]
+ }
+ append msg [string range $u 0 [expr {$break - 1}]]
+ set u [string trim [string range $u $break end]]
+ append msg \n[string repeat " " $max]
+ }
+ append msg $u
+ }
+ return $msg\n
+ } elseif {$option eq "-help"} {
+ return [list -help "" "Display this usage information."]
+ } else {
+ set type [lindex [info args $Verify($option)] 0]
+ return [list $option $type $Usage($option)]
+ }
+}
+
+# tcltest::ProcessFlags --
+#
+# process command line arguments supplied in the flagArray - this
+# is called by processCmdLineArgs. Modifies tcltest variables
+# according to the content of the flagArray.
+#
+# Arguments:
+# flagArray - array containing name/value pairs of flags
+#
+# Results:
+# sets tcltest variables according to their values as defined by
+# flagArray
+#
+# Side effects:
+# None.
+
+proc tcltest::ProcessFlags {flagArray} {
+ # Process -help first
+ if {"-help" in $flagArray} {
+ PrintUsageInfo
+ exit 1
+ }
+
+ if {[llength $flagArray] == 0} {
+ RemoveAutoConfigureTraces
+ } else {
+ set args $flagArray
+ while {[llength $args] > 1 && [catch {configure {*}$args} msg]} {
+
+ # Something went wrong parsing $args for tcltest options
+ # Check whether the problem is "unknown option"
+ if {[regexp {^unknown option (\S+):} $msg -> option]} {
+ # Could be this is an option the Hook knows about
+ set moreOptions [processCmdLineArgsAddFlagsHook]
+ if {$option ni $moreOptions} {
+ # Nope. Report the error, including additional options,
+ # but keep going
+ if {[llength $moreOptions]} {
+ append msg ", "
+ append msg [join [lrange $moreOptions 0 end-1] ", "]
+ append msg "or [lindex $moreOptions end]"
+ }
+ Warn $msg
+ }
+ } else {
+ # error is something other than "unknown option"
+ # notify user of the error; and exit
+ puts [errorChannel] $msg
+ exit 1
+ }
+
+ # To recover, find that unknown option and remove up to it.
+ # then retry
+ while {[lindex $args 0] ne $option} {
+ set args [lrange $args 2 end]
+ }
+ set args [lrange $args 2 end]
+ }
+ if {[llength $args] == 1} {
+ puts [errorChannel] \
+ "missing value for option [lindex $args 0]"
+ exit 1
+ }
+ }
+
+ # Call the hook
+ catch {
+ array set flag $flagArray
+ processCmdLineArgsHook [array get flag]
+ }
+ return
+}
+
+# tcltest::ProcessCmdLineArgs --
+#
+# This procedure must be run after constraint initialization is
+# set up (by [DefineConstraintInitializers]) because some constraints
+# can be overridden.
+#
+# Perform configuration according to the command-line options.
+#
+# Arguments:
+# none
+#
+# Results:
+# Sets the above-named variables in the tcltest namespace.
+#
+# Side Effects:
+# None.
+#
+
+proc tcltest::ProcessCmdLineArgs {} {
+ variable originalEnv
+ variable testConstraints
+
+ # The "argv" var doesn't exist in some cases, so use {}.
+ if {![info exists ::argv]} {
+ ProcessFlags {}
+ } else {
+ ProcessFlags $::argv
+ }
+
+ # Spit out everything you know if we're at a debug level 2 or
+ # greater
+ DebugPuts 2 "Flags passed into tcltest:"
+ if {[info exists ::env(TCLTEST_OPTIONS)]} {
+ DebugPuts 2 \
+ " ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)"
+ }
+ if {[info exists ::argv]} {
+ DebugPuts 2 " argv: $::argv"
+ }
+ DebugPuts 2 "tcltest::debug = [debug]"
+ DebugPuts 2 "tcltest::testsDirectory = [testsDirectory]"
+ DebugPuts 2 "tcltest::workingDirectory = [workingDirectory]"
+ DebugPuts 2 "tcltest::temporaryDirectory = [temporaryDirectory]"
+ DebugPuts 2 "tcltest::outputChannel = [outputChannel]"
+ DebugPuts 2 "tcltest::errorChannel = [errorChannel]"
+ DebugPuts 2 "Original environment (tcltest::originalEnv):"
+ DebugPArray 2 originalEnv
+ DebugPuts 2 "Constraints:"
+ DebugPArray 2 testConstraints
+}
+
+#####################################################################
+
+# Code to run the tests goes here.
+
+# tcltest::TestPuts --
+#
+# Used to redefine puts in test environment. Stores whatever goes
+# out on stdout in tcltest::outData and stderr in errData before
+# sending it on to the regular puts.
+#
+# Arguments:
+# same as standard puts
+#
+# Results:
+# none
+#
+# Side effects:
+# Intercepts puts; data that would otherwise go to stdout, stderr,
+# or file channels specified in outputChannel and errorChannel
+# does not get sent to the normal puts function.
+namespace eval tcltest::Replace {
+ namespace export puts
+}
+proc tcltest::Replace::puts {args} {
+ variable [namespace parent]::outData
+ variable [namespace parent]::errData
+ switch [llength $args] {
+ 1 {
+ # Only the string to be printed is specified
+ append outData [lindex $args 0]\n
+ return
+ # return [Puts [lindex $args 0]]
+ }
+ 2 {
+ # Either -nonewline or channelId has been specified
+ if {[lindex $args 0] eq "-nonewline"} {
+ append outData [lindex $args end]
+ return
+ # return [Puts -nonewline [lindex $args end]]
+ } else {
+ set channel [lindex $args 0]
+ set newline \n
+ }
+ }
+ 3 {
+ if {[lindex $args 0] eq "-nonewline"} {
+ # Both -nonewline and channelId are specified, unless
+ # it's an error. -nonewline is supposed to be argv[0].
+ set channel [lindex $args 1]
+ set newline ""
+ }
+ }
+ }
+
+ if {[info exists channel]} {
+ if {$channel in [list [[namespace parent]::outputChannel] stdout]} {
+ append outData [lindex $args end]$newline
+ return
+ } elseif {$channel in [list [[namespace parent]::errorChannel] stderr]} {
+ append errData [lindex $args end]$newline
+ return
+ }
+ }
+
+ # If we haven't returned by now, we don't know how to handle the
+ # input. Let puts handle it.
+ return [Puts {*}$args]
+}
+
+# tcltest::Eval --
+#
+# Evaluate the script in the test environment. If ignoreOutput is
+# false, store data sent to stderr and stdout in outData and
+# errData. Otherwise, ignore this output altogether.
+#
+# Arguments:
+# script Script to evaluate
+# ?ignoreOutput? Indicates whether or not to ignore output
+# sent to stdout & stderr
+#
+# Results:
+# result from running the script
+#
+# Side effects:
+# Empties the contents of outData and errData before running a
+# test if ignoreOutput is set to 0.
+
+proc tcltest::Eval {script {ignoreOutput 1}} {
+ variable outData
+ variable errData
+ DebugPuts 3 "[lindex [info level 0] 0] called"
+ if {!$ignoreOutput} {
+ set outData {}
+ set errData {}
+ rename ::puts [namespace current]::Replace::Puts
+ namespace eval :: [list namespace import [namespace origin Replace::puts]]
+ namespace import Replace::puts
+ }
+ set result [uplevel 1 $script]
+ if {!$ignoreOutput} {
+ namespace forget puts
+ namespace eval :: namespace forget puts
+ rename [namespace current]::Replace::Puts ::puts
+ }
+ return $result
+}
+
+# tcltest::CompareStrings --
+#
+# compares the expected answer to the actual answer, depending on
+# the mode provided. Mode determines whether a regexp, exact,
+# glob or custom comparison is done.
+#
+# Arguments:
+# actual - string containing the actual result
+# expected - pattern to be matched against
+# mode - type of comparison to be done
+#
+# Results:
+# result of the match
+#
+# Side effects:
+# None.
+
+proc tcltest::CompareStrings {actual expected mode} {
+ variable CustomMatch
+ if {![info exists CustomMatch($mode)]} {
+ return -code error "No matching command registered for `-match $mode'"
+ }
+ set match [namespace eval :: $CustomMatch($mode) [list $expected $actual]]
+ if {[catch {expr {$match && $match}} result]} {
+ return -code error "Invalid result from `-match $mode' command: $result"
+ }
+ return $match
+}
+
+# tcltest::customMatch --
+#
+# registers a command to be called when a particular type of
+# matching is required.
+#
+# Arguments:
+# nickname - Keyword for the type of matching
+# cmd - Incomplete command that implements that type of matching
+# when completed with expected string and actual string
+# and then evaluated.
+#
+# Results:
+# None.
+#
+# Side effects:
+# Sets the variable tcltest::CustomMatch
+
+proc tcltest::customMatch {mode script} {
+ variable CustomMatch
+ if {![info complete $script]} {
+ return -code error \
+ "invalid customMatch script; can't evaluate after completion"
+ }
+ set CustomMatch($mode) $script
+}
+
+# tcltest::SubstArguments list
+#
+# This helper function takes in a list of words, then perform a
+# substitution on the list as though each word in the list is a separate
+# argument to the Tcl function. For example, if this function is
+# invoked as:
+#
+# SubstArguments {$a {$a}}
+#
+# Then it is as though the function is invoked as:
+#
+# SubstArguments $a {$a}
+#
+# This code is adapted from Paul Duffin's function "SplitIntoWords".
+# The original function can be found on:
+#
+# http://purl.org/thecliff/tcl/wiki/858.html
+#
+# Results:
+# a list containing the result of the substitution
+#
+# Exceptions:
+# An error may occur if the list containing unbalanced quote or
+# unknown variable.
+#
+# Side Effects:
+# None.
+#
+
+proc tcltest::SubstArguments {argList} {
+
+ # We need to split the argList up into tokens but cannot use list
+ # operations as they throw away some significant quoting, and
+ # [split] ignores braces as it should. Therefore what we do is
+ # gradually build up a string out of whitespace seperated strings.
+ # We cannot use [split] to split the argList into whitespace
+ # separated strings as it throws away the whitespace which maybe
+ # important so we have to do it all by hand.
+
+ set result {}
+ set token ""
+
+ while {[string length $argList]} {
+ # Look for the next word containing a quote: " { }
+ if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \
+ $argList all]} {
+ # Get the text leading up to this word, but not including
+ # this word, from the argList.
+ set text [string range $argList 0 \
+ [expr {[lindex $all 0] - 1}]]
+ # Get the word with the quote
+ set word [string range $argList \
+ [lindex $all 0] [lindex $all 1]]
+
+ # Remove all text up to and including the word from the
+ # argList.
+ set argList [string range $argList \
+ [expr {[lindex $all 1] + 1}] end]
+ } else {
+ # Take everything up to the end of the argList.
+ set text $argList
+ set word {}
+ set argList {}
+ }
+
+ if {$token ne {}} {
+ # If we saw a word with quote before, then there is a
+ # multi-word token starting with that word. In this case,
+ # add the text and the current word to this token.
+ append token $text $word
+ } else {
+ # Add the text to the result. There is no need to parse
+ # the text because it couldn't be a part of any multi-word
+ # token. Then start a new multi-word token with the word
+ # because we need to pass this token to the Tcl parser to
+ # check for balancing quotes
+ append result $text
+ set token $word
+ }
+
+ if { [catch {llength $token} length] == 0 && $length == 1} {
+ # The token is a valid list so add it to the result.
+ # lappend result [string trim $token]
+ append result \{$token\}
+ set token {}
+ }
+ }
+
+ # If the last token has not been added to the list then there
+ # is a problem.
+ if { [string length $token] } {
+ error "incomplete token \"$token\""
+ }
+
+ return $result
+}
+
+
+# tcltest::test --
+#
+# This procedure runs a test and prints an error message if the test
+# fails. If verbose has been set, it also prints a message even if the
+# test succeeds. The test will be skipped if it doesn't match the
+# match variable, if it matches an element in skip, or if one of the
+# elements of "constraints" turns out not to be true.
+#
+# If testLevel is 1, then this is a top level test, and we record
+# pass/fail information; otherwise, this information is not logged and
+# is not added to running totals.
+#
+# Attributes:
+# Only description is a required attribute. All others are optional.
+# Default values are indicated.
+#
+# constraints - A list of one or more keywords, each of which
+# must be the name of an element in the array
+# "testConstraints". If any of these elements is
+# zero, the test is skipped. This attribute is
+# optional; default is {}
+# body - Script to run to carry out the test. It must
+# return a result that can be checked for
+# correctness. This attribute is optional;
+# default is {}
+# result - Expected result from script. This attribute is
+# optional; default is {}.
+# output - Expected output sent to stdout. This attribute
+# is optional; default is {}.
+# errorOutput - Expected output sent to stderr. This attribute
+# is optional; default is {}.
+# returnCodes - Expected return codes. This attribute is
+# optional; default is {0 2}.
+# errorCode - Expected error code. This attribute is
+# optional; default is {*}. It is a glob pattern.
+# If given, returnCodes defaults to {1}.
+# setup - Code to run before $script (above). This
+# attribute is optional; default is {}.
+# cleanup - Code to run after $script (above). This
+# attribute is optional; default is {}.
+# match - specifies type of matching to do on result,
+# output, errorOutput; this must be a string
+# previously registered by a call to [customMatch].
+# The strings exact, glob, and regexp are pre-registered
+# by the tcltest package. Default value is exact.
+#
+# Arguments:
+# name - Name of test, in the form foo-1.2.
+# description - Short textual description of the test, to
+# help humans understand what it does.
+#
+# Results:
+# None.
+#
+# Side effects:
+# Just about anything is possible depending on the test.
+#
+
+proc tcltest::test {name description args} {
+ global tcl_platform
+ variable testLevel
+ variable coreModTime
+ DebugPuts 3 "test $name $args"
+ DebugDo 1 {
+ variable TestNames
+ catch {
+ puts "test name '$name' re-used; prior use in $TestNames($name)"
+ }
+ set TestNames($name) [info script]
+ }
+
+ FillFilesExisted
+ incr testLevel
+
+ # Pre-define everything to null except output and errorOutput. We
+ # determine whether or not to trap output based on whether or not
+ # these variables (output & errorOutput) are defined.
+ lassign {} constraints setup cleanup body result returnCodes errorCode match
+
+ # Set the default match mode
+ set match exact
+
+ # Set the default match values for return codes (0 is the standard
+ # expected return value if everything went well; 2 represents
+ # 'return' being used in the test script).
+ set returnCodes [list 0 2]
+
+ # Set the default error code pattern
+ set errorCode "*"
+
+ # The old test format can't have a 3rd argument (constraints or
+ # script) that starts with '-'.
+ if {[string match -* [lindex $args 0]] || ([llength $args] <= 1)} {
+ if {[llength $args] == 1} {
+ set list [SubstArguments [lindex $args 0]]
+ foreach {element value} $list {
+ set testAttributes($element) $value
+ }
+ foreach item {constraints match setup body cleanup \
+ result returnCodes errorCode output errorOutput} {
+ if {[info exists testAttributes(-$item)]} {
+ set testAttributes(-$item) [uplevel 1 \
+ ::concat $testAttributes(-$item)]
+ }
+ }
+ } else {
+ array set testAttributes $args
+ }
+
+ set validFlags {-setup -cleanup -body -result -returnCodes \
+ -errorCode -match -output -errorOutput -constraints}
+
+ foreach flag [array names testAttributes] {
+ if {$flag ni $validFlags} {
+ incr testLevel -1
+ set sorted [lsort $validFlags]
+ set options [join [lrange $sorted 0 end-1] ", "]
+ append options ", or [lindex $sorted end]"
+ return -code error "bad option \"$flag\": must be $options"
+ }
+ }
+
+ # store whatever the user gave us
+ foreach item [array names testAttributes] {
+ set [string trimleft $item "-"] $testAttributes($item)
+ }
+
+ # Check the values supplied for -match
+ variable CustomMatch
+ if {$match ni [array names CustomMatch]} {
+ incr testLevel -1
+ set sorted [lsort [array names CustomMatch]]
+ set values [join [lrange $sorted 0 end-1] ", "]
+ append values ", or [lindex $sorted end]"
+ return -code error "bad -match value \"$match\":\
+ must be $values"
+ }
+
+ # Replace symbolic valies supplied for -returnCodes
+ foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} {
+ set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes]
+ }
+ # errorCode without returnCode 1 is meaningless
+ if {$errorCode ne "*" && 1 ni $returnCodes} {
+ set returnCodes 1
+ }
+ } else {
+ # This is parsing for the old test command format; it is here
+ # for backward compatibility.
+ set result [lindex $args end]
+ if {[llength $args] == 2} {
+ set body [lindex $args 0]
+ } elseif {[llength $args] == 3} {
+ set constraints [lindex $args 0]
+ set body [lindex $args 1]
+ } else {
+ incr testLevel -1
+ return -code error "wrong # args:\
+ should be \"test name desc ?options?\""
+ }
+ }
+
+ if {[Skipped $name $constraints]} {
+ incr testLevel -1
+ return
+ }
+
+ # Save information about the core file.
+ if {[preserveCore]} {
+ if {[file exists [file join [workingDirectory] core]]} {
+ set coreModTime [file mtime [file join [workingDirectory] core]]
+ }
+ }
+
+ # First, run the setup script (or a hook if it presents):
+ if {[set cmd [namespace which -command [namespace current]::SetupTest]] ne ""} {
+ set setup [list $cmd $setup]
+ }
+ set processTest 1
+ set code [catch {uplevel 1 $setup} setupMsg]
+ if {$code == 1} {
+ set errorInfo(setup) $::errorInfo
+ set errorCodeRes(setup) $::errorCode
+ if {$errorCodeRes(setup) eq "BYPASS-SKIPPED-TEST"} {
+ _noticeSkipped $name $setupMsg
+ set processTest [set code 0]
+ }
+ }
+ set setupFailure [expr {$code != 0}]
+
+ # Only run the test body if the setup was successful
+ if {$processTest && !$setupFailure} {
+
+ # Register startup time
+ if {[IsVerbose msec] || [IsVerbose usec]} {
+ set timeStart [clock microseconds]
+ }
+
+ # Verbose notification of $body start
+ if {[IsVerbose start]} {
+ puts [outputChannel] "---- $name start"
+ flush [outputChannel]
+ }
+
+ set command [list [namespace origin RunTest] $name $body]
+ if {[info exists output] || [info exists errorOutput]} {
+ set testResult [uplevel 1 [list [namespace origin Eval] $command 0]]
+ } else {
+ set testResult [uplevel 1 [list [namespace origin Eval] $command 1]]
+ }
+ lassign $testResult actualAnswer returnCode
+ if {$returnCode == 1} {
+ set errorInfo(body) $::errorInfo
+ set errorCodeRes(body) $::errorCode
+ if {$errorCodeRes(body) eq "BYPASS-SKIPPED-TEST"} {
+ _noticeSkipped $name $actualAnswer
+ set processTest [set returnCode 0]
+ }
+ }
+ }
+
+ # check if the return code matched the expected return code
+ set codeFailure 0
+ if {$processTest && !$setupFailure && ($returnCode ni $returnCodes)} {
+ set codeFailure 1
+ }
+ set errorCodeFailure 0
+ if {$processTest && !$setupFailure && !$codeFailure && $returnCode == 1 && \
+ ![string match $errorCode $errorCodeRes(body)]} {
+ set errorCodeFailure 1
+ }
+
+ # If expected output/error strings exist, we have to compare
+ # them. If the comparison fails, then so did the test.
+ set outputFailure 0
+ variable outData
+ if {$processTest && [info exists output] && !$codeFailure} {
+ if {[set outputCompare [catch {
+ CompareStrings $outData $output $match
+ } outputMatch]] == 0} {
+ set outputFailure [expr {!$outputMatch}]
+ } else {
+ set outputFailure 1
+ }
+ }
+
+ set errorFailure 0
+ variable errData
+ if {$processTest && [info exists errorOutput] && !$codeFailure} {
+ if {[set errorCompare [catch {
+ CompareStrings $errData $errorOutput $match
+ } errorMatch]] == 0} {
+ set errorFailure [expr {!$errorMatch}]
+ } else {
+ set errorFailure 1
+ }
+ }
+
+ # check if the answer matched the expected answer
+ # Only check if we ran the body of the test (no setup failure)
+ if {!$processTest} {
+ set scriptFailure 0
+ } elseif {$setupFailure || $codeFailure} {
+ set scriptFailure 0
+ } elseif {[set scriptCompare [catch {
+ CompareStrings $actualAnswer $result $match
+ } scriptMatch]] == 0} {
+ set scriptFailure [expr {!$scriptMatch}]
+ } else {
+ set scriptFailure 1
+ }
+
+ # Always run the cleanup script (or a hook if it presents):
+ if {[set cmd [namespace which -command [namespace current]::CleanupTest]] ne ""} {
+ set cleanup [list $cmd $cleanup]
+ }
+ set code [catch {uplevel 1 $cleanup} cleanupMsg]
+ if {$code == 1} {
+ set errorInfo(cleanup) $::errorInfo
+ set errorCodeRes(cleanup) $::errorCode
+ }
+ set cleanupFailure [expr {$code != 0}]
+
+ set coreFailure 0
+ set coreMsg ""
+ # check for a core file first - if one was created by the test,
+ # then the test failed
+ if {[preserveCore]} {
+ if {[file exists [file join [workingDirectory] core]]} {
+ # There's only a test failure if there is a core file
+ # and (1) there previously wasn't one or (2) the new
+ # one is different from the old one.
+ if {[info exists coreModTime]} {
+ if {$coreModTime != [file mtime \
+ [file join [workingDirectory] core]]} {
+ set coreFailure 1
+ }
+ } else {
+ set coreFailure 1
+ }
+
+ if {([preserveCore] > 1) && ($coreFailure)} {
+ append coreMsg "\nMoving file to:\
+ [file join [temporaryDirectory] core-$name]"
+ catch {file rename -force -- \
+ [file join [workingDirectory] core] \
+ [file join [temporaryDirectory] core-$name]
+ } msg
+ if {$msg ne {}} {
+ append coreMsg "\nError:\
+ Problem renaming core file: $msg"
+ }
+ }
+ }
+ }
+
+ if {[IsVerbose msec] || [IsVerbose usec]} {
+ set t [expr {[clock microseconds] - $timeStart}]
+ if {[IsVerbose usec]} {
+ puts [outputChannel] "++++ $name took $t μs"
+ }
+ if {[IsVerbose msec]} {
+ puts [outputChannel] "++++ $name took [expr {round($t/1000.)}] ms"
+ }
+ }
+
+ # if skipped, it is safe to return here
+ if {!$processTest} {
+ incr testLevel -1
+ return
+ }
+
+ # if we didn't experience any failures, then we passed
+ variable numTests
+ if {!($setupFailure || $cleanupFailure || $coreFailure
+ || $outputFailure || $errorFailure || $codeFailure
+ || $errorCodeFailure || $scriptFailure)} {
+ if {$testLevel == 1} {
+ incr numTests(Passed)
+ if {[IsVerbose pass]} {
+ puts [outputChannel] "++++ $name PASSED"
+ }
+ }
+ incr testLevel -1
+ return
+ }
+
+ # We know the test failed, tally it...
+ if {$testLevel == 1} {
+ incr numTests(Failed)
+ }
+
+ # ... then report according to the type of failure
+ variable currentFailure true
+ if {![IsVerbose body]} {
+ set body ""
+ }
+ puts [outputChannel] "\n"
+ if {[IsVerbose line]} {
+ if {![catch {set testFrame [info frame -1]}] &&
+ [dict get $testFrame type] eq "source"} {
+ set testFile [dict get $testFrame file]
+ set testLine [dict get $testFrame line]
+ } else {
+ set testFile [file normalize [uplevel 1 {info script}]]
+ if {[file readable $testFile]} {
+ set testFd [open $testFile r]
+ set testLine [expr {[lsearch -regexp \
+ [split [read $testFd] "\n"] \
+ "^\[ \t\]*test [string map {. \\.} $name] "] + 1}]
+ close $testFd
+ }
+ }
+ if {[info exists testLine]} {
+ puts [outputChannel] "$testFile:$testLine: error: test failed:\
+ $name [string trim $description]"
+ }
+ }
+ puts [outputChannel] "==== $name\
+ [string trim $description] FAILED"
+ if {[string length $body]} {
+ puts [outputChannel] "==== Contents of test case:"
+ puts [outputChannel] $body
+ }
+ if {$setupFailure} {
+ puts [outputChannel] "---- Test setup\
+ failed:\n$setupMsg"
+ if {[info exists errorInfo(setup)]} {
+ puts [outputChannel] "---- errorInfo(setup): $errorInfo(setup)"
+ puts [outputChannel] "---- errorCode(setup): $errorCodeRes(setup)"
+ }
+ }
+ if {$processTest && $scriptFailure} {
+ if {$scriptCompare} {
+ puts [outputChannel] "---- Error testing result: $scriptMatch"
+ } else {
+ puts [outputChannel] "---- Result was:\n$actualAnswer"
+ puts [outputChannel] "---- Result should have been\
+ ($match matching):\n$result"
+ }
+ }
+ if {$errorCodeFailure} {
+ puts [outputChannel] "---- Error code was: '$errorCodeRes(body)'"
+ puts [outputChannel] "---- Error code should have been: '$errorCode'"
+ }
+ if {$codeFailure} {
+ switch -- $returnCode {
+ 0 { set msg "Test completed normally" }
+ 1 { set msg "Test generated error" }
+ 2 { set msg "Test generated return exception" }
+ 3 { set msg "Test generated break exception" }
+ 4 { set msg "Test generated continue exception" }
+ default { set msg "Test generated exception" }
+ }
+ puts [outputChannel] "---- $msg; Return code was: $returnCode"
+ puts [outputChannel] "---- Return code should have been\
+ one of: $returnCodes"
+ if {[IsVerbose error]} {
+ if {[info exists errorInfo(body)] && (1 ni $returnCodes)} {
+ puts [outputChannel] "---- errorInfo: $errorInfo(body)"
+ puts [outputChannel] "---- errorCode: $errorCodeRes(body)"
+ }
+ }
+ }
+ if {$outputFailure} {
+ if {$outputCompare} {
+ puts [outputChannel] "---- Error testing output: $outputMatch"
+ } else {
+ puts [outputChannel] "---- Output was:\n$outData"
+ puts [outputChannel] "---- Output should have been\
+ ($match matching):\n$output"
+ }
+ }
+ if {$errorFailure} {
+ if {$errorCompare} {
+ puts [outputChannel] "---- Error testing errorOutput: $errorMatch"
+ } else {
+ puts [outputChannel] "---- Error output was:\n$errData"
+ puts [outputChannel] "---- Error output should have\
+ been ($match matching):\n$errorOutput"
+ }
+ }
+ if {$cleanupFailure} {
+ puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg"
+ if {[info exists errorInfo(cleanup)]} {
+ puts [outputChannel] "---- errorInfo(cleanup): $errorInfo(cleanup)"
+ puts [outputChannel] "---- errorCode(cleanup): $errorCodeRes(cleanup)"
+ }
+ }
+ if {$coreFailure} {
+ puts [outputChannel] "---- Core file produced while running\
+ test! $coreMsg"
+ }
+ puts [outputChannel] "==== $name FAILED\n"
+
+ incr testLevel -1
+ return
+}
+
+# Skip --
+#
+# Skips a running test and add a reason to skipped "constraints". Can be used
+# to conditional intended abort of the test.
+#
+# Side Effects: Maintains tally of total tests seen and tests skipped.
+#
+proc tcltest::Skip {reason} {
+ return -code error -errorcode BYPASS-SKIPPED-TEST $reason
+}
+
+proc tcltest::_noticeSkipped {name reason} {
+ variable testLevel
+ variable numTests
+
+ if {[IsVerbose skip]} {
+ puts [outputChannel] "++++ $name SKIPPED: $reason"
+ }
+
+ if {$testLevel == 1} {
+ incr numTests(Skipped)
+ AddToSkippedBecause $reason
+ }
+}
+
+
+# Skipped --
+#
+# Given a test name and it constraints, returns a boolean indicating
+# whether the current configuration says the test should be skipped.
+#
+# Side Effects: Maintains tally of total tests seen and tests skipped.
+#
+proc tcltest::Skipped {name constraints} {
+ variable testLevel
+ variable numTests
+ variable testConstraints
+
+ if {$testLevel == 1} {
+ incr numTests(Total)
+ }
+ # skip the test if it's name matches an element of skip
+ foreach pattern [skip] {
+ if {[string match $pattern $name]} {
+ if {$testLevel == 1} {
+ incr numTests(Skipped)
+ DebugDo 1 {AddToSkippedBecause userSpecifiedSkip}
+ }
+ return 1
+ }
+ }
+ # skip the test if it's name doesn't match any element of match
+ set ok 0
+ foreach pattern [match] {
+ if {[string match $pattern $name]} {
+ set ok 1
+ break
+ }
+ }
+ if {!$ok} {
+ if {$testLevel == 1} {
+ incr numTests(Skipped)
+ DebugDo 1 {AddToSkippedBecause userSpecifiedNonMatch}
+ }
+ return 1
+ }
+ if {$constraints eq {}} {
+ # If we're limited to the listed constraints and there aren't
+ # any listed, then we shouldn't run the test.
+ if {[limitConstraints]} {
+ AddToSkippedBecause userSpecifiedLimitConstraint
+ if {$testLevel == 1} {
+ incr numTests(Skipped)
+ }
+ return 1
+ }
+ } else {
+ # "constraints" argument exists;
+ # make sure that the constraints are satisfied.
+
+ set doTest 0
+ if {[string match {*[$\[]*} $constraints] != 0} {
+ # full expression, e.g. {$foo > [info tclversion]}
+ catch {set doTest [uplevel #0 [list expr $constraints]]}
+ } elseif {[regexp {[^.:_a-zA-Z0-9 \n\r\t]+} $constraints] != 0} {
+ # something like {a || b} should be turned into
+ # $testConstraints(a) || $testConstraints(b).
+ regsub -all {[.\w]+} $constraints {$testConstraints(&)} c
+ catch {set doTest [eval [list expr $c]]}
+ } elseif {![catch {llength $constraints}]} {
+ # just simple constraints such as {unixOnly fonts}.
+ set doTest 1
+ foreach constraint $constraints {
+ if {(![info exists testConstraints($constraint)]) \
+ || (!$testConstraints($constraint))} {
+ set doTest 0
+
+ # store the constraint that kept the test from
+ # running
+ set constraints $constraint
+ break
+ }
+ }
+ }
+
+ if {!$doTest} {
+ _noticeSkipped $name $constraints
+ return 1
+ }
+ }
+ return 0
+}
+
+# RunTest --
+#
+# This is where the body of a test is evaluated. The combination of
+# [RunTest] and [Eval] allows the output and error output of the test
+# body to be captured for comparison against the expected values.
+
+proc tcltest::RunTest {name script} {
+ DebugPuts 3 "Running $name {$script}"
+
+ # If there is no "memory" command (because memory debugging isn't
+ # enabled), then don't attempt to use the command.
+
+ if {[llength [info commands memory]] == 1} {
+ memory tag $name
+ }
+
+ # run the test script (or a hook if it presents):
+ if {[set cmd [namespace which -command [namespace current]::EvalTest]] ne ""} {
+ set script [list $cmd $script]
+ }
+ set code [catch {uplevel 1 $script} actualAnswer]
+
+ return [list $actualAnswer $code]
+}
+
+#####################################################################
+
+# tcltest::cleanupTestsHook --
+#
+# This hook allows a harness that builds upon tcltest to specify
+# additional things that should be done at cleanup.
+#
+
+if {[llength [info commands tcltest::cleanupTestsHook]] == 0} {
+ proc tcltest::cleanupTestsHook {} {}
+}
+
+# tcltest::cleanupTests --
+#
+# Remove files and dirs created using the makeFile and makeDirectory
+# commands since the last time this proc was invoked.
+#
+# Print the names of the files created without the makeFile command
+# since the tests were invoked.
+#
+# Print the number tests (total, passed, failed, and skipped) since the
+# tests were invoked.
+#
+# Restore original environment (as reported by special variable env).
+#
+# Arguments:
+# calledFromAllFile - if 0, behave as if we are running a single
+# test file within an entire suite of tests. if we aren't running
+# a single test file, then don't report status. check for new
+# files created during the test run and report on them. if 1,
+# report collated status from all the test file runs.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# None
+#
+
+proc tcltest::cleanupTests {{calledFromAllFile 0}} {
+ variable filesMade
+ variable filesExisted
+ variable createdNewFiles
+ variable testSingleFile
+ variable numTests
+ variable numTestFiles
+ variable failFiles
+ variable skippedBecause
+ variable currentFailure
+ variable originalEnv
+ variable originalTclPlatform
+ variable coreModTime
+
+ FillFilesExisted
+ set testFileName [file tail [info script]]
+
+ # Hook to handle reporting to a parent interpreter
+ if {[llength [info commands [namespace current]::ReportToParent]]} {
+ ReportToParent $numTests(Total) $numTests(Passed) $numTests(Skipped) \
+ $numTests(Failed) [array get skippedBecause] \
+ [array get createdNewFiles]
+ set testSingleFile false
+ }
+
+ # Call the cleanup hook
+ cleanupTestsHook
+
+ # Remove files and directories created by the makeFile and
+ # makeDirectory procedures. Record the names of files in
+ # workingDirectory that were not pre-existing, and associate them
+ # with the test file that created them.
+
+ if {!$calledFromAllFile} {
+ foreach file $filesMade {
+ if {[file exists $file]} {
+ DebugDo 1 {Warn "cleanupTests deleting $file..."}
+ catch {file delete -force -- $file}
+ }
+ }
+ set currentFiles {}
+ foreach file [glob -nocomplain \
+ -directory [temporaryDirectory] *] {
+ lappend currentFiles [file tail $file]
+ }
+ set newFiles {}
+ foreach file $currentFiles {
+ if {$file ni $filesExisted} {
+ lappend newFiles $file
+ }
+ }
+ set filesExisted $currentFiles
+ if {[llength $newFiles] > 0} {
+ set createdNewFiles($testFileName) $newFiles
+ }
+ }
+
+ if {$calledFromAllFile || $testSingleFile} {
+
+ # print stats
+
+ puts -nonewline [outputChannel] "$testFileName:"
+ foreach index [list "Total" "Passed" "Skipped" "Failed"] {
+ puts -nonewline [outputChannel] \
+ "\t$index\t$numTests($index)"
+ }
+ puts [outputChannel] ""
+
+ # print number test files sourced
+ # print names of files that ran tests which failed
+
+ if {$calledFromAllFile} {
+ puts [outputChannel] \
+ "Sourced $numTestFiles Test Files."
+ set numTestFiles 0
+ if {[llength $failFiles] > 0} {
+ puts [outputChannel] \
+ "Files with failing tests: $failFiles"
+ set failFiles {}
+ }
+ }
+
+ # if any tests were skipped, print the constraints that kept
+ # them from running.
+
+ set constraintList [array names skippedBecause]
+ if {[llength $constraintList] > 0} {
+ puts [outputChannel] \
+ "Number of tests skipped for each constraint:"
+ foreach constraint [lsort $constraintList] {
+ puts [outputChannel] \
+ "\t$skippedBecause($constraint)\t$constraint"
+ unset skippedBecause($constraint)
+ }
+ }
+
+ # report the names of test files in createdNewFiles, and reset
+ # the array to be empty.
+
+ set testFilesThatTurded [lsort [array names createdNewFiles]]
+ if {[llength $testFilesThatTurded] > 0} {
+ puts [outputChannel] "Warning: files left behind:"
+ foreach testFile $testFilesThatTurded {
+ puts [outputChannel] \
+ "\t$testFile:\t$createdNewFiles($testFile)"
+ unset createdNewFiles($testFile)
+ }
+ }
+
+ # reset filesMade, filesExisted, and numTests
+
+ set filesMade {}
+ foreach index [list "Total" "Passed" "Skipped" "Failed"] {
+ set numTests($index) 0
+ }
+
+ # exit only if running Tk in non-interactive mode
+ # This should be changed to determine if an event
+ # loop is running, which is the real issue.
+ # Actually, this doesn't belong here at all. A package
+ # really has no business [exit]-ing an application.
+ if {![catch {package present Tk}] && ![testConstraint interactive]} {
+ exit
+ }
+ } else {
+
+ # if we're deferring stat-reporting until all files are sourced,
+ # then add current file to failFile list if any tests in this
+ # file failed
+
+ if {$currentFailure && ($testFileName ni $failFiles)} {
+ lappend failFiles $testFileName
+ }
+ set currentFailure false
+
+ # restore the environment to the state it was in before this package
+ # was loaded
+
+ set newEnv {}
+ set changedEnv {}
+ set removedEnv {}
+ foreach index [array names ::env] {
+ if {![info exists originalEnv($index)]} {
+ lappend newEnv $index
+ unset ::env($index)
+ }
+ }
+ foreach index [array names originalEnv] {
+ if {![info exists ::env($index)]} {
+ lappend removedEnv $index
+ set ::env($index) $originalEnv($index)
+ } elseif {$::env($index) ne $originalEnv($index)} {
+ lappend changedEnv $index
+ set ::env($index) $originalEnv($index)
+ }
+ }
+ if {[llength $newEnv] > 0} {
+ puts [outputChannel] \
+ "env array elements created:\t$newEnv"
+ }
+ if {[llength $changedEnv] > 0} {
+ puts [outputChannel] \
+ "env array elements changed:\t$changedEnv"
+ }
+ if {[llength $removedEnv] > 0} {
+ puts [outputChannel] \
+ "env array elements removed:\t$removedEnv"
+ }
+
+ set changedTclPlatform {}
+ foreach index [array names originalTclPlatform] {
+ if {$::tcl_platform($index) \
+ != $originalTclPlatform($index)} {
+ lappend changedTclPlatform $index
+ set ::tcl_platform($index) $originalTclPlatform($index)
+ }
+ }
+ if {[llength $changedTclPlatform] > 0} {
+ puts [outputChannel] "tcl_platform array elements\
+ changed:\t$changedTclPlatform"
+ }
+
+ if {[file exists [file join [workingDirectory] core]]} {
+ if {[preserveCore] > 1} {
+ puts "rename core file (> 1)"
+ puts [outputChannel] "produced core file! \
+ Moving file to: \
+ [file join [temporaryDirectory] core-$testFileName]"
+ catch {file rename -force -- \
+ [file join [workingDirectory] core] \
+ [file join [temporaryDirectory] core-$testFileName]
+ } msg
+ if {$msg ne {}} {
+ PrintError "Problem renaming file: $msg"
+ }
+ } else {
+ # Print a message if there is a core file and (1) there
+ # previously wasn't one or (2) the new one is different
+ # from the old one.
+
+ if {[info exists coreModTime]} {
+ if {$coreModTime != [file mtime \
+ [file join [workingDirectory] core]]} {
+ puts [outputChannel] "A core file was created!"
+ }
+ } else {
+ puts [outputChannel] "A core file was created!"
+ }
+ }
+ }
+ }
+ flush [outputChannel]
+ flush [errorChannel]
+ return
+}
+
+#####################################################################
+
+# Procs that determine which tests/test files to run
+
+# tcltest::GetMatchingFiles
+#
+# Looks at the patterns given to match and skip files and uses
+# them to put together a list of the tests that will be run.
+#
+# Arguments:
+# directory to search
+#
+# Results:
+# The constructed list is returned to the user. This will
+# primarily be used in 'all.tcl' files. It is used in
+# runAllTests.
+#
+# Side Effects:
+# None
+
+# a lower case version is needed for compatibility with tcltest 1.0
+proc tcltest::getMatchingFiles args {GetMatchingFiles {*}$args}
+
+proc tcltest::GetMatchingFiles { args } {
+ if {[llength $args]} {
+ set dirList $args
+ } else {
+ # Finding tests only in [testsDirectory] is normal operation.
+ # This procedure is written to accept multiple directory arguments
+ # only to satisfy version 1 compatibility.
+ set dirList [list [testsDirectory]]
+ }
+
+ set matchingFiles [list]
+ foreach directory $dirList {
+
+ # List files in $directory that match patterns to run.
+ set matchFileList [list]
+ foreach match [matchFiles] {
+ set matchFileList [concat $matchFileList \
+ [glob -directory $directory -types {b c f p s} \
+ -nocomplain -- $match]]
+ }
+
+ # List files in $directory that match patterns to skip.
+ set skipFileList [list]
+ foreach skip [skipFiles] {
+ set skipFileList [concat $skipFileList \
+ [glob -directory $directory -types {b c f p s} \
+ -nocomplain -- $skip]]
+ }
+
+ # Add to result list all files in match list and not in skip list
+ foreach file $matchFileList {
+ if {$file ni $skipFileList} {
+ lappend matchingFiles $file
+ }
+ }
+ }
+
+ if {[llength $matchingFiles] == 0} {
+ PrintError "No test files remain after applying your match and\
+ skip patterns!"
+ }
+ return $matchingFiles
+}
+
+# tcltest::GetMatchingDirectories --
+#
+# Looks at the patterns given to match and skip directories and
+# uses them to put together a list of the test directories that we
+# should attempt to run. (Only subdirectories containing an
+# "all.tcl" file are put into the list.)
+#
+# Arguments:
+# root directory from which to search
+#
+# Results:
+# The constructed list is returned to the user. This is used in
+# the primary all.tcl file.
+#
+# Side Effects:
+# None.
+
+proc tcltest::GetMatchingDirectories {rootdir} {
+
+ # Determine the skip list first, to avoid [glob]-ing over subdirectories
+ # we're going to throw away anyway. Be sure we skip the $rootdir if it
+ # comes up to avoid infinite loops.
+ set skipDirs [list $rootdir]
+ foreach pattern [skipDirectories] {
+ set skipDirs [concat $skipDirs [glob -directory $rootdir -types d \
+ -nocomplain -- $pattern]]
+ }
+
+ # Now step through the matching directories, prune out the skipped ones
+ # as you go.
+ set matchDirs [list]
+ foreach pattern [matchDirectories] {
+ foreach path [glob -directory $rootdir -types d -nocomplain -- \
+ $pattern] {
+ if {$path ni $skipDirs} {
+ set matchDirs [concat $matchDirs [GetMatchingDirectories $path]]
+ if {[file exists [file join $path all.tcl]]} {
+ lappend matchDirs $path
+ }
+ }
+ }
+ }
+
+ if {[llength $matchDirs] == 0} {
+ DebugPuts 1 "No test directories remain after applying match\
+ and skip patterns!"
+ }
+ return [lsort $matchDirs]
+}
+
+# tcltest::runAllTests --
+#
+# prints output and sources test files according to the match and
+# skip patterns provided. after sourcing test files, it goes on
+# to source all.tcl files in matching test subdirectories.
+#
+# Arguments:
+# shell being tested
+#
+# Results:
+# Whether there were any failures.
+#
+# Side effects:
+# None.
+
+proc tcltest::runAllTests { {shell ""} } {
+ variable testSingleFile
+ variable numTestFiles
+ variable numTests
+ variable failFiles
+ variable DefaultValue
+
+ FillFilesExisted
+ if {[llength [info level 0]] == 1} {
+ set shell [interpreter]
+ }
+
+ set testSingleFile false
+
+ puts [outputChannel] "Tests running in interp: $shell"
+ puts [outputChannel] "Tests located in: [testsDirectory]"
+ puts [outputChannel] "Tests running in: [workingDirectory]"
+ puts [outputChannel] "Temporary files stored in\
+ [temporaryDirectory]"
+
+ # [file system] first available in Tcl 8.4
+ if {![catch {file system [testsDirectory]} result]
+ && ([lindex $result 0] ne "native")} {
+ # If we aren't running in the native filesystem, then we must
+ # run the tests in a single process (via 'source'), because
+ # trying to run then via a pipe will fail since the files don't
+ # really exist.
+ singleProcess 1
+ }
+
+ if {[singleProcess]} {
+ puts [outputChannel] \
+ "Test files sourced into current interpreter"
+ } else {
+ puts [outputChannel] \
+ "Test files run in separate interpreters"
+ }
+ if {[llength [skip]] > 0} {
+ puts [outputChannel] "Skipping tests that match: [skip]"
+ }
+ puts [outputChannel] "Running tests that match: [match]"
+
+ if {[llength [skipFiles]] > 0} {
+ puts [outputChannel] \
+ "Skipping test files that match: [skipFiles]"
+ }
+ if {[llength [matchFiles]] > 0} {
+ puts [outputChannel] \
+ "Only running test files that match: [matchFiles]"
+ }
+
+ set timeCmd {clock format [clock seconds]}
+ puts [outputChannel] "Tests began at [eval $timeCmd]"
+
+ # Run each of the specified tests
+ foreach file [lsort [GetMatchingFiles]] {
+ set tail [file tail $file]
+ puts [outputChannel] $tail
+ flush [outputChannel]
+
+ if {[singleProcess]} {
+ if {[catch {
+ incr numTestFiles
+ uplevel 1 [list ::source $file]
+ } msg]} {
+ puts [outputChannel] "Test file error: $msg"
+ # append the name of the test to a list to be reported
+ # later
+ lappend testFileFailures $file
+ }
+ if {$numTests(Failed) > 0} {
+ set failFilesSet 1
+ }
+ } else {
+ # Pass along our configuration to the child processes.
+ # EXCEPT for the -outfile, because the parent process
+ # needs to read and process output of children.
+ set childargv [list]
+ foreach opt [Configure] {
+ if {$opt eq "-outfile"} {continue}
+ set value [Configure $opt]
+ # Don't bother passing default configuration options
+ if {$value eq $DefaultValue($opt)} {
+ continue
+ }
+ lappend childargv $opt $value
+ }
+ set cmd [linsert $childargv 0 | $shell $file]
+ if {[catch {
+ incr numTestFiles
+ set pipeFd [open $cmd "r"]
+ while {[gets $pipeFd line] >= 0} {
+ if {[regexp [join {
+ {^([^:]+):\t}
+ {Total\t([0-9]+)\t}
+ {Passed\t([0-9]+)\t}
+ {Skipped\t([0-9]+)\t}
+ {Failed\t([0-9]+)}
+ } ""] $line null testFile \
+ Total Passed Skipped Failed]} {
+ foreach index {Total Passed Skipped Failed} {
+ incr numTests($index) [set $index]
+ }
+ if {$Failed > 0} {
+ lappend failFiles $testFile
+ set failFilesSet 1
+ }
+ } elseif {[regexp [join {
+ {^Number of tests skipped }
+ {for each constraint:}
+ {|^\t(\d+)\t(.+)$}
+ } ""] $line match skipped constraint]} {
+ if {[string match \t* $match]} {
+ AddToSkippedBecause $constraint $skipped
+ }
+ } else {
+ puts [outputChannel] $line
+ }
+ }
+ close $pipeFd
+ } msg]} {
+ puts [outputChannel] "Test file error: $msg"
+ # append the name of the test to a list to be reported
+ # later
+ lappend testFileFailures $file
+ }
+ }
+ }
+
+ # cleanup
+ puts [outputChannel] "\nTests ended at [eval $timeCmd]"
+ cleanupTests 1
+ if {[info exists testFileFailures]} {
+ puts [outputChannel] "\nTest files exiting with errors: \n"
+ foreach file $testFileFailures {
+ puts [outputChannel] " [file tail $file]\n"
+ }
+ }
+
+ # Checking for subdirectories in which to run tests
+ foreach directory [GetMatchingDirectories [testsDirectory]] {
+ set dir [file tail $directory]
+ puts [outputChannel] [string repeat ~ 44]
+ puts [outputChannel] "$dir test began at [eval $timeCmd]\n"
+
+ uplevel 1 [list ::source [file join $directory all.tcl]]
+
+ set endTime [eval $timeCmd]
+ puts [outputChannel] "\n$dir test ended at $endTime"
+ puts [outputChannel] ""
+ puts [outputChannel] [string repeat ~ 44]
+ }
+ return [expr {[info exists testFileFailures] || [info exists failFilesSet]}]
+}
+
+#####################################################################
+
+# Test utility procs - not used in tcltest, but may be useful for
+# testing.
+
+# tcltest::loadTestedCommands --
+#
+# Uses the specified script to load the commands to test. Allowed to
+# be empty, as the tested commands could have been compiled into the
+# interpreter.
+#
+# Arguments
+# none
+#
+# Results
+# none
+#
+# Side Effects:
+# none.
+
+proc tcltest::loadTestedCommands {} {
+ return [uplevel 1 [loadScript]]
+}
+
+# tcltest::saveState --
+#
+# Save information regarding what procs and variables exist.
+#
+# Arguments:
+# none
+#
+# Results:
+# Modifies the variable saveState
+#
+# Side effects:
+# None.
+
+proc tcltest::saveState {} {
+ variable saveState
+ uplevel 1 [list ::set [namespace which -variable saveState]] \
+ {[::list [::info procs] [::info vars]]}
+ DebugPuts 2 "[lindex [info level 0] 0]: $saveState"
+ return
+}
+
+# tcltest::restoreState --
+#
+# Remove procs and variables that didn't exist before the call to
+# [saveState].
+#
+# Arguments:
+# none
+#
+# Results:
+# Removes procs and variables from your environment if they don't
+# exist in the saveState variable.
+#
+# Side effects:
+# None.
+
+proc tcltest::restoreState {} {
+ variable saveState
+ foreach p [uplevel 1 {::info procs}] {
+ if {($p ni [lindex $saveState 0]) && ("[namespace current]::$p" ne
+ [uplevel 1 [list ::namespace origin $p]])} {
+
+ DebugPuts 2 "[lindex [info level 0] 0]: Removing proc $p"
+ uplevel 1 [list ::catch [list ::rename $p {}]]
+ }
+ }
+ foreach p [uplevel 1 {::info vars}] {
+ if {$p ni [lindex $saveState 1]} {
+ DebugPuts 2 "[lindex [info level 0] 0]:\
+ Removing variable $p"
+ uplevel 1 [list ::catch [list ::unset $p]]
+ }
+ }
+ return
+}
+
+# tcltest::normalizeMsg --
+#
+# Removes "extra" newlines from a string.
+#
+# Arguments:
+# msg String to be modified
+#
+# Results:
+# string with extra newlines removed
+#
+# Side effects:
+# None.
+
+proc tcltest::normalizeMsg {msg} {
+ regsub "\n$" [string tolower $msg] "" msg
+ set msg [string map [list "\n\n" "\n"] $msg]
+ return [string map [list "\n\}" "\}"] $msg]
+}
+
+# tcltest::makeFile --
+#
+# Create a new file with the name <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.1.tm
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8/8.6/http-2.9.1.tm 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8/8.6/http-2.9.1.tm 2021-03-02 16:29:37 UTC (rev 58056)
@@ -1,3427 +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.1
-
-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 != -1} {
- 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 close
- }
- 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
- }
- 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)"
- }
- 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)
- }
-
- # 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) {}
- }
- }
-
- 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.
- lassign [fconfigure $sock -translation] trRead trWrite
- fconfigure $state(-querychannel) -blocking 1 \
- -translation [list $trRead binary]
- set contDone 0
- }
- if {[info exists state(-method)] && ($state(-method) ne "")} {
- set how $state(-method)
- }
- # 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
- }
- 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 {[info exists phost] && ($phost ne "") && $state(-keepalive)} {
- puts $sock "Proxy-Connection: Keep-Alive"
- }
- 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
- fileevent $sock readable ${token}EventCoroutine
-}
-
-# 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 state(connection) \
- [string trim [string tolower $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 > -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.5.tm
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8/8.6/http-2.9.5.tm (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8/8.6/http-2.9.5.tm 2021-03-02 16:29:37 UTC (rev 58056)
@@ -0,0 +1,3506 @@
+# http.tcl --
+#
+# Client-side HTTP for GET, POST, and HEAD commands. These routines can
+# be used in untrusted code that uses the Safesock security policy.
+# These procedures use a callback interface to avoid using vwait, which
+# is not defined in the safe base.
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require Tcl 8.6-
+# Keep this in sync with pkgIndex.tcl and with the install directories in
+# Makefiles
+package provide http 2.9.5
+
+namespace eval http {
+ # Allow resourcing to not clobber existing data
+
+ variable http
+ if {![info exists http]} {
+ array set http {
+ -accept */*
+ -pipeline 1
+ -postfresh 0
+ -proxyhost {}
+ -proxyport {}
+ -proxyfilter http::ProxyRequired
+ -repost 0
+ -urlencoding utf-8
+ -zip 1
+ }
+ # We need a useragent string of this style or various servers will
+ # refuse to send us compressed content even when we ask for it. This
+ # follows the de-facto layout of user-agent strings in current browsers.
+ # Safe interpreters do not have ::tcl_platform(os) or
+ # ::tcl_platform(osVersion).
+ if {[interp issafe]} {
+ set http(-useragent) "Mozilla/5.0\
+ (Windows; U;\
+ Windows NT 10.0)\
+ http/[package provide http] Tcl/[package provide Tcl]"
+ } else {
+ set http(-useragent) "Mozilla/5.0\
+ ([string totitle $::tcl_platform(platform)]; U;\
+ $::tcl_platform(os) $::tcl_platform(osVersion))\
+ http/[package provide http] Tcl/[package provide Tcl]"
+ }
+ }
+
+ proc init {} {
+ # Set up the map for quoting chars. RFC3986 Section 2.3 say percent
+ # encode all except: "... percent-encoded octets in the ranges of
+ # ALPHA (%41-%5A and %61-%7A), DIGIT (%30-%39), hyphen (%2D), period
+ # (%2E), underscore (%5F), or tilde (%7E) should not be created by URI
+ # producers ..."
+ for {set i 0} {$i <= 256} {incr i} {
+ set c [format %c $i]
+ if {![string match {[-._~a-zA-Z0-9]} $c]} {
+ set map($c) %[format %.2X $i]
+ }
+ }
+ # These are handled specially
+ set map(\n) %0D%0A
+ variable formMap [array get map]
+
+ # Create a map for HTTP/1.1 open sockets
+ variable socketMapping
+ variable socketRdState
+ variable socketWrState
+ variable socketRdQueue
+ variable socketWrQueue
+ variable socketClosing
+ variable socketPlayCmd
+ if {[info exists socketMapping]} {
+ # Close open sockets on re-init. Do not permit retries.
+ foreach {url sock} [array get socketMapping] {
+ unset -nocomplain socketClosing($url)
+ unset -nocomplain socketPlayCmd($url)
+ CloseSocket $sock
+ }
+ }
+
+ # CloseSocket should have unset the socket* arrays, one element at
+ # a time. Now unset anything that was overlooked.
+ # Traces on "unset socketRdState(*)" will call CancelReadPipeline and
+ # cancel any queued responses.
+ # Traces on "unset socketWrState(*)" will call CancelWritePipeline and
+ # cancel any queued requests.
+ array unset socketMapping
+ array unset socketRdState
+ array unset socketWrState
+ array unset socketRdQueue
+ array unset socketWrQueue
+ array unset socketClosing
+ array unset socketPlayCmd
+ array set socketMapping {}
+ array set socketRdState {}
+ array set socketWrState {}
+ array set socketRdQueue {}
+ array set socketWrQueue {}
+ array set socketClosing {}
+ array set socketPlayCmd {}
+ }
+ init
+
+ variable urlTypes
+ if {![info exists urlTypes]} {
+ set urlTypes(http) [list 80 ::socket]
+ }
+
+ variable encodings [string tolower [encoding names]]
+ # This can be changed, but iso8859-1 is the RFC standard.
+ variable defaultCharset
+ if {![info exists defaultCharset]} {
+ set defaultCharset "iso8859-1"
+ }
+
+ # Force RFC 3986 strictness in geturl url verification?
+ variable strict
+ if {![info exists strict]} {
+ set strict 1
+ }
+
+ # Let user control default keepalive for compatibility
+ variable defaultKeepalive
+ if {![info exists defaultKeepalive]} {
+ set defaultKeepalive 0
+ }
+
+ namespace export geturl config reset wait formatQuery quoteString
+ namespace export register unregister registerError
+ # - Useful, but not exported: data, size, status, code, cleanup, error,
+ # meta, ncode, mapReply, init. Comments suggest that "init" can be used
+ # for re-initialisation, although the command is undocumented.
+ # - Not exported, probably should be upper-case initial letter as part
+ # of the internals: getTextLine, make-transformation-chunked.
+}
+
+# http::Log --
+#
+# Debugging output -- define this to observe HTTP/1.1 socket usage.
+# Should echo any args received.
+#
+# Arguments:
+# msg Message to output
+#
+if {[info command http::Log] eq {}} {proc http::Log {args} {}}
+
+# http::register --
+#
+# See documentation for details.
+#
+# Arguments:
+# proto URL protocol prefix, e.g. https
+# port Default port for protocol
+# command Command to use to create socket
+# Results:
+# list of port and command that was registered.
+
+proc http::register {proto port command} {
+ variable urlTypes
+ set urlTypes([string tolower $proto]) [list $port $command]
+}
+
+# http::unregister --
+#
+# Unregisters URL protocol handler
+#
+# Arguments:
+# proto URL protocol prefix, e.g. https
+# Results:
+# list of port and command that was unregistered.
+
+proc http::unregister {proto} {
+ variable urlTypes
+ set lower [string tolower $proto]
+ if {![info exists urlTypes($lower)]} {
+ return -code error "unsupported url type \"$proto\""
+ }
+ set old $urlTypes($lower)
+ unset urlTypes($lower)
+ return $old
+}
+
+# http::config --
+#
+# See documentation for details.
+#
+# Arguments:
+# args Options parsed by the procedure.
+# Results:
+# TODO
+
+proc http::config {args} {
+ variable http
+ set options [lsort [array names http -*]]
+ set usage [join $options ", "]
+ if {[llength $args] == 0} {
+ set result {}
+ foreach name $options {
+ lappend result $name $http($name)
+ }
+ return $result
+ }
+ set options [string map {- ""} $options]
+ set pat ^-(?:[join $options |])$
+ if {[llength $args] == 1} {
+ set flag [lindex $args 0]
+ if {![regexp -- $pat $flag]} {
+ return -code error "Unknown option $flag, must be: $usage"
+ }
+ return $http($flag)
+ } else {
+ foreach {flag value} $args {
+ if {![regexp -- $pat $flag]} {
+ return -code error "Unknown option $flag, must be: $usage"
+ }
+ set http($flag) $value
+ }
+ }
+}
+
+# http::Finish --
+#
+# Clean up the socket and eval close time callbacks
+#
+# Arguments:
+# token Connection token.
+# errormsg (optional) If set, forces status to error.
+# skipCB (optional) If set, don't call the -command callback. This
+# is useful when geturl wants to throw an exception instead
+# of calling the callback. That way, the same error isn't
+# reported to two places.
+#
+# Side Effects:
+# May close the socket.
+
+proc http::Finish {token {errormsg ""} {skipCB 0}} {
+ variable socketMapping
+ variable socketRdState
+ variable socketWrState
+ variable socketRdQueue
+ variable socketWrQueue
+ variable socketClosing
+ variable socketPlayCmd
+
+ variable $token
+ upvar 0 $token state
+ global errorInfo errorCode
+ set closeQueue 0
+ if {$errormsg ne ""} {
+ set state(error) [list $errormsg $errorInfo $errorCode]
+ set state(status) "error"
+ }
+ if {[info commands ${token}EventCoroutine] ne {}} {
+ rename ${token}EventCoroutine {}
+ }
+ if { ($state(status) eq "timeout")
+ || ($state(status) eq "error")
+ || ($state(status) eq "eof")
+ || ([info exists state(-keepalive)] && !$state(-keepalive))
+ || ([info exists state(connection)] && ($state(connection) eq "close"))
+ } {
+ set closeQueue 1
+ set connId $state(socketinfo)
+ set sock $state(sock)
+ CloseSocket $state(sock) $token
+ } elseif {
+ ([info exists state(-keepalive)] && $state(-keepalive))
+ && ([info exists state(connection)] && ($state(connection) ne "close"))
+ } {
+ KeepSocket $token
+ }
+ if {[info exists state(after)]} {
+ after cancel $state(after)
+ unset state(after)
+ }
+ if {[info exists state(-command)] && (!$skipCB)
+ && (![info exists state(done-command-cb)])} {
+ set state(done-command-cb) yes
+ if {[catch {eval $state(-command) {$token}} err] && $errormsg eq ""} {
+ set state(error) [list $err $errorInfo $errorCode]
+ set state(status) error
+ }
+ }
+
+ if { $closeQueue
+ && [info exists socketMapping($connId)]
+ && ($socketMapping($connId) eq $sock)
+ } {
+ http::CloseQueuedQueries $connId $token
+ }
+}
+
+# http::KeepSocket -
+#
+# Keep a socket in the persistent sockets table and connect it to its next
+# queued task if possible. Otherwise leave it idle and ready for its next
+# use.
+#
+# If $socketClosing(*), then ($state(connection) eq "close") and therefore
+# this command will not be called by Finish.
+#
+# Arguments:
+# token Connection token.
+
+proc http::KeepSocket {token} {
+ variable http
+ variable socketMapping
+ variable socketRdState
+ variable socketWrState
+ variable socketRdQueue
+ variable socketWrQueue
+ variable socketClosing
+ variable socketPlayCmd
+
+ variable $token
+ upvar 0 $token state
+ set tk [namespace tail $token]
+
+ # Keep this socket open for another request ("Keep-Alive").
+ # React if the server half-closes the socket.
+ # Discussion is in http::geturl.
+ catch {fileevent $state(sock) readable [list http::CheckEof $state(sock)]}
+
+ # The line below should not be changed in production code.
+ # It is edited by the test suite.
+ set TEST_EOF 0
+ if {$TEST_EOF} {
+ # ONLY for testing reaction to server eof.
+ # No server timeouts will be caught.
+ catch {fileevent $state(sock) readable {}}
+ }
+
+ if { [info exists state(socketinfo)]
+ && [info exists socketMapping($state(socketinfo))]
+ } {
+ set connId $state(socketinfo)
+ # The value "Rready" is set only here.
+ set socketRdState($connId) Rready
+
+ if { $state(-pipeline)
+ && [info exists socketRdQueue($connId)]
+ && [llength $socketRdQueue($connId)]
+ } {
+ # The usual case for pipelined responses - if another response is
+ # queued, arrange to read it.
+ set token3 [lindex $socketRdQueue($connId) 0]
+ set socketRdQueue($connId) [lrange $socketRdQueue($connId) 1 end]
+ variable $token3
+ upvar 0 $token3 state3
+ set tk2 [namespace tail $token3]
+
+ #Log pipelined, GRANT read access to $token3 in KeepSocket
+ set socketRdState($connId) $token3
+ ReceiveResponse $token3
+
+ # Other pipelined cases.
+ # - The test above ensures that, for the pipelined cases in the two
+ # tests below, the read queue is empty.
+ # - In those two tests, check whether the next write will be
+ # nonpipeline.
+ } elseif {
+ $state(-pipeline)
+ && [info exists socketWrState($connId)]
+ && ($socketWrState($connId) eq "peNding")
+
+ && [info exists socketWrQueue($connId)]
+ && [llength $socketWrQueue($connId)]
+ && (![set token3 [lindex $socketWrQueue($connId) 0]
+ set ${token3}(-pipeline)
+ ]
+ )
+ } {
+ # This case:
+ # - Now it the time to run the "pending" request.
+ # - The next token in the write queue is nonpipeline, and
+ # socketWrState has been marked "pending" (in
+ # http::NextPipelinedWrite or http::geturl) so a new pipelined
+ # request cannot jump the queue.
+ #
+ # Tests:
+ # - In this case the read queue (tested above) is empty and this
+ # "pending" write token is in front of the rest of the write
+ # queue.
+ # - The write state is not Wready and therefore appears to be busy,
+ # but because it is "pending" we know that it is reserved for the
+ # first item in the write queue, a non-pipelined request that is
+ # waiting for the read queue to empty. That has now happened: so
+ # give that request read and write access.
+ variable $token3
+ set conn [set ${token3}(tmpConnArgs)]
+ #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
+ set socketRdState($connId) $token3
+ set socketWrState($connId) $token3
+ set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end]
+ # Connect does its own fconfigure.
+ fileevent $state(sock) writable [list http::Connect $token3 {*}$conn]
+ #Log ---- $state(sock) << conn to $token3 for HTTP request (c)
+
+ } elseif {
+ $state(-pipeline)
+ && [info exists socketWrState($connId)]
+ && ($socketWrState($connId) eq "peNding")
+
+ } {
+ # Should not come here. The second block in the previous "elseif"
+ # test should be tautologous (but was needed in an earlier
+ # implementation) and will be removed after testing.
+ # If we get here, the value "pending" was assigned in error.
+ # This error would block the queue for ever.
+ Log ^X$tk <<<<< Error in queueing of requests >>>>> - token $token
+
+ } elseif {
+ $state(-pipeline)
+ && [info exists socketWrState($connId)]
+ && ($socketWrState($connId) eq "Wready")
+
+ && [info exists socketWrQueue($connId)]
+ && [llength $socketWrQueue($connId)]
+ && (![set token3 [lindex $socketWrQueue($connId) 0]
+ set ${token3}(-pipeline)
+ ]
+ )
+ } {
+ # This case:
+ # - The next token in the write queue is nonpipeline, and
+ # socketWrState is Wready. Get the next event from socketWrQueue.
+ # Tests:
+ # - In this case the read state (tested above) is Rready and the
+ # write state (tested here) is Wready - there is no "pending"
+ # request.
+ # Code:
+ # - The code is the same as the code below for the nonpipelined
+ # case with a queued request.
+ variable $token3
+ set conn [set ${token3}(tmpConnArgs)]
+ #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
+ set socketRdState($connId) $token3
+ set socketWrState($connId) $token3
+ set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end]
+ # Connect does its own fconfigure.
+ fileevent $state(sock) writable [list http::Connect $token3 {*}$conn]
+ #Log ---- $state(sock) << conn to $token3 for HTTP request (c)
+
+ } elseif {
+ (!$state(-pipeline))
+ && [info exists socketWrQueue($connId)]
+ && [llength $socketWrQueue($connId)]
+ && ($state(connection) ne "close")
+ } {
+ # If not pipelined, (socketRdState eq Rready) tells us that we are
+ # ready for the next write - there is no need to check
+ # socketWrState. Write the next request, if one is waiting.
+ # If the next request is pipelined, it receives premature read
+ # access to the socket. This is not a problem.
+ set token3 [lindex $socketWrQueue($connId) 0]
+ variable $token3
+ set conn [set ${token3}(tmpConnArgs)]
+ #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
+ set socketRdState($connId) $token3
+ set socketWrState($connId) $token3
+ set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end]
+ # Connect does its own fconfigure.
+ fileevent $state(sock) writable [list http::Connect $token3 {*}$conn]
+ #Log ---- $state(sock) << conn to $token3 for HTTP request (d)
+
+ } elseif {(!$state(-pipeline))} {
+ set socketWrState($connId) Wready
+ # Rready and Wready and idle: nothing to do.
+ }
+
+ } else {
+ CloseSocket $state(sock) $token
+ # There is no socketMapping($state(socketinfo)), so it does not matter
+ # that CloseQueuedQueries is not called.
+ }
+}
+
+# http::CheckEof -
+#
+# Read from a socket and close it if eof.
+# The command is bound to "fileevent readable" on an idle socket, and
+# "eof" is the only event that should trigger the binding, occurring when
+# the server times out and half-closes the socket.
+#
+# A read is necessary so that [eof] gives a meaningful result.
+# Any bytes sent are junk (or a bug).
+
+proc http::CheckEof {sock} {
+ set junk [read $sock]
+ set n [string length $junk]
+ if {$n} {
+ Log "WARNING: $n bytes received but no HTTP request sent"
+ }
+
+ if {[catch {eof $sock} res] || $res} {
+ # The server has half-closed the socket.
+ # If a new write has started, its transaction will fail and
+ # will then be error-handled.
+ CloseSocket $sock
+ }
+}
+
+# http::CloseSocket -
+#
+# Close a socket and remove it from the persistent sockets table. If
+# possible an http token is included here but when we are called from a
+# fileevent on remote closure we need to find the correct entry - hence
+# the "else" block of the first "if" command.
+
+proc http::CloseSocket {s {token {}}} {
+ variable socketMapping
+ variable socketRdState
+ variable socketWrState
+ variable socketRdQueue
+ variable socketWrQueue
+ variable socketClosing
+ variable socketPlayCmd
+
+ set tk [namespace tail $token]
+
+ catch {fileevent $s readable {}}
+ set connId {}
+ if {$token ne ""} {
+ variable $token
+ upvar 0 $token state
+ if {[info exists state(socketinfo)]} {
+ set connId $state(socketinfo)
+ }
+ } else {
+ set map [array get socketMapping]
+ set ndx [lsearch -exact $map $s]
+ if {$ndx >= 0} {
+ incr ndx -1
+ set connId [lindex $map $ndx]
+ }
+ }
+ if { ($connId ne {})
+ && [info exists socketMapping($connId)]
+ && ($socketMapping($connId) eq $s)
+ } {
+ Log "Closing connection $connId (sock $socketMapping($connId))"
+ if {[catch {close $socketMapping($connId)} err]} {
+ Log "Error closing connection: $err"
+ }
+ if {$token eq {}} {
+ # Cases with a non-empty token are handled by Finish, so the tokens
+ # are finished in connection order.
+ http::CloseQueuedQueries $connId
+ }
+ } else {
+ Log "Closing socket $s (no connection info)"
+ if {[catch {close $s} err]} {
+ Log "Error closing socket: $err"
+ }
+ }
+}
+
+# http::CloseQueuedQueries
+#
+# connId - identifier "domain:port" for the connection
+# token - (optional) used only for logging
+#
+# Called from http::CloseSocket and http::Finish, after a connection is closed,
+# to clear the read and write queues if this has not already been done.
+
+proc http::CloseQueuedQueries {connId {token {}}} {
+ variable socketMapping
+ variable socketRdState
+ variable socketWrState
+ variable socketRdQueue
+ variable socketWrQueue
+ variable socketClosing
+ variable socketPlayCmd
+
+ if {![info exists socketMapping($connId)]} {
+ # Command has already been called.
+ # Don't come here again - especially recursively.
+ return
+ }
+
+ # Used only for logging.
+ if {$token eq {}} {
+ set tk {}
+ } else {
+ set tk [namespace tail $token]
+ }
+
+ if { [info exists socketPlayCmd($connId)]
+ && ($socketPlayCmd($connId) ne {ReplayIfClose Wready {} {}})
+ } {
+ # Before unsetting, there is some unfinished business.
+ # - If the server sent "Connection: close", we have stored the command
+ # for retrying any queued requests in socketPlayCmd, so copy that
+ # value for execution below. socketClosing(*) was also set.
+ # - Also clear the queues to prevent calls to Finish that would set the
+ # state for the requests that will be retried to "finished with error
+ # status".
+ set unfinished $socketPlayCmd($connId)
+ set socketRdQueue($connId) {}
+ set socketWrQueue($connId) {}
+ } else {
+ set unfinished {}
+ }
+
+ Unset $connId
+
+ if {$unfinished ne {}} {
+ Log ^R$tk Any unfinished transactions (excluding $token) failed \
+ - token $token
+ {*}$unfinished
+ }
+}
+
+# http::Unset
+#
+# The trace on "unset socketRdState(*)" will call CancelReadPipeline
+# and cancel any queued responses.
+# The trace on "unset socketWrState(*)" will call CancelWritePipeline
+# and cancel any queued requests.
+
+proc http::Unset {connId} {
+ variable socketMapping
+ variable socketRdState
+ variable socketWrState
+ variable socketRdQueue
+ variable socketWrQueue
+ variable socketClosing
+ variable socketPlayCmd
+
+ unset socketMapping($connId)
+ unset socketRdState($connId)
+ unset socketWrState($connId)
+ unset -nocomplain socketRdQueue($connId)
+ unset -nocomplain socketWrQueue($connId)
+ unset -nocomplain socketClosing($connId)
+ unset -nocomplain socketPlayCmd($connId)
+}
+
+# http::reset --
+#
+# See documentation for details.
+#
+# Arguments:
+# token Connection token.
+# why Status info.
+#
+# Side Effects:
+# See Finish
+
+proc http::reset {token {why reset}} {
+ variable $token
+ upvar 0 $token state
+ set state(status) $why
+ catch {fileevent $state(sock) readable {}}
+ catch {fileevent $state(sock) writable {}}
+ Finish $token
+ if {[info exists state(error)]} {
+ set errorlist $state(error)
+ unset state
+ eval ::error $errorlist
+ }
+}
+
+# http::geturl --
+#
+# Establishes a connection to a remote url via http.
+#
+# Arguments:
+# url The http URL to goget.
+# args Option value pairs. Valid options include:
+# -blocksize, -validate, -headers, -timeout
+# Results:
+# Returns a token for this connection. This token is the name of an
+# array that the caller should unset to garbage collect the state.
+
+proc http::geturl {url args} {
+ variable http
+ variable urlTypes
+ variable defaultCharset
+ variable defaultKeepalive
+ variable strict
+
+ # Initialize the state variable, an array. We'll return the name of this
+ # array as the token for the transaction.
+
+ if {![info exists http(uid)]} {
+ set http(uid) 0
+ }
+ set token [namespace current]::[incr http(uid)]
+ ##Log Starting http::geturl - token $token
+ variable $token
+ upvar 0 $token state
+ set tk [namespace tail $token]
+ reset $token
+ Log ^A$tk URL $url - token $token
+
+ # Process command options.
+
+ array set state {
+ -binary false
+ -blocksize 8192
+ -queryblocksize 8192
+ -validate 0
+ -headers {}
+ -timeout 0
+ -type application/x-www-form-urlencoded
+ -queryprogress {}
+ -protocol 1.1
+ binary 0
+ state created
+ meta {}
+ method {}
+ coding {}
+ currentsize 0
+ totalsize 0
+ querylength 0
+ queryoffset 0
+ type text/html
+ body {}
+ status ""
+ http ""
+ connection keep-alive
+ }
+ set state(-keepalive) $defaultKeepalive
+ set state(-strict) $strict
+ # These flags have their types verified [Bug 811170]
+ array set type {
+ -binary boolean
+ -blocksize integer
+ -queryblocksize integer
+ -strict boolean
+ -timeout integer
+ -validate boolean
+ -headers dict
+ }
+ set state(charset) $defaultCharset
+ set options {
+ -binary -blocksize -channel -command -handler -headers -keepalive
+ -method -myaddr -progress -protocol -query -queryblocksize
+ -querychannel -queryprogress -strict -timeout -type -validate
+ }
+ set usage [join [lsort $options] ", "]
+ set options [string map {- ""} $options]
+ set pat ^-(?:[join $options |])$
+ foreach {flag value} $args {
+ if {[regexp -- $pat $flag]} {
+ # Validate numbers
+ if {($flag eq "-headers") ? [catch {dict size $value}] :
+ ([info exists type($flag)] && ![string is $type($flag) -strict $value])
+ } {
+ unset $token
+ return -code error \
+ "Bad value for $flag ($value), must be $type($flag)"
+ }
+ set state($flag) $value
+ } else {
+ unset $token
+ return -code error "Unknown option $flag, can be: $usage"
+ }
+ }
+
+ # Make sure -query and -querychannel aren't both specified
+
+ set isQueryChannel [info exists state(-querychannel)]
+ set isQuery [info exists state(-query)]
+ if {$isQuery && $isQueryChannel} {
+ unset $token
+ return -code error "Can't combine -query and -querychannel options!"
+ }
+
+ # Validate URL, determine the server host and port, and check proxy case
+ # Recognize user:pass 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:
Deleted: trunk/Master/tlpkg/tltcl/lib/tcl8/8.6/tdbc/sqlite3-1.1.1.tm
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8/8.6/tdbc/sqlite3-1.1.1.tm 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8/8.6/tdbc/sqlite3-1.1.1.tm 2021-03-02 16:29:37 UTC (rev 58056)
@@ -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.1
-
-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.2.tm
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8/8.6/tdbc/sqlite3-1.1.2.tm (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8/8.6/tdbc/sqlite3-1.1.2.tm 2021-03-02 16:29:37 UTC (rev 58056)
@@ -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.2
+
+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/auto.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/auto.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/auto.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -240,6 +240,7 @@
set f ""
set error [catch {
set f [open $file]
+ fconfigure $f -eofchar \032
while {[gets $f line] >= 0} {
if {[regexp {^proc[ ]+([^ ]*)} $line match procName]} {
set procName [lindex [auto_qualify $procName "::"] 0]
@@ -350,6 +351,7 @@
set scriptFile $file
set fid [open $file]
+ fconfigure $fid -eofchar \032
set contents [read $fid]
close $fid
@@ -376,10 +378,10 @@
# auto_mkindex_parser::hook command
#
-# Registers a Tcl command to evaluate when initializing the slave interpreter
-# used by the mkindex parser. The command is evaluated in the master
+# Registers a Tcl command to evaluate when initializing the child interpreter
+# used by the mkindex parser. The command is evaluated in the parent
# interpreter, and can use the variable auto_mkindex_parser::parser to get to
-# the slave
+# the child
proc auto_mkindex_parser::hook {cmd} {
variable initCommands
@@ -389,14 +391,14 @@
# auto_mkindex_parser::slavehook command
#
-# Registers a Tcl command to evaluate when initializing the slave interpreter
-# used by the mkindex parser. The command is evaluated in the slave
+# Registers a Tcl command to evaluate when initializing the child interpreter
+# used by the mkindex parser. The command is evaluated in the child
# interpreter.
proc auto_mkindex_parser::slavehook {cmd} {
variable initCommands
- # The $parser variable is defined to be the name of the slave interpreter
+ # The $parser variable is defined to be the name of the child interpreter
# when this command is used later.
lappend initCommands "\$parser eval [list $cmd]"
@@ -550,7 +552,7 @@
# Conditionally add support for Tcl byte code files. There are some tricky
# details here. First, we need to get the tbcload library initialized in the
-# current interpreter. We cannot load tbcload into the slave until we have
+# current interpreter. We cannot load tbcload into the child until we have
# done so because it needs access to the tcl_patchLevel variable. Second,
# because the package index file may defer loading the library until we invoke
# a command, we need to explicitly invoke auto_load to force it to be loaded.
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/clock.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/clock.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/clock.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -9,7 +9,7 @@
#
#----------------------------------------------------------------------
#
-# Copyright (c) 2004,2005,2006,2007 by Kevin B. Kenny
+# Copyright (c) 2004-2007 Kevin B. Kenny
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
@@ -3304,7 +3304,7 @@
return
}
- # Since an unsafe interp uses the [clock] command in the master, this code
+ # Since an unsafe interp uses the [clock] command in the parent, this code
# is security sensitive. Make sure that the path name cannot escape the
# given directory.
@@ -3344,7 +3344,7 @@
proc ::tcl::clock::LoadZoneinfoFile { fileName } {
variable ZoneinfoPaths
- # Since an unsafe interp uses the [clock] command in the master, this code
+ # Since an unsafe interp uses the [clock] command in the parent, this code
# is security sensitive. Make sure that the path name cannot escape the
# given directory.
@@ -3452,7 +3452,7 @@
set times [linsert $times 0 $MINWIDE]
set codes {}
foreach c $tempCodes {
- lappend codes [expr { $c & 0xff }]
+ lappend codes [expr { $c & 0xFF }]
}
set codes [linsert $codes 0 0]
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/encoding/tis-620.enc
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/encoding/tis-620.enc 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/encoding/tis-620.enc 2021-03-02 16:29:37 UTC (rev 58056)
@@ -17,4 +17,4 @@
0E200E210E220E230E240E250E260E270E280E290E2A0E2B0E2C0E2D0E2E0E2F
0E300E310E320E330E340E350E360E370E380E390E3A00000000000000000E3F
0E400E410E420E430E440E450E460E470E480E490E4A0E4B0E4C0E4D0E4E0E4F
-0E500E510E520E530E540E550E560E570E580E590E5A0E5B0000000000000000
\ No newline at end of file
+0E500E510E520E530E540E550E560E570E580E590E5A0E5B0000000000000000
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/init.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/init.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/init.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -6,7 +6,7 @@
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 Scriptics Corporation.
-# Copyright (c) 2004 by Kevin B. Kenny. All rights reserved.
+# Copyright (c) 2004 Kevin B. Kenny. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -16,7 +16,7 @@
if {[info commands package] == ""} {
error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
}
-package require -exact Tcl 8.6.10
+package require -exact Tcl 8.6.11
# Compute the auto path to use in this interpreter.
# The values on the path come from several locations:
@@ -37,9 +37,13 @@
# tcl_pkgPath, which is set by the platform-specific initialization routines
# On UNIX it is compiled in
# On Windows, it is not used
+#
+# (Ticket 41c9857bdd) In a safe interpreter, this file does not set
+# ::auto_path (other than to {} if it is undefined). The caller, typically
+# a Safe Base command, is responsible for setting ::auto_path.
if {![info exists auto_path]} {
- if {[info exists env(TCLLIBPATH)]} {
+ if {[info exists env(TCLLIBPATH)] && (![interp issafe])} {
set auto_path $env(TCLLIBPATH)
} else {
set auto_path ""
@@ -46,32 +50,33 @@
}
}
namespace eval tcl {
- variable Dir
- foreach Dir [list $::tcl_library [file dirname $::tcl_library]] {
+ if {![interp issafe]} {
+ variable Dir
+ foreach Dir [list $::tcl_library [file dirname $::tcl_library]] {
+ if {$Dir ni $::auto_path} {
+ lappend ::auto_path $Dir
+ }
+ }
+ set Dir [file join [file dirname [file dirname \
+ [info nameofexecutable]]] lib]
if {$Dir ni $::auto_path} {
lappend ::auto_path $Dir
}
- }
- set Dir [file join [file dirname [file dirname \
- [info nameofexecutable]]] lib]
- if {$Dir ni $::auto_path} {
- lappend ::auto_path $Dir
- }
- catch {
- foreach Dir $::tcl_pkgPath {
- if {$Dir ni $::auto_path} {
- lappend ::auto_path $Dir
+ if {[info exists ::tcl_pkgPath]} { catch {
+ foreach Dir $::tcl_pkgPath {
+ if {$Dir ni $::auto_path} {
+ lappend ::auto_path $Dir
+ }
}
- }
- }
+ }}
- if {![interp issafe]} {
- variable Path [encoding dirs]
- set Dir [file join $::tcl_library encoding]
- if {$Dir ni $Path} {
+ variable Path [encoding dirs]
+ set Dir [file join $::tcl_library encoding]
+ if {$Dir ni $Path} {
lappend Path $Dir
encoding dirs $Path
- }
+ }
+ unset Dir Path
}
# TIP #255 min and max functions
@@ -79,7 +84,7 @@
proc min {args} {
if {![llength $args]} {
return -code error \
- "too few arguments to math function \"min\""
+ "not enough arguments to math function \"min\""
}
set val Inf
foreach arg $args {
@@ -95,7 +100,7 @@
proc max {args} {
if {![llength $args]} {
return -code error \
- "too few arguments to math function \"max\""
+ "not enough arguments to math function \"max\""
}
set val -Inf
foreach arg $args {
@@ -308,7 +313,7 @@
set errInfo [string range $errInfo 0 $last-1]
set tail "\"$cinfo\""
set last [string last $tail $errInfo]
- if {$last + [string length $tail] != [string length $errInfo]} {
+ if {$last < 0 || $last + [string length $tail] != [string length $errInfo]} {
return -code error -errorcode $errCode \
-errorinfo $errInfo $msg
}
@@ -489,6 +494,7 @@
continue
} else {
set error [catch {
+ fconfigure $f -eofchar \032
set id [gets $f]
if {$id eq "# Tcl autoload index file, version 2.0"} {
eval [read $f]
@@ -792,7 +798,7 @@
}
}
} else {
- if {[string first $nsrc $ndest] != -1} {
+ if {[string first $nsrc $ndest] >= 0} {
set srclen [expr {[llength [file split $nsrc]] - 1}]
set ndest [lindex [file split $ndest] $srclen]
if {$ndest eq [file tail $nsrc]} {
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/opt0.4/optparse.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/opt0.4/optparse.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/opt0.4/optparse.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -8,10 +8,10 @@
# on it. If your code does rely on this package you
# may directly incorporate this code into your application.
-package require Tcl 8.2
+package require Tcl 8.5-
# When this version number changes, update the pkgIndex.tcl file
# and the install directory in the Makefiles.
-package provide opt 0.4.6
+package provide opt 0.4.8
namespace eval ::tcl {
@@ -44,8 +44,8 @@
{-intflag 7}
{-weirdflag "help string"}
{-noStatics "Not ok to load static packages"}
- {-nestedloading1 true "OK to load into nested slaves"}
- {-nestedloading2 -boolean true "OK to load into nested slaves"}
+ {-nestedloading1 true "OK to load into nested children"}
+ {-nestedloading2 -boolean true "OK to load into nested children"}
{-libsOK -choice {Tk SybTcl}
"List of packages that can be loaded"}
{-precision -int 12 "Number of digits of precision"}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/opt0.4/pkgIndex.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/opt0.4/pkgIndex.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/opt0.4/pkgIndex.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -8,5 +8,5 @@
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
-if {![package vsatisfies [package provide Tcl] 8.2]} {return}
-package ifneeded opt 0.4.6 [list source [file join $dir optparse.tcl]]
+if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
+package ifneeded opt 0.4.8 [list source [file join $dir optparse.tcl]]
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/package.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/package.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/package.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -237,7 +237,7 @@
$c eval [list set ::tcl::file $file]
$c eval [list set ::tcl::direct $direct]
- # Download needed procedures into the slave because we've just deleted
+ # Download needed procedures into the child because we've just deleted
# the unknown procedure. This doesn't handle procedures with default
# arguments.
@@ -479,9 +479,12 @@
}
set tclSeenPath($dir) 1
- # we can't use glob in safe interps, so enclose the following in a
- # catch statement, where we get the pkgIndex files out of the
- # subdirectories
+ # Get the pkgIndex.tcl files in subdirectories of auto_path directories.
+ # - Safe Base interpreters have a restricted "glob" command that
+ # works in this case.
+ # - The "catch" was essential when there was no safe glob and every
+ # call in a safe interp failed; it is retained only for corner
+ # cases in which the eventual call to glob returns an error.
catch {
foreach file [glob -directory $dir -join -nocomplain \
* pkgIndex.tcl] {
@@ -585,6 +588,7 @@
set tclSeenPath($dir) 1
# get the pkgIndex files out of the subdirectories
+ # Safe interpreters do not use tcl::MacOSXPkgUnknown - see init.tcl.
foreach file [glob -directory $dir -join -nocomplain \
* Resources Scripts pkgIndex.tcl] {
set dir [file dirname $file]
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/safe.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/safe.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/safe.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -1,9 +1,9 @@
# safe.tcl --
#
# This file provide a safe loading/sourcing mechanism for safe interpreters.
-# It implements a virtual path mecanism to hide the real pathnames from the
-# slave. It runs in a master interpreter and sets up data structure and
-# aliases that will be invoked when used from a slave interpreter.
+# It implements a virtual path mechanism to hide the real pathnames from the
+# child. It runs in a parent interpreter and sets up data structure and
+# aliases that will be invoked when used from a child interpreter.
#
# See the safe.n man page for details.
#
@@ -20,7 +20,7 @@
#
# Needed utilities package
-package require opt 0.4.1
+package require opt 0.4.8
# Create the safe namespace
namespace eval ::safe {
@@ -79,6 +79,7 @@
# Interface/entry point function and front end for "Create"
proc ::safe::interpCreate {args} {
set Args [::tcl::OptKeyParse ::safe::interpCreate $args]
+ RejectExcessColons $slave
InterpCreate $slave $accessPath \
[InterpStatics] [InterpNested] $deleteHook
}
@@ -88,16 +89,17 @@
if {![::interp exists $slave]} {
return -code error "\"$slave\" is not an interpreter"
}
+ RejectExcessColons $slave
InterpInit $slave $accessPath \
[InterpStatics] [InterpNested] $deleteHook
}
-# Check that the given slave is "one of us"
-proc ::safe::CheckInterp {slave} {
- namespace upvar ::safe S$slave state
- if {![info exists state] || ![::interp exists $slave]} {
+# Check that the given child is "one of us"
+proc ::safe::CheckInterp {child} {
+ namespace upvar ::safe [VarName $child] state
+ if {![info exists state] || ![::interp exists $child]} {
return -code error \
- "\"$slave\" is not an interpreter managed by ::safe::"
+ "\"$child\" is not an interpreter managed by ::safe::"
}
}
@@ -119,11 +121,11 @@
1 {
# If we have exactly 1 argument the semantic is to return all
# the current configuration. We still call OptKeyParse though
- # we know that "slave" is our given argument because it also
+ # we know that "child" is our given argument because it also
# checks for the "-help" option.
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
CheckInterp $slave
- namespace upvar ::safe S$slave state
+ namespace upvar ::safe [VarName $slave] state
return [join [list \
[list -accessPath $state(access_path)] \
@@ -146,7 +148,7 @@
return -code error [::tcl::OptFlagUsage $desc $arg]
}
CheckInterp $slave
- namespace upvar ::safe S$slave state
+ namespace upvar ::safe [VarName $slave] state
set item [::tcl::OptCurDesc $desc]
set name [::tcl::OptName $item]
@@ -187,15 +189,15 @@
# create did
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
CheckInterp $slave
- namespace upvar ::safe S$slave state
+ namespace upvar ::safe [VarName $slave] state
# Get the current (and not the default) values of whatever has
# not been given:
if {![::tcl::OptProcArgGiven -accessPath]} {
- set doreset 1
+ set doreset 0
set accessPath $state(access_path)
} else {
- set doreset 0
+ set doreset 1
}
if {
![::tcl::OptProcArgGiven -statics]
@@ -218,7 +220,7 @@
}
# we can now reconfigure :
InterpSetConfig $slave $accessPath $statics $nested $deleteHook
- # auto_reset the slave (to completly synch the new access_path)
+ # auto_reset the child (to completly synch the new access_path)
if {$doreset} {
if {[catch {::interp eval $slave {auto_reset}} msg]} {
Log $slave "auto_reset failed: $msg"
@@ -225,7 +227,26 @@
} else {
Log $slave "successful auto_reset" NOTICE
}
+
+ # Sync the paths used to search for Tcl modules.
+ ::interp eval $slave {tcl::tm::path remove {*}[tcl::tm::list]}
+ if {[llength $state(tm_path_slave)] > 0} {
+ ::interp eval $slave [list \
+ ::tcl::tm::add {*}[lreverse $state(tm_path_slave)]]
+ }
+
+ # Remove stale "package ifneeded" data for non-loaded packages.
+ # - Not for loaded packages, because "package forget" erases
+ # data from "package provide" as well as "package ifneeded".
+ # - This is OK because the script cannot reload any version of
+ # the package unless it first does "package forget".
+ foreach pkg [::interp eval $slave {package names}] {
+ if {[::interp eval $slave [list package provide $pkg]] eq ""} {
+ ::interp eval $slave [list package forget $pkg]
+ }
+ }
}
+ return
}
}
}
@@ -239,17 +260,17 @@
#
# safe::InterpCreate : doing the real job
#
-# This procedure creates a safe slave and initializes it with the safe
+# This procedure creates a safe interpreter and initializes it with the safe
# base aliases.
-# NB: slave name must be simple alphanumeric string, no spaces, no (), no
+# NB: child name must be simple alphanumeric string, no spaces, no (), no
# {},... {because the state array is stored as part of the name}
#
-# Returns the slave name.
+# Returns the child name.
#
# Optional Arguments :
-# + slave name : if empty, generated name will be used
+# + child name : if empty, generated name will be used
# + access_path: path list controlling where load/source can occur,
-# if empty: the master auto_path will be used.
+# if empty: the parent auto_path will be used.
# + staticsok : flag, if 0 :no static package can be loaded (load {} Xxx)
# if 1 :static packages are ok.
# + nestedok: flag, if 0 :no loading to sub-sub interps (load xx xx sub)
@@ -257,35 +278,37 @@
# use the full name and no indent so auto_mkIndex can find us
proc ::safe::InterpCreate {
- slave
+ child
access_path
staticsok
nestedok
deletehook
} {
- # Create the slave.
- if {$slave ne ""} {
- ::interp create -safe $slave
+ # Create the child.
+ # If evaluated in ::safe, the interpreter command for foo is ::foo;
+ # but for foo::bar is safe::foo::bar. So evaluate in :: instead.
+ if {$child ne ""} {
+ namespace eval :: [list ::interp create -safe $child]
} else {
- # empty argument: generate slave name
- set slave [::interp create -safe]
+ # empty argument: generate child name
+ set child [::interp create -safe]
}
- Log $slave "Created" NOTICE
+ Log $child "Created" NOTICE
- # Initialize it. (returns slave name)
- InterpInit $slave $access_path $staticsok $nestedok $deletehook
+ # Initialize it. (returns child name)
+ InterpInit $child $access_path $staticsok $nestedok $deletehook
}
#
# InterpSetConfig (was setAccessPath) :
-# Sets up slave virtual auto_path and corresponding structure within
-# the master. Also sets the tcl_library in the slave to be the first
+# Sets up child virtual auto_path and corresponding structure within
+# the parent. Also sets the tcl_library in the child to be the first
# directory in the path.
-# NB: If you change the path after the slave has been initialized you
-# probably need to call "auto_reset" in the slave in order that it gets
+# NB: If you change the path after the child has been initialized you
+# probably need to call "auto_reset" in the child in order that it gets
# the right auto_index() array values.
-proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} {
+proc ::safe::InterpSetConfig {child access_path staticsok nestedok deletehook} {
global auto_path
# determine and store the access path if empty
@@ -295,10 +318,10 @@
# Make sure that tcl_library is in auto_path and at the first
# position (needed by setAccessPath)
set where [lsearch -exact $access_path [info library]]
- if {$where == -1} {
+ if {$where < 0} {
# not found, add it.
set access_path [linsert $access_path 0 [info library]]
- Log $slave "tcl_library was not in auto_path,\
+ Log $child "tcl_library was not in auto_path,\
added it to slave's access_path" NOTICE
} elseif {$where != 0} {
# not first, move it first
@@ -305,26 +328,26 @@
set access_path [linsert \
[lreplace $access_path $where $where] \
0 [info library]]
- Log $slave "tcl_libray was not in first in auto_path,\
+ Log $child "tcl_libray was not in first in auto_path,\
moved it to front of slave's access_path" NOTICE
}
# Add 1st level sub dirs (will searched by auto loading from tcl
- # code in the slave using glob and thus fail, so we add them here
+ # code in the child using glob and thus fail, so we add them here
# so by default it works the same).
set access_path [AddSubDirs $access_path]
}
- Log $slave "Setting accessPath=($access_path) staticsok=$staticsok\
+ Log $child "Setting accessPath=($access_path) staticsok=$staticsok\
nestedok=$nestedok deletehook=($deletehook)" NOTICE
- namespace upvar ::safe S$slave state
+ namespace upvar ::safe [VarName $child] state
# clear old autopath if it existed
# build new one
# Extend the access list with the paths used to look for Tcl Modules.
# We save the virtual form separately as well, as syncing it with the
- # slave has to be defered until the necessary commands are present for
+ # child has to be deferred until the necessary commands are present for
# setup.
set norm_access_path {}
@@ -344,6 +367,7 @@
}
set morepaths [::tcl::tm::list]
+ set firstpass 1
while {[llength $morepaths]} {
set addpaths $morepaths
set morepaths {}
@@ -352,6 +376,12 @@
# Prevent the addition of dirs on the tm list to the
# result if they are already known.
if {[dict exists $remap_access_path $dir]} {
+ if {$firstpass} {
+ # $dir is in [::tcl::tm::list] and belongs in the slave_tm_path.
+ # Later passes handle subdirectories, which belong in the
+ # access path but not in the module path.
+ lappend slave_tm_path [dict get $remap_access_path $dir]
+ }
continue
}
@@ -361,7 +391,12 @@
lappend map_access_path $token $dir
lappend remap_access_path $dir $token
lappend norm_access_path [file normalize $dir]
- lappend slave_tm_path $token
+ if {$firstpass} {
+ # $dir is in [::tcl::tm::list] and belongs in the slave_tm_path.
+ # Later passes handle subdirectories, which belong in the
+ # access path but not in the module path.
+ lappend slave_tm_path $token
+ }
incr i
# [Bug 2854929]
@@ -372,6 +407,7 @@
# subdirectories.
lappend morepaths {*}[glob -nocomplain -directory $dir -type d *]
}
+ set firstpass 0
}
set state(access_path) $access_path
@@ -384,7 +420,8 @@
set state(nestedok) $nestedok
set state(cleanupHook) $deletehook
- SyncAccessPath $slave
+ SyncAccessPath $child
+ return
}
#
@@ -392,11 +429,12 @@
# FindInAccessPath:
# Search for a real directory and returns its virtual Id (including the
# "$")
-proc ::safe::interpFindInAccessPath {slave path} {
- namespace upvar ::safe S$slave state
+proc ::safe::interpFindInAccessPath {child path} {
+ CheckInterp $child
+ namespace upvar ::safe [VarName $child] state
if {![dict exists $state(access_path,remap) $path]} {
- return -code error "$path not found in access path $access_path"
+ return -code error "$path not found in access path"
}
return [dict get $state(access_path,remap) $path]
@@ -406,10 +444,11 @@
# addToAccessPath:
# add (if needed) a real directory to access path and return its
# virtual token (including the "$").
-proc ::safe::interpAddToAccessPath {slave path} {
+proc ::safe::interpAddToAccessPath {child path} {
# first check if the directory is already in there
# (inlined interpFindInAccessPath).
- namespace upvar ::safe S$slave state
+ CheckInterp $child
+ namespace upvar ::safe [VarName $child] state
if {[dict exists $state(access_path,remap) $path]} {
return [dict get $state(access_path,remap) $path]
@@ -424,7 +463,7 @@
lappend state(access_path,remap) $path $token
lappend state(access_path,norm) [file normalize $path]
- SyncAccessPath $slave
+ SyncAccessPath $child
return $token
}
@@ -432,7 +471,7 @@
# interpreter. It is useful when you want to install the safe base aliases
# into a preexisting safe interpreter.
proc ::safe::InterpInit {
- slave
+ child
access_path
staticsok
nestedok
@@ -439,18 +478,18 @@
deletehook
} {
# Configure will generate an access_path when access_path is empty.
- InterpSetConfig $slave $access_path $staticsok $nestedok $deletehook
+ InterpSetConfig $child $access_path $staticsok $nestedok $deletehook
# NB we need to add [namespace current], aliases are always absolute
# paths.
- # These aliases let the slave load files to define new commands
- # This alias lets the slave use the encoding names, convertfrom,
+ # These aliases let the child load files to define new commands
+ # This alias lets the child use the encoding names, convertfrom,
# convertto, and system, but not "encoding system <name>" to set the
# system encoding.
# Handling Tcl Modules, we need a restricted form of Glob.
# This alias interposes on the 'exit' command and cleanly terminates
- # the slave.
+ # the child.
foreach {command alias} {
source AliasSource
@@ -459,16 +498,16 @@
exit interpDelete
glob AliasGlob
} {
- ::interp alias $slave $command {} [namespace current]::$alias $slave
+ ::interp alias $child $command {} [namespace current]::$alias $child
}
- # This alias lets the slave have access to a subset of the 'file'
+ # This alias lets the child have access to a subset of the 'file'
# command functionality.
- ::interp expose $slave file
+ ::interp expose $child file
foreach subcommand {dirname extension rootname tail} {
- ::interp alias $slave ::tcl::file::$subcommand {} \
- ::safe::AliasFileSubcommand $slave $subcommand
+ ::interp alias $child ::tcl::file::$subcommand {} \
+ ::safe::AliasFileSubcommand $child $subcommand
}
foreach subcommand {
atime attributes copy delete executable exists isdirectory isfile
@@ -475,8 +514,8 @@
link lstat mtime mkdir nativename normalize owned readable readlink
rename size stat tempfile type volumes writable
} {
- ::interp alias $slave ::tcl::file::$subcommand {} \
- ::safe::BadSubcommand $slave file $subcommand
+ ::interp alias $child ::tcl::file::$subcommand {} \
+ ::safe::BadSubcommand $child file $subcommand
}
# Subcommands of info
@@ -483,37 +522,37 @@
foreach {subcommand alias} {
nameofexecutable AliasExeName
} {
- ::interp alias $slave ::tcl::info::$subcommand \
- {} [namespace current]::$alias $slave
+ ::interp alias $child ::tcl::info::$subcommand \
+ {} [namespace current]::$alias $child
}
- # The allowed slave variables already have been set by Tcl_MakeSafe(3)
+ # The allowed child variables already have been set by Tcl_MakeSafe(3)
- # Source init.tcl and tm.tcl into the slave, to get auto_load and
+ # Source init.tcl and tm.tcl into the child, to get auto_load and
# other procedures defined:
- if {[catch {::interp eval $slave {
+ if {[catch {::interp eval $child {
source [file join $tcl_library init.tcl]
}} msg opt]} {
- Log $slave "can't source init.tcl ($msg)"
- return -options $opt "can't source init.tcl into slave $slave ($msg)"
+ Log $child "can't source init.tcl ($msg)"
+ return -options $opt "can't source init.tcl into slave $child ($msg)"
}
- if {[catch {::interp eval $slave {
+ if {[catch {::interp eval $child {
source [file join $tcl_library tm.tcl]
}} msg opt]} {
- Log $slave "can't source tm.tcl ($msg)"
- return -options $opt "can't source tm.tcl into slave $slave ($msg)"
+ Log $child "can't source tm.tcl ($msg)"
+ return -options $opt "can't source tm.tcl into slave $child ($msg)"
}
# Sync the paths used to search for Tcl modules. This can be done only
# now, after tm.tcl was loaded.
- namespace upvar ::safe S$slave state
+ namespace upvar ::safe [VarName $child] state
if {[llength $state(tm_path_slave)] > 0} {
- ::interp eval $slave [list \
+ ::interp eval $child [list \
::tcl::tm::add {*}[lreverse $state(tm_path_slave)]]
}
- return $slave
+ return $child
}
# Add (only if needed, avoid duplicates) 1 level of sub directories to an
@@ -539,15 +578,30 @@
return $res
}
-# This procedure deletes a safe slave managed by Safe Tcl and cleans up
-# associated state:
+# This procedure deletes a safe interpreter managed by Safe Tcl and cleans up
+# associated state.
+# - The command will also delete non-Safe-Base interpreters.
+# - This is regrettable, but to avoid breaking existing code this should be
+# amended at the next major revision by uncommenting "CheckInterp".
-proc ::safe::interpDelete {slave} {
- Log $slave "About to delete" NOTICE
+proc ::safe::interpDelete {child} {
+ Log $child "About to delete" NOTICE
- namespace upvar ::safe S$slave state
+ # CheckInterp $child
+ namespace upvar ::safe [VarName $child] state
- # If the slave has a cleanup hook registered, call it. Check the
+ # When an interpreter is deleted with [interp delete], any sub-interpreters
+ # are deleted automatically, but this leaves behind their data in the Safe
+ # Base. To clean up properly, we call safe::interpDelete recursively on each
+ # Safe Base sub-interpreter, so each one is deleted cleanly and not by
+ # the automatic mechanism built into [interp delete].
+ foreach sub [interp children $child] {
+ if {[info exists ::safe::[VarName [list $child $sub]]]} {
+ ::safe::interpDelete [list $child $sub]
+ }
+ }
+
+ # If the child has a cleanup hook registered, call it. Check the
# existance because we might be called to delete an interp which has
# not been registered with us at all
@@ -558,14 +612,14 @@
# we'll loop
unset state(cleanupHook)
try {
- {*}$hook $slave
+ {*}$hook $child
} on error err {
- Log $slave "Delete hook error ($err)"
+ Log $child "Delete hook error ($err)"
}
}
}
- # Discard the global array of state associated with the slave, and
+ # Discard the global array of state associated with the child, and
# delete the interpreter.
if {[info exists state]} {
@@ -574,9 +628,9 @@
# if we have been called twice, the interp might have been deleted
# already
- if {[::interp exists $slave]} {
- ::interp delete $slave
- Log $slave "Deleted" NOTICE
+ if {[::interp exists $child]} {
+ ::interp delete $child
+ Log $child "Deleted" NOTICE
}
return
@@ -602,9 +656,9 @@
} else {
# Activate logging, define proper command.
- proc ::safe::Log {slave msg {type ERROR}} {
+ proc ::safe::Log {child msg {type ERROR}} {
variable Log
- {*}$Log "$type for slave $slave : $msg"
+ {*}$Log "$type for slave $child : $msg"
return
}
}
@@ -613,16 +667,16 @@
# ------------------- END OF PUBLIC METHODS ------------
#
-# Sets the slave auto_path to the master recorded value. Also sets
+# Sets the child auto_path to the parent recorded value. Also sets
# tcl_library to the first token of the virtual path.
#
-proc ::safe::SyncAccessPath {slave} {
- namespace upvar ::safe S$slave state
+proc ::safe::SyncAccessPath {child} {
+ namespace upvar ::safe [VarName $child] state
set slave_access_path $state(access_path,slave)
- ::interp eval $slave [list set auto_path $slave_access_path]
+ ::interp eval $child [list set auto_path $slave_access_path]
- Log $slave "auto_path in $slave has been set to $slave_access_path"\
+ Log $child "auto_path in $child has been set to $slave_access_path"\
NOTICE
# This code assumes that info library is the first element in the
@@ -629,7 +683,7 @@
# list of auto_path's. See -> InterpSetConfig for the code which
# ensures this condition.
- ::interp eval $slave [list \
+ ::interp eval $child [list \
set tcl_library [lindex $slave_access_path 0]]
}
@@ -643,8 +697,8 @@
#
# translate virtual path into real path
#
-proc ::safe::TranslatePath {slave path} {
- namespace upvar ::safe S$slave state
+proc ::safe::TranslatePath {child path} {
+ namespace upvar ::safe [VarName $child] state
# somehow strip the namespaces 'functionality' out (the danger is that
# we would strip valid macintosh "../" queries... :
@@ -659,7 +713,7 @@
# file name control (limit access to files/resources that should be a
# valid tcl source file)
-proc ::safe::CheckFileName {slave file} {
+proc ::safe::CheckFileName {child file} {
# This used to limit what can be sourced to ".tcl" and forbid files
# with more than 1 dot and longer than 14 chars, but I changed that
# for 8.4 as a safe interp has enough internal protection already to
@@ -680,17 +734,17 @@
# interpreters that are *almost* safe. In particular, it just acts to
# prevent discovery of what home directories exist.
-proc ::safe::AliasFileSubcommand {slave subcommand name} {
+proc ::safe::AliasFileSubcommand {child subcommand name} {
if {[string match ~* $name]} {
set name ./$name
}
- tailcall ::interp invokehidden $slave tcl:file:$subcommand $name
+ tailcall ::interp invokehidden $child tcl:file:$subcommand $name
}
# AliasGlob is the target of the "glob" alias in safe interpreters.
-proc ::safe::AliasGlob {slave args} {
- Log $slave "GLOB ! $args" NOTICE
+proc ::safe::AliasGlob {child args} {
+ Log $child "GLOB ! $args" NOTICE
set cmd {}
set at 0
array set got {
@@ -712,11 +766,15 @@
while {$at < [llength $args]} {
switch -glob -- [set opt [lindex $args $at]] {
- -nocomplain - -- - -join - -tails {
+ -nocomplain - -- - -tails {
lappend cmd $opt
set got($opt) 1
incr at
}
+ -join {
+ set got($opt) 1
+ incr at
+ }
-types - -type {
lappend cmd -types [lindex $args [incr at]]
incr at
@@ -730,15 +788,8 @@
set virtualdir [lindex $args [incr at]]
incr at
}
- pkgIndex.tcl {
- # Oops, this is globbing a subdirectory in regular package
- # search. That is not wanted. Abort, handler does catch
- # already (because glob was not defined before). See
- # package.tcl, lines 484ff in tclPkgUnknown.
- return -code error "unknown command glob"
- }
-* {
- Log $slave "Safe base rejecting glob option '$opt'"
+ Log $child "Safe base rejecting glob option '$opt'"
return -code error "Safe base rejecting glob option '$opt'"
}
default {
@@ -749,52 +800,86 @@
}
# Get the real path from the virtual one and check that the path is in the
- # access path of that slave. Done after basic argument processing so that
+ # access path of that child. Done after basic argument processing so that
# we know if -nocomplain is set.
if {$got(-directory)} {
try {
- set dir [TranslatePath $slave $virtualdir]
- DirInAccessPath $slave $dir
+ set dir [TranslatePath $child $virtualdir]
+ DirInAccessPath $child $dir
} on error msg {
- Log $slave $msg
+ Log $child $msg
if {$got(-nocomplain)} return
return -code error "permission denied"
}
- lappend cmd -directory $dir
+ if {$got(--)} {
+ set cmd [linsert $cmd end-1 -directory $dir]
+ } else {
+ lappend cmd -directory $dir
+ }
+ } else {
+ # The code after this "if ... else" block would conspire to return with
+ # no results in this case, if it were allowed to proceed. Instead,
+ # return now and reduce the number of cases to be considered later.
+ Log $child {option -directory must be supplied}
+ if {$got(-nocomplain)} return
+ return -code error "permission denied"
}
- # Apply the -join semantics ourselves
+ # Apply the -join semantics ourselves.
if {$got(-join)} {
set args [lreplace $args $at end [join [lrange $args $at end] "/"]]
}
- # Process remaining pattern arguments
+ # Process the pattern arguments. If we've done a join there is only one
+ # pattern argument.
+
set firstPattern [llength $cmd]
foreach opt [lrange $args $at end] {
if {![regexp $dirPartRE $opt -> thedir thefile]} {
set thedir .
- } elseif {[string match ~* $thedir]} {
- set thedir ./$thedir
+ # The *.tm search comes here.
}
- if {$thedir eq "*" &&
- ($thefile eq "pkgIndex.tcl" || $thefile eq "*.tm")} {
+ # "Special" treatment for (joined) argument {*/pkgIndex.tcl}.
+ # Do the expansion of "*" here, and filter out any directories that are
+ # not in the access path. The outcome is to lappend to cmd a path of
+ # the form $virtualdir/subdir/pkgIndex.tcl for each subdirectory subdir,
+ # after removing any subdir that are not in the access path.
+ if {($thedir eq "*") && ($thefile eq "pkgIndex.tcl")} {
set mapped 0
- foreach d [glob -directory [TranslatePath $slave $virtualdir] \
+ foreach d [glob -directory [TranslatePath $child $virtualdir] \
-types d -tails *] {
catch {
- DirInAccessPath $slave \
- [TranslatePath $slave [file join $virtualdir $d]]
+ DirInAccessPath $child \
+ [TranslatePath $child [file join $virtualdir $d]]
lappend cmd [file join $d $thefile]
set mapped 1
}
}
if {$mapped} continue
+ # Don't [continue] if */pkgIndex.tcl has no matches in the access
+ # path. The pattern will now receive the same treatment as a
+ # "non-special" pattern (and will fail because it includes a "*" in
+ # the directory name).
}
+ # Any directory pattern that is not an exact (i.e. non-glob) match to a
+ # directory in the access path will be rejected here.
+ # - Rejections include any directory pattern that has glob matching
+ # patterns "*", "?", backslashes, braces or square brackets, (UNLESS
+ # it corresponds to a genuine directory name AND that directory is in
+ # the access path).
+ # - The only "special matching characters" that remain in patterns for
+ # processing by glob are in the filename tail.
+ # - [file join $anything ~${foo}] is ~${foo}, which is not an exact
+ # match to any directory in the access path. Hence directory patterns
+ # that begin with "~" are rejected here. Tests safe-16.[5-8] check
+ # that "file join" remains as required and does not expand ~${foo}.
+ # - Bug [3529949] relates to unwanted expansion of ~${foo} and this is
+ # how the present code avoids the bug. All tests safe-16.* relate.
try {
- DirInAccessPath $slave [TranslatePath $slave \
+ DirInAccessPath $child [TranslatePath $child \
[file join $virtualdir $thedir]]
} on error msg {
- Log $slave $msg
+ Log $child $msg
if {$got(-nocomplain)} continue
return -code error "permission denied"
}
@@ -801,21 +886,30 @@
lappend cmd $opt
}
- Log $slave "GLOB = $cmd" NOTICE
+ Log $child "GLOB = $cmd" NOTICE
if {$got(-nocomplain) && [llength $cmd] eq $firstPattern} {
return
}
try {
- set entries [::interp invokehidden $slave glob {*}$cmd]
+ # >>>>>>>>>> HERE'S THE CALL TO SAFE INTERP GLOB <<<<<<<<<<
+ # - Pattern arguments added to cmd have NOT been translated from tokens.
+ # Only the virtualdir is translated (to dir).
+ # - In the pkgIndex.tcl case, there is no "*" in the pattern arguments,
+ # which are a list of names each with tail pkgIndex.tcl. The purpose
+ # of the call to glob is to remove the names for which the file does
+ # not exist.
+ set entries [::interp invokehidden $child glob {*}$cmd]
} on error msg {
- Log $slave $msg
+ # This is the only place that a call with -nocomplain and no invalid
+ # "dash-options" can return an error.
+ Log $child $msg
return -code error "script error"
}
- Log $slave "GLOB < $entries" NOTICE
+ Log $child "GLOB < $entries" NOTICE
- # Translate path back to what the slave should see.
+ # Translate path back to what the child should see.
set res {}
set l [string length $dir]
foreach p $entries {
@@ -825,13 +919,13 @@
lappend res $p
}
- Log $slave "GLOB > $res" NOTICE
+ Log $child "GLOB > $res" NOTICE
return $res
}
# AliasSource is the target of the "source" alias in safe interpreters.
-proc ::safe::AliasSource {slave args} {
+proc ::safe::AliasSource {child args} {
set argc [llength $args]
# Extended for handling of Tcl Modules to allow not only "source
# filename", but "source -encoding E filename" as well.
@@ -840,7 +934,7 @@
set encoding [lindex $args 1]
set at 2
if {$encoding eq "identity"} {
- Log $slave "attempt to use the identity encoding"
+ Log $child "attempt to use the identity encoding"
return -code error "permission denied"
}
} else {
@@ -849,7 +943,7 @@
}
if {$argc != 1} {
set msg "wrong # args: should be \"source ?-encoding E? fileName\""
- Log $slave "$msg ($args)"
+ Log $child "$msg ($args)"
return -code error $msg
}
set file [lindex $args $at]
@@ -856,32 +950,35 @@
# get the real path from the virtual one.
if {[catch {
- set realfile [TranslatePath $slave $file]
+ set realfile [TranslatePath $child $file]
} msg]} {
- Log $slave $msg
+ Log $child $msg
return -code error "permission denied"
}
- # check that the path is in the access path of that slave
+ # check that the path is in the access path of that child
if {[catch {
- FileInAccessPath $slave $realfile
+ FileInAccessPath $child $realfile
} msg]} {
- Log $slave $msg
+ Log $child $msg
return -code error "permission denied"
}
- # do the checks on the filename :
+ # Check that the filename exists and is readable. If it is not, deliver
+ # this -errorcode so that caller in tclPkgUnknown does not write a message
+ # to tclLog. Has no effect on other callers of ::source, which are in
+ # "package ifneeded" scripts.
if {[catch {
- CheckFileName $slave $realfile
+ CheckFileName $child $realfile
} msg]} {
- Log $slave "$realfile:$msg"
- return -code error $msg
+ Log $child "$realfile:$msg"
+ return -code error -errorcode {POSIX EACCES} $msg
}
# Passed all the tests, lets source it. Note that we do this all manually
- # because we want to control [info script] in the slave so information
+ # because we want to control [info script] in the child so information
# doesn't leak so much. [Bug 2913625]
- set old [::interp eval $slave {info script}]
+ set old [::interp eval $child {info script}]
set replacementMsg "script error"
set code [catch {
set f [open $realfile]
@@ -891,17 +988,17 @@
}
set contents [read $f]
close $f
- ::interp eval $slave [list info script $file]
+ ::interp eval $child [list info script $file]
} msg opt]
if {$code == 0} {
- set code [catch {::interp eval $slave $contents} msg opt]
+ set code [catch {::interp eval $child $contents} msg opt]
set replacementMsg $msg
}
- catch {interp eval $slave [list info script $old]}
+ catch {interp eval $child [list info script $old]}
# Note that all non-errors are fine result codes from [source], so we must
# take a little care to do it properly. [Bug 2923613]
if {$code == 1} {
- Log $slave $msg
+ Log $child $msg
return -code error $replacementMsg
}
return -code $code -options $opt $msg
@@ -909,11 +1006,11 @@
# AliasLoad is the target of the "load" alias in safe interpreters.
-proc ::safe::AliasLoad {slave file args} {
+proc ::safe::AliasLoad {child file args} {
set argc [llength $args]
if {$argc > 2} {
set msg "load error: too many arguments"
- Log $slave "$msg ($argc) {$file $args}"
+ Log $child "$msg ($argc) {$file $args}"
return -code error $msg
}
@@ -920,7 +1017,7 @@
# package name (can be empty if file is not).
set package [lindex $args 0]
- namespace upvar ::safe S$slave state
+ namespace upvar ::safe [VarName $child] state
# Determine where to load. load use a relative interp path and {}
# means self, so we can directly and safely use passed arg.
@@ -929,7 +1026,7 @@
# we will try to load into a sub sub interp; check that we want to
# authorize that.
if {!$state(nestedok)} {
- Log $slave "loading to a sub interp (nestedok)\
+ Log $child "loading to a sub interp (nestedok)\
disabled (trying to load $package to $target)"
return -code error "permission denied (nested load)"
}
@@ -940,11 +1037,11 @@
# static package loading
if {$package eq ""} {
set msg "load error: empty filename and no package name"
- Log $slave $msg
+ Log $child $msg
return -code error $msg
}
if {!$state(staticsok)} {
- Log $slave "static packages loading disabled\
+ Log $child "static packages loading disabled\
(trying to load $package to $target)"
return -code error "permission denied (static package)"
}
@@ -953,36 +1050,43 @@
# get the real path from the virtual one.
try {
- set file [TranslatePath $slave $file]
+ set file [TranslatePath $child $file]
} on error msg {
- Log $slave $msg
+ Log $child $msg
return -code error "permission denied"
}
# check the translated path
try {
- FileInAccessPath $slave $file
+ FileInAccessPath $child $file
} on error msg {
- Log $slave $msg
+ Log $child $msg
return -code error "permission denied (path)"
}
}
try {
- return [::interp invokehidden $slave load $file $package $target]
+ return [::interp invokehidden $child load $file $package $target]
} on error msg {
- Log $slave $msg
+ # Some packages return no error message.
+ set msg0 "load of binary library for package $package failed"
+ if {$msg eq {}} {
+ set msg $msg0
+ } else {
+ set msg "$msg0: $msg"
+ }
+ Log $child $msg
return -code error $msg
}
}
# FileInAccessPath raises an error if the file is not found in the list of
-# directories contained in the (master side recorded) slave's access path.
+# directories contained in the (parent side recorded) child's access path.
# the security here relies on "file dirname" answering the proper
# result... needs checking ?
-proc ::safe::FileInAccessPath {slave file} {
- namespace upvar ::safe S$slave state
+proc ::safe::FileInAccessPath {child file} {
+ namespace upvar ::safe [VarName $child] state
set access_path $state(access_path)
if {[file isdirectory $file]} {
@@ -994,14 +1098,14 @@
# potential pathname anomalies.
set norm_parent [file normalize $parent]
- namespace upvar ::safe S$slave state
+ namespace upvar ::safe [VarName $child] state
if {$norm_parent ni $state(access_path,norm)} {
return -code error "\"$file\": not in access_path"
}
}
-proc ::safe::DirInAccessPath {slave dir} {
- namespace upvar ::safe S$slave state
+proc ::safe::DirInAccessPath {child dir} {
+ namespace upvar ::safe [VarName $child] state
set access_path $state(access_path)
if {[file isfile $dir]} {
@@ -1012,7 +1116,7 @@
# potential pathname anomalies.
set norm_dir [file normalize $dir]
- namespace upvar ::safe S$slave state
+ namespace upvar ::safe [VarName $child] state
if {$norm_dir ni $state(access_path,norm)} {
return -code error "\"$dir\": not in access_path"
}
@@ -1021,16 +1125,16 @@
# This procedure is used to report an attempt to use an unsafe member of an
# ensemble command.
-proc ::safe::BadSubcommand {slave command subcommand args} {
+proc ::safe::BadSubcommand {child command subcommand args} {
set msg "not allowed to invoke subcommand $subcommand of $command"
- Log $slave $msg
+ Log $child $msg
return -code error -errorcode {TCL SAFE SUBCOMMAND} $msg
}
# AliasEncoding is the target of the "encoding" alias in safe interpreters.
-proc ::safe::AliasEncoding {slave option args} {
- # Note that [encoding dirs] is not supported in safe slaves at all
+proc ::safe::AliasEncoding {child option args} {
+ # Note that [encoding dirs] is not supported in safe children at all
set subcommands {convertfrom convertto names system}
try {
set option [tcl::prefix match -error [list -level 1 -errorcode \
@@ -1041,18 +1145,70 @@
"wrong # args: should be \"encoding system\""
}
} on error {msg options} {
- Log $slave $msg
+ Log $child $msg
return -options $options $msg
}
- tailcall ::interp invokehidden $slave encoding $option {*}$args
+ tailcall ::interp invokehidden $child encoding $option {*}$args
}
# Various minor hiding of platform features. [Bug 2913625]
-proc ::safe::AliasExeName {slave} {
+proc ::safe::AliasExeName {child} {
return ""
}
+# ------------------------------------------------------------------------------
+# Using Interpreter Names with Namespace Qualifiers
+# ------------------------------------------------------------------------------
+# (1) We wish to preserve compatibility with existing code, in which Safe Base
+# interpreter names have no namespace qualifiers.
+# (2) safe::interpCreate and the rest of the Safe Base previously could not
+# accept namespace qualifiers in an interpreter name.
+# (3) The interp command will accept namespace qualifiers in an interpreter
+# name, but accepts distinct interpreters that will have the same command
+# name (e.g. foo, ::foo, and :::foo) (bug 66c2e8c974).
+# (4) To satisfy these constraints, Safe Base interpreter names will be fully
+# qualified namespace names with no excess colons and with the leading "::"
+# omitted.
+# (5) Trailing "::" implies a namespace tail {}, which interp reads as {{}}.
+# Reject such names.
+# (6) We could:
+# (a) EITHER reject usable but non-compliant names (e.g. excess colons) in
+# interpCreate, interpInit;
+# (b) OR accept such names and then translate to a compliant name in every
+# command.
+# The problem with (b) is that the user will expect to use the name with the
+# interp command and will find that it is not recognised.
+# E.g "interpCreate ::foo" creates interpreter "foo", and the user's name
+# "::foo" works with all the Safe Base commands, but "interp eval ::foo"
+# fails.
+# So we choose (a).
+# (7) The command
+# namespace upvar ::safe S$child state
+# becomes
+# namespace upvar ::safe [VarName $child] state
+# ------------------------------------------------------------------------------
+
+proc ::safe::RejectExcessColons {child} {
+ set stripped [regsub -all -- {:::*} $child ::]
+ if {[string range $stripped end-1 end] eq {::}} {
+ return -code error {interpreter name must not end in "::"}
+ }
+ if {$stripped ne $child} {
+ set msg {interpreter name has excess colons in namespace separators}
+ return -code error $msg
+ }
+ if {[string range $stripped 0 1] eq {::}} {
+ return -code error {interpreter name must not begin "::"}
+ }
+ return
+}
+
+proc ::safe::VarName {child} {
+ # return S$child
+ return S[string map {:: @N @ @A} $child]
+}
+
proc ::safe::Setup {} {
####
#
@@ -1111,20 +1267,20 @@
# Log command, set via 'setLogCmd'. Logging is disabled when empty.
variable Log {}
- # The package maintains a state array per slave interp under its
+ # The package maintains a state array per child interp under its
# control. The name of this array is S<interp-name>. This array is
# brought into scope where needed, using 'namespace upvar'. The S
- # prefix is used to avoid that a slave interp called "Log" smashes
+ # prefix is used to avoid that a child interp called "Log" smashes
# the "Log" variable.
#
# The array's elements are:
#
- # access_path : List of paths accessible to the slave.
+ # access_path : List of paths accessible to the child.
# access_path,norm : Ditto, in normalized form.
- # access_path,slave : Ditto, as the path tokens as seen by the slave.
+ # access_path,slave : Ditto, as the path tokens as seen by the child.
# access_path,map : dict ( token -> path )
# access_path,remap : dict ( path -> token )
- # tm_path_slave : List of TM root directories, as tokens seen by the slave.
+ # tm_path_slave : List of TM root directories, as tokens seen by the child.
# staticsok : Value of option -statics
# nestedok : Value of option -nested
# cleanupHook : Value of option -deleteHook
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tm.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tm.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tm.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -212,11 +212,12 @@
}
set strip [llength [file split $path]]
- # We can't use glob in safe interps, so enclose the following in a
- # catch statement, where we get the module files out of the
- # subdirectories. In other words, Tcl Modules are not-functional
- # in such an interpreter. This is the same as for the command
- # "tclPkgUnknown", i.e. the search for regular packages.
+ # Get the module files out of the subdirectories.
+ # - Safe Base interpreters have a restricted "glob" command that
+ # works in this case.
+ # - The "catch" was essential when there was no safe glob and every
+ # call in a safe interp failed; it is retained only for corner
+ # cases in which the eventual call to glob returns an error.
catch {
# We always look for _all_ possible modules in the current
@@ -238,12 +239,16 @@
continue
}
- if {[package ifneeded $pkgname $pkgversion] ne {}} {
+ if {([package ifneeded $pkgname $pkgversion] ne {})
+ && (![interp issafe])
+ } {
# There's already a provide script registered for
# this version of this package. Since all units of
# code claiming to be the same version of the same
# package ought to be identical, just stick with
# the one we already have.
+ # This does not apply to Safe Base interpreters because
+ # the token-to-directory mapping may have changed.
continue
}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Africa/Accra
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Africa/Accra 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Africa/Accra 2021-03-02 16:29:37 UTC (rev 58056)
@@ -2,51 +2,65 @@
set TZData(:Africa/Accra) {
{-9223372036854775808 -52 0 LMT}
- {-1640995148 0 0 GMT}
- {-1556841600 1200 1 GMT}
- {-1546388400 0 0 GMT}
- {-1525305600 1200 1 GMT}
- {-1514852400 0 0 GMT}
- {-1493769600 1200 1 GMT}
- {-1483316400 0 0 GMT}
- {-1462233600 1200 1 GMT}
- {-1451780400 0 0 GMT}
- {-1430611200 1200 1 GMT}
- {-1420158000 0 0 GMT}
- {-1399075200 1200 1 GMT}
- {-1388622000 0 0 GMT}
- {-1367539200 1200 1 GMT}
- {-1357086000 0 0 GMT}
- {-1336003200 1200 1 GMT}
- {-1325550000 0 0 GMT}
- {-1304380800 1200 1 GMT}
- {-1293927600 0 0 GMT}
- {-1272844800 1200 1 GMT}
- {-1262391600 0 0 GMT}
- {-1241308800 1200 1 GMT}
- {-1230855600 0 0 GMT}
- {-1209772800 1200 1 GMT}
- {-1199319600 0 0 GMT}
- {-1178150400 1200 1 GMT}
- {-1167697200 0 0 GMT}
- {-1146614400 1200 1 GMT}
- {-1136161200 0 0 GMT}
- {-1115078400 1200 1 GMT}
- {-1104625200 0 0 GMT}
- {-1083542400 1200 1 GMT}
- {-1073089200 0 0 GMT}
- {-1051920000 1200 1 GMT}
- {-1041466800 0 0 GMT}
- {-1020384000 1200 1 GMT}
- {-1009930800 0 0 GMT}
- {-988848000 1200 1 GMT}
- {-978394800 0 0 GMT}
- {-957312000 1200 1 GMT}
- {-946858800 0 0 GMT}
- {-925689600 1200 1 GMT}
- {-915236400 0 0 GMT}
- {-894153600 1200 1 GMT}
- {-883700400 0 0 GMT}
- {-862617600 1200 1 GMT}
- {-852164400 0 0 GMT}
+ {-1709337548 0 0 GMT}
+ {-1581206400 1200 1 +0020}
+ {-1577917200 0 0 GMT}
+ {-1556834400 1200 1 +0020}
+ {-1546294800 0 0 GMT}
+ {-1525298400 1200 1 +0020}
+ {-1514758800 0 0 GMT}
+ {-1493762400 1200 1 +0020}
+ {-1483222800 0 0 GMT}
+ {-1462226400 1200 1 +0020}
+ {-1451686800 0 0 GMT}
+ {-1430604000 1200 1 +0020}
+ {-1420064400 0 0 GMT}
+ {-1399068000 1200 1 +0020}
+ {-1388528400 0 0 GMT}
+ {-1367532000 1200 1 +0020}
+ {-1356992400 0 0 GMT}
+ {-1335996000 1200 1 +0020}
+ {-1325456400 0 0 GMT}
+ {-1304373600 1200 1 +0020}
+ {-1293834000 0 0 GMT}
+ {-1272837600 1200 1 +0020}
+ {-1262298000 0 0 GMT}
+ {-1241301600 1200 1 +0020}
+ {-1230762000 0 0 GMT}
+ {-1209765600 1200 1 +0020}
+ {-1199226000 0 0 GMT}
+ {-1178143200 1200 1 +0020}
+ {-1167603600 0 0 GMT}
+ {-1146607200 1200 1 +0020}
+ {-1136067600 0 0 GMT}
+ {-1115071200 1200 1 +0020}
+ {-1104531600 0 0 GMT}
+ {-1083535200 1200 1 +0020}
+ {-1072995600 0 0 GMT}
+ {-1051912800 1200 1 +0020}
+ {-1041373200 0 0 GMT}
+ {-1020376800 1200 1 +0020}
+ {-1009837200 0 0 GMT}
+ {-988840800 1200 1 +0020}
+ {-978301200 0 0 GMT}
+ {-957304800 1200 1 +0020}
+ {-946765200 0 0 GMT}
+ {-936309600 1200 1 +0020}
+ {-915142800 0 0 GMT}
+ {-904773600 1200 1 +0020}
+ {-883606800 0 0 GMT}
+ {-880329600 1800 0 +0030}
+ {-756952200 0 0 GMT}
+ {-610149600 1800 1 +0030}
+ {-599610600 0 0 GMT}
+ {-578613600 1800 1 +0030}
+ {-568074600 0 0 GMT}
+ {-546991200 1800 1 +0030}
+ {-536452200 0 0 GMT}
+ {-515455200 1800 1 +0030}
+ {-504916200 0 0 GMT}
+ {-483919200 1800 1 +0030}
+ {-473380200 0 0 GMT}
+ {-452383200 1800 1 +0030}
+ {-441844200 0 0 GMT}
}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Africa/Algiers
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Africa/Algiers 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Africa/Algiers 2021-03-02 16:29:37 UTC (rev 58056)
@@ -2,7 +2,7 @@
set TZData(:Africa/Algiers) {
{-9223372036854775808 732 0 LMT}
- {-2486679072 561 0 PMT}
+ {-2486592732 561 0 PMT}
{-1855958961 0 0 WET}
{-1689814800 3600 1 WEST}
{-1680397200 0 0 WET}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Africa/Casablanca
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Africa/Casablanca 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Africa/Casablanca 2021-03-02 16:29:37 UTC (rev 58056)
@@ -60,13 +60,13 @@
{1557021600 0 1 +01}
{1560045600 3600 0 +01}
{1587261600 0 1 +01}
- {1590285600 3600 0 +01}
+ {1590890400 3600 0 +01}
{1618106400 0 1 +01}
{1621130400 3600 0 +01}
{1648346400 0 1 +01}
{1651975200 3600 0 +01}
{1679191200 0 1 +01}
- {1682215200 3600 0 +01}
+ {1682820000 3600 0 +01}
{1710036000 0 1 +01}
{1713060000 3600 0 +01}
{1740276000 0 1 +01}
@@ -76,13 +76,13 @@
{1801965600 0 1 +01}
{1804989600 3600 0 +01}
{1832205600 0 1 +01}
- {1835229600 3600 0 +01}
+ {1835834400 3600 0 +01}
{1863050400 0 1 +01}
{1866074400 3600 0 +01}
{1893290400 0 1 +01}
{1896919200 3600 0 +01}
{1924135200 0 1 +01}
- {1927159200 3600 0 +01}
+ {1927764000 3600 0 +01}
{1954980000 0 1 +01}
{1958004000 3600 0 +01}
{1985220000 0 1 +01}
@@ -92,13 +92,13 @@
{2046304800 0 1 +01}
{2049933600 3600 0 +01}
{2077149600 0 1 +01}
- {2080173600 3600 0 +01}
+ {2080778400 3600 0 +01}
{2107994400 0 1 +01}
{2111018400 3600 0 +01}
{2138234400 0 1 +01}
{2141863200 3600 0 +01}
{2169079200 0 1 +01}
- {2172103200 3600 0 +01}
+ {2172708000 3600 0 +01}
{2199924000 0 1 +01}
{2202948000 3600 0 +01}
{2230164000 0 1 +01}
@@ -108,13 +108,13 @@
{2291248800 0 1 +01}
{2294877600 3600 0 +01}
{2322093600 0 1 +01}
- {2325117600 3600 0 +01}
+ {2325722400 3600 0 +01}
{2352938400 0 1 +01}
{2355962400 3600 0 +01}
{2383178400 0 1 +01}
{2386807200 3600 0 +01}
{2414023200 0 1 +01}
- {2417047200 3600 0 +01}
+ {2417652000 3600 0 +01}
{2444868000 0 1 +01}
{2447892000 3600 0 +01}
{2475108000 0 1 +01}
@@ -124,13 +124,13 @@
{2536192800 0 1 +01}
{2539821600 3600 0 +01}
{2567037600 0 1 +01}
- {2570061600 3600 0 +01}
+ {2570666400 3600 0 +01}
{2597882400 0 1 +01}
{2600906400 3600 0 +01}
{2628122400 0 1 +01}
{2631751200 3600 0 +01}
{2658967200 0 1 +01}
- {2661991200 3600 0 +01}
+ {2662596000 3600 0 +01}
{2689812000 0 1 +01}
{2692836000 3600 0 +01}
{2720052000 0 1 +01}
@@ -140,63 +140,63 @@
{2781136800 0 1 +01}
{2784765600 3600 0 +01}
{2811981600 0 1 +01}
- {2815005600 3600 0 +01}
+ {2815610400 3600 0 +01}
{2842826400 0 1 +01}
{2845850400 3600 0 +01}
{2873066400 0 1 +01}
{2876695200 3600 0 +01}
{2903911200 0 1 +01}
- {2906935200 3600 0 +01}
+ {2907540000 3600 0 +01}
{2934756000 0 1 +01}
{2937780000 3600 0 +01}
{2964996000 0 1 +01}
- {2968020000 3600 0 +01}
+ {2968624800 3600 0 +01}
{2995840800 0 1 +01}
{2998864800 3600 0 +01}
{3026080800 0 1 +01}
{3029709600 3600 0 +01}
{3056925600 0 1 +01}
- {3059949600 3600 0 +01}
+ {3060554400 3600 0 +01}
{3087770400 0 1 +01}
{3090794400 3600 0 +01}
{3118010400 0 1 +01}
{3121639200 3600 0 +01}
{3148855200 0 1 +01}
- {3151879200 3600 0 +01}
+ {3152484000 3600 0 +01}
{3179700000 0 1 +01}
{3182724000 3600 0 +01}
{3209940000 0 1 +01}
- {3212964000 3600 0 +01}
+ {3213568800 3600 0 +01}
{3240784800 0 1 +01}
{3243808800 3600 0 +01}
{3271024800 0 1 +01}
{3274653600 3600 0 +01}
{3301869600 0 1 +01}
- {3304893600 3600 0 +01}
+ {3305498400 3600 0 +01}
{3332714400 0 1 +01}
{3335738400 3600 0 +01}
{3362954400 0 1 +01}
{3366583200 3600 0 +01}
{3393799200 0 1 +01}
- {3396823200 3600 0 +01}
+ {3397428000 3600 0 +01}
{3424644000 0 1 +01}
{3427668000 3600 0 +01}
{3454884000 0 1 +01}
- {3457908000 3600 0 +01}
+ {3458512800 3600 0 +01}
{3485728800 0 1 +01}
{3488752800 3600 0 +01}
{3515968800 0 1 +01}
{3519597600 3600 0 +01}
{3546813600 0 1 +01}
- {3549837600 3600 0 +01}
+ {3550442400 3600 0 +01}
{3577658400 0 1 +01}
{3580682400 3600 0 +01}
{3607898400 0 1 +01}
{3611527200 3600 0 +01}
{3638743200 0 1 +01}
- {3641767200 3600 0 +01}
+ {3642372000 3600 0 +01}
{3669588000 0 1 +01}
{3672612000 3600 0 +01}
{3699828000 0 1 +01}
- {3702852000 3600 0 +01}
+ {3703456800 3600 0 +01}
}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Africa/El_Aaiun
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Africa/El_Aaiun 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Africa/El_Aaiun 2021-03-02 16:29:37 UTC (rev 58056)
@@ -49,13 +49,13 @@
{1557021600 0 1 +01}
{1560045600 3600 0 +01}
{1587261600 0 1 +01}
- {1590285600 3600 0 +01}
+ {1590890400 3600 0 +01}
{1618106400 0 1 +01}
{1621130400 3600 0 +01}
{1648346400 0 1 +01}
{1651975200 3600 0 +01}
{1679191200 0 1 +01}
- {1682215200 3600 0 +01}
+ {1682820000 3600 0 +01}
{1710036000 0 1 +01}
{1713060000 3600 0 +01}
{1740276000 0 1 +01}
@@ -65,13 +65,13 @@
{1801965600 0 1 +01}
{1804989600 3600 0 +01}
{1832205600 0 1 +01}
- {1835229600 3600 0 +01}
+ {1835834400 3600 0 +01}
{1863050400 0 1 +01}
{1866074400 3600 0 +01}
{1893290400 0 1 +01}
{1896919200 3600 0 +01}
{1924135200 0 1 +01}
- {1927159200 3600 0 +01}
+ {1927764000 3600 0 +01}
{1954980000 0 1 +01}
{1958004000 3600 0 +01}
{1985220000 0 1 +01}
@@ -81,13 +81,13 @@
{2046304800 0 1 +01}
{2049933600 3600 0 +01}
{2077149600 0 1 +01}
- {2080173600 3600 0 +01}
+ {2080778400 3600 0 +01}
{2107994400 0 1 +01}
{2111018400 3600 0 +01}
{2138234400 0 1 +01}
{2141863200 3600 0 +01}
{2169079200 0 1 +01}
- {2172103200 3600 0 +01}
+ {2172708000 3600 0 +01}
{2199924000 0 1 +01}
{2202948000 3600 0 +01}
{2230164000 0 1 +01}
@@ -97,13 +97,13 @@
{2291248800 0 1 +01}
{2294877600 3600 0 +01}
{2322093600 0 1 +01}
- {2325117600 3600 0 +01}
+ {2325722400 3600 0 +01}
{2352938400 0 1 +01}
{2355962400 3600 0 +01}
{2383178400 0 1 +01}
{2386807200 3600 0 +01}
{2414023200 0 1 +01}
- {2417047200 3600 0 +01}
+ {2417652000 3600 0 +01}
{2444868000 0 1 +01}
{2447892000 3600 0 +01}
{2475108000 0 1 +01}
@@ -113,13 +113,13 @@
{2536192800 0 1 +01}
{2539821600 3600 0 +01}
{2567037600 0 1 +01}
- {2570061600 3600 0 +01}
+ {2570666400 3600 0 +01}
{2597882400 0 1 +01}
{2600906400 3600 0 +01}
{2628122400 0 1 +01}
{2631751200 3600 0 +01}
{2658967200 0 1 +01}
- {2661991200 3600 0 +01}
+ {2662596000 3600 0 +01}
{2689812000 0 1 +01}
{2692836000 3600 0 +01}
{2720052000 0 1 +01}
@@ -129,63 +129,63 @@
{2781136800 0 1 +01}
{2784765600 3600 0 +01}
{2811981600 0 1 +01}
- {2815005600 3600 0 +01}
+ {2815610400 3600 0 +01}
{2842826400 0 1 +01}
{2845850400 3600 0 +01}
{2873066400 0 1 +01}
{2876695200 3600 0 +01}
{2903911200 0 1 +01}
- {2906935200 3600 0 +01}
+ {2907540000 3600 0 +01}
{2934756000 0 1 +01}
{2937780000 3600 0 +01}
{2964996000 0 1 +01}
- {2968020000 3600 0 +01}
+ {2968624800 3600 0 +01}
{2995840800 0 1 +01}
{2998864800 3600 0 +01}
{3026080800 0 1 +01}
{3029709600 3600 0 +01}
{3056925600 0 1 +01}
- {3059949600 3600 0 +01}
+ {3060554400 3600 0 +01}
{3087770400 0 1 +01}
{3090794400 3600 0 +01}
{3118010400 0 1 +01}
{3121639200 3600 0 +01}
{3148855200 0 1 +01}
- {3151879200 3600 0 +01}
+ {3152484000 3600 0 +01}
{3179700000 0 1 +01}
{3182724000 3600 0 +01}
{3209940000 0 1 +01}
- {3212964000 3600 0 +01}
+ {3213568800 3600 0 +01}
{3240784800 0 1 +01}
{3243808800 3600 0 +01}
{3271024800 0 1 +01}
{3274653600 3600 0 +01}
{3301869600 0 1 +01}
- {3304893600 3600 0 +01}
+ {3305498400 3600 0 +01}
{3332714400 0 1 +01}
{3335738400 3600 0 +01}
{3362954400 0 1 +01}
{3366583200 3600 0 +01}
{3393799200 0 1 +01}
- {3396823200 3600 0 +01}
+ {3397428000 3600 0 +01}
{3424644000 0 1 +01}
{3427668000 3600 0 +01}
{3454884000 0 1 +01}
- {3457908000 3600 0 +01}
+ {3458512800 3600 0 +01}
{3485728800 0 1 +01}
{3488752800 3600 0 +01}
{3515968800 0 1 +01}
{3519597600 3600 0 +01}
{3546813600 0 1 +01}
- {3549837600 3600 0 +01}
+ {3550442400 3600 0 +01}
{3577658400 0 1 +01}
{3580682400 3600 0 +01}
{3607898400 0 1 +01}
{3611527200 3600 0 +01}
{3638743200 0 1 +01}
- {3641767200 3600 0 +01}
+ {3642372000 3600 0 +01}
{3669588000 0 1 +01}
{3672612000 3600 0 +01}
{3699828000 0 1 +01}
- {3702852000 3600 0 +01}
+ {3703456800 3600 0 +01}
}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Africa/Lagos
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Africa/Lagos 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Africa/Lagos 2021-03-02 16:29:37 UTC (rev 58056)
@@ -1,6 +1,9 @@
# created by tools/tclZIC.tcl - do not edit
set TZData(:Africa/Lagos) {
- {-9223372036854775808 816 0 LMT}
- {-1588464816 3600 0 WAT}
+ {-9223372036854775808 815 0 LMT}
+ {-2035584815 0 0 GMT}
+ {-1940889600 815 0 LMT}
+ {-1767226415 1800 0 +0030}
+ {-1588465800 3600 0 WAT}
}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Africa/Nairobi
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Africa/Nairobi 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Africa/Nairobi 2021-03-02 16:29:37 UTC (rev 58056)
@@ -2,8 +2,9 @@
set TZData(:Africa/Nairobi) {
{-9223372036854775808 8836 0 LMT}
- {-1309746436 10800 0 EAT}
- {-1262314800 9000 0 +0230}
- {-946780200 9900 0 +0245}
- {-315629100 10800 0 EAT}
+ {-1946168836 9000 0 +0230}
+ {-1309746600 10800 0 EAT}
+ {-1261969200 9000 0 +0230}
+ {-1041388200 9900 0 +0245}
+ {-865305900 10800 0 EAT}
}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Belize
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Belize 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Belize 2021-03-02 16:29:37 UTC (rev 58056)
@@ -51,8 +51,51 @@
{-911759400 -21600 0 CST}
{-891194400 -19800 1 -0530}
{-879705000 -21600 0 CST}
- {-859744800 -19800 1 -0530}
- {-848255400 -21600 0 CST}
+ {-868212000 -18000 1 CWT}
+ {-769395600 -18000 1 CPT}
+ {-758746800 -21600 0 CST}
+ {-701892000 -19800 1 -0530}
+ {-690402600 -21600 0 CST}
+ {-670442400 -19800 1 -0530}
+ {-658953000 -21600 0 CST}
+ {-638992800 -19800 1 -0530}
+ {-627503400 -21600 0 CST}
+ {-606938400 -19800 1 -0530}
+ {-596053800 -21600 0 CST}
+ {-575488800 -19800 1 -0530}
+ {-564604200 -21600 0 CST}
+ {-544039200 -19800 1 -0530}
+ {-532549800 -21600 0 CST}
+ {-512589600 -19800 1 -0530}
+ {-501100200 -21600 0 CST}
+ {-481140000 -19800 1 -0530}
+ {-469650600 -21600 0 CST}
+ {-449690400 -19800 1 -0530}
+ {-438201000 -21600 0 CST}
+ {-417636000 -19800 1 -0530}
+ {-406751400 -21600 0 CST}
+ {-386186400 -19800 1 -0530}
+ {-375301800 -21600 0 CST}
+ {-354736800 -19800 1 -0530}
+ {-343247400 -21600 0 CST}
+ {-323287200 -19800 1 -0530}
+ {-311797800 -21600 0 CST}
+ {-291837600 -19800 1 -0530}
+ {-280348200 -21600 0 CST}
+ {-259783200 -19800 1 -0530}
+ {-248898600 -21600 0 CST}
+ {-228333600 -19800 1 -0530}
+ {-217449000 -21600 0 CST}
+ {-196884000 -19800 1 -0530}
+ {-185999400 -21600 0 CST}
+ {-165434400 -19800 1 -0530}
+ {-153945000 -21600 0 CST}
+ {-133984800 -19800 1 -0530}
+ {-122495400 -21600 0 CST}
+ {-102535200 -19800 1 -0530}
+ {-91045800 -21600 0 CST}
+ {-70480800 -19800 1 -0530}
+ {-59596200 -21600 0 CST}
{123919200 -18000 1 CDT}
{129618000 -21600 0 CST}
{409039200 -18000 1 CDT}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Dawson
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Dawson 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Dawson 2021-03-02 16:29:37 UTC (rev 58056)
@@ -94,163 +94,5 @@
{1552212000 -25200 1 PDT}
{1572771600 -28800 0 PST}
{1583661600 -25200 1 PDT}
- {1604221200 -28800 0 PST}
- {1615716000 -25200 1 PDT}
- {1636275600 -28800 0 PST}
- {1647165600 -25200 1 PDT}
- {1667725200 -28800 0 PST}
- {1678615200 -25200 1 PDT}
- {1699174800 -28800 0 PST}
- {1710064800 -25200 1 PDT}
- {1730624400 -28800 0 PST}
- {1741514400 -25200 1 PDT}
- {1762074000 -28800 0 PST}
- {1772964000 -25200 1 PDT}
- {1793523600 -28800 0 PST}
- {1805018400 -25200 1 PDT}
- {1825578000 -28800 0 PST}
- {1836468000 -25200 1 PDT}
- {1857027600 -28800 0 PST}
- {1867917600 -25200 1 PDT}
- {1888477200 -28800 0 PST}
- {1899367200 -25200 1 PDT}
- {1919926800 -28800 0 PST}
- {1930816800 -25200 1 PDT}
- {1951376400 -28800 0 PST}
- {1962871200 -25200 1 PDT}
- {1983430800 -28800 0 PST}
- {1994320800 -25200 1 PDT}
- {2014880400 -28800 0 PST}
- {2025770400 -25200 1 PDT}
- {2046330000 -28800 0 PST}
- {2057220000 -25200 1 PDT}
- {2077779600 -28800 0 PST}
- {2088669600 -25200 1 PDT}
- {2109229200 -28800 0 PST}
- {2120119200 -25200 1 PDT}
- {2140678800 -28800 0 PST}
- {2152173600 -25200 1 PDT}
- {2172733200 -28800 0 PST}
- {2183623200 -25200 1 PDT}
- {2204182800 -28800 0 PST}
- {2215072800 -25200 1 PDT}
- {2235632400 -28800 0 PST}
- {2246522400 -25200 1 PDT}
- {2267082000 -28800 0 PST}
- {2277972000 -25200 1 PDT}
- {2298531600 -28800 0 PST}
- {2309421600 -25200 1 PDT}
- {2329981200 -28800 0 PST}
- {2341476000 -25200 1 PDT}
- {2362035600 -28800 0 PST}
- {2372925600 -25200 1 PDT}
- {2393485200 -28800 0 PST}
- {2404375200 -25200 1 PDT}
- {2424934800 -28800 0 PST}
- {2435824800 -25200 1 PDT}
- {2456384400 -28800 0 PST}
- {2467274400 -25200 1 PDT}
- {2487834000 -28800 0 PST}
- {2499328800 -25200 1 PDT}
- {2519888400 -28800 0 PST}
- {2530778400 -25200 1 PDT}
- {2551338000 -28800 0 PST}
- {2562228000 -25200 1 PDT}
- {2582787600 -28800 0 PST}
- {2593677600 -25200 1 PDT}
- {2614237200 -28800 0 PST}
- {2625127200 -25200 1 PDT}
- {2645686800 -28800 0 PST}
- {2656576800 -25200 1 PDT}
- {2677136400 -28800 0 PST}
- {2688631200 -25200 1 PDT}
- {2709190800 -28800 0 PST}
- {2720080800 -25200 1 PDT}
- {2740640400 -28800 0 PST}
- {2751530400 -25200 1 PDT}
- {2772090000 -28800 0 PST}
- {2782980000 -25200 1 PDT}
- {2803539600 -28800 0 PST}
- {2814429600 -25200 1 PDT}
- {2834989200 -28800 0 PST}
- {2846484000 -25200 1 PDT}
- {2867043600 -28800 0 PST}
- {2877933600 -25200 1 PDT}
- {2898493200 -28800 0 PST}
- {2909383200 -25200 1 PDT}
- {2929942800 -28800 0 PST}
- {2940832800 -25200 1 PDT}
- {2961392400 -28800 0 PST}
- {2972282400 -25200 1 PDT}
- {2992842000 -28800 0 PST}
- {3003732000 -25200 1 PDT}
- {3024291600 -28800 0 PST}
- {3035786400 -25200 1 PDT}
- {3056346000 -28800 0 PST}
- {3067236000 -25200 1 PDT}
- {3087795600 -28800 0 PST}
- {3098685600 -25200 1 PDT}
- {3119245200 -28800 0 PST}
- {3130135200 -25200 1 PDT}
- {3150694800 -28800 0 PST}
- {3161584800 -25200 1 PDT}
- {3182144400 -28800 0 PST}
- {3193034400 -25200 1 PDT}
- {3213594000 -28800 0 PST}
- {3225088800 -25200 1 PDT}
- {3245648400 -28800 0 PST}
- {3256538400 -25200 1 PDT}
- {3277098000 -28800 0 PST}
- {3287988000 -25200 1 PDT}
- {3308547600 -28800 0 PST}
- {3319437600 -25200 1 PDT}
- {3339997200 -28800 0 PST}
- {3350887200 -25200 1 PDT}
- {3371446800 -28800 0 PST}
- {3382941600 -25200 1 PDT}
- {3403501200 -28800 0 PST}
- {3414391200 -25200 1 PDT}
- {3434950800 -28800 0 PST}
- {3445840800 -25200 1 PDT}
- {3466400400 -28800 0 PST}
- {3477290400 -25200 1 PDT}
- {3497850000 -28800 0 PST}
- {3508740000 -25200 1 PDT}
- {3529299600 -28800 0 PST}
- {3540189600 -25200 1 PDT}
- {3560749200 -28800 0 PST}
- {3572244000 -25200 1 PDT}
- {3592803600 -28800 0 PST}
- {3603693600 -25200 1 PDT}
- {3624253200 -28800 0 PST}
- {3635143200 -25200 1 PDT}
- {3655702800 -28800 0 PST}
- {3666592800 -25200 1 PDT}
- {3687152400 -28800 0 PST}
- {3698042400 -25200 1 PDT}
- {3718602000 -28800 0 PST}
- {3730096800 -25200 1 PDT}
- {3750656400 -28800 0 PST}
- {3761546400 -25200 1 PDT}
- {3782106000 -28800 0 PST}
- {3792996000 -25200 1 PDT}
- {3813555600 -28800 0 PST}
- {3824445600 -25200 1 PDT}
- {3845005200 -28800 0 PST}
- {3855895200 -25200 1 PDT}
- {3876454800 -28800 0 PST}
- {3887344800 -25200 1 PDT}
- {3907904400 -28800 0 PST}
- {3919399200 -25200 1 PDT}
- {3939958800 -28800 0 PST}
- {3950848800 -25200 1 PDT}
- {3971408400 -28800 0 PST}
- {3982298400 -25200 1 PDT}
- {4002858000 -28800 0 PST}
- {4013748000 -25200 1 PDT}
- {4034307600 -28800 0 PST}
- {4045197600 -25200 1 PDT}
- {4065757200 -28800 0 PST}
- {4076647200 -25200 1 PDT}
- {4097206800 -28800 0 PST}
+ {1604217600 -25200 0 MST}
}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Godthab
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Godthab 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Godthab 2021-03-02 16:29:37 UTC (rev 58056)
@@ -1,246 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-
-set TZData(:America/Godthab) {
- {-9223372036854775808 -12416 0 LMT}
- {-1686083584 -10800 0 -03}
- {323845200 -7200 0 -02}
- {338950800 -10800 0 -03}
- {354675600 -7200 1 -02}
- {370400400 -10800 0 -03}
- {386125200 -7200 1 -02}
- {401850000 -10800 0 -03}
- {417574800 -7200 1 -02}
- {433299600 -10800 0 -03}
- {449024400 -7200 1 -02}
- {465354000 -10800 0 -03}
- {481078800 -7200 1 -02}
- {496803600 -10800 0 -03}
- {512528400 -7200 1 -02}
- {528253200 -10800 0 -03}
- {543978000 -7200 1 -02}
- {559702800 -10800 0 -03}
- {575427600 -7200 1 -02}
- {591152400 -10800 0 -03}
- {606877200 -7200 1 -02}
- {622602000 -10800 0 -03}
- {638326800 -7200 1 -02}
- {654656400 -10800 0 -03}
- {670381200 -7200 1 -02}
- {686106000 -10800 0 -03}
- {701830800 -7200 1 -02}
- {717555600 -10800 0 -03}
- {733280400 -7200 1 -02}
- {749005200 -10800 0 -03}
- {764730000 -7200 1 -02}
- {780454800 -10800 0 -03}
- {796179600 -7200 1 -02}
- {811904400 -10800 0 -03}
- {828234000 -7200 1 -02}
- {846378000 -10800 0 -03}
- {859683600 -7200 1 -02}
- {877827600 -10800 0 -03}
- {891133200 -7200 1 -02}
- {909277200 -10800 0 -03}
- {922582800 -7200 1 -02}
- {941331600 -10800 0 -03}
- {954032400 -7200 1 -02}
- {972781200 -10800 0 -03}
- {985482000 -7200 1 -02}
- {1004230800 -10800 0 -03}
- {1017536400 -7200 1 -02}
- {1035680400 -10800 0 -03}
- {1048986000 -7200 1 -02}
- {1067130000 -10800 0 -03}
- {1080435600 -7200 1 -02}
- {1099184400 -10800 0 -03}
- {1111885200 -7200 1 -02}
- {1130634000 -10800 0 -03}
- {1143334800 -7200 1 -02}
- {1162083600 -10800 0 -03}
- {1174784400 -7200 1 -02}
- {1193533200 -10800 0 -03}
- {1206838800 -7200 1 -02}
- {1224982800 -10800 0 -03}
- {1238288400 -7200 1 -02}
- {1256432400 -10800 0 -03}
- {1269738000 -7200 1 -02}
- {1288486800 -10800 0 -03}
- {1301187600 -7200 1 -02}
- {1319936400 -10800 0 -03}
- {1332637200 -7200 1 -02}
- {1351386000 -10800 0 -03}
- {1364691600 -7200 1 -02}
- {1382835600 -10800 0 -03}
- {1396141200 -7200 1 -02}
- {1414285200 -10800 0 -03}
- {1427590800 -7200 1 -02}
- {1445734800 -10800 0 -03}
- {1459040400 -7200 1 -02}
- {1477789200 -10800 0 -03}
- {1490490000 -7200 1 -02}
- {1509238800 -10800 0 -03}
- {1521939600 -7200 1 -02}
- {1540688400 -10800 0 -03}
- {1553994000 -7200 1 -02}
- {1572138000 -10800 0 -03}
- {1585443600 -7200 1 -02}
- {1603587600 -10800 0 -03}
- {1616893200 -7200 1 -02}
- {1635642000 -10800 0 -03}
- {1648342800 -7200 1 -02}
- {1667091600 -10800 0 -03}
- {1679792400 -7200 1 -02}
- {1698541200 -10800 0 -03}
- {1711846800 -7200 1 -02}
- {1729990800 -10800 0 -03}
- {1743296400 -7200 1 -02}
- {1761440400 -10800 0 -03}
- {1774746000 -7200 1 -02}
- {1792890000 -10800 0 -03}
- {1806195600 -7200 1 -02}
- {1824944400 -10800 0 -03}
- {1837645200 -7200 1 -02}
- {1856394000 -10800 0 -03}
- {1869094800 -7200 1 -02}
- {1887843600 -10800 0 -03}
- {1901149200 -7200 1 -02}
- {1919293200 -10800 0 -03}
- {1932598800 -7200 1 -02}
- {1950742800 -10800 0 -03}
- {1964048400 -7200 1 -02}
- {1982797200 -10800 0 -03}
- {1995498000 -7200 1 -02}
- {2014246800 -10800 0 -03}
- {2026947600 -7200 1 -02}
- {2045696400 -10800 0 -03}
- {2058397200 -7200 1 -02}
- {2077146000 -10800 0 -03}
- {2090451600 -7200 1 -02}
- {2108595600 -10800 0 -03}
- {2121901200 -7200 1 -02}
- {2140045200 -10800 0 -03}
- {2153350800 -7200 1 -02}
- {2172099600 -10800 0 -03}
- {2184800400 -7200 1 -02}
- {2203549200 -10800 0 -03}
- {2216250000 -7200 1 -02}
- {2234998800 -10800 0 -03}
- {2248304400 -7200 1 -02}
- {2266448400 -10800 0 -03}
- {2279754000 -7200 1 -02}
- {2297898000 -10800 0 -03}
- {2311203600 -7200 1 -02}
- {2329347600 -10800 0 -03}
- {2342653200 -7200 1 -02}
- {2361402000 -10800 0 -03}
- {2374102800 -7200 1 -02}
- {2392851600 -10800 0 -03}
- {2405552400 -7200 1 -02}
- {2424301200 -10800 0 -03}
- {2437606800 -7200 1 -02}
- {2455750800 -10800 0 -03}
- {2469056400 -7200 1 -02}
- {2487200400 -10800 0 -03}
- {2500506000 -7200 1 -02}
- {2519254800 -10800 0 -03}
- {2531955600 -7200 1 -02}
- {2550704400 -10800 0 -03}
- {2563405200 -7200 1 -02}
- {2582154000 -10800 0 -03}
- {2595459600 -7200 1 -02}
- {2613603600 -10800 0 -03}
- {2626909200 -7200 1 -02}
- {2645053200 -10800 0 -03}
- {2658358800 -7200 1 -02}
- {2676502800 -10800 0 -03}
- {2689808400 -7200 1 -02}
- {2708557200 -10800 0 -03}
- {2721258000 -7200 1 -02}
- {2740006800 -10800 0 -03}
- {2752707600 -7200 1 -02}
- {2771456400 -10800 0 -03}
- {2784762000 -7200 1 -02}
- {2802906000 -10800 0 -03}
- {2816211600 -7200 1 -02}
- {2834355600 -10800 0 -03}
- {2847661200 -7200 1 -02}
- {2866410000 -10800 0 -03}
- {2879110800 -7200 1 -02}
- {2897859600 -10800 0 -03}
- {2910560400 -7200 1 -02}
- {2929309200 -10800 0 -03}
- {2942010000 -7200 1 -02}
- {2960758800 -10800 0 -03}
- {2974064400 -7200 1 -02}
- {2992208400 -10800 0 -03}
- {3005514000 -7200 1 -02}
- {3023658000 -10800 0 -03}
- {3036963600 -7200 1 -02}
- {3055712400 -10800 0 -03}
- {3068413200 -7200 1 -02}
- {3087162000 -10800 0 -03}
- {3099862800 -7200 1 -02}
- {3118611600 -10800 0 -03}
- {3131917200 -7200 1 -02}
- {3150061200 -10800 0 -03}
- {3163366800 -7200 1 -02}
- {3181510800 -10800 0 -03}
- {3194816400 -7200 1 -02}
- {3212960400 -10800 0 -03}
- {3226266000 -7200 1 -02}
- {3245014800 -10800 0 -03}
- {3257715600 -7200 1 -02}
- {3276464400 -10800 0 -03}
- {3289165200 -7200 1 -02}
- {3307914000 -10800 0 -03}
- {3321219600 -7200 1 -02}
- {3339363600 -10800 0 -03}
- {3352669200 -7200 1 -02}
- {3370813200 -10800 0 -03}
- {3384118800 -7200 1 -02}
- {3402867600 -10800 0 -03}
- {3415568400 -7200 1 -02}
- {3434317200 -10800 0 -03}
- {3447018000 -7200 1 -02}
- {3465766800 -10800 0 -03}
- {3479072400 -7200 1 -02}
- {3497216400 -10800 0 -03}
- {3510522000 -7200 1 -02}
- {3528666000 -10800 0 -03}
- {3541971600 -7200 1 -02}
- {3560115600 -10800 0 -03}
- {3573421200 -7200 1 -02}
- {3592170000 -10800 0 -03}
- {3604870800 -7200 1 -02}
- {3623619600 -10800 0 -03}
- {3636320400 -7200 1 -02}
- {3655069200 -10800 0 -03}
- {3668374800 -7200 1 -02}
- {3686518800 -10800 0 -03}
- {3699824400 -7200 1 -02}
- {3717968400 -10800 0 -03}
- {3731274000 -7200 1 -02}
- {3750022800 -10800 0 -03}
- {3762723600 -7200 1 -02}
- {3781472400 -10800 0 -03}
- {3794173200 -7200 1 -02}
- {3812922000 -10800 0 -03}
- {3825622800 -7200 1 -02}
- {3844371600 -10800 0 -03}
- {3857677200 -7200 1 -02}
- {3875821200 -10800 0 -03}
- {3889126800 -7200 1 -02}
- {3907270800 -10800 0 -03}
- {3920576400 -7200 1 -02}
- {3939325200 -10800 0 -03}
- {3952026000 -7200 1 -02}
- {3970774800 -10800 0 -03}
- {3983475600 -7200 1 -02}
- {4002224400 -10800 0 -03}
- {4015530000 -7200 1 -02}
- {4033674000 -10800 0 -03}
- {4046979600 -7200 1 -02}
- {4065123600 -10800 0 -03}
- {4078429200 -7200 1 -02}
- {4096573200 -10800 0 -03}
+if {![info exists TZData(America/Nuuk)]} {
+ LoadTimeZoneFile America/Nuuk
}
+set TZData(:America/Godthab) $TZData(:America/Nuuk)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Grand_Turk
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Grand_Turk 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Grand_Turk 2021-03-02 16:29:37 UTC (rev 58056)
@@ -77,8 +77,7 @@
{1383458400 -18000 0 EST}
{1394348400 -14400 1 EDT}
{1414908000 -18000 0 EST}
- {1425798000 -14400 1 EDT}
- {1446361200 -14400 0 AST}
+ {1425798000 -14400 0 AST}
{1520751600 -14400 0 EDT}
{1541311200 -18000 0 EST}
{1552201200 -14400 1 EDT}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Nassau
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Nassau 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Nassau 2021-03-02 16:29:37 UTC (rev 58056)
@@ -3,6 +3,11 @@
set TZData(:America/Nassau) {
{-9223372036854775808 -18570 0 LMT}
{-1825095030 -18000 0 EST}
+ {-873140400 -14400 1 EWT}
+ {-788904000 -18000 0 EST}
+ {-786222000 -14400 1 EWT}
+ {-769395600 -14400 1 EPT}
+ {-763848000 -18000 0 EST}
{-179341200 -14400 1 EDT}
{-163620000 -18000 0 EST}
{-147891600 -14400 1 EDT}
Added: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Nuuk
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Nuuk (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Nuuk 2021-03-02 16:29:37 UTC (rev 58056)
@@ -0,0 +1,246 @@
+# created by tools/tclZIC.tcl - do not edit
+
+set TZData(:America/Nuuk) {
+ {-9223372036854775808 -12416 0 LMT}
+ {-1686083584 -10800 0 -03}
+ {323845200 -7200 0 -02}
+ {338950800 -10800 0 -03}
+ {354675600 -7200 1 -02}
+ {370400400 -10800 0 -03}
+ {386125200 -7200 1 -02}
+ {401850000 -10800 0 -03}
+ {417574800 -7200 1 -02}
+ {433299600 -10800 0 -03}
+ {449024400 -7200 1 -02}
+ {465354000 -10800 0 -03}
+ {481078800 -7200 1 -02}
+ {496803600 -10800 0 -03}
+ {512528400 -7200 1 -02}
+ {528253200 -10800 0 -03}
+ {543978000 -7200 1 -02}
+ {559702800 -10800 0 -03}
+ {575427600 -7200 1 -02}
+ {591152400 -10800 0 -03}
+ {606877200 -7200 1 -02}
+ {622602000 -10800 0 -03}
+ {638326800 -7200 1 -02}
+ {654656400 -10800 0 -03}
+ {670381200 -7200 1 -02}
+ {686106000 -10800 0 -03}
+ {701830800 -7200 1 -02}
+ {717555600 -10800 0 -03}
+ {733280400 -7200 1 -02}
+ {749005200 -10800 0 -03}
+ {764730000 -7200 1 -02}
+ {780454800 -10800 0 -03}
+ {796179600 -7200 1 -02}
+ {811904400 -10800 0 -03}
+ {828234000 -7200 1 -02}
+ {846378000 -10800 0 -03}
+ {859683600 -7200 1 -02}
+ {877827600 -10800 0 -03}
+ {891133200 -7200 1 -02}
+ {909277200 -10800 0 -03}
+ {922582800 -7200 1 -02}
+ {941331600 -10800 0 -03}
+ {954032400 -7200 1 -02}
+ {972781200 -10800 0 -03}
+ {985482000 -7200 1 -02}
+ {1004230800 -10800 0 -03}
+ {1017536400 -7200 1 -02}
+ {1035680400 -10800 0 -03}
+ {1048986000 -7200 1 -02}
+ {1067130000 -10800 0 -03}
+ {1080435600 -7200 1 -02}
+ {1099184400 -10800 0 -03}
+ {1111885200 -7200 1 -02}
+ {1130634000 -10800 0 -03}
+ {1143334800 -7200 1 -02}
+ {1162083600 -10800 0 -03}
+ {1174784400 -7200 1 -02}
+ {1193533200 -10800 0 -03}
+ {1206838800 -7200 1 -02}
+ {1224982800 -10800 0 -03}
+ {1238288400 -7200 1 -02}
+ {1256432400 -10800 0 -03}
+ {1269738000 -7200 1 -02}
+ {1288486800 -10800 0 -03}
+ {1301187600 -7200 1 -02}
+ {1319936400 -10800 0 -03}
+ {1332637200 -7200 1 -02}
+ {1351386000 -10800 0 -03}
+ {1364691600 -7200 1 -02}
+ {1382835600 -10800 0 -03}
+ {1396141200 -7200 1 -02}
+ {1414285200 -10800 0 -03}
+ {1427590800 -7200 1 -02}
+ {1445734800 -10800 0 -03}
+ {1459040400 -7200 1 -02}
+ {1477789200 -10800 0 -03}
+ {1490490000 -7200 1 -02}
+ {1509238800 -10800 0 -03}
+ {1521939600 -7200 1 -02}
+ {1540688400 -10800 0 -03}
+ {1553994000 -7200 1 -02}
+ {1572138000 -10800 0 -03}
+ {1585443600 -7200 1 -02}
+ {1603587600 -10800 0 -03}
+ {1616893200 -7200 1 -02}
+ {1635642000 -10800 0 -03}
+ {1648342800 -7200 1 -02}
+ {1667091600 -10800 0 -03}
+ {1679792400 -7200 1 -02}
+ {1698541200 -10800 0 -03}
+ {1711846800 -7200 1 -02}
+ {1729990800 -10800 0 -03}
+ {1743296400 -7200 1 -02}
+ {1761440400 -10800 0 -03}
+ {1774746000 -7200 1 -02}
+ {1792890000 -10800 0 -03}
+ {1806195600 -7200 1 -02}
+ {1824944400 -10800 0 -03}
+ {1837645200 -7200 1 -02}
+ {1856394000 -10800 0 -03}
+ {1869094800 -7200 1 -02}
+ {1887843600 -10800 0 -03}
+ {1901149200 -7200 1 -02}
+ {1919293200 -10800 0 -03}
+ {1932598800 -7200 1 -02}
+ {1950742800 -10800 0 -03}
+ {1964048400 -7200 1 -02}
+ {1982797200 -10800 0 -03}
+ {1995498000 -7200 1 -02}
+ {2014246800 -10800 0 -03}
+ {2026947600 -7200 1 -02}
+ {2045696400 -10800 0 -03}
+ {2058397200 -7200 1 -02}
+ {2077146000 -10800 0 -03}
+ {2090451600 -7200 1 -02}
+ {2108595600 -10800 0 -03}
+ {2121901200 -7200 1 -02}
+ {2140045200 -10800 0 -03}
+ {2153350800 -7200 1 -02}
+ {2172099600 -10800 0 -03}
+ {2184800400 -7200 1 -02}
+ {2203549200 -10800 0 -03}
+ {2216250000 -7200 1 -02}
+ {2234998800 -10800 0 -03}
+ {2248304400 -7200 1 -02}
+ {2266448400 -10800 0 -03}
+ {2279754000 -7200 1 -02}
+ {2297898000 -10800 0 -03}
+ {2311203600 -7200 1 -02}
+ {2329347600 -10800 0 -03}
+ {2342653200 -7200 1 -02}
+ {2361402000 -10800 0 -03}
+ {2374102800 -7200 1 -02}
+ {2392851600 -10800 0 -03}
+ {2405552400 -7200 1 -02}
+ {2424301200 -10800 0 -03}
+ {2437606800 -7200 1 -02}
+ {2455750800 -10800 0 -03}
+ {2469056400 -7200 1 -02}
+ {2487200400 -10800 0 -03}
+ {2500506000 -7200 1 -02}
+ {2519254800 -10800 0 -03}
+ {2531955600 -7200 1 -02}
+ {2550704400 -10800 0 -03}
+ {2563405200 -7200 1 -02}
+ {2582154000 -10800 0 -03}
+ {2595459600 -7200 1 -02}
+ {2613603600 -10800 0 -03}
+ {2626909200 -7200 1 -02}
+ {2645053200 -10800 0 -03}
+ {2658358800 -7200 1 -02}
+ {2676502800 -10800 0 -03}
+ {2689808400 -7200 1 -02}
+ {2708557200 -10800 0 -03}
+ {2721258000 -7200 1 -02}
+ {2740006800 -10800 0 -03}
+ {2752707600 -7200 1 -02}
+ {2771456400 -10800 0 -03}
+ {2784762000 -7200 1 -02}
+ {2802906000 -10800 0 -03}
+ {2816211600 -7200 1 -02}
+ {2834355600 -10800 0 -03}
+ {2847661200 -7200 1 -02}
+ {2866410000 -10800 0 -03}
+ {2879110800 -7200 1 -02}
+ {2897859600 -10800 0 -03}
+ {2910560400 -7200 1 -02}
+ {2929309200 -10800 0 -03}
+ {2942010000 -7200 1 -02}
+ {2960758800 -10800 0 -03}
+ {2974064400 -7200 1 -02}
+ {2992208400 -10800 0 -03}
+ {3005514000 -7200 1 -02}
+ {3023658000 -10800 0 -03}
+ {3036963600 -7200 1 -02}
+ {3055712400 -10800 0 -03}
+ {3068413200 -7200 1 -02}
+ {3087162000 -10800 0 -03}
+ {3099862800 -7200 1 -02}
+ {3118611600 -10800 0 -03}
+ {3131917200 -7200 1 -02}
+ {3150061200 -10800 0 -03}
+ {3163366800 -7200 1 -02}
+ {3181510800 -10800 0 -03}
+ {3194816400 -7200 1 -02}
+ {3212960400 -10800 0 -03}
+ {3226266000 -7200 1 -02}
+ {3245014800 -10800 0 -03}
+ {3257715600 -7200 1 -02}
+ {3276464400 -10800 0 -03}
+ {3289165200 -7200 1 -02}
+ {3307914000 -10800 0 -03}
+ {3321219600 -7200 1 -02}
+ {3339363600 -10800 0 -03}
+ {3352669200 -7200 1 -02}
+ {3370813200 -10800 0 -03}
+ {3384118800 -7200 1 -02}
+ {3402867600 -10800 0 -03}
+ {3415568400 -7200 1 -02}
+ {3434317200 -10800 0 -03}
+ {3447018000 -7200 1 -02}
+ {3465766800 -10800 0 -03}
+ {3479072400 -7200 1 -02}
+ {3497216400 -10800 0 -03}
+ {3510522000 -7200 1 -02}
+ {3528666000 -10800 0 -03}
+ {3541971600 -7200 1 -02}
+ {3560115600 -10800 0 -03}
+ {3573421200 -7200 1 -02}
+ {3592170000 -10800 0 -03}
+ {3604870800 -7200 1 -02}
+ {3623619600 -10800 0 -03}
+ {3636320400 -7200 1 -02}
+ {3655069200 -10800 0 -03}
+ {3668374800 -7200 1 -02}
+ {3686518800 -10800 0 -03}
+ {3699824400 -7200 1 -02}
+ {3717968400 -10800 0 -03}
+ {3731274000 -7200 1 -02}
+ {3750022800 -10800 0 -03}
+ {3762723600 -7200 1 -02}
+ {3781472400 -10800 0 -03}
+ {3794173200 -7200 1 -02}
+ {3812922000 -10800 0 -03}
+ {3825622800 -7200 1 -02}
+ {3844371600 -10800 0 -03}
+ {3857677200 -7200 1 -02}
+ {3875821200 -10800 0 -03}
+ {3889126800 -7200 1 -02}
+ {3907270800 -10800 0 -03}
+ {3920576400 -7200 1 -02}
+ {3939325200 -10800 0 -03}
+ {3952026000 -7200 1 -02}
+ {3970774800 -10800 0 -03}
+ {3983475600 -7200 1 -02}
+ {4002224400 -10800 0 -03}
+ {4015530000 -7200 1 -02}
+ {4033674000 -10800 0 -03}
+ {4046979600 -7200 1 -02}
+ {4065123600 -10800 0 -03}
+ {4078429200 -7200 1 -02}
+ {4096573200 -10800 0 -03}
+}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Whitehorse
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Whitehorse 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/America/Whitehorse 2021-03-02 16:29:37 UTC (rev 58056)
@@ -94,163 +94,5 @@
{1552212000 -25200 1 PDT}
{1572771600 -28800 0 PST}
{1583661600 -25200 1 PDT}
- {1604221200 -28800 0 PST}
- {1615716000 -25200 1 PDT}
- {1636275600 -28800 0 PST}
- {1647165600 -25200 1 PDT}
- {1667725200 -28800 0 PST}
- {1678615200 -25200 1 PDT}
- {1699174800 -28800 0 PST}
- {1710064800 -25200 1 PDT}
- {1730624400 -28800 0 PST}
- {1741514400 -25200 1 PDT}
- {1762074000 -28800 0 PST}
- {1772964000 -25200 1 PDT}
- {1793523600 -28800 0 PST}
- {1805018400 -25200 1 PDT}
- {1825578000 -28800 0 PST}
- {1836468000 -25200 1 PDT}
- {1857027600 -28800 0 PST}
- {1867917600 -25200 1 PDT}
- {1888477200 -28800 0 PST}
- {1899367200 -25200 1 PDT}
- {1919926800 -28800 0 PST}
- {1930816800 -25200 1 PDT}
- {1951376400 -28800 0 PST}
- {1962871200 -25200 1 PDT}
- {1983430800 -28800 0 PST}
- {1994320800 -25200 1 PDT}
- {2014880400 -28800 0 PST}
- {2025770400 -25200 1 PDT}
- {2046330000 -28800 0 PST}
- {2057220000 -25200 1 PDT}
- {2077779600 -28800 0 PST}
- {2088669600 -25200 1 PDT}
- {2109229200 -28800 0 PST}
- {2120119200 -25200 1 PDT}
- {2140678800 -28800 0 PST}
- {2152173600 -25200 1 PDT}
- {2172733200 -28800 0 PST}
- {2183623200 -25200 1 PDT}
- {2204182800 -28800 0 PST}
- {2215072800 -25200 1 PDT}
- {2235632400 -28800 0 PST}
- {2246522400 -25200 1 PDT}
- {2267082000 -28800 0 PST}
- {2277972000 -25200 1 PDT}
- {2298531600 -28800 0 PST}
- {2309421600 -25200 1 PDT}
- {2329981200 -28800 0 PST}
- {2341476000 -25200 1 PDT}
- {2362035600 -28800 0 PST}
- {2372925600 -25200 1 PDT}
- {2393485200 -28800 0 PST}
- {2404375200 -25200 1 PDT}
- {2424934800 -28800 0 PST}
- {2435824800 -25200 1 PDT}
- {2456384400 -28800 0 PST}
- {2467274400 -25200 1 PDT}
- {2487834000 -28800 0 PST}
- {2499328800 -25200 1 PDT}
- {2519888400 -28800 0 PST}
- {2530778400 -25200 1 PDT}
- {2551338000 -28800 0 PST}
- {2562228000 -25200 1 PDT}
- {2582787600 -28800 0 PST}
- {2593677600 -25200 1 PDT}
- {2614237200 -28800 0 PST}
- {2625127200 -25200 1 PDT}
- {2645686800 -28800 0 PST}
- {2656576800 -25200 1 PDT}
- {2677136400 -28800 0 PST}
- {2688631200 -25200 1 PDT}
- {2709190800 -28800 0 PST}
- {2720080800 -25200 1 PDT}
- {2740640400 -28800 0 PST}
- {2751530400 -25200 1 PDT}
- {2772090000 -28800 0 PST}
- {2782980000 -25200 1 PDT}
- {2803539600 -28800 0 PST}
- {2814429600 -25200 1 PDT}
- {2834989200 -28800 0 PST}
- {2846484000 -25200 1 PDT}
- {2867043600 -28800 0 PST}
- {2877933600 -25200 1 PDT}
- {2898493200 -28800 0 PST}
- {2909383200 -25200 1 PDT}
- {2929942800 -28800 0 PST}
- {2940832800 -25200 1 PDT}
- {2961392400 -28800 0 PST}
- {2972282400 -25200 1 PDT}
- {2992842000 -28800 0 PST}
- {3003732000 -25200 1 PDT}
- {3024291600 -28800 0 PST}
- {3035786400 -25200 1 PDT}
- {3056346000 -28800 0 PST}
- {3067236000 -25200 1 PDT}
- {3087795600 -28800 0 PST}
- {3098685600 -25200 1 PDT}
- {3119245200 -28800 0 PST}
- {3130135200 -25200 1 PDT}
- {3150694800 -28800 0 PST}
- {3161584800 -25200 1 PDT}
- {3182144400 -28800 0 PST}
- {3193034400 -25200 1 PDT}
- {3213594000 -28800 0 PST}
- {3225088800 -25200 1 PDT}
- {3245648400 -28800 0 PST}
- {3256538400 -25200 1 PDT}
- {3277098000 -28800 0 PST}
- {3287988000 -25200 1 PDT}
- {3308547600 -28800 0 PST}
- {3319437600 -25200 1 PDT}
- {3339997200 -28800 0 PST}
- {3350887200 -25200 1 PDT}
- {3371446800 -28800 0 PST}
- {3382941600 -25200 1 PDT}
- {3403501200 -28800 0 PST}
- {3414391200 -25200 1 PDT}
- {3434950800 -28800 0 PST}
- {3445840800 -25200 1 PDT}
- {3466400400 -28800 0 PST}
- {3477290400 -25200 1 PDT}
- {3497850000 -28800 0 PST}
- {3508740000 -25200 1 PDT}
- {3529299600 -28800 0 PST}
- {3540189600 -25200 1 PDT}
- {3560749200 -28800 0 PST}
- {3572244000 -25200 1 PDT}
- {3592803600 -28800 0 PST}
- {3603693600 -25200 1 PDT}
- {3624253200 -28800 0 PST}
- {3635143200 -25200 1 PDT}
- {3655702800 -28800 0 PST}
- {3666592800 -25200 1 PDT}
- {3687152400 -28800 0 PST}
- {3698042400 -25200 1 PDT}
- {3718602000 -28800 0 PST}
- {3730096800 -25200 1 PDT}
- {3750656400 -28800 0 PST}
- {3761546400 -25200 1 PDT}
- {3782106000 -28800 0 PST}
- {3792996000 -25200 1 PDT}
- {3813555600 -28800 0 PST}
- {3824445600 -25200 1 PDT}
- {3845005200 -28800 0 PST}
- {3855895200 -25200 1 PDT}
- {3876454800 -28800 0 PST}
- {3887344800 -25200 1 PDT}
- {3907904400 -28800 0 PST}
- {3919399200 -25200 1 PDT}
- {3939958800 -28800 0 PST}
- {3950848800 -25200 1 PDT}
- {3971408400 -28800 0 PST}
- {3982298400 -25200 1 PDT}
- {4002858000 -28800 0 PST}
- {4013748000 -25200 1 PDT}
- {4034307600 -28800 0 PST}
- {4045197600 -25200 1 PDT}
- {4065757200 -28800 0 PST}
- {4076647200 -25200 1 PDT}
- {4097206800 -28800 0 PST}
+ {1604217600 -25200 0 MST}
}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Antarctica/Casey
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Antarctica/Casey 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Antarctica/Casey 2021-03-02 16:29:37 UTC (rev 58056)
@@ -9,4 +9,9 @@
{1329843600 28800 0 +08}
{1477065600 39600 0 +11}
{1520701200 28800 0 +08}
+ {1538856000 39600 0 +11}
+ {1552752000 28800 0 +08}
+ {1570129200 39600 0 +11}
+ {1583596800 28800 0 +08}
+ {1601740860 39600 0 +11}
}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Antarctica/Macquarie
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Antarctica/Macquarie 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Antarctica/Macquarie 2021-03-02 16:29:37 UTC (rev 58056)
@@ -5,7 +5,7 @@
{-2214259200 36000 0 AEST}
{-1680508800 39600 1 AEDT}
{-1669892400 39600 0 AEDT}
- {-1665392400 36000 0 AEST}
+ {-1665388800 36000 0 AEST}
{-1601719200 0 0 -00}
{-94730400 36000 0 AEST}
{-71136000 39600 1 AEDT}
@@ -93,5 +93,184 @@
{1223136000 39600 1 AEDT}
{1238860800 36000 0 AEST}
{1254585600 39600 1 AEDT}
- {1270310400 39600 0 +11}
+ {1262264400 39600 1 AEDT}
+ {1293800400 39600 0 AEST}
+ {1301760000 36000 0 AEST}
+ {1317484800 39600 1 AEDT}
+ {1333209600 36000 0 AEST}
+ {1349539200 39600 1 AEDT}
+ {1365264000 36000 0 AEST}
+ {1380988800 39600 1 AEDT}
+ {1396713600 36000 0 AEST}
+ {1412438400 39600 1 AEDT}
+ {1428163200 36000 0 AEST}
+ {1443888000 39600 1 AEDT}
+ {1459612800 36000 0 AEST}
+ {1475337600 39600 1 AEDT}
+ {1491062400 36000 0 AEST}
+ {1506787200 39600 1 AEDT}
+ {1522512000 36000 0 AEST}
+ {1538841600 39600 1 AEDT}
+ {1554566400 36000 0 AEST}
+ {1570291200 39600 1 AEDT}
+ {1586016000 36000 0 AEST}
+ {1601740800 39600 1 AEDT}
+ {1617465600 36000 0 AEST}
+ {1633190400 39600 1 AEDT}
+ {1648915200 36000 0 AEST}
+ {1664640000 39600 1 AEDT}
+ {1680364800 36000 0 AEST}
+ {1696089600 39600 1 AEDT}
+ {1712419200 36000 0 AEST}
+ {1728144000 39600 1 AEDT}
+ {1743868800 36000 0 AEST}
+ {1759593600 39600 1 AEDT}
+ {1775318400 36000 0 AEST}
+ {1791043200 39600 1 AEDT}
+ {1806768000 36000 0 AEST}
+ {1822492800 39600 1 AEDT}
+ {1838217600 36000 0 AEST}
+ {1853942400 39600 1 AEDT}
+ {1869667200 36000 0 AEST}
+ {1885996800 39600 1 AEDT}
+ {1901721600 36000 0 AEST}
+ {1917446400 39600 1 AEDT}
+ {1933171200 36000 0 AEST}
+ {1948896000 39600 1 AEDT}
+ {1964620800 36000 0 AEST}
+ {1980345600 39600 1 AEDT}
+ {1996070400 36000 0 AEST}
+ {2011795200 39600 1 AEDT}
+ {2027520000 36000 0 AEST}
+ {2043244800 39600 1 AEDT}
+ {2058969600 36000 0 AEST}
+ {2075299200 39600 1 AEDT}
+ {2091024000 36000 0 AEST}
+ {2106748800 39600 1 AEDT}
+ {2122473600 36000 0 AEST}
+ {2138198400 39600 1 AEDT}
+ {2153923200 36000 0 AEST}
+ {2169648000 39600 1 AEDT}
+ {2185372800 36000 0 AEST}
+ {2201097600 39600 1 AEDT}
+ {2216822400 36000 0 AEST}
+ {2233152000 39600 1 AEDT}
+ {2248876800 36000 0 AEST}
+ {2264601600 39600 1 AEDT}
+ {2280326400 36000 0 AEST}
+ {2296051200 39600 1 AEDT}
+ {2311776000 36000 0 AEST}
+ {2327500800 39600 1 AEDT}
+ {2343225600 36000 0 AEST}
+ {2358950400 39600 1 AEDT}
+ {2374675200 36000 0 AEST}
+ {2390400000 39600 1 AEDT}
+ {2406124800 36000 0 AEST}
+ {2422454400 39600 1 AEDT}
+ {2438179200 36000 0 AEST}
+ {2453904000 39600 1 AEDT}
+ {2469628800 36000 0 AEST}
+ {2485353600 39600 1 AEDT}
+ {2501078400 36000 0 AEST}
+ {2516803200 39600 1 AEDT}
+ {2532528000 36000 0 AEST}
+ {2548252800 39600 1 AEDT}
+ {2563977600 36000 0 AEST}
+ {2579702400 39600 1 AEDT}
+ {2596032000 36000 0 AEST}
+ {2611756800 39600 1 AEDT}
+ {2627481600 36000 0 AEST}
+ {2643206400 39600 1 AEDT}
+ {2658931200 36000 0 AEST}
+ {2674656000 39600 1 AEDT}
+ {2690380800 36000 0 AEST}
+ {2706105600 39600 1 AEDT}
+ {2721830400 36000 0 AEST}
+ {2737555200 39600 1 AEDT}
+ {2753280000 36000 0 AEST}
+ {2769609600 39600 1 AEDT}
+ {2785334400 36000 0 AEST}
+ {2801059200 39600 1 AEDT}
+ {2816784000 36000 0 AEST}
+ {2832508800 39600 1 AEDT}
+ {2848233600 36000 0 AEST}
+ {2863958400 39600 1 AEDT}
+ {2879683200 36000 0 AEST}
+ {2895408000 39600 1 AEDT}
+ {2911132800 36000 0 AEST}
+ {2926857600 39600 1 AEDT}
+ {2942582400 36000 0 AEST}
+ {2958912000 39600 1 AEDT}
+ {2974636800 36000 0 AEST}
+ {2990361600 39600 1 AEDT}
+ {3006086400 36000 0 AEST}
+ {3021811200 39600 1 AEDT}
+ {3037536000 36000 0 AEST}
+ {3053260800 39600 1 AEDT}
+ {3068985600 36000 0 AEST}
+ {3084710400 39600 1 AEDT}
+ {3100435200 36000 0 AEST}
+ {3116764800 39600 1 AEDT}
+ {3132489600 36000 0 AEST}
+ {3148214400 39600 1 AEDT}
+ {3163939200 36000 0 AEST}
+ {3179664000 39600 1 AEDT}
+ {3195388800 36000 0 AEST}
+ {3211113600 39600 1 AEDT}
+ {3226838400 36000 0 AEST}
+ {3242563200 39600 1 AEDT}
+ {3258288000 36000 0 AEST}
+ {3274012800 39600 1 AEDT}
+ {3289737600 36000 0 AEST}
+ {3306067200 39600 1 AEDT}
+ {3321792000 36000 0 AEST}
+ {3337516800 39600 1 AEDT}
+ {3353241600 36000 0 AEST}
+ {3368966400 39600 1 AEDT}
+ {3384691200 36000 0 AEST}
+ {3400416000 39600 1 AEDT}
+ {3416140800 36000 0 AEST}
+ {3431865600 39600 1 AEDT}
+ {3447590400 36000 0 AEST}
+ {3463315200 39600 1 AEDT}
+ {3479644800 36000 0 AEST}
+ {3495369600 39600 1 AEDT}
+ {3511094400 36000 0 AEST}
+ {3526819200 39600 1 AEDT}
+ {3542544000 36000 0 AEST}
+ {3558268800 39600 1 AEDT}
+ {3573993600 36000 0 AEST}
+ {3589718400 39600 1 AEDT}
+ {3605443200 36000 0 AEST}
+ {3621168000 39600 1 AEDT}
+ {3636892800 36000 0 AEST}
+ {3653222400 39600 1 AEDT}
+ {3668947200 36000 0 AEST}
+ {3684672000 39600 1 AEDT}
+ {3700396800 36000 0 AEST}
+ {3716121600 39600 1 AEDT}
+ {3731846400 36000 0 AEST}
+ {3747571200 39600 1 AEDT}
+ {3763296000 36000 0 AEST}
+ {3779020800 39600 1 AEDT}
+ {3794745600 36000 0 AEST}
+ {3810470400 39600 1 AEDT}
+ {3826195200 36000 0 AEST}
+ {3842524800 39600 1 AEDT}
+ {3858249600 36000 0 AEST}
+ {3873974400 39600 1 AEDT}
+ {3889699200 36000 0 AEST}
+ {3905424000 39600 1 AEDT}
+ {3921148800 36000 0 AEST}
+ {3936873600 39600 1 AEDT}
+ {3952598400 36000 0 AEST}
+ {3968323200 39600 1 AEDT}
+ {3984048000 36000 0 AEST}
+ {4000377600 39600 1 AEDT}
+ {4016102400 36000 0 AEST}
+ {4031827200 39600 1 AEDT}
+ {4047552000 36000 0 AEST}
+ {4063276800 39600 1 AEDT}
+ {4079001600 36000 0 AEST}
+ {4094726400 39600 1 AEDT}
}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Gaza
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Gaza 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Gaza 2021-03-02 16:29:37 UTC (rev 58056)
@@ -3,16 +3,18 @@
set TZData(:Asia/Gaza) {
{-9223372036854775808 8272 0 LMT}
{-2185409872 7200 0 EEST}
- {-933645600 10800 1 EEST}
- {-857358000 7200 0 EEST}
+ {-933638400 10800 1 EEST}
+ {-923097600 7200 0 EEST}
+ {-919036800 10800 1 EEST}
+ {-857347200 7200 0 EEST}
{-844300800 10800 1 EEST}
- {-825822000 7200 0 EEST}
- {-812685600 10800 1 EEST}
- {-794199600 7200 0 EEST}
- {-779853600 10800 1 EEST}
- {-762656400 7200 0 EEST}
+ {-825811200 7200 0 EEST}
+ {-812678400 10800 1 EEST}
+ {-794188800 7200 0 EEST}
+ {-779846400 10800 1 EEST}
+ {-762652800 7200 0 EEST}
{-748310400 10800 1 EEST}
- {-731127600 7200 0 EEST}
+ {-731116800 7200 0 EEST}
{-682653600 7200 0 EET}
{-399088800 10800 1 EEST}
{-386650800 7200 0 EET}
@@ -40,12 +42,12 @@
{150843600 7200 0 IST}
{167176800 10800 1 IDT}
{178664400 7200 0 IST}
- {334015200 10800 1 IDT}
- {337644000 7200 0 IST}
- {452556000 10800 1 IDT}
- {462232800 7200 0 IST}
+ {334101600 10800 1 IDT}
+ {337730400 7200 0 IST}
+ {452642400 10800 1 IDT}
+ {462319200 7200 0 IST}
{482277600 10800 1 IDT}
- {495579600 7200 0 IST}
+ {494370000 7200 0 IST}
{516751200 10800 1 IDT}
{526424400 7200 0 IST}
{545436000 10800 1 IDT}
@@ -110,7 +112,7 @@
{1395957600 10800 1 EEST}
{1414098000 7200 0 EET}
{1427493600 10800 1 EEST}
- {1445547600 7200 0 EET}
+ {1445551200 7200 0 EET}
{1458946800 10800 1 EEST}
{1477692000 7200 0 EET}
{1490396400 10800 1 EEST}
@@ -118,165 +120,165 @@
{1521846000 10800 1 EEST}
{1540591200 7200 0 EET}
{1553810400 10800 1 EEST}
- {1572040800 7200 0 EET}
- {1585260000 10800 1 EEST}
- {1604095200 7200 0 EET}
- {1616709600 10800 1 EEST}
+ {1572037200 7200 0 EET}
+ {1585346400 10800 1 EEST}
+ {1603490400 7200 0 EET}
+ {1616796000 10800 1 EEST}
{1635544800 7200 0 EET}
- {1648159200 10800 1 EEST}
+ {1648245600 10800 1 EEST}
{1666994400 7200 0 EET}
- {1680213600 10800 1 EEST}
+ {1679695200 10800 1 EEST}
{1698444000 7200 0 EET}
- {1711663200 10800 1 EEST}
+ {1711749600 10800 1 EEST}
{1729893600 7200 0 EET}
- {1743112800 10800 1 EEST}
+ {1743199200 10800 1 EEST}
{1761343200 7200 0 EET}
- {1774562400 10800 1 EEST}
- {1793397600 7200 0 EET}
- {1806012000 10800 1 EEST}
+ {1774648800 10800 1 EEST}
+ {1792792800 7200 0 EET}
+ {1806098400 10800 1 EEST}
{1824847200 7200 0 EET}
- {1838066400 10800 1 EEST}
+ {1837548000 10800 1 EEST}
{1856296800 7200 0 EET}
- {1869516000 10800 1 EEST}
+ {1868997600 10800 1 EEST}
{1887746400 7200 0 EET}
- {1900965600 10800 1 EEST}
+ {1901052000 10800 1 EEST}
{1919196000 7200 0 EET}
- {1932415200 10800 1 EEST}
+ {1932501600 10800 1 EEST}
{1950645600 7200 0 EET}
- {1963864800 10800 1 EEST}
+ {1963951200 10800 1 EEST}
{1982700000 7200 0 EET}
- {1995314400 10800 1 EEST}
+ {1995400800 10800 1 EEST}
{2014149600 7200 0 EET}
- {2027368800 10800 1 EEST}
+ {2026850400 10800 1 EEST}
{2045599200 7200 0 EET}
- {2058818400 10800 1 EEST}
+ {2058300000 10800 1 EEST}
{2077048800 7200 0 EET}
- {2090268000 10800 1 EEST}
+ {2090354400 10800 1 EEST}
{2108498400 7200 0 EET}
- {2121717600 10800 1 EEST}
- {2140552800 7200 0 EET}
- {2153167200 10800 1 EEST}
+ {2121804000 10800 1 EEST}
+ {2139948000 7200 0 EET}
+ {2153253600 10800 1 EEST}
{2172002400 7200 0 EET}
- {2184616800 10800 1 EEST}
+ {2184703200 10800 1 EEST}
{2203452000 7200 0 EET}
- {2216671200 10800 1 EEST}
+ {2216152800 10800 1 EEST}
{2234901600 7200 0 EET}
- {2248120800 10800 1 EEST}
+ {2248207200 10800 1 EEST}
{2266351200 7200 0 EET}
- {2279570400 10800 1 EEST}
+ {2279656800 10800 1 EEST}
{2297800800 7200 0 EET}
- {2311020000 10800 1 EEST}
- {2329855200 7200 0 EET}
- {2342469600 10800 1 EEST}
+ {2311106400 10800 1 EEST}
+ {2329250400 7200 0 EET}
+ {2342556000 10800 1 EEST}
{2361304800 7200 0 EET}
- {2374524000 10800 1 EEST}
+ {2374005600 10800 1 EEST}
{2392754400 7200 0 EET}
- {2405973600 10800 1 EEST}
+ {2405455200 10800 1 EEST}
{2424204000 7200 0 EET}
- {2437423200 10800 1 EEST}
+ {2437509600 10800 1 EEST}
{2455653600 7200 0 EET}
- {2468872800 10800 1 EEST}
- {2487708000 7200 0 EET}
- {2500322400 10800 1 EEST}
+ {2468959200 10800 1 EEST}
+ {2487103200 7200 0 EET}
+ {2500408800 10800 1 EEST}
{2519157600 7200 0 EET}
- {2531772000 10800 1 EEST}
+ {2531858400 10800 1 EEST}
{2550607200 7200 0 EET}
- {2563826400 10800 1 EEST}
+ {2563308000 10800 1 EEST}
{2582056800 7200 0 EET}
- {2595276000 10800 1 EEST}
+ {2595362400 10800 1 EEST}
{2613506400 7200 0 EET}
- {2626725600 10800 1 EEST}
+ {2626812000 10800 1 EEST}
{2644956000 7200 0 EET}
- {2658175200 10800 1 EEST}
- {2677010400 7200 0 EET}
- {2689624800 10800 1 EEST}
+ {2658261600 10800 1 EEST}
+ {2676405600 7200 0 EET}
+ {2689711200 10800 1 EEST}
{2708460000 7200 0 EET}
- {2721679200 10800 1 EEST}
+ {2721160800 10800 1 EEST}
{2739909600 7200 0 EET}
- {2753128800 10800 1 EEST}
+ {2752610400 10800 1 EEST}
{2771359200 7200 0 EET}
- {2784578400 10800 1 EEST}
+ {2784664800 10800 1 EEST}
{2802808800 7200 0 EET}
- {2816028000 10800 1 EEST}
+ {2816114400 10800 1 EEST}
{2834258400 7200 0 EET}
- {2847477600 10800 1 EEST}
+ {2847564000 10800 1 EEST}
{2866312800 7200 0 EET}
- {2878927200 10800 1 EEST}
+ {2879013600 10800 1 EEST}
{2897762400 7200 0 EET}
- {2910981600 10800 1 EEST}
+ {2910463200 10800 1 EEST}
{2929212000 7200 0 EET}
- {2942431200 10800 1 EEST}
+ {2941912800 10800 1 EEST}
{2960661600 7200 0 EET}
- {2973880800 10800 1 EEST}
+ {2973967200 10800 1 EEST}
{2992111200 7200 0 EET}
- {3005330400 10800 1 EEST}
- {3024165600 7200 0 EET}
- {3036780000 10800 1 EEST}
+ {3005416800 10800 1 EEST}
+ {3023560800 7200 0 EET}
+ {3036866400 10800 1 EEST}
{3055615200 7200 0 EET}
- {3068229600 10800 1 EEST}
+ {3068316000 10800 1 EEST}
{3087064800 7200 0 EET}
- {3100284000 10800 1 EEST}
+ {3099765600 10800 1 EEST}
{3118514400 7200 0 EET}
- {3131733600 10800 1 EEST}
+ {3131820000 10800 1 EEST}
{3149964000 7200 0 EET}
- {3163183200 10800 1 EEST}
+ {3163269600 10800 1 EEST}
{3181413600 7200 0 EET}
- {3194632800 10800 1 EEST}
- {3213468000 7200 0 EET}
- {3226082400 10800 1 EEST}
+ {3194719200 10800 1 EEST}
+ {3212863200 7200 0 EET}
+ {3226168800 10800 1 EEST}
{3244917600 7200 0 EET}
- {3258136800 10800 1 EEST}
+ {3257618400 10800 1 EEST}
{3276367200 7200 0 EET}
- {3289586400 10800 1 EEST}
+ {3289068000 10800 1 EEST}
{3307816800 7200 0 EET}
- {3321036000 10800 1 EEST}
+ {3321122400 10800 1 EEST}
{3339266400 7200 0 EET}
- {3352485600 10800 1 EEST}
- {3371320800 7200 0 EET}
- {3383935200 10800 1 EEST}
+ {3352572000 10800 1 EEST}
+ {3370716000 7200 0 EET}
+ {3384021600 10800 1 EEST}
{3402770400 7200 0 EET}
- {3415384800 10800 1 EEST}
+ {3415471200 10800 1 EEST}
{3434220000 7200 0 EET}
- {3447439200 10800 1 EEST}
+ {3446920800 10800 1 EEST}
{3465669600 7200 0 EET}
- {3478888800 10800 1 EEST}
+ {3478975200 10800 1 EEST}
{3497119200 7200 0 EET}
- {3510338400 10800 1 EEST}
+ {3510424800 10800 1 EEST}
{3528568800 7200 0 EET}
- {3541788000 10800 1 EEST}
- {3560623200 7200 0 EET}
- {3573237600 10800 1 EEST}
+ {3541874400 10800 1 EEST}
+ {3560018400 7200 0 EET}
+ {3573324000 10800 1 EEST}
{3592072800 7200 0 EET}
- {3605292000 10800 1 EEST}
+ {3604773600 10800 1 EEST}
{3623522400 7200 0 EET}
- {3636741600 10800 1 EEST}
+ {3636223200 10800 1 EEST}
{3654972000 7200 0 EET}
- {3668191200 10800 1 EEST}
+ {3668277600 10800 1 EEST}
{3686421600 7200 0 EET}
- {3699640800 10800 1 EEST}
+ {3699727200 10800 1 EEST}
{3717871200 7200 0 EET}
- {3731090400 10800 1 EEST}
+ {3731176800 10800 1 EEST}
{3749925600 7200 0 EET}
- {3762540000 10800 1 EEST}
+ {3762626400 10800 1 EEST}
{3781375200 7200 0 EET}
- {3794594400 10800 1 EEST}
+ {3794076000 10800 1 EEST}
{3812824800 7200 0 EET}
- {3826044000 10800 1 EEST}
+ {3825525600 10800 1 EEST}
{3844274400 7200 0 EET}
- {3857493600 10800 1 EEST}
+ {3857580000 10800 1 EEST}
{3875724000 7200 0 EET}
- {3888943200 10800 1 EEST}
- {3907778400 7200 0 EET}
- {3920392800 10800 1 EEST}
+ {3889029600 10800 1 EEST}
+ {3907173600 7200 0 EET}
+ {3920479200 10800 1 EEST}
{3939228000 7200 0 EET}
- {3951842400 10800 1 EEST}
+ {3951928800 10800 1 EEST}
{3970677600 7200 0 EET}
- {3983896800 10800 1 EEST}
+ {3983378400 10800 1 EEST}
{4002127200 7200 0 EET}
- {4015346400 10800 1 EEST}
+ {4015432800 10800 1 EEST}
{4033576800 7200 0 EET}
- {4046796000 10800 1 EEST}
+ {4046882400 10800 1 EEST}
{4065026400 7200 0 EET}
- {4078245600 10800 1 EEST}
- {4097080800 7200 0 EET}
+ {4078332000 10800 1 EEST}
+ {4096476000 7200 0 EET}
}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Hebron
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Hebron 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Hebron 2021-03-02 16:29:37 UTC (rev 58056)
@@ -3,16 +3,18 @@
set TZData(:Asia/Hebron) {
{-9223372036854775808 8423 0 LMT}
{-2185410023 7200 0 EEST}
- {-933645600 10800 1 EEST}
- {-857358000 7200 0 EEST}
+ {-933638400 10800 1 EEST}
+ {-923097600 7200 0 EEST}
+ {-919036800 10800 1 EEST}
+ {-857347200 7200 0 EEST}
{-844300800 10800 1 EEST}
- {-825822000 7200 0 EEST}
- {-812685600 10800 1 EEST}
- {-794199600 7200 0 EEST}
- {-779853600 10800 1 EEST}
- {-762656400 7200 0 EEST}
+ {-825811200 7200 0 EEST}
+ {-812678400 10800 1 EEST}
+ {-794188800 7200 0 EEST}
+ {-779846400 10800 1 EEST}
+ {-762652800 7200 0 EEST}
{-748310400 10800 1 EEST}
- {-731127600 7200 0 EEST}
+ {-731116800 7200 0 EEST}
{-682653600 7200 0 EET}
{-399088800 10800 1 EEST}
{-386650800 7200 0 EET}
@@ -40,12 +42,12 @@
{150843600 7200 0 IST}
{167176800 10800 1 IDT}
{178664400 7200 0 IST}
- {334015200 10800 1 IDT}
- {337644000 7200 0 IST}
- {452556000 10800 1 IDT}
- {462232800 7200 0 IST}
+ {334101600 10800 1 IDT}
+ {337730400 7200 0 IST}
+ {452642400 10800 1 IDT}
+ {462319200 7200 0 IST}
{482277600 10800 1 IDT}
- {495579600 7200 0 IST}
+ {494370000 7200 0 IST}
{516751200 10800 1 IDT}
{526424400 7200 0 IST}
{545436000 10800 1 IDT}
@@ -109,7 +111,7 @@
{1395957600 10800 1 EEST}
{1414098000 7200 0 EET}
{1427493600 10800 1 EEST}
- {1445547600 7200 0 EET}
+ {1445551200 7200 0 EET}
{1458946800 10800 1 EEST}
{1477692000 7200 0 EET}
{1490396400 10800 1 EEST}
@@ -117,165 +119,165 @@
{1521846000 10800 1 EEST}
{1540591200 7200 0 EET}
{1553810400 10800 1 EEST}
- {1572040800 7200 0 EET}
- {1585260000 10800 1 EEST}
- {1604095200 7200 0 EET}
- {1616709600 10800 1 EEST}
+ {1572037200 7200 0 EET}
+ {1585346400 10800 1 EEST}
+ {1603490400 7200 0 EET}
+ {1616796000 10800 1 EEST}
{1635544800 7200 0 EET}
- {1648159200 10800 1 EEST}
+ {1648245600 10800 1 EEST}
{1666994400 7200 0 EET}
- {1680213600 10800 1 EEST}
+ {1679695200 10800 1 EEST}
{1698444000 7200 0 EET}
- {1711663200 10800 1 EEST}
+ {1711749600 10800 1 EEST}
{1729893600 7200 0 EET}
- {1743112800 10800 1 EEST}
+ {1743199200 10800 1 EEST}
{1761343200 7200 0 EET}
- {1774562400 10800 1 EEST}
- {1793397600 7200 0 EET}
- {1806012000 10800 1 EEST}
+ {1774648800 10800 1 EEST}
+ {1792792800 7200 0 EET}
+ {1806098400 10800 1 EEST}
{1824847200 7200 0 EET}
- {1838066400 10800 1 EEST}
+ {1837548000 10800 1 EEST}
{1856296800 7200 0 EET}
- {1869516000 10800 1 EEST}
+ {1868997600 10800 1 EEST}
{1887746400 7200 0 EET}
- {1900965600 10800 1 EEST}
+ {1901052000 10800 1 EEST}
{1919196000 7200 0 EET}
- {1932415200 10800 1 EEST}
+ {1932501600 10800 1 EEST}
{1950645600 7200 0 EET}
- {1963864800 10800 1 EEST}
+ {1963951200 10800 1 EEST}
{1982700000 7200 0 EET}
- {1995314400 10800 1 EEST}
+ {1995400800 10800 1 EEST}
{2014149600 7200 0 EET}
- {2027368800 10800 1 EEST}
+ {2026850400 10800 1 EEST}
{2045599200 7200 0 EET}
- {2058818400 10800 1 EEST}
+ {2058300000 10800 1 EEST}
{2077048800 7200 0 EET}
- {2090268000 10800 1 EEST}
+ {2090354400 10800 1 EEST}
{2108498400 7200 0 EET}
- {2121717600 10800 1 EEST}
- {2140552800 7200 0 EET}
- {2153167200 10800 1 EEST}
+ {2121804000 10800 1 EEST}
+ {2139948000 7200 0 EET}
+ {2153253600 10800 1 EEST}
{2172002400 7200 0 EET}
- {2184616800 10800 1 EEST}
+ {2184703200 10800 1 EEST}
{2203452000 7200 0 EET}
- {2216671200 10800 1 EEST}
+ {2216152800 10800 1 EEST}
{2234901600 7200 0 EET}
- {2248120800 10800 1 EEST}
+ {2248207200 10800 1 EEST}
{2266351200 7200 0 EET}
- {2279570400 10800 1 EEST}
+ {2279656800 10800 1 EEST}
{2297800800 7200 0 EET}
- {2311020000 10800 1 EEST}
- {2329855200 7200 0 EET}
- {2342469600 10800 1 EEST}
+ {2311106400 10800 1 EEST}
+ {2329250400 7200 0 EET}
+ {2342556000 10800 1 EEST}
{2361304800 7200 0 EET}
- {2374524000 10800 1 EEST}
+ {2374005600 10800 1 EEST}
{2392754400 7200 0 EET}
- {2405973600 10800 1 EEST}
+ {2405455200 10800 1 EEST}
{2424204000 7200 0 EET}
- {2437423200 10800 1 EEST}
+ {2437509600 10800 1 EEST}
{2455653600 7200 0 EET}
- {2468872800 10800 1 EEST}
- {2487708000 7200 0 EET}
- {2500322400 10800 1 EEST}
+ {2468959200 10800 1 EEST}
+ {2487103200 7200 0 EET}
+ {2500408800 10800 1 EEST}
{2519157600 7200 0 EET}
- {2531772000 10800 1 EEST}
+ {2531858400 10800 1 EEST}
{2550607200 7200 0 EET}
- {2563826400 10800 1 EEST}
+ {2563308000 10800 1 EEST}
{2582056800 7200 0 EET}
- {2595276000 10800 1 EEST}
+ {2595362400 10800 1 EEST}
{2613506400 7200 0 EET}
- {2626725600 10800 1 EEST}
+ {2626812000 10800 1 EEST}
{2644956000 7200 0 EET}
- {2658175200 10800 1 EEST}
- {2677010400 7200 0 EET}
- {2689624800 10800 1 EEST}
+ {2658261600 10800 1 EEST}
+ {2676405600 7200 0 EET}
+ {2689711200 10800 1 EEST}
{2708460000 7200 0 EET}
- {2721679200 10800 1 EEST}
+ {2721160800 10800 1 EEST}
{2739909600 7200 0 EET}
- {2753128800 10800 1 EEST}
+ {2752610400 10800 1 EEST}
{2771359200 7200 0 EET}
- {2784578400 10800 1 EEST}
+ {2784664800 10800 1 EEST}
{2802808800 7200 0 EET}
- {2816028000 10800 1 EEST}
+ {2816114400 10800 1 EEST}
{2834258400 7200 0 EET}
- {2847477600 10800 1 EEST}
+ {2847564000 10800 1 EEST}
{2866312800 7200 0 EET}
- {2878927200 10800 1 EEST}
+ {2879013600 10800 1 EEST}
{2897762400 7200 0 EET}
- {2910981600 10800 1 EEST}
+ {2910463200 10800 1 EEST}
{2929212000 7200 0 EET}
- {2942431200 10800 1 EEST}
+ {2941912800 10800 1 EEST}
{2960661600 7200 0 EET}
- {2973880800 10800 1 EEST}
+ {2973967200 10800 1 EEST}
{2992111200 7200 0 EET}
- {3005330400 10800 1 EEST}
- {3024165600 7200 0 EET}
- {3036780000 10800 1 EEST}
+ {3005416800 10800 1 EEST}
+ {3023560800 7200 0 EET}
+ {3036866400 10800 1 EEST}
{3055615200 7200 0 EET}
- {3068229600 10800 1 EEST}
+ {3068316000 10800 1 EEST}
{3087064800 7200 0 EET}
- {3100284000 10800 1 EEST}
+ {3099765600 10800 1 EEST}
{3118514400 7200 0 EET}
- {3131733600 10800 1 EEST}
+ {3131820000 10800 1 EEST}
{3149964000 7200 0 EET}
- {3163183200 10800 1 EEST}
+ {3163269600 10800 1 EEST}
{3181413600 7200 0 EET}
- {3194632800 10800 1 EEST}
- {3213468000 7200 0 EET}
- {3226082400 10800 1 EEST}
+ {3194719200 10800 1 EEST}
+ {3212863200 7200 0 EET}
+ {3226168800 10800 1 EEST}
{3244917600 7200 0 EET}
- {3258136800 10800 1 EEST}
+ {3257618400 10800 1 EEST}
{3276367200 7200 0 EET}
- {3289586400 10800 1 EEST}
+ {3289068000 10800 1 EEST}
{3307816800 7200 0 EET}
- {3321036000 10800 1 EEST}
+ {3321122400 10800 1 EEST}
{3339266400 7200 0 EET}
- {3352485600 10800 1 EEST}
- {3371320800 7200 0 EET}
- {3383935200 10800 1 EEST}
+ {3352572000 10800 1 EEST}
+ {3370716000 7200 0 EET}
+ {3384021600 10800 1 EEST}
{3402770400 7200 0 EET}
- {3415384800 10800 1 EEST}
+ {3415471200 10800 1 EEST}
{3434220000 7200 0 EET}
- {3447439200 10800 1 EEST}
+ {3446920800 10800 1 EEST}
{3465669600 7200 0 EET}
- {3478888800 10800 1 EEST}
+ {3478975200 10800 1 EEST}
{3497119200 7200 0 EET}
- {3510338400 10800 1 EEST}
+ {3510424800 10800 1 EEST}
{3528568800 7200 0 EET}
- {3541788000 10800 1 EEST}
- {3560623200 7200 0 EET}
- {3573237600 10800 1 EEST}
+ {3541874400 10800 1 EEST}
+ {3560018400 7200 0 EET}
+ {3573324000 10800 1 EEST}
{3592072800 7200 0 EET}
- {3605292000 10800 1 EEST}
+ {3604773600 10800 1 EEST}
{3623522400 7200 0 EET}
- {3636741600 10800 1 EEST}
+ {3636223200 10800 1 EEST}
{3654972000 7200 0 EET}
- {3668191200 10800 1 EEST}
+ {3668277600 10800 1 EEST}
{3686421600 7200 0 EET}
- {3699640800 10800 1 EEST}
+ {3699727200 10800 1 EEST}
{3717871200 7200 0 EET}
- {3731090400 10800 1 EEST}
+ {3731176800 10800 1 EEST}
{3749925600 7200 0 EET}
- {3762540000 10800 1 EEST}
+ {3762626400 10800 1 EEST}
{3781375200 7200 0 EET}
- {3794594400 10800 1 EEST}
+ {3794076000 10800 1 EEST}
{3812824800 7200 0 EET}
- {3826044000 10800 1 EEST}
+ {3825525600 10800 1 EEST}
{3844274400 7200 0 EET}
- {3857493600 10800 1 EEST}
+ {3857580000 10800 1 EEST}
{3875724000 7200 0 EET}
- {3888943200 10800 1 EEST}
- {3907778400 7200 0 EET}
- {3920392800 10800 1 EEST}
+ {3889029600 10800 1 EEST}
+ {3907173600 7200 0 EET}
+ {3920479200 10800 1 EEST}
{3939228000 7200 0 EET}
- {3951842400 10800 1 EEST}
+ {3951928800 10800 1 EEST}
{3970677600 7200 0 EET}
- {3983896800 10800 1 EEST}
+ {3983378400 10800 1 EEST}
{4002127200 7200 0 EET}
- {4015346400 10800 1 EEST}
+ {4015432800 10800 1 EEST}
{4033576800 7200 0 EET}
- {4046796000 10800 1 EEST}
+ {4046882400 10800 1 EEST}
{4065026400 7200 0 EET}
- {4078245600 10800 1 EEST}
- {4097080800 7200 0 EET}
+ {4078332000 10800 1 EEST}
+ {4096476000 7200 0 EET}
}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Jerusalem
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Jerusalem 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Jerusalem 2021-03-02 16:29:37 UTC (rev 58056)
@@ -4,47 +4,49 @@
{-9223372036854775808 8454 0 LMT}
{-2840149254 8440 0 JMT}
{-1641003640 7200 0 IST}
- {-933645600 10800 1 IDT}
- {-857358000 7200 0 IST}
+ {-933638400 10800 1 IDT}
+ {-923097600 7200 0 IST}
+ {-919036800 10800 1 IDT}
+ {-857347200 7200 0 IST}
{-844300800 10800 1 IDT}
- {-825822000 7200 0 IST}
- {-812685600 10800 1 IDT}
- {-794199600 7200 0 IST}
- {-779853600 10800 1 IDT}
- {-762656400 7200 0 IST}
+ {-825811200 7200 0 IST}
+ {-812678400 10800 1 IDT}
+ {-794188800 7200 0 IST}
+ {-779846400 10800 1 IDT}
+ {-762652800 7200 0 IST}
{-748310400 10800 1 IDT}
- {-731127600 7200 0 IST}
- {-681962400 14400 1 IDDT}
- {-673243200 10800 1 IDT}
- {-667962000 7200 0 IST}
- {-652327200 10800 1 IDT}
- {-636426000 7200 0 IST}
- {-622087200 10800 1 IDT}
+ {-731116800 7200 0 IST}
+ {-681955200 14400 1 IDDT}
+ {-673228800 10800 1 IDT}
+ {-667958400 7200 0 IST}
+ {-652320000 10800 1 IDT}
+ {-636422400 7200 0 IST}
+ {-622080000 10800 1 IDT}
{-608947200 7200 0 IST}
- {-591847200 10800 1 IDT}
+ {-591840000 10800 1 IDT}
{-572486400 7200 0 IST}
{-558576000 10800 1 IDT}
{-542851200 7200 0 IST}
{-527731200 10800 1 IDT}
{-514425600 7200 0 IST}
- {-490845600 10800 1 IDT}
- {-482986800 7200 0 IST}
- {-459475200 10800 1 IDT}
- {-451537200 7200 0 IST}
- {-428551200 10800 1 IDT}
+ {-490838400 10800 1 IDT}
+ {-482976000 7200 0 IST}
+ {-459388800 10800 1 IDT}
+ {-451526400 7200 0 IST}
+ {-428544000 10800 1 IDT}
{-418262400 7200 0 IST}
- {-400032000 10800 1 IDT}
- {-387428400 7200 0 IST}
+ {-400118400 10800 1 IDT}
+ {-387417600 7200 0 IST}
{142380000 10800 1 IDT}
{150843600 7200 0 IST}
{167176800 10800 1 IDT}
{178664400 7200 0 IST}
- {334015200 10800 1 IDT}
- {337644000 7200 0 IST}
- {452556000 10800 1 IDT}
- {462232800 7200 0 IST}
+ {334101600 10800 1 IDT}
+ {337730400 7200 0 IST}
+ {452642400 10800 1 IDT}
+ {462319200 7200 0 IST}
{482277600 10800 1 IDT}
- {495579600 7200 0 IST}
+ {494370000 7200 0 IST}
{516751200 10800 1 IDT}
{526424400 7200 0 IST}
{545436000 10800 1 IDT}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Shanghai
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Shanghai 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Asia/Shanghai 2021-03-02 16:29:37 UTC (rev 58056)
@@ -3,6 +3,8 @@
set TZData(:Asia/Shanghai) {
{-9223372036854775808 29143 0 LMT}
{-2177481943 28800 0 CST}
+ {-1600675200 32400 1 CDT}
+ {-1585904400 28800 0 CST}
{-933667200 32400 1 CDT}
{-922093200 28800 0 CST}
{-908870400 32400 1 CDT}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Atlantic/Bermuda
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Atlantic/Bermuda 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Atlantic/Bermuda 2021-03-02 16:29:37 UTC (rev 58056)
@@ -2,7 +2,34 @@
set TZData(:Atlantic/Bermuda) {
{-9223372036854775808 -15558 0 LMT}
- {-1262281242 -14400 0 AST}
+ {-2524506042 -15558 0 BMT}
+ {-1664307642 -11958 1 BMT}
+ {-1648932042 -15558 0 BMT}
+ {-1632080442 -11958 1 BMT}
+ {-1618692042 -15558 0 BST}
+ {-1262281242 -14400 0 AT}
+ {-882727200 -10800 1 ADT}
+ {-858538800 -14400 0 AST}
+ {-845229600 -10800 1 ADT}
+ {-825879600 -14400 0 AST}
+ {-814384800 -10800 1 ADT}
+ {-793825200 -14400 0 AST}
+ {-782935200 -10800 1 ADT}
+ {-762375600 -14400 0 AST}
+ {-713988000 -10800 1 ADT}
+ {-703710000 -14400 0 AST}
+ {-681933600 -10800 1 ADT}
+ {-672865200 -14400 0 AST}
+ {-650484000 -10800 1 ADT}
+ {-641415600 -14400 0 AST}
+ {-618429600 -10800 1 ADT}
+ {-609966000 -14400 0 AST}
+ {-586980000 -10800 1 ADT}
+ {-578516400 -14400 0 AST}
+ {-555530400 -10800 1 ADT}
+ {-546462000 -14400 0 AST}
+ {-429127200 -10800 1 ADT}
+ {-415825200 -14400 0 AST}
{136360800 -10800 0 ADT}
{152082000 -14400 0 AST}
{167810400 -10800 1 ADT}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Adelaide
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Adelaide 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Adelaide 2021-03-02 16:29:37 UTC (rev 58056)
@@ -4,14 +4,14 @@
{-9223372036854775808 33260 0 LMT}
{-2364110060 32400 0 ACST}
{-2230189200 34200 0 ACST}
- {-1672565340 37800 1 ACDT}
- {-1665390600 34200 0 ACST}
+ {-1672558200 37800 1 ACDT}
+ {-1665387000 34200 0 ACST}
{-883639800 37800 1 ACDT}
- {-876126600 34200 0 ACST}
+ {-876123000 34200 0 ACST}
{-860398200 37800 1 ACDT}
- {-844677000 34200 0 ACST}
+ {-844673400 34200 0 ACST}
{-828343800 37800 1 ACDT}
- {-813227400 34200 0 ACST}
+ {-813223800 34200 0 ACST}
{31501800 34200 0 ACST}
{57688200 37800 1 ACDT}
{67969800 34200 0 ACST}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Brisbane
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Brisbane 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Brisbane 2021-03-02 16:29:37 UTC (rev 58056)
@@ -3,14 +3,14 @@
set TZData(:Australia/Brisbane) {
{-9223372036854775808 36728 0 LMT}
{-2366791928 36000 0 AEST}
- {-1672567140 39600 1 AEDT}
- {-1665392400 36000 0 AEST}
+ {-1672560000 39600 1 AEDT}
+ {-1665388800 36000 0 AEST}
{-883641600 39600 1 AEDT}
- {-876128400 36000 0 AEST}
+ {-876124800 36000 0 AEST}
{-860400000 39600 1 AEDT}
- {-844678800 36000 0 AEST}
+ {-844675200 36000 0 AEST}
{-828345600 39600 1 AEDT}
- {-813229200 36000 0 AEST}
+ {-813225600 36000 0 AEST}
{31500000 36000 0 AEST}
{57686400 39600 1 AEDT}
{67968000 36000 0 AEST}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Broken_Hill
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Broken_Hill 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Broken_Hill 2021-03-02 16:29:37 UTC (rev 58056)
@@ -5,14 +5,14 @@
{-2364110748 36000 0 AEST}
{-2314951200 32400 0 ACST}
{-2230189200 34200 0 ACST}
- {-1672565340 37800 1 ACDT}
- {-1665390600 34200 0 ACST}
+ {-1672558200 37800 1 ACDT}
+ {-1665387000 34200 0 ACST}
{-883639800 37800 1 ACDT}
- {-876126600 34200 0 ACST}
+ {-876123000 34200 0 ACST}
{-860398200 37800 1 ACDT}
- {-844677000 34200 0 ACST}
+ {-844673400 34200 0 ACST}
{-828343800 37800 1 ACDT}
- {-813227400 34200 0 ACST}
+ {-813223800 34200 0 ACST}
{31501800 34200 0 ACST}
{57688200 37800 1 ACDT}
{67969800 34200 0 ACST}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Currie
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Currie 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Currie 2021-03-02 16:29:37 UTC (rev 58056)
@@ -1,273 +1,5 @@
# created by tools/tclZIC.tcl - do not edit
-
-set TZData(:Australia/Currie) {
- {-9223372036854775808 34528 0 LMT}
- {-2345794528 36000 0 AEST}
- {-1680508800 39600 1 AEDT}
- {-1669892400 39600 0 AEDT}
- {-1665392400 36000 0 AEST}
- {-883641600 39600 1 AEDT}
- {-876128400 36000 0 AEST}
- {-860400000 39600 1 AEDT}
- {-844678800 36000 0 AEST}
- {-828345600 39600 1 AEDT}
- {-813229200 36000 0 AEST}
- {47138400 36000 0 AEST}
- {57686400 39600 1 AEDT}
- {67968000 36000 0 AEST}
- {89136000 39600 1 AEDT}
- {100022400 36000 0 AEST}
- {120585600 39600 1 AEDT}
- {131472000 36000 0 AEST}
- {152035200 39600 1 AEDT}
- {162921600 36000 0 AEST}
- {183484800 39600 1 AEDT}
- {194976000 36000 0 AEST}
- {215539200 39600 1 AEDT}
- {226425600 36000 0 AEST}
- {246988800 39600 1 AEDT}
- {257875200 36000 0 AEST}
- {278438400 39600 1 AEDT}
- {289324800 36000 0 AEST}
- {309888000 39600 1 AEDT}
- {320774400 36000 0 AEST}
- {341337600 39600 1 AEDT}
- {352224000 36000 0 AEST}
- {372787200 39600 1 AEDT}
- {386092800 36000 0 AEST}
- {404841600 39600 1 AEDT}
- {417542400 36000 0 AEST}
- {436291200 39600 1 AEDT}
- {447177600 36000 0 AEST}
- {467740800 39600 1 AEDT}
- {478627200 36000 0 AEST}
- {499190400 39600 1 AEDT}
- {510076800 36000 0 AEST}
- {530035200 39600 1 AEDT}
- {542736000 36000 0 AEST}
- {562089600 39600 1 AEDT}
- {574790400 36000 0 AEST}
- {594144000 39600 1 AEDT}
- {606240000 36000 0 AEST}
- {625593600 39600 1 AEDT}
- {637689600 36000 0 AEST}
- {657043200 39600 1 AEDT}
- {670348800 36000 0 AEST}
- {686678400 39600 1 AEDT}
- {701798400 36000 0 AEST}
- {718128000 39600 1 AEDT}
- {733248000 36000 0 AEST}
- {749577600 39600 1 AEDT}
- {764697600 36000 0 AEST}
- {781027200 39600 1 AEDT}
- {796147200 36000 0 AEST}
- {812476800 39600 1 AEDT}
- {828201600 36000 0 AEST}
- {844531200 39600 1 AEDT}
- {859651200 36000 0 AEST}
- {875980800 39600 1 AEDT}
- {891100800 36000 0 AEST}
- {907430400 39600 1 AEDT}
- {922550400 36000 0 AEST}
- {938880000 39600 1 AEDT}
- {954000000 36000 0 AEST}
- {967305600 39600 1 AEDT}
- {985449600 36000 0 AEST}
- {1002384000 39600 1 AEDT}
- {1017504000 36000 0 AEST}
- {1033833600 39600 1 AEDT}
- {1048953600 36000 0 AEST}
- {1065283200 39600 1 AEDT}
- {1080403200 36000 0 AEST}
- {1096732800 39600 1 AEDT}
- {1111852800 36000 0 AEST}
- {1128182400 39600 1 AEDT}
- {1143907200 36000 0 AEST}
- {1159632000 39600 1 AEDT}
- {1174752000 36000 0 AEST}
- {1191686400 39600 1 AEDT}
- {1207411200 36000 0 AEST}
- {1223136000 39600 1 AEDT}
- {1238860800 36000 0 AEST}
- {1254585600 39600 1 AEDT}
- {1270310400 36000 0 AEST}
- {1286035200 39600 1 AEDT}
- {1301760000 36000 0 AEST}
- {1317484800 39600 1 AEDT}
- {1333209600 36000 0 AEST}
- {1349539200 39600 1 AEDT}
- {1365264000 36000 0 AEST}
- {1380988800 39600 1 AEDT}
- {1396713600 36000 0 AEST}
- {1412438400 39600 1 AEDT}
- {1428163200 36000 0 AEST}
- {1443888000 39600 1 AEDT}
- {1459612800 36000 0 AEST}
- {1475337600 39600 1 AEDT}
- {1491062400 36000 0 AEST}
- {1506787200 39600 1 AEDT}
- {1522512000 36000 0 AEST}
- {1538841600 39600 1 AEDT}
- {1554566400 36000 0 AEST}
- {1570291200 39600 1 AEDT}
- {1586016000 36000 0 AEST}
- {1601740800 39600 1 AEDT}
- {1617465600 36000 0 AEST}
- {1633190400 39600 1 AEDT}
- {1648915200 36000 0 AEST}
- {1664640000 39600 1 AEDT}
- {1680364800 36000 0 AEST}
- {1696089600 39600 1 AEDT}
- {1712419200 36000 0 AEST}
- {1728144000 39600 1 AEDT}
- {1743868800 36000 0 AEST}
- {1759593600 39600 1 AEDT}
- {1775318400 36000 0 AEST}
- {1791043200 39600 1 AEDT}
- {1806768000 36000 0 AEST}
- {1822492800 39600 1 AEDT}
- {1838217600 36000 0 AEST}
- {1853942400 39600 1 AEDT}
- {1869667200 36000 0 AEST}
- {1885996800 39600 1 AEDT}
- {1901721600 36000 0 AEST}
- {1917446400 39600 1 AEDT}
- {1933171200 36000 0 AEST}
- {1948896000 39600 1 AEDT}
- {1964620800 36000 0 AEST}
- {1980345600 39600 1 AEDT}
- {1996070400 36000 0 AEST}
- {2011795200 39600 1 AEDT}
- {2027520000 36000 0 AEST}
- {2043244800 39600 1 AEDT}
- {2058969600 36000 0 AEST}
- {2075299200 39600 1 AEDT}
- {2091024000 36000 0 AEST}
- {2106748800 39600 1 AEDT}
- {2122473600 36000 0 AEST}
- {2138198400 39600 1 AEDT}
- {2153923200 36000 0 AEST}
- {2169648000 39600 1 AEDT}
- {2185372800 36000 0 AEST}
- {2201097600 39600 1 AEDT}
- {2216822400 36000 0 AEST}
- {2233152000 39600 1 AEDT}
- {2248876800 36000 0 AEST}
- {2264601600 39600 1 AEDT}
- {2280326400 36000 0 AEST}
- {2296051200 39600 1 AEDT}
- {2311776000 36000 0 AEST}
- {2327500800 39600 1 AEDT}
- {2343225600 36000 0 AEST}
- {2358950400 39600 1 AEDT}
- {2374675200 36000 0 AEST}
- {2390400000 39600 1 AEDT}
- {2406124800 36000 0 AEST}
- {2422454400 39600 1 AEDT}
- {2438179200 36000 0 AEST}
- {2453904000 39600 1 AEDT}
- {2469628800 36000 0 AEST}
- {2485353600 39600 1 AEDT}
- {2501078400 36000 0 AEST}
- {2516803200 39600 1 AEDT}
- {2532528000 36000 0 AEST}
- {2548252800 39600 1 AEDT}
- {2563977600 36000 0 AEST}
- {2579702400 39600 1 AEDT}
- {2596032000 36000 0 AEST}
- {2611756800 39600 1 AEDT}
- {2627481600 36000 0 AEST}
- {2643206400 39600 1 AEDT}
- {2658931200 36000 0 AEST}
- {2674656000 39600 1 AEDT}
- {2690380800 36000 0 AEST}
- {2706105600 39600 1 AEDT}
- {2721830400 36000 0 AEST}
- {2737555200 39600 1 AEDT}
- {2753280000 36000 0 AEST}
- {2769609600 39600 1 AEDT}
- {2785334400 36000 0 AEST}
- {2801059200 39600 1 AEDT}
- {2816784000 36000 0 AEST}
- {2832508800 39600 1 AEDT}
- {2848233600 36000 0 AEST}
- {2863958400 39600 1 AEDT}
- {2879683200 36000 0 AEST}
- {2895408000 39600 1 AEDT}
- {2911132800 36000 0 AEST}
- {2926857600 39600 1 AEDT}
- {2942582400 36000 0 AEST}
- {2958912000 39600 1 AEDT}
- {2974636800 36000 0 AEST}
- {2990361600 39600 1 AEDT}
- {3006086400 36000 0 AEST}
- {3021811200 39600 1 AEDT}
- {3037536000 36000 0 AEST}
- {3053260800 39600 1 AEDT}
- {3068985600 36000 0 AEST}
- {3084710400 39600 1 AEDT}
- {3100435200 36000 0 AEST}
- {3116764800 39600 1 AEDT}
- {3132489600 36000 0 AEST}
- {3148214400 39600 1 AEDT}
- {3163939200 36000 0 AEST}
- {3179664000 39600 1 AEDT}
- {3195388800 36000 0 AEST}
- {3211113600 39600 1 AEDT}
- {3226838400 36000 0 AEST}
- {3242563200 39600 1 AEDT}
- {3258288000 36000 0 AEST}
- {3274012800 39600 1 AEDT}
- {3289737600 36000 0 AEST}
- {3306067200 39600 1 AEDT}
- {3321792000 36000 0 AEST}
- {3337516800 39600 1 AEDT}
- {3353241600 36000 0 AEST}
- {3368966400 39600 1 AEDT}
- {3384691200 36000 0 AEST}
- {3400416000 39600 1 AEDT}
- {3416140800 36000 0 AEST}
- {3431865600 39600 1 AEDT}
- {3447590400 36000 0 AEST}
- {3463315200 39600 1 AEDT}
- {3479644800 36000 0 AEST}
- {3495369600 39600 1 AEDT}
- {3511094400 36000 0 AEST}
- {3526819200 39600 1 AEDT}
- {3542544000 36000 0 AEST}
- {3558268800 39600 1 AEDT}
- {3573993600 36000 0 AEST}
- {3589718400 39600 1 AEDT}
- {3605443200 36000 0 AEST}
- {3621168000 39600 1 AEDT}
- {3636892800 36000 0 AEST}
- {3653222400 39600 1 AEDT}
- {3668947200 36000 0 AEST}
- {3684672000 39600 1 AEDT}
- {3700396800 36000 0 AEST}
- {3716121600 39600 1 AEDT}
- {3731846400 36000 0 AEST}
- {3747571200 39600 1 AEDT}
- {3763296000 36000 0 AEST}
- {3779020800 39600 1 AEDT}
- {3794745600 36000 0 AEST}
- {3810470400 39600 1 AEDT}
- {3826195200 36000 0 AEST}
- {3842524800 39600 1 AEDT}
- {3858249600 36000 0 AEST}
- {3873974400 39600 1 AEDT}
- {3889699200 36000 0 AEST}
- {3905424000 39600 1 AEDT}
- {3921148800 36000 0 AEST}
- {3936873600 39600 1 AEDT}
- {3952598400 36000 0 AEST}
- {3968323200 39600 1 AEDT}
- {3984048000 36000 0 AEST}
- {4000377600 39600 1 AEDT}
- {4016102400 36000 0 AEST}
- {4031827200 39600 1 AEDT}
- {4047552000 36000 0 AEST}
- {4063276800 39600 1 AEDT}
- {4079001600 36000 0 AEST}
- {4094726400 39600 1 AEDT}
+if {![info exists TZData(Australia/Hobart)]} {
+ LoadTimeZoneFile Australia/Hobart
}
+set TZData(:Australia/Currie) $TZData(:Australia/Hobart)
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Darwin
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Darwin 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Darwin 2021-03-02 16:29:37 UTC (rev 58056)
@@ -4,12 +4,12 @@
{-9223372036854775808 31400 0 LMT}
{-2364108200 32400 0 ACST}
{-2230189200 34200 0 ACST}
- {-1672565340 37800 1 ACDT}
- {-1665390600 34200 0 ACST}
+ {-1672558200 37800 1 ACDT}
+ {-1665387000 34200 0 ACST}
{-883639800 37800 1 ACDT}
- {-876126600 34200 0 ACST}
+ {-876123000 34200 0 ACST}
{-860398200 37800 1 ACDT}
- {-844677000 34200 0 ACST}
+ {-844673400 34200 0 ACST}
{-828343800 37800 1 ACDT}
- {-813227400 34200 0 ACST}
+ {-813223800 34200 0 ACST}
}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Eucla
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Eucla 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Eucla 2021-03-02 16:29:37 UTC (rev 58056)
@@ -3,12 +3,12 @@
set TZData(:Australia/Eucla) {
{-9223372036854775808 30928 0 LMT}
{-2337928528 31500 0 +0945}
- {-1672562640 35100 1 +0945}
- {-1665387900 31500 0 +0945}
+ {-1672555500 35100 1 +0945}
+ {-1665384300 31500 0 +0945}
{-883637100 35100 1 +0945}
- {-876123900 31500 0 +0945}
+ {-876120300 31500 0 +0945}
{-860395500 35100 1 +0945}
- {-844674300 31500 0 +0945}
+ {-844670700 31500 0 +0945}
{-836473500 35100 0 +0945}
{152039700 35100 1 +0945}
{162926100 31500 0 +0945}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Hobart
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Hobart 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Hobart 2021-03-02 16:29:37 UTC (rev 58056)
@@ -4,14 +4,18 @@
{-9223372036854775808 35356 0 LMT}
{-2345795356 36000 0 AEST}
{-1680508800 39600 1 AEDT}
- {-1669892400 39600 0 AEDT}
- {-1665392400 36000 0 AEST}
+ {-1665388800 36000 0 AEST}
+ {-1646640000 39600 1 AEDT}
+ {-1635753600 36000 0 AEST}
+ {-1615190400 39600 1 AEDT}
+ {-1604304000 36000 0 AEST}
+ {-1583920800 36000 0 AEST}
{-883641600 39600 1 AEDT}
- {-876128400 36000 0 AEST}
+ {-876124800 36000 0 AEST}
{-860400000 39600 1 AEDT}
- {-844678800 36000 0 AEST}
+ {-844675200 36000 0 AEST}
{-828345600 39600 1 AEDT}
- {-813229200 36000 0 AEST}
+ {-813225600 36000 0 AEST}
{-94730400 36000 0 AEST}
{-71136000 39600 1 AEDT}
{-55411200 36000 0 AEST}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Lindeman
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Lindeman 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Lindeman 2021-03-02 16:29:37 UTC (rev 58056)
@@ -3,14 +3,14 @@
set TZData(:Australia/Lindeman) {
{-9223372036854775808 35756 0 LMT}
{-2366790956 36000 0 AEST}
- {-1672567140 39600 1 AEDT}
- {-1665392400 36000 0 AEST}
+ {-1672560000 39600 1 AEDT}
+ {-1665388800 36000 0 AEST}
{-883641600 39600 1 AEDT}
- {-876128400 36000 0 AEST}
+ {-876124800 36000 0 AEST}
{-860400000 39600 1 AEDT}
- {-844678800 36000 0 AEST}
+ {-844675200 36000 0 AEST}
{-828345600 39600 1 AEDT}
- {-813229200 36000 0 AEST}
+ {-813225600 36000 0 AEST}
{31500000 36000 0 AEST}
{57686400 39600 1 AEDT}
{67968000 36000 0 AEST}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Melbourne
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Melbourne 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Melbourne 2021-03-02 16:29:37 UTC (rev 58056)
@@ -3,14 +3,14 @@
set TZData(:Australia/Melbourne) {
{-9223372036854775808 34792 0 LMT}
{-2364111592 36000 0 AEST}
- {-1672567140 39600 1 AEDT}
- {-1665392400 36000 0 AEST}
+ {-1672560000 39600 1 AEDT}
+ {-1665388800 36000 0 AEST}
{-883641600 39600 1 AEDT}
- {-876128400 36000 0 AEST}
+ {-876124800 36000 0 AEST}
{-860400000 39600 1 AEDT}
- {-844678800 36000 0 AEST}
+ {-844675200 36000 0 AEST}
{-828345600 39600 1 AEDT}
- {-813229200 36000 0 AEST}
+ {-813225600 36000 0 AEST}
{31500000 36000 0 AEST}
{57686400 39600 1 AEDT}
{67968000 36000 0 AEST}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Perth
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Perth 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Perth 2021-03-02 16:29:37 UTC (rev 58056)
@@ -3,12 +3,12 @@
set TZData(:Australia/Perth) {
{-9223372036854775808 27804 0 LMT}
{-2337925404 28800 0 AWST}
- {-1672559940 32400 1 AWDT}
- {-1665385200 28800 0 AWST}
+ {-1672552800 32400 1 AWDT}
+ {-1665381600 28800 0 AWST}
{-883634400 32400 1 AWDT}
- {-876121200 28800 0 AWST}
+ {-876117600 28800 0 AWST}
{-860392800 32400 1 AWDT}
- {-844671600 28800 0 AWST}
+ {-844668000 28800 0 AWST}
{-836470800 32400 0 AWST}
{152042400 32400 1 AWDT}
{162928800 28800 0 AWST}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Sydney
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Sydney 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Australia/Sydney 2021-03-02 16:29:37 UTC (rev 58056)
@@ -3,14 +3,14 @@
set TZData(:Australia/Sydney) {
{-9223372036854775808 36292 0 LMT}
{-2364113092 36000 0 AEST}
- {-1672567140 39600 1 AEDT}
- {-1665392400 36000 0 AEST}
+ {-1672560000 39600 1 AEDT}
+ {-1665388800 36000 0 AEST}
{-883641600 39600 1 AEDT}
- {-876128400 36000 0 AEST}
+ {-876124800 36000 0 AEST}
{-860400000 39600 1 AEDT}
- {-844678800 36000 0 AEST}
+ {-844675200 36000 0 AEST}
{-828345600 39600 1 AEDT}
- {-813229200 36000 0 AEST}
+ {-813225600 36000 0 AEST}
{31500000 36000 0 AEST}
{57686400 39600 1 AEDT}
{67968000 36000 0 AEST}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Budapest
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Budapest 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Budapest 2021-03-02 16:29:37 UTC (rev 58056)
@@ -2,17 +2,19 @@
set TZData(:Europe/Budapest) {
{-9223372036854775808 4580 0 LMT}
- {-2500938980 3600 0 CET}
+ {-2498260580 3600 0 CET}
{-1693706400 7200 1 CEST}
{-1680483600 3600 0 CET}
{-1663455600 7200 1 CEST}
{-1650150000 3600 0 CET}
{-1640998800 3600 0 CET}
- {-1633212000 7200 1 CEST}
+ {-1632006000 7200 1 CEST}
{-1618700400 3600 0 CET}
- {-1600466400 7200 1 CEST}
- {-1581202800 3600 0 CET}
- {-906771600 3600 0 CET}
+ {-1600470000 7200 1 CEST}
+ {-1587250800 3600 0 CET}
+ {-1569711600 7200 1 CEST}
+ {-1555196400 3600 0 CET}
+ {-906775200 3600 0 CET}
{-857257200 3600 0 CET}
{-844556400 7200 1 CEST}
{-828226800 3600 0 CET}
@@ -20,9 +22,9 @@
{-796777200 3600 0 CET}
{-788922000 3600 0 CET}
{-778471200 7200 1 CEST}
- {-762660000 3600 0 CET}
+ {-762656400 3600 0 CET}
{-749689200 7200 1 CEST}
- {-733359600 3600 0 CET}
+ {-733276800 3600 0 CET}
{-717634800 7200 1 CEST}
{-701910000 3600 0 CET}
{-686185200 7200 1 CEST}
@@ -29,24 +31,23 @@
{-670460400 3600 0 CET}
{-654130800 7200 1 CEST}
{-639010800 3600 0 CET}
- {-621990000 7200 1 CEST}
- {-605660400 3600 0 CET}
{-492656400 7200 1 CEST}
{-481168800 3600 0 CET}
- {-461120400 7200 1 CEST}
- {-449632800 3600 0 CET}
- {-428547600 7200 1 CEST}
- {-418269600 3600 0 CET}
- {-397094400 7200 1 CEST}
+ {-461199600 7200 1 CEST}
+ {-449708400 3600 0 CET}
+ {-428540400 7200 1 CEST}
+ {-418258800 3600 0 CET}
+ {-397090800 7200 1 CEST}
{-386809200 3600 0 CET}
- {323827200 7200 1 CEST}
- {338950800 3600 0 CET}
- {354675600 7200 1 CEST}
- {370400400 3600 0 CET}
- {386125200 7200 1 CEST}
- {401850000 3600 0 CET}
- {417574800 7200 1 CEST}
- {433299600 3600 0 CET}
+ {323823600 7200 1 CEST}
+ {338943600 3600 0 CET}
+ {354668400 7200 1 CEST}
+ {370393200 3600 0 CET}
+ {386118000 7200 1 CEST}
+ {401842800 3600 0 CET}
+ {417567600 7200 1 CEST}
+ {433292400 3600 0 CET}
+ {441759600 3600 0 CET}
{449024400 7200 1 CEST}
{465354000 3600 0 CET}
{481078800 7200 1 CEST}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Monaco
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Monaco 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Monaco 2021-03-02 16:29:37 UTC (rev 58056)
@@ -2,8 +2,8 @@
set TZData(:Europe/Monaco) {
{-9223372036854775808 1772 0 LMT}
- {-2486680172 561 0 PMT}
- {-1855958961 0 0 WET}
+ {-2448318572 561 0 PMT}
+ {-1854403761 0 0 WET}
{-1689814800 3600 1 WEST}
{-1680397200 0 0 WET}
{-1665363600 3600 1 WEST}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Paris
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Paris 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Paris 2021-03-02 16:29:37 UTC (rev 58056)
@@ -2,8 +2,8 @@
set TZData(:Europe/Paris) {
{-9223372036854775808 561 0 LMT}
- {-2486678901 561 0 PMT}
- {-1855958901 0 0 WET}
+ {-2486592561 561 0 PMT}
+ {-1855958961 0 0 WET}
{-1689814800 3600 1 WEST}
{-1680397200 0 0 WET}
{-1665363600 3600 1 WEST}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Volgograd
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Volgograd 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Europe/Volgograd 2021-03-02 16:29:37 UTC (rev 58056)
@@ -69,4 +69,5 @@
{1301180400 14400 0 +04}
{1414274400 10800 0 +03}
{1540681200 14400 0 +04}
+ {1609020000 10800 0 +03}
}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Indian/Mahe
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Indian/Mahe 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Indian/Mahe 2021-03-02 16:29:37 UTC (rev 58056)
@@ -2,5 +2,5 @@
set TZData(:Indian/Mahe) {
{-9223372036854775808 13308 0 LMT}
- {-2006653308 14400 0 +04}
+ {-1988163708 14400 0 +04}
}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Efate
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Efate 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Efate 2021-03-02 16:29:37 UTC (rev 58056)
@@ -3,9 +3,11 @@
set TZData(:Pacific/Efate) {
{-9223372036854775808 40396 0 LMT}
{-1829387596 39600 0 +11}
+ {125409600 43200 1 +11}
+ {133876800 39600 0 +11}
{433256400 43200 1 +11}
{448977600 39600 0 +11}
- {467298000 43200 1 +11}
+ {464706000 43200 1 +11}
{480427200 39600 0 +11}
{496760400 43200 1 +11}
{511876800 39600 0 +11}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Fiji
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Fiji 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/tzdata/Pacific/Fiji 2021-03-02 16:29:37 UTC (rev 58056)
@@ -29,7 +29,7 @@
{1547301600 43200 0 +12}
{1573308000 46800 1 +12}
{1578751200 43200 0 +12}
- {1604757600 46800 1 +12}
+ {1608386400 46800 1 +12}
{1610805600 43200 0 +12}
{1636812000 46800 1 +12}
{1642255200 43200 0 +12}
Modified: trunk/Master/tlpkg/tltcl/lib/tcl8.6/word.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tcl8.6/word.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tcl8.6/word.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -4,8 +4,8 @@
# strings. This file is primarily needed so Tk text and entry widgets behave
# properly for different platforms.
#
-# Copyright (c) 1996 by Sun Microsystems, Inc.
-# Copyright (c) 1998 by Scritpics Corporation.
+# Copyright (c) 1996 Sun Microsystems, Inc.
+# Copyright (c) 1998 Scritpics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -146,7 +146,9 @@
proc tcl_startOfPreviousWord {str start} {
variable ::tcl::WordBreakRE
set word {-1 -1}
- regexp -indices -- $WordBreakRE(previous) [string range $str 0 $start-1] \
- result word
+ if {$start > 0} {
+ regexp -indices -- $WordBreakRE(previous) [string range $str 0 $start-1] \
+ result word
+ }
return [lindex $word 0]
}
Modified: trunk/Master/tlpkg/tltcl/lib/tclConfig.sh
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tclConfig.sh 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tclConfig.sh 2021-03-02 16:29:37 UTC (rev 58056)
@@ -15,13 +15,13 @@
TCL_VERSION='8.6'
TCL_MAJOR_VERSION='8'
TCL_MINOR_VERSION='6'
-TCL_PATCH_LEVEL='.10'
+TCL_PATCH_LEVEL='.11'
# C compiler to use for compilation.
TCL_CC='i686-w64-mingw32-gcc'
# -D flags for use with the C compiler.
-TCL_DEFS='-DPACKAGE_NAME=\"\" -DPACKAGE_TARNAME=\"\" -DPACKAGE_VERSION=\"\" -DPACKAGE_STRING=\"\" -DPACKAGE_BUGREPORT=\"\" -DSTDC_HEADERS=1 -DTCL_THREADS=1 -DUSE_THREAD_ALLOC=1 -DTCL_CFGVAL_ENCODING=\"cp1252\" -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 -DMODULE_SCOPE=extern -DHAVE_NO_SEH=1 -DHAVE_CAST_TO_UNION=1 -DHAVE_ZLIB=1 -DHAVE_INTPTR_T=1 -DHAVE_UINTPTR_T=1 -DHAVE_INTRIN_H=1 -DHAVE_WSPIAPI_H=1 -DNDEBUG=1 -DTCL_CFG_OPTIMIZED=1 '
+TCL_DEFS='-DPACKAGE_NAME=\"\" -DPACKAGE_TARNAME=\"\" -DPACKAGE_VERSION=\"\" -DPACKAGE_STRING=\"\" -DPACKAGE_BUGREPORT=\"\" -DSTDC_HEADERS=1 -DTCL_THREADS=1 -DUSE_THREAD_ALLOC=1 -DTCL_CFGVAL_ENCODING=\"cp1252\" -DMODULE_SCOPE=extern -DHAVE_NO_SEH=1 -DHAVE_CAST_TO_UNION=1 -DHAVE_ZLIB=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_INTRIN_H=1 -DHAVE_WSPIAPI_H=1 -DNDEBUG=1 -DTCL_CFG_OPTIMIZED=1 '
# If TCL was built with debugging symbols, generated libraries contain
# this string at the end of the library name (before the extension).
@@ -39,7 +39,7 @@
TCL_SHARED_BUILD=1
# The name of the Tcl library (may be either a .a file or a shared library):
-TCL_LIB_FILE='libtcl86.a'
+TCL_LIB_FILE='libtcl86.dll.a'
# Flag to indicate whether shared libraries need export files.
TCL_NEEDS_EXP_FILE=
@@ -48,7 +48,7 @@
# name that comes after the "libxxx" (includes version number, if any,
# extension, and anything else needed). May depend on the variables
# VERSION. On most UNIX systems this is ${VERSION}.exp.
-TCL_EXPORT_FILE_SUFFIX='${NODOT_VERSION}${DBGX}.a'
+TCL_EXPORT_FILE_SUFFIX='${NODOT_VERSION}.a'
# Additional libraries to use when linking Tcl.
TCL_LIBS='-lnetapi32 -lkernel32 -luser32 -ladvapi32 -luserenv -lws2_32'
@@ -55,17 +55,17 @@
# Top-level directory in which Tcl's platform-independent files are
# installed.
-TCL_PREFIX='/tmp/siepo/tcltk'
+TCL_PREFIX='/home/siepo/tltcl'
# Top-level directory in which Tcl's platform-specific files (e.g.
# executables) are installed.
-TCL_EXEC_PREFIX='/tmp/siepo/tcltk'
+TCL_EXEC_PREFIX='/home/siepo/tltcl'
# Flags to pass to cc when compiling the components of a shared library:
TCL_SHLIB_CFLAGS=''
# Flags to pass to cc to get warning messages
-TCL_CFLAGS_WARNING='-Wall -Wdeclaration-after-statement'
+TCL_CFLAGS_WARNING='-Wall -Wpointer-arith -Wdeclaration-after-statement'
# Extra flags to pass to cc:
TCL_EXTRA_CFLAGS='-pipe'
@@ -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.10/win -ltcl86'
+TCL_BUILD_LIB_SPEC='-L/home/siepo/xdrive/tltcl/tcl8.6.11/win -ltcl86'
# String to pass to linker to pick up the Tcl library from its
# installed directory.
-TCL_LIB_SPEC='-L/tmp/siepo/tcltk/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/siepo/tcltk/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
@@ -132,13 +132,13 @@
# extension, and anything else needed). May depend on the variables
# VERSION and SHLIB_SUFFIX. On most UNIX systems this is
# ${VERSION}${SHLIB_SUFFIX}.
-TCL_SHARED_LIB_SUFFIX='${NODOT_VERSION}${DBGX}.dll'
+TCL_SHARED_LIB_SUFFIX='${NODOT_VERSION}.dll'
# String that can be evaluated to generate the part of an unshared library
# name that comes after the "libxxx" (includes version number, if any,
# extension, and anything else needed). May depend on the variable
# VERSION. On most UNIX systems this is ${VERSION}.a.
-TCL_UNSHARED_LIB_SUFFIX='${NODOT_VERSION}${DBGX}.a'
+TCL_UNSHARED_LIB_SUFFIX='${NODOT_VERSION}.a'
# Location of the top-level source directory from which Tcl was built.
# This is the directory that contains a README file as well as
@@ -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.10'
+TCL_SRC_DIR='/home/siepo/xdrive/tltcl/tcl8.6.11'
# 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/siepo/tcltk/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.10/win -ltclstub86'
+TCL_BUILD_STUB_LIB_SPEC='-L/home/siepo/xdrive/tltcl/tcl8.6.11/win -ltclstub86'
# String to pass to linker to pick up the Tcl stub library from its
# installed directory.
-TCL_STUB_LIB_SPEC='-L/tmp/siepo/tcltk/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.10/win/libtclstub86.a'
+TCL_BUILD_STUB_LIB_PATH='/home/siepo/xdrive/tltcl/tcl8.6.11/win/libtclstub86.a'
# Path to the Tcl stub library in the install directory.
-TCL_STUB_LIB_PATH='/tmp/siepo/tcltk/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.2/libtdbcstub112.a
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.2/libtdbcstub112.a
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbc1.1.2/libtdbcstub112.a 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tdbc1.1.2/libtdbcstub112.a 2021-03-02 16:29:37 UTC (rev 58056)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.2/libtdbcstub112.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.2/pkgIndex.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbc1.1.2/pkgIndex.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tdbc1.1.2/pkgIndex.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -0,0 +1,18 @@
+# Index file to load the TDBC package.
+
+# Make sure that TDBC is running in a compatible version of Tcl, and
+# that TclOO is available.
+
+if {[catch {package present Tcl 8.5-}]} {
+ 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]
+ }
+ package ifneeded tdbc 1.1.2 \
+ "package require TclOO 1.0-;\
+ [list load [file join $dir tdbc112.dll] tdbc]\;\
+ [list source $libraryfile]"
+}} $dir
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.2/pkgIndex.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.2/tdbc.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbc1.1.2/tdbc.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tdbc1.1.2/tdbc.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -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.2/tdbc.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.2/tdbc112.dll
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.2/tdbc112.dll
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbc1.1.2/tdbc112.dll 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tdbc1.1.2/tdbc112.dll 2021-03-02 16:29:37 UTC (rev 58056)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.2/tdbc112.dll
___________________________________________________________________
Added: svn:mime-type
## -0,0 +1 ##
+application/x-dosexec
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbc1.1.2/tdbcConfig.sh
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbc1.1.2/tdbcConfig.sh (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tdbc1.1.2/tdbcConfig.sh 2021-03-02 16:29:37 UTC (rev 58056)
@@ -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.2
+TDBC_VERSION=1.1.2
+
+# Name of the TDBC library - may be either a static or shared library
+tdbc_LIB_FILE=tdbc112.dll
+TDBC_LIB_FILE=tdbc112.dll
+
+# String to pass to the linker to pick up the TDBC library from its build dir
+tdbc_BUILD_LIB_SPEC="-L/home/siepo/xdrive/tltcl/tcl8.6.11/win/pkgs/tdbc1.1.2 -ltdbc112"
+TDBC_BUILD_LIB_SPEC="-L/home/siepo/xdrive/tltcl/tcl8.6.11/win/pkgs/tdbc1.1.2 -ltdbc112"
+
+# 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.2 -ltdbc112"
+TDBC_LIB_SPEC="-L/home/siepo/tltcl/lib/tdbc1.1.2 -ltdbc112"
+
+# Name of the TBDC stub library
+tdbc_STUB_LIB_FILE="libtdbcstub112.a"
+TDBC_STUB_LIB_FILE="libtdbcstub112.a"
+
+# String to pass to the linker to pick up the TDBC stub library from its
+# build directory
+tdbc_BUILD_STUB_LIB_SPEC="-L/home/siepo/xdrive/tltcl/tcl8.6.11/win/pkgs/tdbc1.1.2 -ltdbcstub112"
+TDBC_BUILD_STUB_LIB_SPEC="-L/home/siepo/xdrive/tltcl/tcl8.6.11/win/pkgs/tdbc1.1.2 -ltdbcstub112"
+
+# 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.2 -ltdbcstub112"
+TDBC_STUB_LIB_SPEC="-L/home/siepo/tltcl/lib/tdbc1.1.2 -ltdbcstub112"
+
+# Path name of the TDBC stub library in its build directory
+tdbc_BUILD_STUB_LIB_PATH="/home/siepo/xdrive/tltcl/tcl8.6.11/win/pkgs/tdbc1.1.2/libtdbcstub112.a"
+TDBC_BUILD_STUB_LIB_PATH="/home/siepo/xdrive/tltcl/tcl8.6.11/win/pkgs/tdbc1.1.2/libtdbcstub112.a"
+
+# Path name of the TDBC stub library in its installed directory
+tdbc_STUB_LIB_PATH="/home/siepo/tltcl/lib/tdbc1.1.2/libtdbcstub112.a"
+TDBC_STUB_LIB_PATH="/home/siepo/tltcl/lib/tdbc1.1.2/libtdbcstub112.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="/home/siepo/xdrive/tltcl/tcl8.6.11/pkgs/tdbc1.1.2"
+TDBC_SRC_DIR="/home/siepo/xdrive/tltcl/tcl8.6.11/pkgs/tdbc1.1.2"
+
+# 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/home/siepo/xdrive/tltcl/tcl8.6.11/pkgs/tdbc1.1.2/generic"
+TDBC_BUILD_INCLUDE_SPEC="-I/home/siepo/xdrive/tltcl/tcl8.6.11/pkgs/tdbc1.1.2/generic"
+
+# Path name where .tcl files in the tdbc package appear at run time.
+tdbc_LIBRARY_PATH="/home/siepo/tltcl/lib/tdbc1.1.2"
+TDBC_LIBRARY_PATH="/home/siepo/tltcl/lib/tdbc1.1.2"
+
+# Path name where .tcl files in the tdbc package appear at build time.
+tdbc_BUILD_LIBRARY_PATH="/home/siepo/xdrive/tltcl/tcl8.6.11/pkgs/tdbc1.1.2/library"
+TDBC_BUILD_LIBRARY_PATH="/home/siepo/xdrive/tltcl/tcl8.6.11/pkgs/tdbc1.1.2/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.2/tdbcConfig.sh
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.2/pkgIndex.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.2/pkgIndex.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.2/pkgIndex.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -0,0 +1,8 @@
+# Index file to load the TDBC MySQL package.
+
+if {[catch {package require Tcl 8.6}]} {
+ return
+}
+package ifneeded tdbc::mysql 1.1.2 \
+ "[list source [file join $dir tdbcmysql.tcl]]\;\
+ [list load [file join $dir tdbcmysql112.dll] tdbcmysql]"
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.2/pkgIndex.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.2/tdbcmysql.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.2/tdbcmysql.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.2/tdbcmysql.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -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.2/tdbcmysql.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.2/tdbcmysql112.dll
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.2/tdbcmysql112.dll
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.2/tdbcmysql112.dll 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.2/tdbcmysql112.dll 2021-03-02 16:29:37 UTC (rev 58056)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbcmysql1.1.2/tdbcmysql112.dll
___________________________________________________________________
Added: svn:mime-type
## -0,0 +1 ##
+application/x-dosexec
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.2/pkgIndex.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.2/pkgIndex.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.2/pkgIndex.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -0,0 +1,8 @@
+# Index file to load the TDBC ODBC package.
+
+if {[catch {package require Tcl 8.6}]} {
+ return
+}
+package ifneeded tdbc::odbc 1.1.2 \
+ "[list source [file join $dir tdbcodbc.tcl]]\;\
+ [list load [file join $dir tdbcodbc112.dll] tdbcodbc]"
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.2/pkgIndex.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.2/tdbcodbc.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.2/tdbcodbc.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.2/tdbcodbc.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -0,0 +1,515 @@
+# 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 '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::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.2/tdbcodbc.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.2/tdbcodbc112.dll
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.2/tdbcodbc112.dll
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.2/tdbcodbc112.dll 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.2/tdbcodbc112.dll 2021-03-02 16:29:37 UTC (rev 58056)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbcodbc1.1.2/tdbcodbc112.dll
___________________________________________________________________
Added: svn:mime-type
## -0,0 +1 ##
+application/x-dosexec
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.2/pkgIndex.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.2/pkgIndex.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.2/pkgIndex.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -0,0 +1,8 @@
+# Index file to load the TDBC Postgres package.
+
+if {[catch {package require Tcl 8.6}]} {
+ return
+}
+package ifneeded tdbc::postgres 1.1.2 \
+ "[list source [file join $dir tdbcpostgres.tcl]]\;\
+ [list load [file join $dir tdbcpostgres112.dll] tdbcpostgres]"
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.2/pkgIndex.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.2/tdbcpostgres.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.2/tdbcpostgres.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.2/tdbcpostgres.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -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.2/tdbcpostgres.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.2/tdbcpostgres112.dll
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.2/tdbcpostgres112.dll
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.2/tdbcpostgres112.dll 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.2/tdbcpostgres112.dll 2021-03-02 16:29:37 UTC (rev 58056)
Property changes on: trunk/Master/tlpkg/tltcl/lib/tdbcpostgres1.1.2/tdbcpostgres112.dll
___________________________________________________________________
Added: svn:mime-type
## -0,0 +1 ##
+application/x-dosexec
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/thread2.8.6/pkgIndex.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/thread2.8.6/pkgIndex.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/thread2.8.6/pkgIndex.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -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.6
+#
+# 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.6 [list load [file join $dir thread286.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.6 "
+ [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.6 [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.6/pkgIndex.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/thread2.8.6/thread286.dll
===================================================================
(Binary files differ)
Index: trunk/Master/tlpkg/tltcl/lib/thread2.8.6/thread286.dll
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/thread2.8.6/thread286.dll 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/thread2.8.6/thread286.dll 2021-03-02 16:29:37 UTC (rev 58056)
Property changes on: trunk/Master/tlpkg/tltcl/lib/thread2.8.6/thread286.dll
___________________________________________________________________
Added: svn:mime-type
## -0,0 +1 ##
+application/x-dosexec
\ No newline at end of property
Added: trunk/Master/tlpkg/tltcl/lib/thread2.8.6/ttrace.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/thread2.8.6/ttrace.tcl (rev 0)
+++ trunk/Master/tlpkg/tltcl/lib/thread2.8.6/ttrace.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -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.6
+
+ # 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 [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 $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 ttrace::_resolve [list $cmd]]} {
+ set c [catch {uplevel $cmd [lrange $args 1 end]} r]
+ } else {
+ set c [catch {::eval ::tcl::unknown $args} r]
+ }
+ return -code $c -errorcode $::errorCode -errorinfo $::errorInfo $r
+ }
+
+ proc _resolve {cmd} {
+ variable resolvers
+ foreach resolver $resolvers {
+ if {[uplevel [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 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 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 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 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 ::tcl::info $args}]} {
+ uplevel ttrace::_resolve [list [lindex $args 1]]
+ }
+ return [uplevel ::tcl::info $args]
+ }
+ if {$hit == -1} {
+ return [uplevel ::tcl::info $args]
+ }
+ set cns [uplevel 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 ::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 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 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 [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.6/ttrace.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/bgerror.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/bgerror.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/bgerror.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -41,7 +41,7 @@
set w .bgerrorDialog
set caption [option get $w.function text {}]
set command [option get $w.function command {}]
- if { ($caption eq "") || ($command eq "") } {
+ if {($caption eq "") || ($command eq "")} {
grid forget $w.function
}
lappend command [$w.top.info.text get 1.0 end-1c]
@@ -50,7 +50,7 @@
}
proc ::tk::dialog::error::SaveToLog {text} {
- if { $::tcl_platform(platform) eq "windows" } {
+ if {$::tcl_platform(platform) eq "windows"} {
set allFiles *.*
} else {
set allFiles *
@@ -129,11 +129,11 @@
set lines 0
set maxLine 45
foreach line [split $err \n] {
- if { [string length $line] > $maxLine } {
- append displayedErr "[string range $line 0 [expr {$maxLine-3}]]..."
+ if {[string length $line] > $maxLine} {
+ append displayedErr "[string range $line 0 $maxLine-3]..."
break
}
- if { $lines > 4 } {
+ if {$lines > 4} {
append displayedErr "..."
break
} else {
@@ -182,7 +182,7 @@
pack $W.text -side left -expand yes -fill both
$W.text insert 0.0 "$err\n$info"
$W.text mark set insert 0.0
- bind $W.text <ButtonPress-1> { focus %W }
+ bind $W.text <Button-1> {focus %W}
$W.text configure -state disabled
# 2. Fill the top part with bitmap and message
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/clrpick.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/clrpick.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/clrpick.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -396,7 +396,7 @@
# Draw the selection polygons
CreateSelector $w $sel $c
- $sel bind $data($c,index) <ButtonPress-1> \
+ $sel bind $data($c,index) <Button-1> \
[list tk::dialog::color::StartMove $w $sel $c %x $data(selPad) 1]
$sel bind $data($c,index) <B1-Motion> \
[list tk::dialog::color::MoveSelector $w $sel $c %x $data(selPad)]
@@ -409,7 +409,7 @@
set data($c,clickRegion) [$sel create rectangle 0 0 \
$data(canvasWidth) $height -fill {} -outline {}]
- bind $col <ButtonPress-1> \
+ bind $col <Button-1> \
[list tk::dialog::color::StartMove $w $sel $c %x $data(colorPad)]
bind $col <B1-Motion> \
[list tk::dialog::color::MoveSelector $w $sel $c %x $data(colorPad)]
@@ -416,7 +416,7 @@
bind $col <ButtonRelease-1> \
[list tk::dialog::color::ReleaseMouse $w $sel $c %x $data(colorPad)]
- $sel bind $data($c,clickRegion) <ButtonPress-1> \
+ $sel bind $data($c,clickRegion) <Button-1> \
[list tk::dialog::color::StartMove $w $sel $c %x $data(selPad)]
$sel bind $data($c,clickRegion) <B1-Motion> \
[list tk::dialog::color::MoveSelector $w $sel $c %x $data(selPad)]
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/comdlg.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/comdlg.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/comdlg.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -29,7 +29,8 @@
# {....}
# }
#
-# flags = currently unused.
+# flags = a list of flags. Currently supported flags are:
+# DONTSETDEFAULTS = skip default values setting
#
# argList = The list of "-option value" pairs.
#
@@ -63,8 +64,10 @@
# 2: set the default values
#
- foreach cmdsw [array names cmd] {
- set data($cmdsw) $def($cmdsw)
+ if {"DONTSETDEFAULTS" ni $flags} {
+ foreach cmdsw [array names cmd] {
+ set data($cmdsw) $def($cmdsw)
+ }
}
# 3: parse the argument list
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/console.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/console.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/console.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -131,7 +131,7 @@
default { set preferred {} }
}
foreach {family size} $preferred {
- if {[lsearch -exact $families $family] != -1} {
+ if {$family in $families} {
font configure TkConsoleFont -family $family -size $size
break
}
@@ -592,7 +592,7 @@
}
bind Console <F9> {
eval destroy [winfo child .]
- source [file join $tk_library console.tcl]
+ source -encoding utf-8 [file join $tk_library console.tcl]
}
if {[tk windowingsystem] eq "aqua"} {
bind Console <Command-q> {
@@ -740,9 +740,9 @@
}
proc ::tk::console::FontchooserVisibility {index} {
if {[tk fontchooser configure -visible]} {
- .menubar.edit entryconfigure $index -label [msgcat::mc "Hide Fonts"]
+ .menubar.edit entryconfigure $index -label [::tk::msgcat::mc "Hide Fonts"]
} else {
- .menubar.edit entryconfigure $index -label [msgcat::mc "Show Fonts"]
+ .menubar.edit entryconfigure $index -label [::tk::msgcat::mc "Show Fonts"]
}
}
proc ::tk::console::FontchooserFocus {w isFocusIn} {
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/arrow.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/arrow.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/arrow.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -154,11 +154,11 @@
$c bind box <Leave> "$c itemconfigure current $demo_arrowInfo(boxStyle)"
$c bind box <B1-Enter> " "
$c bind box <B1-Leave> " "
-$c bind box1 <1> {set demo_arrowInfo(motionProc) arrowMove1}
-$c bind box2 <1> {set demo_arrowInfo(motionProc) arrowMove2}
-$c bind box3 <1> {set demo_arrowInfo(motionProc) arrowMove3}
+$c bind box1 <Button-1> {set demo_arrowInfo(motionProc) arrowMove1}
+$c bind box2 <Button-1> {set demo_arrowInfo(motionProc) arrowMove2}
+$c bind box3 <Button-1> {set demo_arrowInfo(motionProc) arrowMove3}
$c bind box <B1-Motion> "\$demo_arrowInfo(motionProc) $c %x %y"
-bind $c <Any-ButtonRelease-1> "arrowSetup $c"
+bind $c <ButtonRelease-1> "arrowSetup $c"
# arrowMove1 --
# This procedure is called for each mouse motion event on box1 (the
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/bind.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/bind.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/bind.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -63,16 +63,16 @@
# Create bindings for tags.
foreach tag {d1 d2 d3 d4 d5 d6} {
- $w.text tag bind $tag <Any-Enter> "$w.text tag configure $tag $bold"
- $w.text tag bind $tag <Any-Leave> "$w.text tag configure $tag $normal"
+ $w.text tag bind $tag <Enter> "$w.text tag configure $tag $bold"
+ $w.text tag bind $tag <Leave> "$w.text tag configure $tag $normal"
}
# Main widget program sets variable tk_demoDirectory
-$w.text tag bind d1 <1> {source [file join $tk_demoDirectory items.tcl]}
-$w.text tag bind d2 <1> {source [file join $tk_demoDirectory plot.tcl]}
-$w.text tag bind d3 <1> {source [file join $tk_demoDirectory ctext.tcl]}
-$w.text tag bind d4 <1> {source [file join $tk_demoDirectory arrow.tcl]}
-$w.text tag bind d5 <1> {source [file join $tk_demoDirectory ruler.tcl]}
-$w.text tag bind d6 <1> {source [file join $tk_demoDirectory cscroll.tcl]}
+$w.text tag bind d1 <Button-1> {source -encoding utf-8 [file join $tk_demoDirectory items.tcl]}
+$w.text tag bind d2 <Button-1> {source -encoding utf-8 [file join $tk_demoDirectory plot.tcl]}
+$w.text tag bind d3 <Button-1> {source -encoding utf-8 [file join $tk_demoDirectory ctext.tcl]}
+$w.text tag bind d4 <Button-1> {source -encoding utf-8 [file join $tk_demoDirectory arrow.tcl]}
+$w.text tag bind d5 <Button-1> {source -encoding utf-8 [file join $tk_demoDirectory ruler.tcl]}
+$w.text tag bind d6 <Button-1> {source -encoding utf-8 [file join $tk_demoDirectory cscroll.tcl]}
$w.text mark set insert 0.0
$w.text configure -state disabled
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/colors.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/colors.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/colors.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -32,7 +32,7 @@
-width 20 -height 16 -setgrid 1
pack $w.frame.list $w.frame.scroll -side left -fill y -expand 1
-bind $w.frame.list <Double-1> {
+bind $w.frame.list <Double-Button-1> {
tk_setPalette [selection get]
}
$w.frame.list insert 0 gray60 gray70 gray80 gray85 gray90 gray95 \
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/cscroll.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/cscroll.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/cscroll.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -53,54 +53,84 @@
}
}
-$c bind all <Any-Enter> "scrollEnter $c"
-$c bind all <Any-Leave> "scrollLeave $c"
-$c bind all <1> "scrollButton $c"
-bind $c <2> "$c scan mark %x %y"
-bind $c <B2-Motion> "$c scan dragto %x %y"
-if {[tk windowingsystem] eq "aqua"} {
+$c bind all <Enter> "scrollEnter $c"
+$c bind all <Leave> "scrollLeave $c"
+$c bind all <Button-1> "scrollButton $c"
+if {([tk windowingsystem] eq "aqua") && ![package vsatisfies [package provide Tk] 8.7-]} {
+ bind $c <Button-3> "$c scan mark %x %y"
+ bind $c <B3-Motion> "$c scan dragto %x %y"
bind $c <MouseWheel> {
- %W yview scroll [expr {-(%D)}] units
+ %W yview scroll [expr {-%D}] units
}
bind $c <Option-MouseWheel> {
- %W yview scroll [expr {-10 * (%D)}] units
+ %W yview scroll [expr {-10*%D}] units
}
bind $c <Shift-MouseWheel> {
- %W xview scroll [expr {-(%D)}] units
+ %W xview scroll [expr {-%D}] units
}
bind $c <Shift-Option-MouseWheel> {
- %W xview scroll [expr {-10 * (%D)}] units
+ %W xview scroll [expr {-10*%D}] units
}
} else {
+ bind $c <Button-2> "$c scan mark %x %y"
+ bind $c <B2-Motion> "$c scan dragto %x %y"
+ # We must make sure that positive and negative movements are rounded
+ # equally to integers, avoiding the problem that
+ # (int)1/-30 = -1,
+ # but
+ # (int)-1/-30 = 0
+ # The following code ensure equal +/- behaviour.
bind $c <MouseWheel> {
- %W yview scroll [expr {-(%D / 30)}] units
+ if {%D >= 0} {
+ %W yview scroll [expr {%D/-30}] units
+ } else {
+ %W yview scroll [expr {(%D-29)/-30}] units
+ }
}
+ bind $c <Option-MouseWheel> {
+ if {%D >= 0} {
+ %W yview scroll [expr {%D/-3}] units
+ } else {
+ %W yview scroll [expr {(%D-2)/-3}] units
+ }
+ }
bind $c <Shift-MouseWheel> {
- %W xview scroll [expr {-(%D / 30)}] units
+ if {%D >= 0} {
+ %W xview scroll [expr {%D/-30}] units
+ } else {
+ %W xview scroll [expr {(%D-29)/-30}] units
+ }
}
+ bind $c <Shift-Option-MouseWheel> {
+ if {%D >= 0} {
+ %W xview scroll [expr {%D/-3}] units
+ } else {
+ %W xview scroll [expr {(%D-2)/-3}] units
+ }
+ }
}
-if {[tk windowingsystem] eq "x11"} {
+if {[tk windowingsystem] eq "x11" && ![package vsatisfies [package provide Tk] 8.7-]} {
# Support for mousewheels on Linux/Unix commonly comes through mapping
# the wheel to the extended buttons. If you have a mousewheel, find
# Linux configuration info at:
# http://linuxreviews.org/howtos/xfree/mouse/
- bind $c <4> {
+ bind $c <Button-4> {
if {!$tk_strictMotif} {
%W yview scroll -5 units
}
}
- bind $c <Shift-4> {
+ bind $c <Shift-Button-4> {
if {!$tk_strictMotif} {
%W xview scroll -5 units
}
}
- bind $c <5> {
+ bind $c <Button-5> {
if {!$tk_strictMotif} {
%W yview scroll 5 units
}
}
- bind $c <Shift-5> {
+ bind $c <Shift-Button-5> {
if {!$tk_strictMotif} {
%W xview scroll 5 units
}
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/ctext.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/ctext.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/ctext.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -41,16 +41,20 @@
# First, create the text item and give it bindings so it can be edited.
$c addtag text withtag [$c create text 250 200 -text "This is just a string of text to demonstrate the text facilities of canvas widgets. Bindings have been defined to support editing (see above)." -width 440 -anchor n -font $textFont -justify left]
-$c bind text <1> "textB1Press $c %x %y"
+$c bind text <Button-1> "textB1Press $c %x %y"
$c bind text <B1-Motion> "textB1Move $c %x %y"
-$c bind text <Shift-1> "$c select adjust current @%x,%y"
+$c bind text <Shift-Button-1> "$c select adjust current @%x,%y"
$c bind text <Shift-B1-Motion> "textB1Move $c %x %y"
-$c bind text <KeyPress> "textInsert $c %A"
+$c bind text <Key> "textInsert $c %A"
$c bind text <Return> "textInsert $c \\n"
$c bind text <Control-h> "textBs $c"
$c bind text <BackSpace> "textBs $c"
$c bind text <Delete> "textDel $c"
-$c bind text <2> "textPaste $c @%x,%y"
+if {[tk windowingsystem] eq "aqua" && ![package vsatisfies [package provide Tk] 8.7-]} {
+ $c bind text <Button-3> "textPaste $c @%x,%y"
+} else {
+ $c bind text <Button-2> "textPaste $c @%x,%y"
+}
# Next, create some items that allow the text's anchor position
# to be edited.
@@ -58,7 +62,7 @@
proc mkTextConfigBox {w x y option value color} {
set item [$w create rect $x $y [expr {$x+30}] [expr {$y+30}] \
-outline black -fill $color -width 1]
- $w bind $item <1> "$w itemconf text $option $value"
+ $w bind $item <Button-1> "$w itemconf text $option $value"
$w addtag config withtag $item
}
proc mkTextConfigPie {w x y a option value color} {
@@ -65,7 +69,7 @@
set item [$w create arc $x $y [expr {$x+90}] [expr {$y+90}] \
-start [expr {$a-15}] -extent 30 -outline black -fill $color \
-width 1]
- $w bind $item <1> "$w itemconf text $option $value"
+ $w bind $item <Button-1> "$w itemconf text $option $value"
$w addtag config withtag $item
}
@@ -84,7 +88,7 @@
set item [$c create rect \
[expr {$x+40}] [expr {$y+40}] [expr {$x+50}] [expr {$y+50}] \
-outline black -fill red]
-$c bind $item <1> "$c itemconf text -anchor center"
+$c bind $item <Button-1> "$c itemconf text -anchor center"
$c create text [expr {$x+45}] [expr {$y-5}] \
-text {Text Position} -anchor s -font {Times 20} -fill brown
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/dialog1.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/dialog1.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/dialog1.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -2,16 +2,16 @@
#
# This demonstration script creates a dialog box with a local grab.
-interp create slave
-load {} Tk slave
-slave eval {
- wm title . slave
+interp create child
+load {} Tk child
+child eval {
+ wm title . child
wm geometry . +700+30
pack [text .t -width 30 -height 10]
}
after idle {.dialog1.msg configure -wraplength 4i}
-set i [tk_dialog .dialog1 "Dialog with local grab" {This is a modal dialog box. It uses Tk's "grab" command to create a "local grab" on the dialog box. The grab prevents any mouse or keyboard events from getting to any other windows in the application until you have answered the dialog by invoking one of the buttons below. However, you can still interact with other applications. For example, you should be able to edit text in the window named "slave" which was created by a slave interpreter.} \
+set i [tk_dialog .dialog1 "Dialog with local grab" {This is a modal dialog box. It uses Tk's "grab" command to create a "local grab" on the dialog box. The grab prevents any mouse or keyboard events from getting to any other windows in the application until you have answered the dialog by invoking one of the buttons below. However, you can still interact with other applications. For example, you should be able to edit text in the window named "child" which was created by a child interpreter.} \
info 0 OK Cancel {Show Code}]
switch $i {
@@ -20,6 +20,6 @@
2 {showCode .dialog1}
}
-if {[interp exists slave]} {
- interp delete slave
+if {[interp exists child]} {
+ interp delete child
}
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/entry1.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/entry1.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/entry1.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -16,7 +16,7 @@
wm iconname $w "entry1"
positionWindow $w
-label $w.msg -font $font -wraplength 5i -justify left -text "Three different entries are displayed below. You can add characters by pointing, clicking and typing. The normal Motif editing characters are supported, along with many Emacs bindings. For example, Backspace and Control-h delete the character to the left of the insertion cursor and Delete and Control-d delete the chararacter to the right of the insertion cursor. For entries that are too large to fit in the window all at once, you can scan through the entries by dragging with mouse button2 pressed."
+label $w.msg -font $font -wraplength 5i -justify left -text "Three different entries are displayed below. You can add characters by pointing, clicking and typing. The normal Motif editing characters are supported, along with many Emacs bindings. For example, Backspace and Control-h delete the character to the left of the insertion cursor and Delete and Control-d delete the chararacter to the right of the insertion cursor. For entries that are too large to fit in the window all at once, you can scan through the entries by dragging with mouse the middle mouse button pressed."
pack $w.msg -side top
## See Code / Dismiss buttons
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/entry2.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/entry2.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/entry2.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -16,7 +16,7 @@
wm iconname $w "entry2"
positionWindow $w
-label $w.msg -font $font -wraplength 5i -justify left -text "Three different entries are displayed below, with a scrollbar for each entry. You can add characters by pointing, clicking and typing. The normal Motif editing characters are supported, along with many Emacs bindings. For example, Backspace and Control-h delete the character to the left of the insertion cursor and Delete and Control-d delete the chararacter to the right of the insertion cursor. For entries that are too large to fit in the window all at once, you can scan through the entries with the scrollbars, or by dragging with mouse button2 pressed."
+label $w.msg -font $font -wraplength 5i -justify left -text "Three different entries are displayed below, with a scrollbar for each entry. You can add characters by pointing, clicking and typing. The normal Motif editing characters are supported, along with many Emacs bindings. For example, Backspace and Control-h delete the character to the left of the insertion cursor and Delete and Control-d delete the chararacter to the right of the insertion cursor. For entries that are too large to fit in the window all at once, you can scan through the entries with the scrollbars, or by dragging with the middle mouse button pressed."
pack $w.msg -side top
## See Code / Dismiss buttons
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/entry3.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/entry3.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/entry3.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -102,7 +102,7 @@
proc validatePhoneChange {W vmode idx char} {
global phoneNumberMap entry3content
- if {$idx == -1} {return 1}
+ if {$idx < 0} {return 1}
after idle [list $W configure -validate $vmode -invcmd bell]
if {
!($idx<3 || $idx==6 || $idx==7 || $idx==11 || $idx>15) &&
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/floor.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/floor.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/floor.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -1354,13 +1354,18 @@
# Set up event bindings for canvas:
-$c bind floor1 <1> "floorDisplay $c 1"
-$c bind floor2 <1> "floorDisplay $c 2"
-$c bind floor3 <1> "floorDisplay $c 3"
+$c bind floor1 <Button-1> "floorDisplay $c 1"
+$c bind floor2 <Button-1> "floorDisplay $c 2"
+$c bind floor3 <Button-1> "floorDisplay $c 3"
$c bind room <Enter> "newRoom $c"
$c bind room <Leave> {set currentRoom ""}
-bind $c <2> "$c scan mark %x %y"
-bind $c <B2-Motion> "$c scan dragto %x %y"
+if {[tk windowingsystem] eq "aqua" && ![package vsatisfies [package provide Tk] 8.7-]} {
+ bind $c <Button-3> "$c scan mark %x %y"
+ bind $c <B3-Motion> "$c scan dragto %x %y"
+} else {
+ bind $c <Button-2> "$c scan mark %x %y"
+ bind $c <B2-Motion> "$c scan dragto %x %y"
+}
bind $c <Destroy> "unset currentRoom"
set currentRoom ""
trace variable currentRoom w "roomChanged $c"
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/fontchoose.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/fontchoose.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/fontchoose.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -55,10 +55,6 @@
grid $f.font - -sticky e
grid columnconfigure $f 0 -weight 1
grid rowconfigure $f 0 -weight 1
-bind $w <Visibility> {
- bind %W <Visibility> {}
- grid propagate %W.f 0
-}
## See Code / Dismiss buttons
set btns [addSeeDismiss $w.buttons $w]
@@ -67,3 +63,5 @@
grid $btns -sticky ew
grid columnconfigure $w 0 -weight 1
grid rowconfigure $w 0 -weight 1
+update idletasks
+grid propagate $f 0
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/goldberg.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/goldberg.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/goldberg.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -105,7 +105,7 @@
$w.c yview moveto .05
pack $w.c -in $w.screen -side top -fill both -expand 1
- bind $w.c <3> [list $w.pause invoke]
+ bind $w.c <Button-3> [list $w.pause invoke]
bind $w.c <Destroy> {
after cancel $animationCallbacks(goldberg)
unset animationCallbacks(goldberg)
@@ -162,7 +162,7 @@
grid $w.speed -in $w.ctrl -row 99 -sticky ew -pady {0 5}
pack $w.speed.scale -fill both -expand 1
grid $w.about -in $w.ctrl -row 100 -sticky ew
- bind $w.reset <3> {set S(mode) -1} ;# Debugging
+ bind $w.reset <Button-3> {set S(mode) -1} ;# Debugging
## See Code / Dismiss buttons hack!
set btns [addSeeDismiss $w.ctrl.buttons $w]
@@ -342,7 +342,7 @@
set xy {719 119 763 119}
$w.c create line $xy -tag I0 -fill $color -width 5 -arrow last \
-arrowshape {18 18 5}
- $w.c bind I0 <1> Start
+ $w.c bind I0 <Button-1> Start
}
proc Move0 {w {step {}}} {
set step [GetStep 0 $step]
@@ -372,7 +372,7 @@
set xy [box 812 122 9]
$w.c create oval $xy -tag I1 -fill $color2 -outline {}
- $w.c bind I1 <1> Start
+ $w.c bind I1 <Button-1> Start
}
proc Move1 {w {step {}}} {
set step [GetStep 1 $step]
@@ -1620,7 +1620,7 @@
$w.c delete I24 I26
$w.c create text 430 755 -anchor s -tag I26 \
-text "click to continue" -font {{Times Roman} 24 bold}
- bind $w.c <1> [list Reset $w]
+ bind $w.c <Button-1> [list Reset $w]
return 4
}
@@ -1675,7 +1675,7 @@
proc Reset {w} {
global S
DrawAll $w
- bind $w.c <1> {}
+ bind $w.c <Button-1> {}
set S(mode) $::MSTART
set S(active) 0
}
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/image2.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/image2.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/image2.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -95,7 +95,7 @@
ttk::scrollbar $w.f.scroll -command "$w.f.list yview"
pack $w.f.list $w.f.scroll -side left -fill y -expand 1
$w.f.list insert 0 earth.gif earthris.gif teapot.ppm
-bind $w.f.list <Double-1> "loadImage $w %x %y"
+bind $w.f.list <Double-Button-1> "loadImage $w %x %y"
catch {image delete image2a}
image create photo image2a
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/items.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/items.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/items.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -17,7 +17,7 @@
positionWindow $w
set c $w.frame.c
-label $w.msg -font $font -wraplength 5i -justify left -text "This window contains a canvas widget with examples of the various kinds of items supported by canvases. The following operations are supported:\n Button-1 drag:\tmoves item under pointer.\n Button-2 drag:\trepositions view.\n Button-3 drag:\tstrokes out area.\n Ctrl+f:\t\tprints items under area."
+label $w.msg -font $font -wraplength 5i -justify left -text "This window contains a canvas widget with examples of the various kinds of items supported by canvases. The following operations are supported:\n Left-Button drag:\tmoves item under pointer.\n Middle-Button drag:\trepositions view.\n Right-Button drag:\tstrokes out area.\n Ctrl+f:\t\tprints items under area."
pack $w.msg -side top
## See Code / Dismiss buttons
@@ -171,14 +171,21 @@
# Set up event bindings for canvas:
-$c bind item <Any-Enter> "itemEnter $c"
-$c bind item <Any-Leave> "itemLeave $c"
-bind $c <2> "$c scan mark %x %y"
-bind $c <B2-Motion> "$c scan dragto %x %y"
-bind $c <3> "itemMark $c %x %y"
-bind $c <B3-Motion> "itemStroke $c %x %y"
+$c bind item <Enter> "itemEnter $c"
+$c bind item <Leave> "itemLeave $c"
+if {[tk windowingsystem] eq "aqua" && ![package vsatisfies [package provide Tk] 8.7-]} {
+ bind $c <Button-2> "itemMark $c %x %y"
+ bind $c <B2-Motion> "itemStroke $c %x %y"
+ bind $c <Button-3> "$c scan mark %x %y"
+ bind $c <B3-Motion> "$c scan dragto %x %y"
+} else {
+ bind $c <Button-2> "$c scan mark %x %y"
+ bind $c <B2-Motion> "$c scan dragto %x %y"
+ bind $c <Button-3> "itemMark $c %x %y"
+ bind $c <B3-Motion> "itemStroke $c %x %y"
+}
bind $c <<NextChar>> "itemsUnderArea $c"
-bind $c <1> "itemStartDrag $c %x %y"
+bind $c <Button-1> "itemStartDrag $c %x %y"
bind $c <B1-Motion> "itemDrag $c %x %y"
# Utility procedures for highlighting the item under the pointer:
@@ -250,7 +257,7 @@
set area [$c find withtag area]
set items ""
foreach i [$c find enclosed $areaX1 $areaY1 $areaX2 $areaY2] {
- if {[lsearch [$c gettags $i] item] != -1} {
+ if {[lsearch [$c gettags $i] item] >= 0} {
lappend items $i
}
}
@@ -257,7 +264,7 @@
puts stdout "Items enclosed by area: $items"
set items ""
foreach i [$c find overlapping $areaX1 $areaY1 $areaX2 $areaY2] {
- if {[lsearch [$c gettags $i] item] != -1} {
+ if {[lsearch [$c gettags $i] item] >= 0} {
lappend items $i
}
}
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/ixset
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/ixset 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/ixset 2021-03-02 16:29:37 UTC (rev 58056)
@@ -54,7 +54,7 @@
global screencyc ; set screencyc 600
set xfd [open "|xset q" r]
- while {[gets $xfd line] > -1} {
+ while {[gets $xfd line] >= 0} {
switch -- [lindex $line 0] {
auto {
set rpt [lindex $line 1]
@@ -197,7 +197,7 @@
bind . <Return> {.buttons.ok flash; .buttons.ok invoke}
bind . <Escape> {.buttons.quit flash; .buttons.quit invoke}
- bind . <1> {
+ bind . <Button-1> {
if {![string match .buttons* %W]} {
.buttons.apply configure -state normal
.buttons.cancel configure -state normal
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/knightstour.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/knightstour.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/knightstour.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -21,7 +21,7 @@
# If you let it repeat then it will choose random start positions
# for each new tour.
-package require Tk 8.5
+package require Tk
# Return a list of accessible squares from a given square
proc ValidMoves {square} {
@@ -29,7 +29,7 @@
foreach pair {{-1 -2} {-2 -1} {-2 1} {-1 2} {1 2} {2 1} {2 -1} {1 -2}} {
set col [expr {($square % 8) + [lindex $pair 0]}]
set row [expr {($square / 8) + [lindex $pair 1]}]
- if {$row > -1 && $row < 8 && $col > -1 && $col < 8} {
+ if {$row >= 0 && $row < 8 && $col >= 0 && $col < 8} {
lappend moves [expr {$row * 8 + $col}]
}
}
@@ -41,7 +41,7 @@
variable visited
set moves 0
foreach test [ValidMoves $square] {
- if {[lsearch -exact -integer $visited $test] == -1} {
+ if {[lsearch -exact -integer $visited $test] < 0} {
incr moves
}
}
@@ -55,7 +55,7 @@
set minimum 9
set nextSquare -1
foreach testSquare [ValidMoves $square] {
- if {[lsearch -exact -integer $visited $testSquare] == -1} {
+ if {[lsearch -exact -integer $visited $testSquare] < 0} {
set count [CheckSquare $testSquare]
if {$count < $minimum} {
set minimum $count
@@ -190,7 +190,7 @@
ttk::button $dlg.tf.b1 -text Start -command [list Tour $dlg]
ttk::button $dlg.tf.b2 -text Exit -command [list Exit $dlg]
set square 0
- for {set row 7} {$row != -1} {incr row -1} {
+ for {set row 7} {$row >= 0} {incr row -1} {
for {set col 0} {$col < 8} {incr col} {
if {(($col & 1) ^ ($row & 1))} {
set fill tan3 ; set dfill tan4
@@ -218,7 +218,7 @@
-fill black -activefill "#600000"
}
$c moveto knight {*}[lrange [$c coords [expr {1 + int(rand() * 64)}]] 0 1]
- $c bind knight <ButtonPress-1> [namespace code [list DragStart %W %x %y]]
+ $c bind knight <Button-1> [namespace code [list DragStart %W %x %y]]
$c bind knight <Motion> [namespace code [list DragMotion %W %x %y]]
$c bind knight <ButtonRelease-1> [namespace code [list DragEnd %W %x %y]]
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/menu.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/menu.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/menu.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -63,7 +63,7 @@
}
foreach i {A B C D E F} {
$m add command -label "Print letter \"$i\"" -underline 14 \
- -accelerator Meta+$i -command "puts $i" -accelerator $modifier+$i
+ -accelerator $modifier+$i -command "puts $i"
bind $w <$modifier-[string tolower $i]> "puts $i"
}
@@ -144,9 +144,24 @@
set m $w.menu.colors
$w.menu add cascade -label "Colors" -menu $m -underline 1
menu $m -tearoff 1
-foreach i {red orange yellow green blue} {
- $m add command -label $i -background $i -command [list \
- puts "You invoked \"$i\"" ]
+if {[tk windowingsystem] eq "aqua"} {
+ # Aqua ignores the -background and -foreground options, but a compound
+ # button can be used for selecting colors.
+ foreach i {red orange yellow green blue} {
+ image create photo image_$i -height 16 -width 16
+ image_$i put black -to 0 0 16 1
+ image_$i put black -to 0 1 1 16
+ image_$i put black -to 0 15 16 16
+ image_$i put black -to 15 1 16 16
+ image_$i put $i -to 1 1 15 15
+ $m add command -label $i -image image_$i -compound left -command [list \
+ puts "You invoked \"$i\"" ]
+ }
+} else {
+ foreach i {red orange yellow green blue} {
+ $m add command -label $i -background $i -command [list \
+ puts "You invoked \"$i\"" ]
+ }
}
$w configure -menu $w.menu
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/pendulum.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/pendulum.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/pendulum.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -113,7 +113,7 @@
after cancel $animationCallbacks(pendulum)
unset animationCallbacks(pendulum)
}
-bind $w.c <1> {
+bind $w.c <Button-1> {
after cancel $animationCallbacks(pendulum)
showPendulum %W at %x %y
}
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/plot.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/plot.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/plot.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -55,9 +55,9 @@
$c addtag point withtag $item
}
-$c bind point <Any-Enter> "$c itemconfig current -fill red"
-$c bind point <Any-Leave> "$c itemconfig current -fill SkyBlue2"
-$c bind point <1> "plotDown $c %x %y"
+$c bind point <Enter> "$c itemconfig current -fill red"
+$c bind point <Leave> "$c itemconfig current -fill SkyBlue2"
+$c bind point <Button-1> "plotDown $c %x %y"
$c bind point <ButtonRelease-1> "$c dtag selected"
bind $c <B1-Motion> "plotMove $c %x %y"
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/ruler.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/ruler.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/ruler.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -77,10 +77,10 @@
$c addtag well withtag [rulerMkTab $c [winfo pixels $c 13.5c] \
[winfo pixels $c .65c]]
-$c bind well <1> "rulerNewTab $c %x %y"
-$c bind tab <1> "rulerSelectTab $c %x %y"
+$c bind well <Button-1> "rulerNewTab $c %x %y"
+$c bind tab <Button-1> "rulerSelectTab $c %x %y"
bind $c <B1-Motion> "rulerMoveTab $c %x %y"
-bind $c <Any-ButtonRelease-1> "rulerReleaseTab $c"
+bind $c <ButtonRelease-1> "rulerReleaseTab $c"
# rulerNewTab --
# Does all the work of creating a tab stop, including creating the
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/tclIndex
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/tclIndex 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/tclIndex 2021-03-02 16:29:37 UTC (rev 58056)
@@ -6,62 +6,62 @@
# element name is the name of a command and the value is
# a script that loads the command.
-set auto_index(arrowSetup) [list source [file join $dir arrow.tcl]]
-set auto_index(arrowMove1) [list source [file join $dir arrow.tcl]]
-set auto_index(arrowMove2) [list source [file join $dir arrow.tcl]]
-set auto_index(arrowMove3) [list source [file join $dir arrow.tcl]]
-set auto_index(textLoadFile) [list source [file join $dir search.tcl]]
-set auto_index(textSearch) [list source [file join $dir search.tcl]]
-set auto_index(textToggle) [list source [file join $dir search.tcl]]
-set auto_index(itemEnter) [list source [file join $dir items.tcl]]
-set auto_index(itemLeave) [list source [file join $dir items.tcl]]
-set auto_index(itemMark) [list source [file join $dir items.tcl]]
-set auto_index(itemStroke) [list source [file join $dir items.tcl]]
-set auto_index(itemsUnderArea) [list source [file join $dir items.tcl]]
-set auto_index(itemStartDrag) [list source [file join $dir items.tcl]]
-set auto_index(itemDrag) [list source [file join $dir items.tcl]]
-set auto_index(butPress) [list source [file join $dir items.tcl]]
-set auto_index(loadDir) [list source [file join $dir image2.tcl]]
-set auto_index(loadImage) [list source [file join $dir image2.tcl]]
-set auto_index(rulerMkTab) [list source [file join $dir ruler.tcl]]
-set auto_index(rulerNewTab) [list source [file join $dir ruler.tcl]]
-set auto_index(rulerSelectTab) [list source [file join $dir ruler.tcl]]
-set auto_index(rulerMoveTab) [list source [file join $dir ruler.tcl]]
-set auto_index(rulerReleaseTab) [list source [file join $dir ruler.tcl]]
-set auto_index(mkTextConfig) [list source [file join $dir ctext.tcl]]
-set auto_index(textEnter) [list source [file join $dir ctext.tcl]]
-set auto_index(textInsert) [list source [file join $dir ctext.tcl]]
-set auto_index(textPaste) [list source [file join $dir ctext.tcl]]
-set auto_index(textB1Press) [list source [file join $dir ctext.tcl]]
-set auto_index(textB1Move) [list source [file join $dir ctext.tcl]]
-set auto_index(textBs) [list source [file join $dir ctext.tcl]]
-set auto_index(textDel) [list source [file join $dir ctext.tcl]]
-set auto_index(bitmapRow) [list source [file join $dir bitmap.tcl]]
-set auto_index(scrollEnter) [list source [file join $dir cscroll.tcl]]
-set auto_index(scrollLeave) [list source [file join $dir cscroll.tcl]]
-set auto_index(scrollButton) [list source [file join $dir cscroll.tcl]]
-set auto_index(textWindOn) [list source [file join $dir twind.tcl]]
-set auto_index(textWindOff) [list source [file join $dir twind.tcl]]
-set auto_index(textWindPlot) [list source [file join $dir twind.tcl]]
-set auto_index(embPlotDown) [list source [file join $dir twind.tcl]]
-set auto_index(embPlotMove) [list source [file join $dir twind.tcl]]
-set auto_index(textWindDel) [list source [file join $dir twind.tcl]]
-set auto_index(embDefBg) [list source [file join $dir twind.tcl]]
-set auto_index(floorDisplay) [list source [file join $dir floor.tcl]]
-set auto_index(newRoom) [list source [file join $dir floor.tcl]]
-set auto_index(roomChanged) [list source [file join $dir floor.tcl]]
-set auto_index(bg1) [list source [file join $dir floor.tcl]]
-set auto_index(bg2) [list source [file join $dir floor.tcl]]
-set auto_index(bg3) [list source [file join $dir floor.tcl]]
-set auto_index(fg1) [list source [file join $dir floor.tcl]]
-set auto_index(fg2) [list source [file join $dir floor.tcl]]
-set auto_index(fg3) [list source [file join $dir floor.tcl]]
-set auto_index(setWidth) [list source [file join $dir hscale.tcl]]
-set auto_index(plotDown) [list source [file join $dir plot.tcl]]
-set auto_index(plotMove) [list source [file join $dir plot.tcl]]
-set auto_index(puzzleSwitch) [list source [file join $dir puzzle.tcl]]
-set auto_index(setHeight) [list source [file join $dir vscale.tcl]]
-set auto_index(showMessageBox) [list source [file join $dir msgbox.tcl]]
-set auto_index(setColor) [list source [file join $dir clrpick.tcl]]
-set auto_index(setColor_helper) [list source [file join $dir clrpick.tcl]]
-set auto_index(fileDialog) [list source [file join $dir filebox.tcl]]
+set auto_index(arrowSetup) [list source -encoding utf-8 [file join $dir arrow.tcl]]
+set auto_index(arrowMove1) [list source -encoding utf-8 [file join $dir arrow.tcl]]
+set auto_index(arrowMove2) [list source -encoding utf-8 [file join $dir arrow.tcl]]
+set auto_index(arrowMove3) [list source -encoding utf-8 [file join $dir arrow.tcl]]
+set auto_index(textLoadFile) [list source -encoding utf-8 [file join $dir search.tcl]]
+set auto_index(textSearch) [list source -encoding utf-8 [file join $dir search.tcl]]
+set auto_index(textToggle) [list source -encoding utf-8 [file join $dir search.tcl]]
+set auto_index(itemEnter) [list source -encoding utf-8 [file join $dir items.tcl]]
+set auto_index(itemLeave) [list source -encoding utf-8 [file join $dir items.tcl]]
+set auto_index(itemMark) [list source -encoding utf-8 [file join $dir items.tcl]]
+set auto_index(itemStroke) [list source -encoding utf-8 [file join $dir items.tcl]]
+set auto_index(itemsUnderArea) [list source -encoding utf-8 [file join $dir items.tcl]]
+set auto_index(itemStartDrag) [list source -encoding utf-8 [file join $dir items.tcl]]
+set auto_index(itemDrag) [list source -encoding utf-8 [file join $dir items.tcl]]
+set auto_index(butPress) [list source -encoding utf-8 [file join $dir items.tcl]]
+set auto_index(loadDir) [list source -encoding utf-8 [file join $dir image2.tcl]]
+set auto_index(loadImage) [list source -encoding utf-8 [file join $dir image2.tcl]]
+set auto_index(rulerMkTab) [list source -encoding utf-8 [file join $dir ruler.tcl]]
+set auto_index(rulerNewTab) [list source -encoding utf-8 [file join $dir ruler.tcl]]
+set auto_index(rulerSelectTab) [list source -encoding utf-8 [file join $dir ruler.tcl]]
+set auto_index(rulerMoveTab) [list source -encoding utf-8 [file join $dir ruler.tcl]]
+set auto_index(rulerReleaseTab) [list source -encoding utf-8 [file join $dir ruler.tcl]]
+set auto_index(mkTextConfig) [list source -encoding utf-8 [file join $dir ctext.tcl]]
+set auto_index(textEnter) [list source -encoding utf-8 [file join $dir ctext.tcl]]
+set auto_index(textInsert) [list source -encoding utf-8 [file join $dir ctext.tcl]]
+set auto_index(textPaste) [list source -encoding utf-8 [file join $dir ctext.tcl]]
+set auto_index(textB1Press) [list source -encoding utf-8 [file join $dir ctext.tcl]]
+set auto_index(textB1Move) [list source -encoding utf-8 [file join $dir ctext.tcl]]
+set auto_index(textBs) [list source -encoding utf-8 [file join $dir ctext.tcl]]
+set auto_index(textDel) [list source -encoding utf-8 [file join $dir ctext.tcl]]
+set auto_index(bitmapRow) [list source -encoding utf-8 [file join $dir bitmap.tcl]]
+set auto_index(scrollEnter) [list source -encoding utf-8 [file join $dir cscroll.tcl]]
+set auto_index(scrollLeave) [list source -encoding utf-8 [file join $dir cscroll.tcl]]
+set auto_index(scrollButton) [list source -encoding utf-8 [file join $dir cscroll.tcl]]
+set auto_index(textWindOn) [list source -encoding utf-8 [file join $dir twind.tcl]]
+set auto_index(textWindOff) [list source -encoding utf-8 [file join $dir twind.tcl]]
+set auto_index(textWindPlot) [list source -encoding utf-8 [file join $dir twind.tcl]]
+set auto_index(embPlotDown) [list source -encoding utf-8 [file join $dir twind.tcl]]
+set auto_index(embPlotMove) [list source -encoding utf-8 [file join $dir twind.tcl]]
+set auto_index(textWindDel) [list source -encoding utf-8 [file join $dir twind.tcl]]
+set auto_index(embDefBg) [list source -encoding utf-8 [file join $dir twind.tcl]]
+set auto_index(floorDisplay) [list source -encoding utf-8 [file join $dir floor.tcl]]
+set auto_index(newRoom) [list source -encoding utf-8 [file join $dir floor.tcl]]
+set auto_index(roomChanged) [list source -encoding utf-8 [file join $dir floor.tcl]]
+set auto_index(bg1) [list source -encoding utf-8 [file join $dir floor.tcl]]
+set auto_index(bg2) [list source -encoding utf-8 [file join $dir floor.tcl]]
+set auto_index(bg3) [list source -encoding utf-8 [file join $dir floor.tcl]]
+set auto_index(fg1) [list source -encoding utf-8 [file join $dir floor.tcl]]
+set auto_index(fg2) [list source -encoding utf-8 [file join $dir floor.tcl]]
+set auto_index(fg3) [list source -encoding utf-8 [file join $dir floor.tcl]]
+set auto_index(setWidth) [list source -encoding utf-8 [file join $dir hscale.tcl]]
+set auto_index(plotDown) [list source -encoding utf-8 [file join $dir plot.tcl]]
+set auto_index(plotMove) [list source -encoding utf-8 [file join $dir plot.tcl]]
+set auto_index(puzzleSwitch) [list source -encoding utf-8 [file join $dir puzzle.tcl]]
+set auto_index(setHeight) [list source -encoding utf-8 [file join $dir vscale.tcl]]
+set auto_index(showMessageBox) [list source -encoding utf-8 [file join $dir msgbox.tcl]]
+set auto_index(setColor) [list source -encoding utf-8 [file join $dir clrpick.tcl]]
+set auto_index(setColor_helper) [list source -encoding utf-8 [file join $dir clrpick.tcl]]
+set auto_index(fileDialog) [list source -encoding utf-8 [file join $dir filebox.tcl]]
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/tcolor
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/tcolor 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/tcolor 2021-03-02 16:29:37 UTC (rev 58056)
@@ -7,7 +7,7 @@
# create colors using either the RGB, HSB, or CYM color spaces
# and apply the color to existing applications.
-package require Tk 8.4
+package require Tk
wm title . "Color Editor"
# Global variables that control the program:
@@ -90,7 +90,7 @@
grid columnconfigure . 0 -weight 1
listbox .names.lb -width 20 -height 12 -yscrollcommand ".names.s set" \
-exportselection false
- bind .names.lb <Double-1> {
+ bind .names.lb <Double-Button-1> {
tc_loadNamedColor [.names.lb get [.names.lb curselection]]
}
scrollbar .names.s -orient vertical -command ".names.lb yview"
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/text.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/text.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/text.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -57,8 +57,9 @@
1. Scrolling. Use the scrollbar to adjust the view in the text window.
-2. Scanning. Press mouse button 2 in the text window and drag up or down.
-This will drag the text at high speed to allow you to scan its contents.
+2. Scanning. Press the middle mouse button in the text window and drag up
+or down. This will drag the text at high speed to allow you to scan its
+contents.
3. Insert text. Press mouse button 1 to set the insertion cursor, then
type text. What you type will be added to the widget.
@@ -77,7 +78,8 @@
6. Copy the selection. To copy the selection into this window, select
what you want to copy (either here or in another application), then
-click button 2 to copy the selection to the point of the mouse cursor.
+click the middle mouse button to copy the selection to the point of the
+mouse cursor.
7. Edit. Text widgets support the standard Motif editing characters
plus many Emacs editing characters. Backspace and Control-h erase the
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/tree.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/tree.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/tree.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -39,6 +39,7 @@
set path [$tree set $node fullpath]
$tree delete [$tree children $node]
foreach f [lsort -dictionary [glob -nocomplain -dir $path *]] {
+ set f [file normalize $f]
set type [file type $f]
set id [$tree insert $node end -text [file tail $f] \
-values [list $f $type]]
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/twind.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/twind.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/twind.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -265,9 +265,9 @@
$c addtag point withtag $item
}
- $c bind point <Any-Enter> "$c itemconfig current -fill red"
- $c bind point <Any-Leave> "$c itemconfig current -fill SkyBlue2"
- $c bind point <1> "embPlotDown $c %x %y"
+ $c bind point <Enter> "$c itemconfig current -fill red"
+ $c bind point <Leave> "$c itemconfig current -fill SkyBlue2"
+ $c bind point <Button-1> "embPlotDown $c %x %y"
$c bind point <ButtonRelease-1> "$c dtag selected"
bind $c <B1-Motion> "embPlotMove $c %x %y"
return $c
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/unicodeout.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/unicodeout.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/unicodeout.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -109,10 +109,10 @@
}
addSample $w "Trad. Chinese" "\u4E2D\u570B\u7684\u6F22\u5B57"
addSample $w "Simpl. Chinese" "\u6C49\u8BED"
-addSample $w French "Langue fran\u00E7aise"
+addSample $w French "Langue fran\xE7aise"
addSample $w Greek \
- "\u0395\u03BB\u03BB\u03B7\u03BD\u03B9\u03BA\u03AE " \
- "\u03B3\u03BB\u03CE\u03C3\u03C3\u03B1"
+ "\u0395\u03BB\u03BB\u03B7\u03BD\u03B9\u03BA\u03AE " \
+ "\u03B3\u03BB\u03CE\u03C3\u03C3\u03B1"
if {[usePresentationFormsFor Hebrew]} {
# Visual order (pre-layouted)
addSample $w Hebrew \
@@ -123,17 +123,21 @@
"\u05DB\u05EA\u05D1 \u05E2\u05D1\u05E8\u05D9\u05EA"
}
addSample $w Hindi \
- "\u0939\u093f\u0928\u094d\u0926\u0940 \u092d\u093e\u0937\u093e"
-addSample $w Icelandic "\u00CDslenska"
+ "\u0939\u093F\u0928\u094D\u0926\u0940 \u092D\u093E\u0937\u093E"
+addSample $w Icelandic "\xCDslenska"
addSample $w Japanese \
- "\u65E5\u672C\u8A9E\u306E\u3072\u3089\u304C\u306A, " \
- "\u6F22\u5B57\u3068\u30AB\u30BF\u30AB\u30CA"
+ "\u65E5\u672C\u8A9E\u306E\u3072\u3089\u304C\u306A, " \
+ "\u6F22\u5B57\u3068\u30AB\u30BF\u30AB\u30CA"
addSample $w Korean "\uB300\uD55C\uBBFC\uAD6D\uC758 \uD55C\uAE00"
addSample $w Russian \
"\u0420\u0443\u0441\u0441\u043A\u0438\u0439 \u044F\u0437\u044B\u043A"
-if {[tk windowingsystem] ne "x11"} {
- addSample $w Emoji \
- "\uD83D\uDE00\uD83D\uDCA9\uD83D\uDC4D\uD83C\uDDF3\uD83C\uDDF1"
+if {([tk windowingsystem] ne "x11") || (![catch {tk::pkgconfig get fontsystem} fs] && ($fs eq "xft"))} {
+ if {[package vsatisfies [package provide Tcl] 8.7-]} {
+ addSample $w Emoji "😀💩👍🇳🇱"
+ } else {
+ addSample $w Emoji \
+ "\uD83D\uDE00\uD83D\uDCA9\uD83D\uDC4D\uD83C\uDDF3\uD83C\uDDF1"
+ }
}
## We're done processing, so change things back to normal running...
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/widget
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/widget 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/demos/widget 2021-03-02 16:29:37 UTC (rev 58056)
@@ -83,12 +83,20 @@
# Note that this is run through the message catalog! This is because this is
# actually an image of a word.
-image create photo ::img::new -format GIF -data [mc {
- R0lGODlhHgAOALMPALMAANyIiOu7u8dEROaqqvru7sxVVeGZmbgREfXd3b0iItZ3
- d8IzM9FmZvDMzP///yH5BAEAAA8ALAAAAAAeAA4AAASa8MlJq7046827WVOCHEkw
- nANhUgJlEBIABJIwL3K+4IcUALCHjfbItYZDSgJgkBiYPmBMAUAkkLPKs/BAyLgM
- wAQwOAAY2ByCaw4QAFQSoDEePJ6DmU1xInYZTw5nOEFFdgVUelkVDTIMd3AKFGQ1
- MgI2AwEmQW8APZ0gdRONAks5nhIFVVxdAAkUAS2pAVwFl7ITB4UqHb0XEQA7
+image create photo ::img::new -format PNG -data [mc {
+ iVBORw0KGgoAAAANSUhEUgAAAB4AAAAOCAYAAAA45qw5AAACMElEQVR4AeVTAwxd
+ QRCc2tZHGtQ2w9q2bdsOa9u2bUW1bdt2Z372JZe6DapJLqtb3h7+T8yKi5j4CsYD
+ EUQXxETclT7kWOlH2VV+tFkdQHPSwksSISF+BauCqL0qgOcMWgGfgEkaMsHxqUBk
+ 3plE/sOnh/qDPAPJH/CKFBivGHWzFwBRnHhlqbu1Mh6CoFNnC/JshQ9p4YC2lrKt
+ DCAV+THiVejyhMjAbrNSrroiEfKR9g7ZfCgOog8QfnUQV62wAk68ndQ9ZbyoWO1H
+ Y6eDY1LCQL6a9ApOp9Hi1T0+gQq2JKMlky/oTKQliKWxEZvyG575kpW4pl1aZnQK
+ CLOVt45Lkp8uXp2SL8KO6uitNTZLdpK6s+I/eZbhpmsmWeOGOVQNKYLITzpKPAO3
+ tY7LSNZ7ccSLxX9y3uuOxRkg3dKESMoCHvL+GRVCutXsB3guLgDCeXOv4iWWkvwG
+ BaS+PmlpK6SI9ApI2oC2UtrwZQEkhkH+NtolVlQXJl1I+QltuU3XEc721bIRFpa8
+ IA5iqTo6vNNWmkNBLQbPeXwF2g17Q94nTQAfY3YzeY+WSu8MDzQ2kpELUhSGJUHE
+ 0zeR3rY1L+Xl5G/re+jbiK6KhThwwInsts1fbMUUcpZszKeVtggZEiGdZDe5AtHh
+ 7vL4CGiRvvKPS8FAvq9Nr4ZkFadR2y6kggu1z4vlyIbBp6BugQ8JLEg4bTkD9eMZ
+ QZ8hpJ3VvTtuvbWrY/ElvP/9R+Aj3603+iE3fkEAAAAASUVORK5CYII=
}]
#----------------------------------------------------------------
@@ -186,6 +194,10 @@
-foreground blue -underline 1
.t tag configure visited -lmargin1 1c -lmargin2 1c \
-foreground #303080 -underline 1
+ if {[tk windowingsystem] eq "aqua"} {
+ .t tag configure demo -foreground systemLinkColor
+ .t tag configure visited -foreground purple
+ }
.t tag configure hot -foreground red -underline 1
}
.t tag bind demo <ButtonRelease-1> {
@@ -504,7 +516,7 @@
.t configure -cursor [::ttk::cursor busy]
update
set demo [string range [lindex $tags $i] 5 end]
- uplevel 1 [list source [file join $tk_demoDirectory $demo.tcl]]
+ uplevel 1 [list source -encoding utf-8 [file join $tk_demoDirectory $demo.tcl]]
update
.t configure -cursor $cursor
@@ -612,6 +624,7 @@
wm title $top [mc "Demo code: %s" [file join $tk_demoDirectory $file]]
wm iconname $top $file
set id [open [file join $tk_demoDirectory $file]]
+ fconfigure $id -encoding utf-8 -eofchar \032
$top.f.text delete 1.0 end
$top.f.text insert 1.0 [read $id]
$top.f.text mark set insert 1.0
@@ -710,10 +723,10 @@
proc tkAboutDialog {} {
tk_messageBox -icon info -type ok -title [mc "About Widget Demo"] \
-message [mc "Tk widget demonstration application"] -detail \
-"[mc "Copyright \u00a9 %s" {1996-1997 Sun Microsystems, Inc.}]
-[mc "Copyright \u00a9 %s" {1997-2000 Ajuba Solutions, Inc.}]
-[mc "Copyright \u00a9 %s" {2001-2009 Donal K. Fellows}]
-[mc "Copyright \u00a9 %s" {2002-2007 Daniel A. Steffen}]"
+"[mc "Copyright \xA9 %s" {1996-1997 Sun Microsystems, Inc.}]
+[mc "Copyright \xA9 %s" {1997-2000 Ajuba Solutions, Inc.}]
+[mc "Copyright \xA9 %s" {2001-2009 Donal K. Fellows}]
+[mc "Copyright \xA9 %s" {2002-2007 Daniel A. Steffen}]"
}
# Local Variables:
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/entry.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/entry.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/entry.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -58,7 +58,7 @@
}
bind Entry <<Clear>> {
# ignore if there is no selection
- catch { %W delete sel.first sel.last }
+ catch {%W delete sel.first sel.last}
}
bind Entry <<PasteSelection>> {
if {$tk_strictMotif || ![info exists tk::Priv(mouseMoved)]
@@ -74,7 +74,7 @@
# Standard Motif bindings:
-bind Entry <1> {
+bind Entry <Button-1> {
tk::EntryButton1 %W %x
%W selection clear
}
@@ -82,25 +82,25 @@
set tk::Priv(x) %x
tk::EntryMouseSelect %W %x
}
-bind Entry <Double-1> {
+bind Entry <Double-Button-1> {
set tk::Priv(selectMode) word
tk::EntryMouseSelect %W %x
catch {%W icursor sel.last}
}
-bind Entry <Triple-1> {
+bind Entry <Triple-Button-1> {
set tk::Priv(selectMode) line
tk::EntryMouseSelect %W %x
catch {%W icursor sel.last}
}
-bind Entry <Shift-1> {
+bind Entry <Shift-Button-1> {
set tk::Priv(selectMode) char
%W selection adjust @%x
}
-bind Entry <Double-Shift-1> {
+bind Entry <Double-Shift-Button-1> {
set tk::Priv(selectMode) word
tk::EntryMouseSelect %W %x
}
-bind Entry <Triple-Shift-1> {
+bind Entry <Triple-Shift-Button-1> {
set tk::Priv(selectMode) line
tk::EntryMouseSelect %W %x
}
@@ -114,22 +114,22 @@
bind Entry <ButtonRelease-1> {
tk::CancelRepeat
}
-bind Entry <Control-1> {
+bind Entry <Control-Button-1> {
%W icursor @%x
}
bind Entry <<PrevChar>> {
- tk::EntrySetCursor %W [expr {[%W index insert] - 1}]
+ tk::EntrySetCursor %W [expr {[%W index insert]-1}]
}
bind Entry <<NextChar>> {
- tk::EntrySetCursor %W [expr {[%W index insert] + 1}]
+ tk::EntrySetCursor %W [expr {[%W index insert]+1}]
}
bind Entry <<SelectPrevChar>> {
- tk::EntryKeySelect %W [expr {[%W index insert] - 1}]
+ tk::EntryKeySelect %W [expr {[%W index insert]-1}]
tk::EntrySeeInsert %W
}
bind Entry <<SelectNextChar>> {
- tk::EntryKeySelect %W [expr {[%W index insert] + 1}]
+ tk::EntryKeySelect %W [expr {[%W index insert]+1}]
tk::EntrySeeInsert %W
}
bind Entry <<PrevWord>> {
@@ -190,7 +190,7 @@
bind Entry <<SelectNone>> {
%W selection clear
}
-bind Entry <KeyPress> {
+bind Entry <Key> {
tk::CancelRepeat
tk::EntryInsert %W %A
}
@@ -197,12 +197,12 @@
# 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, Return, and Tab.
-bind Entry <Alt-KeyPress> {# nothing}
-bind Entry <Meta-KeyPress> {# nothing}
-bind Entry <Control-KeyPress> {# nothing}
+bind Entry <Alt-Key> {# nothing}
+bind Entry <Meta-Key> {# nothing}
+bind Entry <Control-Key> {# nothing}
bind Entry <Escape> {# nothing}
bind Entry <Return> {# nothing}
bind Entry <KP_Enter> {# nothing}
@@ -210,7 +210,7 @@
bind Entry <Prior> {# nothing}
bind Entry <Next> {# nothing}
if {[tk windowingsystem] eq "aqua"} {
- bind Entry <Command-KeyPress> {# nothing}
+ bind Entry <Command-Key> {# nothing}
}
# Tk-on-Cocoa generates characters for these two keys. [Bug 2971663]
bind Entry <<NextLine>> {# nothing}
@@ -278,7 +278,7 @@
dict set ::tk::Priv(IMETextMark) "%W" [%W index insert]
}
bind Entry <<TkEndIMEMarkedText>> {
- if { [catch {dict get $::tk::Priv(IMETextMark) "%W"} mark] } {
+ if {[catch {dict get $::tk::Priv(IMETextMark) "%W"} mark]} {
bell
} else {
%W selection range $mark insert
@@ -293,15 +293,28 @@
# A few additional bindings of my own.
-bind Entry <2> {
- if {!$tk_strictMotif} {
- ::tk::EntryScanMark %W %x
+if {[tk windowingsystem] ne "aqua"} {
+ bind Entry <Button-2> {
+ if {!$tk_strictMotif} {
+ ::tk::EntryScanMark %W %x
+ }
}
-}
-bind Entry <B2-Motion> {
- if {!$tk_strictMotif} {
- ::tk::EntryScanDrag %W %x
+ bind Entry <B2-Motion> {
+ if {!$tk_strictMotif} {
+ ::tk::EntryScanDrag %W %x
+ }
}
+} else {
+ bind Entry <Button-3> {
+ if {!$tk_strictMotif} {
+ ::tk::EntryScanMark %W %x
+ }
+ }
+ bind Entry <B3-Motion> {
+ if {!$tk_strictMotif} {
+ ::tk::EntryScanDrag %W %x
+ }
+ }
}
# ::tk::EntryClosestGap --
@@ -378,10 +391,10 @@
word {
if {$cur < $anchor} {
set before [tcl_wordBreakBefore [$w get] $cur]
- set after [tcl_wordBreakAfter [$w get] [expr {$anchor-1}]]
+ set after [tcl_wordBreakAfter [$w get] $anchor-1]
} elseif {$cur > $anchor} {
set before [tcl_wordBreakBefore [$w get] $anchor]
- set after [tcl_wordBreakAfter [$w get] [expr {$cur - 1}]]
+ set after [tcl_wordBreakAfter [$w get] $cur-1]
} else {
if {[$w index @$Priv(pressX)] < $anchor} {
incr anchor -1
@@ -505,9 +518,9 @@
if {[$w selection present]} {
$w delete sel.first sel.last
} else {
- set x [expr {[$w index insert] - 1}]
- if {$x >= 0} {
- $w delete $x
+ set x [$w index insert]
+ if {$x > 0} {
+ $w delete [expr {$x-1}]
}
if {[$w index @0] >= [$w index insert]} {
set range [$w xview]
@@ -562,12 +575,12 @@
if {$i < [$w index end]} {
incr i
}
- set first [expr {$i-2}]
- if {$first < 0} {
+ if {$i < 2} {
return
}
+ set first [expr {$i-2}]
set data [$w get]
- set new [string index $data [expr {$i-1}]][string index $data $first]
+ set new [string index $data $i-1][string index $data $first]
$w delete $first $i
$w insert insert $new
EntrySeeInsert $w
@@ -647,7 +660,7 @@
proc ::tk::EntryScanDrag {w x} {
# Make sure these exist, as some weird situations can trigger the
# motion binding without the initial press. [Bug #220269]
- if {![info exists ::tk::Priv(x)]} { set ::tk::Priv(x) $x }
+ if {![info exists ::tk::Priv(x)]} {set ::tk::Priv(x) $x}
# allow for a delta
if {abs($x-$::tk::Priv(x)) > 2} {
set ::tk::Priv(mouseMoved) 1
@@ -664,7 +677,7 @@
proc ::tk::EntryGetSelection {w} {
set entryString [string range [$w get] [$w index sel.first] \
- [expr {[$w index sel.last] - 1}]]
+ [$w index sel.last]-1]
if {[$w cget -show] ne ""} {
return [string repeat [string index [$w cget -show] 0] \
[string length $entryString]]
@@ -671,12 +684,3 @@
}
return $entryString
}
-
-
-
-
-
-
-
-
-
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/fontchooser.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/fontchooser.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/fontchooser.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -14,11 +14,11 @@
set S(W) .__tk__fontchooser
set S(fonts) [lsort -dictionary [font families]]
set S(styles) [list \
- [::msgcat::mc "Regular"] \
- [::msgcat::mc "Italic"] \
- [::msgcat::mc "Bold"] \
- [::msgcat::mc "Bold Italic"] \
- ]
+ [::msgcat::mc "Regular"] \
+ [::msgcat::mc "Italic"] \
+ [::msgcat::mc "Bold"] \
+ [::msgcat::mc "Bold Italic"] \
+ ]
set S(sizes) {8 9 10 11 12 14 16 18 20 22 24 26 28 36 48 72}
set S(strike) 0
@@ -36,9 +36,9 @@
# Canonical versions of font families, styles, etc. for easier searching
set S(fonts,lcase) {}
- foreach font $S(fonts) { lappend S(fonts,lcase) [string tolower $font]}
+ foreach font $S(fonts) {lappend S(fonts,lcase) [string tolower $font]}
set S(styles,lcase) {}
- foreach style $S(styles) { lappend S(styles,lcase) [string tolower $style]}
+ foreach style $S(styles) {lappend S(styles,lcase) [string tolower $style]}
set S(sizes,lcase) $S(sizes)
::ttk::style layout FontchooserFrame {
@@ -111,7 +111,7 @@
set cache [dict create -parent $S(-parent) -title $S(-title) \
-font $S(-font) -command $S(-command)]
- set r [tclParseConfigSpec [namespace which -variable S] $specs "" $args]
+ set r [tclParseConfigSpec [namespace which -variable S] $specs DONTSETDEFAULTS $args]
if {![winfo exists $S(-parent)]} {
set code [list TK LOOKUP WINDOW $S(-parent)]
set err "bad window path name \"$S(-parent)\""
@@ -121,7 +121,7 @@
if {[string trim $S(-title)] eq ""} {
set S(-title) [::msgcat::mc "Font"]
}
- if {[winfo exists $S(W)] && [lsearch $args -font] != -1} {
+ if {[winfo exists $S(W)] && ("-font" in $args)} {
Init $S(-font)
event generate $S(-parent) <<TkFontchooserFontChanged>>
}
@@ -145,10 +145,13 @@
wm title $S(W) $S(-title)
wm transient $S(W) [winfo toplevel $S(-parent)]
+ set scaling [tk scaling]
+ set sizeWidth [expr {int([string length [::msgcat::mc "&Size:"]] * $scaling)}]
+
set outer [::ttk::frame $S(W).outer -padding {10 10}]
::tk::AmpWidget ::ttk::label $S(W).font -text [::msgcat::mc "&Font:"]
::tk::AmpWidget ::ttk::label $S(W).style -text [::msgcat::mc "Font st&yle:"]
- ::tk::AmpWidget ::ttk::label $S(W).size -text [::msgcat::mc "&Size:"]
+ ::tk::AmpWidget ::ttk::label $S(W).size -text [::msgcat::mc "&Size:"] -width $sizeWidth
ttk::entry $S(W).efont -width 18 \
-textvariable [namespace which -variable S](font)
ttk::entry $S(W).estyle -width 10 \
@@ -199,7 +202,7 @@
set minsize(sizes) \
[expr {[font measure TkDefaultFont "-99"] + $scroll_width}]
set min [expr {$minsize(gap) * 4}]
- foreach {what width} [array get minsize] { incr min $width }
+ foreach {what width} [array get minsize] {incr min $width}
wm minsize $S(W) $min 260
bind $S(W) <Return> [namespace code [list Done 1]]
@@ -277,7 +280,7 @@
# Arguments:
# ok true if user pressed OK
#
-proc ::tk::::fontchooser::Done {ok} {
+proc ::tk::fontchooser::Done {ok} {
variable S
if {! $ok} {
@@ -327,13 +330,13 @@
set S(size) $F(-size)
set S(strike) $F(-overstrike)
set S(under) $F(-underline)
- set S(style) "Regular"
+ set S(style) [::msgcat::mc "Regular"]
if {$F(-weight) eq "bold" && $F(-slant) eq "italic"} {
- set S(style) "Bold Italic"
+ set S(style) [::msgcat::mc "Bold Italic"]
} elseif {$F(-weight) eq "bold"} {
- set S(style) "Bold"
+ set S(style) [::msgcat::mc "Bold"]
} elseif {$F(-slant) eq "italic"} {
- set S(style) "Italic"
+ set S(style) [::msgcat::mc "Italic"]
}
set S(first) 0
@@ -381,7 +384,7 @@
$S(W).l${var}s selection clear 0 end
set n [lsearch -exact $S(${var}s,lcase) $value]
$S(W).l${var}s selection set $n
- if {$n != -1} {
+ if {$n >= 0} {
set S($var) [lindex $S(${var}s) $n]
$S(W).e$var icursor end
$S(W).e$var selection clear
@@ -396,7 +399,7 @@
}
$S(W).l${var}s see $n
}
- if {!$bad} { Update }
+ if {!$bad} {Update}
$S(W).ok configure -state $nstate
}
@@ -408,11 +411,11 @@
variable S
set S(result) [list $S(font) $S(size)]
- if {$S(style) eq "Bold"} { lappend S(result) bold }
- if {$S(style) eq "Italic"} { lappend S(result) italic }
- if {$S(style) eq "Bold Italic"} { lappend S(result) bold italic}
- if {$S(strike)} { lappend S(result) overstrike}
- if {$S(under)} { lappend S(result) underline}
+ if {$S(style) eq [::msgcat::mc "Bold"]} {lappend S(result) bold}
+ if {$S(style) eq [::msgcat::mc "Italic"]} {lappend S(result) italic}
+ if {$S(style) eq [::msgcat::mc "Bold Italic"]} {lappend S(result) bold italic}
+ if {$S(strike)} {lappend S(result) overstrike}
+ if {$S(under)} {lappend S(result) underline}
$S(sample) configure -font $S(result)
}
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/iconlist.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/iconlist.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/iconlist.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -26,7 +26,7 @@
# <path> selection includes <item>
# <path> selection set <first> ?<last>?
-package require Tk 8.6
+package require Tk
::tk::Megawidget create ::tk::IconList ::tk::FocusableWidget {
variable w canvas sbar accel accelCB fill font index \
@@ -697,7 +697,7 @@
}
}
- if {$theIndex > -1} {
+ if {$theIndex >= 0} {
$w selection clear 0 end
$w selection set $theIndex
$w selection anchor $theIndex
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/listbox.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/listbox.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/listbox.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -311,13 +311,13 @@
set Priv(listboxSelection) [$w curselection]
}
while {($i < $el) && ($i < $anchor)} {
- if {[lsearch $Priv(listboxSelection) $i] >= 0} {
+ if {$i in $Priv(listboxSelection)} {
$w selection set $i
}
incr i
}
while {($i > $el) && ($i > $anchor)} {
- if {[lsearch $Priv(listboxSelection) $i] >= 0} {
+ if {$i in $Priv(listboxSelection)} {
$w selection set $i
}
incr i -1
@@ -517,7 +517,7 @@
}
$w selection clear $first $last
while {$first <= $last} {
- if {[lsearch $Priv(listboxSelection) $first] >= 0} {
+ if {$first in $Priv(listboxSelection)} {
$w selection set $first
}
incr first
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/megawidget.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/megawidget.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/megawidget.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -10,7 +10,7 @@
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-package require Tk 8.6
+package require Tk
::oo::class create ::tk::Megawidget {
superclass ::oo::class
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/menu.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/menu.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/menu.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -138,7 +138,7 @@
bind Menu <Motion> {
tk::MenuMotion %W %x %y %s
}
-bind Menu <ButtonPress> {
+bind Menu <Button> {
tk::MenuButtonDown %W
}
bind Menu <ButtonRelease> {
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/pkgIndex.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/pkgIndex.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/pkgIndex.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -1,7 +1,7 @@
if {[catch {package present 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.10 [list load [file normalize [file join $dir .. .. bin libtk8.6.dll]] Tk]
+ package ifneeded Tk 8.6.11 [list load [file normalize [file join $dir .. .. bin libtk8.6.dll]] Tk]
} else {
- package ifneeded Tk 8.6.10 [list load [file normalize [file join $dir .. .. bin tk86.dll]] Tk]
+ package ifneeded Tk 8.6.11 [list load [file normalize [file join $dir .. .. bin tk86.dll]] Tk]
}
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/safetk.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/safetk.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/safetk.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -14,9 +14,9 @@
# Note: It is now ok to let untrusted code being executed
# between the creation of the interp and the actual loading
# of Tk in that interp because the C side Tk_Init will
-# now look up the master interp and ask its safe::TkInit
+# now look up the parent interp and ask its safe::TkInit
# for the actual parameters to use for it's initialization (if allowed),
-# not relying on the slave state.
+# not relying on the child state.
#
# We use opt (optional arguments parsing)
@@ -29,11 +29,11 @@
}
#
-# tkInterpInit : prepare the slave interpreter for tk loading
+# tkInterpInit : prepare the child interpreter for tk loading
# most of the real job is done by loadTk
-# returns the slave name (tkInterpInit does)
+# returns the child name (tkInterpInit does)
#
-proc ::safe::tkInterpInit {slave argv} {
+proc ::safe::tkInterpInit {child argv} {
global env tk_library
# We have to make sure that the tk_library variable is normalized.
@@ -40,20 +40,20 @@
set tk_library [file normalize $tk_library]
# Clear Tk's access for that interp (path).
- allowTk $slave $argv
+ allowTk $child $argv
# Ensure tk_library and subdirs (eg, ttk) are on the access path
- ::interp eval $slave [list set tk_library [::safe::interpAddToAccessPath $slave $tk_library]]
+ ::interp eval $child [list set tk_library [::safe::interpAddToAccessPath $child $tk_library]]
foreach subdir [::safe::AddSubDirs [list $tk_library]] {
- ::safe::interpAddToAccessPath $slave $subdir
+ ::safe::interpAddToAccessPath $child $subdir
}
- return $slave
+ return $child
}
# tkInterpLoadTk:
# Do additional configuration as needed (calling tkInterpInit)
-# and actually load Tk into the slave.
+# and actually load Tk into the child.
#
# Either contained in the specified windowId (-use) or
# creating a decorated toplevel for it.
@@ -62,7 +62,7 @@
proc ::safe::loadTk {} {}
::tcl::OptProc ::safe::loadTk {
- {slave -interp "name of the slave interpreter"}
+ {child -interp "name of the child interpreter"}
{-use -windowId {} "window Id to use (new toplevel otherwise)"}
{-display -displayName {} "display name to use (current one otherwise)"}
} {
@@ -69,12 +69,12 @@
set displayGiven [::tcl::OptProcArgGiven "-display"]
if {!$displayGiven} {
# Try to get the current display from "."
- # (which might not exist if the master is tk-less)
+ # (which might not exist if the parent is tk-less)
if {[catch {set display [winfo screen .]}]} {
if {[info exists ::env(DISPLAY)]} {
set display $::env(DISPLAY)
} else {
- Log $slave "no winfo screen . nor env(DISPLAY)" WARNING
+ Log $child "no winfo screen . nor env(DISPLAY)" WARNING
set display ":0.0"
}
}
@@ -81,18 +81,18 @@
}
# Get state for access to the cleanupHook.
- namespace upvar ::safe S$slave state
+ namespace upvar ::safe S$child state
if {![::tcl::OptProcArgGiven "-use"]} {
# create a decorated toplevel
- lassign [tkTopLevel $slave $display] w use
+ lassign [tkTopLevel $child $display] w use
- # set our delete hook (slave arg is added by interpDelete)
- # to clean up both window related code and tkInit(slave)
+ # set our delete hook (child arg is added by interpDelete)
+ # to clean up both window related code and tkInit(child)
set state(cleanupHook) [list tkDelete {} $w]
} else {
- # set our delete hook (slave arg is added by interpDelete)
- # to clean up tkInit(slave)
+ # set our delete hook (child arg is added by interpDelete)
+ # to clean up tkInit(child)
set state(cleanupHook) [list disallowTk]
# Let's be nice and also accept tk window names instead of ids
@@ -122,12 +122,12 @@
}
}
- # Prepares the slave for tk with those parameters
- tkInterpInit $slave [list "-use" $use "-display" $display]
+ # Prepares the child for tk with those parameters
+ tkInterpInit $child [list "-use" $use "-display" $display]
- load {} Tk $slave
+ load {} Tk $child
- return $slave
+ return $child
}
proc ::safe::TkInit {interpPath} {
@@ -149,7 +149,7 @@
# safe::TkInit.
#
# Arguments:
-# interpPath slave interpreter handle
+# interpPath child interpreter handle
# argv arguments passed to safe::TkInterpInit
#
# Results:
@@ -168,7 +168,7 @@
# in safe::TkInit.
#
# Arguments:
-# interpPath slave interpreter handle
+# interpPath child interpreter handle
#
# Results:
# none.
@@ -188,43 +188,43 @@
# Clean up the window associated with the interp being deleted.
#
# Arguments:
-# interpPath slave interpreter handle
+# interpPath child interpreter handle
#
# Results:
# none.
-proc ::safe::tkDelete {W window slave} {
+proc ::safe::tkDelete {W window child} {
# we are going to be called for each widget... skip untill it's
# top level
- Log $slave "Called tkDelete $W $window" NOTICE
- if {[::interp exists $slave]} {
- if {[catch {::safe::interpDelete $slave} msg]} {
- Log $slave "Deletion error : $msg"
+ Log $child "Called tkDelete $W $window" NOTICE
+ if {[::interp exists $child]} {
+ if {[catch {::safe::interpDelete $child} msg]} {
+ Log $child "Deletion error : $msg"
}
}
if {[winfo exists $window]} {
- Log $slave "Destroy toplevel $window" NOTICE
+ Log $child "Destroy toplevel $window" NOTICE
destroy $window
}
- # clean up tkInit(slave)
- disallowTk $slave
+ # clean up tkInit(child)
+ disallowTk $child
return
}
-proc ::safe::tkTopLevel {slave display} {
+proc ::safe::tkTopLevel {child display} {
variable tkSafeId
incr tkSafeId
set w ".safe$tkSafeId"
if {[catch {toplevel $w -screen $display -class SafeTk} msg]} {
return -code error -errorcode {TK TOPLEVEL SAFE} \
- "Unable to create toplevel for safe slave \"$slave\" ($msg)"
+ "Unable to create toplevel for \"$child\" ($msg)"
}
- Log $slave "New toplevel $w" NOTICE
+ Log $child "New toplevel $w" NOTICE
- set msg "Untrusted Tcl applet ($slave)"
+ set msg "Untrusted Tcl applet ($child)"
wm title $w $msg
# Control frame (we must create a style for it)
@@ -236,7 +236,7 @@
# We will destroy the interp when the window is destroyed
bindtags $wc [concat Safe$wc [bindtags $wc]]
- bind Safe$wc <Destroy> [list ::safe::tkDelete %W $w $slave]
+ bind Safe$wc <Destroy> [list ::safe::tkDelete %W $w $child]
ttk::label $wc.l -text $msg -anchor w
@@ -247,7 +247,7 @@
# but still have the default background instead of red one from the parent
ttk::frame $wc.fb -borderwidth 0
ttk::button $wc.fb.b -text "Delete" \
- -command [list ::safe::tkDelete $w $w $slave]
+ -command [list ::safe::tkDelete $w $w $child]
pack $wc.fb.b -side right -fill both
pack $wc.fb -side right -fill both -expand 1
pack $wc.l -side left -fill both -expand 1 -ipady 2
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/spinbox.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/spinbox.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/spinbox.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -280,15 +280,28 @@
# A few additional bindings of my own.
-bind Spinbox <2> {
- if {!$tk_strictMotif} {
- ::tk::EntryScanMark %W %x
+if {[tk windowingsystem] ne "aqua"} {
+ bind Spinbox <2> {
+ if {!$tk_strictMotif} {
+ ::tk::EntryScanMark %W %x
+ }
}
-}
-bind Spinbox <B2-Motion> {
- if {!$tk_strictMotif} {
- ::tk::EntryScanDrag %W %x
+ bind Spinbox <B2-Motion> {
+ if {!$tk_strictMotif} {
+ ::tk::EntryScanDrag %W %x
+ }
}
+} else {
+ bind Spinbox <3> {
+ if {!$tk_strictMotif} {
+ ::tk::EntryScanMark %W %x
+ }
+ }
+ bind Spinbox <B3-Motion> {
+ if {!$tk_strictMotif} {
+ ::tk::EntryScanDrag %W %x
+ }
+ }
}
# ::tk::spinbox::Invoke --
@@ -470,10 +483,10 @@
word {
if {$cur < [$w index anchor]} {
set before [tcl_wordBreakBefore [$w get] $cur]
- set after [tcl_wordBreakAfter [$w get] [expr {$anchor-1}]]
+ set after [tcl_wordBreakAfter [$w get] $anchor-1]
} else {
set before [tcl_wordBreakBefore [$w get] $anchor]
- set after [tcl_wordBreakAfter [$w get] [expr {$cur - 1}]]
+ set after [tcl_wordBreakAfter [$w get] $cur-1]
}
if {$before < 0} {
set before 0
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/tearoff.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/tearoff.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/tearoff.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -39,7 +39,7 @@
# Shift by height of tearoff entry minus height of window titlebar
catch {incr y [expr {[$w yposition 1] - 16}]}
# Avoid the native menu bar which sits on top of everything.
- if {$y < 22} { set y 22 }
+ if {$y < 22} {set y 22}
}
}
@@ -153,9 +153,11 @@
# Copy tags to x, replacing each substring of src with dst.
- while {[set index [string first $src $tags]] != -1} {
- append x [string range $tags 0 [expr {$index - 1}]]$dst
- set tags [string range $tags [expr {$index + $srcLen}] end]
+ while {[set index [string first $src $tags]] >= 0} {
+ if {$index > 0} {
+ append x [string range $tags 0 $index-1]$dst
+ }
+ set tags [string range $tags $index+$srcLen end]
}
append x $tags
@@ -168,10 +170,12 @@
# Copy script to x, replacing each substring of event with dst.
- while {[set index [string first $event $script]] != -1} {
- append x [string range $script 0 [expr {$index - 1}]]
+ while {[set index [string first $event $script]] >= 0} {
+ if {$index > 0} {
+ append x [string range $script 0 $index-1]
+ }
append x $dst
- set script [string range $script [expr {$index + $eventLen}] end]
+ set script [string range $script $index+$eventLen end]
}
append x $script
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/text.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/text.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/text.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -429,15 +429,28 @@
%W see insert
}
}
-bind Text <2> {
- if {!$tk_strictMotif} {
- tk::TextScanMark %W %x %y
+if {[tk windowingsystem] ne "aqua"} {
+ bind Text <2> {
+ if {!$tk_strictMotif} {
+ tk::TextScanMark %W %x %y
+ }
}
-}
-bind Text <B2-Motion> {
- if {!$tk_strictMotif} {
- tk::TextScanDrag %W %x %y
+ bind Text <B2-Motion> {
+ if {!$tk_strictMotif} {
+ tk::TextScanDrag %W %x %y
+ }
}
+} else {
+ bind Text <3> {
+ if {!$tk_strictMotif} {
+ tk::TextScanMark %W %x %y
+ }
+ }
+ bind Text <B3-Motion> {
+ if {!$tk_strictMotif} {
+ tk::TextScanDrag %W %x %y
+ }
+ }
}
set ::tk::Priv(prevPos) {}
@@ -558,12 +571,7 @@
} else {
$w mark gravity $anchorname left
}
- # Allow focus in any case on Windows, because that will let the
- # selection be displayed even for state disabled text widgets.
- if {[tk windowingsystem] eq "win32" \
- || [$w cget -state] eq "normal"} {
- focus $w
- }
+ focus $w
if {[$w cget -autoseparators]} {
$w edit separator
}
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/tk.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/tk.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/tk.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -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.10
+package require -exact Tk 8.6.11
# Create a ::tk namespace
namespace eval ::tk {
@@ -400,7 +400,7 @@
event add <<NextPara>> <Control-Down>
event add <<SelectPrevPara>> <Control-Shift-Up>
event add <<SelectNextPara>> <Control-Shift-Down>
- event add <<ToggleSelection>> <Control-ButtonPress-1>
+ event add <<ToggleSelection>> <Control-Button-1>
# Some OS's define a goofy (as in, not <Shift-Tab>) keysym that is
# returned when the user presses <Shift-Tab>. In order for tab
@@ -449,7 +449,7 @@
event add <<NextPara>> <Control-Down>
event add <<SelectPrevPara>> <Control-Shift-Up>
event add <<SelectNextPara>> <Control-Shift-Down>
- event add <<ToggleSelection>> <Control-ButtonPress-1>
+ event add <<ToggleSelection>> <Control-Button-1>
}
"aqua" {
event add <<Cut>> <Command-Key-x> <Key-F2> <Command-Lock-Key-X>
@@ -462,8 +462,6 @@
# Official bindings
# See http://support.apple.com/kb/HT1343
event add <<SelectAll>> <Command-Key-a>
- #Attach function keys not otherwise assigned to this event so they no-op - workaround for bug 0e6930dfe7
- event add <<SelectNone>> <Option-Command-Key-a> <Key-F5> <Key-F1> <Key-F5> <Key-F6> <Key-F7> <Key-F8> <Key-F9> <Key-F10> <Key-F11> <Key-F12>
event add <<Undo>> <Command-Key-z> <Command-Lock-Key-Z>
event add <<Redo>> <Shift-Command-Key-z> <Shift-Command-Lock-Key-z>
event add <<NextChar>> <Right> <Control-Key-f> <Control-Lock-Key-F>
@@ -488,7 +486,7 @@
event add <<NextPara>> <Option-Down>
event add <<SelectPrevPara>> <Shift-Option-Up>
event add <<SelectNextPara>> <Shift-Option-Down>
- event add <<ToggleSelection>> <Command-ButtonPress-1>
+ event add <<ToggleSelection>> <Command-Button-1>
}
}
@@ -498,7 +496,7 @@
if {$::tk_library ne ""} {
proc ::tk::SourceLibFile {file} {
- namespace eval :: [list source [file join $::tk_library $file.tcl]]
+ namespace eval :: [list source -encoding utf-8 [file join $::tk_library $file.tcl]]
}
namespace eval ::tk {
SourceLibFile icons
@@ -689,9 +687,11 @@
if {[tk windowingsystem] eq "aqua"} {
#stub procedures to respond to "do script" Apple Events
proc ::tk::mac::DoScriptFile {file} {
- source $file
+ uplevel #0 $file
+ source -encoding utf-8 $file
}
proc ::tk::mac::DoScriptText {script} {
+ uplevel #0 $script
eval $script
}
}
@@ -703,7 +703,7 @@
# Run the Ttk themed widget set initialization
if {$::ttk::library ne ""} {
- uplevel \#0 [list source $::ttk::library/ttk.tcl]
+ uplevel \#0 [list source -encoding utf-8 $::ttk::library/ttk.tcl]
}
# Local Variables:
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/tkAppInit.c
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/tkAppInit.c 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/tkAppInit.c 2021-03-02 16:29:37 UTC (rev 58056)
@@ -15,9 +15,16 @@
#undef BUILD_tk
#undef STATIC_BUILD
#include "tk.h"
+#include "tkPort.h"
#ifdef TK_TEST
+#ifdef __cplusplus
+extern "C" {
+#endif
extern Tcl_PackageInitProc Tktest_Init;
+#ifdef __cplusplus
+}
+#endif
#endif /* TK_TEST */
/*
@@ -30,7 +37,11 @@
#define TK_LOCAL_APPINIT Tcl_AppInit
#endif
#ifndef MODULE_SCOPE
-# define MODULE_SCOPE extern
+# ifdef __cplusplus
+# define MODULE_SCOPE extern "C"
+# else
+# define MODULE_SCOPE extern
+# endif
#endif
MODULE_SCOPE int TK_LOCAL_APPINIT(Tcl_Interp *);
MODULE_SCOPE int main(int, char **);
@@ -111,6 +122,13 @@
}
Tcl_StaticPackage(interp, "Tk", Tk_Init, Tk_SafeInit);
+#if defined(USE_CUSTOM_EXIT_PROC)
+ if (TkpWantsExitProc()) {
+ /* The cast below avoids warnings from old gcc compilers. */
+ Tcl_SetExitProc((void *)TkpExitProc);
+ }
+#endif
+
#ifdef TK_TEST
if (Tktest_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/aquaTheme.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/aquaTheme.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/aquaTheme.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -15,7 +15,7 @@
-insertwidth 1
ttk::style map . \
- -foreground {
+ -foreground {
disabled systemDisabledControlTextColor
background systemLabelColor} \
-selectbackground {
@@ -35,22 +35,39 @@
ttk::style configure TMenubutton -anchor center -padding {2 0 0 2}
ttk::style configure Toolbutton -anchor center
+ # For Entry, Combobox and Spinbox widgets the selected text background
+ # is the "Highlight color" selected in preferences when the widget
+ # has focus. It is a gray color when the widget does not have focus or
+ # the window does not have focus. (The background state implies !focus
+ # so we only need to specify !focus.)
+
# Entry
- ttk::style configure TEntry \
- -foreground systemTextColor \
- -background systemTextBackgroundColor
ttk::style map TEntry \
-foreground {
disabled systemDisabledControlTextColor
} \
- -selectforeground {
- background systemTextColor
+ -selectbackground {
+ !focus systemUnemphasizedSelectedTextBackgroundColor
+ }
+
+ # Combobox:
+ ttk::style map TCombobox \
+ -foreground {
+ disabled systemDisabledControlTextColor
} \
-selectbackground {
- background systemTextBackgroundColor
+ !focus systemUnemphasizedSelectedTextBackgroundColor
}
-
+ # Spinbox
+ ttk::style map TSpinbox \
+ -foreground {
+ disabled systemDisabledControlTextColor
+ } \
+ -selectbackground {
+ !focus systemUnemphasizedSelectedTextBackgroundColor
+ }
+
# Workaround for #1100117:
# Actually, on Aqua we probably shouldn't stipple images in
# disabled buttons even if it did work...
@@ -67,40 +84,6 @@
disabled systemDisabledControlTextColor
selected systemSelectedTabTextColor}
- # Combobox:
- ttk::style configure TCombobox \
- -foreground systemTextColor \
- -background systemTransparent
- ttk::style map TCombobox \
- -foreground {
- disabled systemDisabledControlTextColor
- } \
- -selectforeground {
- background systemTextColor
- } \
- -selectbackground {
- background systemTransparent
- }
-
- # Spinbox
- ttk::style configure TSpinbox \
- -foreground systemTextColor \
- -background systemTextBackgroundColor \
- -selectforeground systemSelectedTextColor \
- -selectbackground systemSelectedTextBackgroundColor
- ttk::style map TSpinbox \
- -foreground {
- disabled systemDisabledControlTextColor
- } \
- -selectforeground {
- !active systemTextColor
- } \
- -selectbackground {
- !active systemTextBackgroundColor
- !focus systemTextBackgroundColor
- focus systemSelectedTextBackgroundColor
- }
-
# Treeview:
ttk::style configure Heading \
-font TkHeadingFont \
@@ -116,7 +99,7 @@
}
# Enable animation for ttk::progressbar widget:
- ttk::style configure TProgressbar -period 100 -maxphase 255
+ ttk::style configure TProgressbar -period 100 -maxphase 120
# For Aqua, labelframe labels should appear outside the border,
# with a 14 pixel inset and 4 pixels spacing between border and label
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/button.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/button.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/button.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -8,8 +8,8 @@
# (If the button is released off the widget, the grab deactivates and
# we get a <Leave> event then, which turns off the "active" state)
#
-# Normally, <ButtonRelease> and <ButtonN-Enter/Leave> events are
-# delivered to the widget which received the initial <ButtonPress>
+# Normally, <ButtonRelease> and <ButtonN-Enter/Leave> events are
+# delivered to the widget which received the initial <Button>
# event. However, Tk [grab]s (#1223103) and menu interactions
# (#1222605) can interfere with this. To guard against spurious
# <Button1-Enter> events, the <Button1-Enter> binding only sets
@@ -20,10 +20,10 @@
bind TButton <Enter> { %W instate !disabled {%W state active} }
bind TButton <Leave> { %W state !active }
-bind TButton <Key-space> { ttk::button::activate %W }
+bind TButton <space> { ttk::button::activate %W }
bind TButton <<Invoke>> { ttk::button::activate %W }
-bind TButton <ButtonPress-1> \
+bind TButton <Button-1> \
{ %W instate !disabled { ttk::clickToFocus %W; %W state pressed } }
bind TButton <ButtonRelease-1> \
{ %W instate pressed { %W state !pressed; %W instate !disabled { %W invoke } } }
@@ -39,11 +39,11 @@
# ...plus a few more:
-bind TRadiobutton <KeyPress-Up> { ttk::button::RadioTraverse %W -1 }
-bind TRadiobutton <KeyPress-Down> { ttk::button::RadioTraverse %W +1 }
+bind TRadiobutton <Up> { ttk::button::RadioTraverse %W -1 }
+bind TRadiobutton <Down> { ttk::button::RadioTraverse %W +1 }
-# bind TCheckbutton <KeyPress-plus> { %W select }
-# bind TCheckbutton <KeyPress-minus> { %W deselect }
+# bind TCheckbutton <plus> { %W select }
+# bind TCheckbutton <minus> { %W deselect }
# activate --
# Simulate a button press: temporarily set the state to 'pressed',
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/clamTheme.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/clamTheme.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/clamTheme.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -5,7 +5,7 @@
#
namespace eval ttk::theme::clam {
- variable colors
+ variable colors
array set colors {
-disabledfg "#999999"
-frame "#dcdad5"
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/combobox.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/combobox.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/combobox.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -45,13 +45,13 @@
ttk::copyBindings TEntry TCombobox
-bind TCombobox <KeyPress-Down> { ttk::combobox::Post %W }
-bind TCombobox <KeyPress-Escape> { ttk::combobox::Unpost %W }
+bind TCombobox <Down> { ttk::combobox::Post %W }
+bind TCombobox <Escape> { ttk::combobox::Unpost %W }
-bind TCombobox <ButtonPress-1> { ttk::combobox::Press "" %W %x %y }
-bind TCombobox <Shift-ButtonPress-1> { ttk::combobox::Press "s" %W %x %y }
-bind TCombobox <Double-ButtonPress-1> { ttk::combobox::Press "2" %W %x %y }
-bind TCombobox <Triple-ButtonPress-1> { ttk::combobox::Press "3" %W %x %y }
+bind TCombobox <Button-1> { ttk::combobox::Press "" %W %x %y }
+bind TCombobox <Shift-Button-1> { ttk::combobox::Press "s" %W %x %y }
+bind TCombobox <Double-Button-1> { ttk::combobox::Press "2" %W %x %y }
+bind TCombobox <Triple-Button-1> { ttk::combobox::Press "3" %W %x %y }
bind TCombobox <B1-Motion> { ttk::combobox::Drag %W %x }
bind TCombobox <Motion> { ttk::combobox::Motion %W %x %y }
@@ -62,9 +62,9 @@
### Combobox listbox bindings.
#
bind ComboboxListbox <ButtonRelease-1> { ttk::combobox::LBSelected %W }
-bind ComboboxListbox <KeyPress-Return> { ttk::combobox::LBSelected %W }
-bind ComboboxListbox <KeyPress-Escape> { ttk::combobox::LBCancel %W }
-bind ComboboxListbox <KeyPress-Tab> { ttk::combobox::LBTab %W next }
+bind ComboboxListbox <Return> { ttk::combobox::LBSelected %W }
+bind ComboboxListbox <Escape> { ttk::combobox::LBCancel %W }
+bind ComboboxListbox <Tab> { ttk::combobox::LBTab %W next }
bind ComboboxListbox <<PrevWindow>> { ttk::combobox::LBTab %W prev }
bind ComboboxListbox <Destroy> { ttk::combobox::LBCleanup %W }
bind ComboboxListbox <Motion> { ttk::combobox::LBHover %W %x %y }
@@ -82,7 +82,7 @@
#
bind ComboboxPopdown <Map> { ttk::combobox::MapPopdown %W }
bind ComboboxPopdown <Unmap> { ttk::combobox::UnmapPopdown %W }
-bind ComboboxPopdown <ButtonPress> \
+bind ComboboxPopdown <Button> \
{ ttk::combobox::Unpost [winfo parent %W] }
### Option database settings.
@@ -106,7 +106,7 @@
### Binding procedures.
#
-## Press $mode $x $y -- ButtonPress binding for comboboxes.
+## Press $mode $x $y -- Button binding for comboboxes.
# Either post/unpost the listbox, or perform Entry widget binding,
# depending on widget state and location of button press.
#
@@ -135,7 +135,7 @@
}
## Drag -- B1-Motion binding for comboboxes.
-# If the initial ButtonPress event was handled by Entry binding,
+# If the initial Button event was handled by Entry binding,
# perform Entry widget drag binding; otherwise nothing.
#
proc ttk::combobox::Drag {w x} {
@@ -149,12 +149,14 @@
# Set cursor.
#
proc ttk::combobox::Motion {w x y} {
+ variable State
+ ttk::saveCursor $w State(userConfCursor) [ttk::cursor text]
if { [$w identify $x $y] eq "textarea"
&& [$w instate {!readonly !disabled}]
} {
ttk::setCursor $w text
} else {
- ttk::setCursor $w ""
+ ttk::setCursor $w $State(userConfCursor)
}
}
@@ -355,6 +357,9 @@
set w [winfo width $cb]
set h [winfo height $cb]
set style [$cb cget -style]
+ if { $style eq {} } {
+ set style TCombobox
+ }
set postoffset [ttk::style lookup $style -postoffset {} {0 0 0 0}]
foreach var {x y w h} delta $postoffset {
incr $var $delta
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/cursors.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/cursors.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/cursors.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -140,11 +140,33 @@
proc ttk::setCursor {w name} {
variable Cursors
- if {[$w cget -cursor] ne $Cursors($name)} {
- $w configure -cursor $Cursors($name)
+ if {[info exists Cursors($name)]} {
+ set cursorname $Cursors($name)
+ } else {
+ set cursorname $name
}
+ if {[$w cget -cursor] ne $cursorname} {
+ $w configure -cursor $cursorname
+ }
}
+## ttk::saveCursor $w $saveVar $excludeList --
+# Set variable $saveVar to the -cursor value from widget $w,
+# if either:
+# a. $saveVar does not yet exist
+# b. the currently user-specified cursor for $w is not in
+# $excludeList
+
+proc ttk::saveCursor {w saveVar excludeList} {
+ upvar $saveVar sv
+ if {![info exists sv]} {
+ set sv [$w cget -cursor]
+ }
+ if {[$w cget -cursor] ni $excludeList} {
+ set sv [$w cget -cursor]
+ }
+}
+
## Interactive test harness:
#
proc ttk::CursorSampler {f} {
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/defaults.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/defaults.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/defaults.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -43,7 +43,7 @@
ttk::style configure TButton \
-anchor center -padding "3 3" -width -9 \
-relief raised -shiftrelief 1
- ttk::style map TButton -relief [list {!disabled pressed} sunken]
+ ttk::style map TButton -relief [list {!disabled pressed} sunken]
ttk::style configure TCheckbutton \
-indicatorcolor "#ffffff" -indicatorrelief sunken -padding 1
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/entry.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/entry.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/entry.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -40,20 +40,20 @@
#
# Removed the following standard Tk bindings:
#
-# <Control-Key-space>, <Control-Shift-Key-space>,
-# <Key-Select>, <Shift-Key-Select>:
+# <Control-space>, <Control-Shift-space>,
+# <Select>, <Shift-Select>:
# Ttk entry widget doesn't use selection anchor.
-# <Key-Insert>:
+# <Insert>:
# Inserts PRIMARY selection (on non-Windows platforms).
# This is inconsistent with typical platform bindings.
-# <Double-Shift-ButtonPress-1>, <Triple-Shift-ButtonPress-1>:
+# <Double-Shift-Button-1>, <Triple-Shift-Button-1>:
# These don't do the right thing to start with.
-# <Meta-Key-b>, <Meta-Key-d>, <Meta-Key-f>,
-# <Meta-Key-BackSpace>, <Meta-Key-Delete>:
+# <Meta-b>, <Meta-d>, <Meta-f>,
+# <Meta-BackSpace>, <Meta-Delete>:
# Judgment call. If <Meta> happens to be assigned to the Alt key,
# these could conflict with application accelerators.
# (Plus, who has a Meta key these days?)
-# <Control-Key-t>:
+# <Control-t>:
# Another judgment call. If anyone misses this, let me know
# and I'll put it back.
#
@@ -68,27 +68,34 @@
## Button1 bindings:
# Used for selection and navigation.
#
-bind TEntry <ButtonPress-1> { ttk::entry::Press %W %x }
-bind TEntry <Shift-ButtonPress-1> { ttk::entry::Shift-Press %W %x }
-bind TEntry <Double-ButtonPress-1> { ttk::entry::Select %W %x word }
-bind TEntry <Triple-ButtonPress-1> { ttk::entry::Select %W %x line }
+bind TEntry <Button-1> { ttk::entry::Press %W %x }
+bind TEntry <Shift-Button-1> { ttk::entry::Shift-Press %W %x }
+bind TEntry <Double-Button-1> { ttk::entry::Select %W %x word }
+bind TEntry <Triple-Button-1> { ttk::entry::Select %W %x line }
bind TEntry <B1-Motion> { ttk::entry::Drag %W %x }
-bind TEntry <B1-Leave> { ttk::entry::DragOut %W %m }
-bind TEntry <B1-Enter> { ttk::entry::DragIn %W }
-bind TEntry <ButtonRelease-1> { ttk::entry::Release %W }
+bind TEntry <B1-Leave> { ttk::entry::DragOut %W %m }
+bind TEntry <B1-Enter> { ttk::entry::DragIn %W }
+bind TEntry <ButtonRelease-1> { ttk::entry::Release %W }
bind TEntry <<ToggleSelection>> {
%W instate {!readonly !disabled} { %W icursor @%x ; focus %W }
}
-## Button2 bindings:
+## Button2 (Button3 on Aqua) bindings:
# Used for scanning and primary transfer.
-# Note: ButtonRelease-2 is mapped to <<PasteSelection>> in tk.tcl.
+# Note: ButtonRelease-2 (ButtonRelease-3 on Aqua)
+# is mapped to <<PasteSelection>> in tk.tcl.
#
-bind TEntry <ButtonPress-2> { ttk::entry::ScanMark %W %x }
-bind TEntry <B2-Motion> { ttk::entry::ScanDrag %W %x }
-bind TEntry <ButtonRelease-2> { ttk::entry::ScanRelease %W %x }
+if {[tk windowingsystem] ne "aqua"} {
+ bind TEntry <Button-2> { ttk::entry::ScanMark %W %x }
+ bind TEntry <B2-Motion> { ttk::entry::ScanDrag %W %x }
+ bind TEntry <ButtonRelease-2> { ttk::entry::ScanRelease %W %x }
+} else {
+ bind TEntry <Button-3> { ttk::entry::ScanMark %W %x }
+ bind TEntry <B3-Motion> { ttk::entry::ScanDrag %W %x }
+ bind TEntry <ButtonRelease-3> { ttk::entry::ScanRelease %W %x }
+}
bind TEntry <<PasteSelection>> { ttk::entry::ScanRelease %W %x }
## Keyboard navigation bindings:
@@ -114,26 +121,26 @@
## Edit bindings:
#
-bind TEntry <KeyPress> { ttk::entry::Insert %W %A }
-bind TEntry <Key-Delete> { ttk::entry::Delete %W }
-bind TEntry <Key-BackSpace> { ttk::entry::Backspace %W }
+bind TEntry <Key> { ttk::entry::Insert %W %A }
+bind TEntry <Delete> { ttk::entry::Delete %W }
+bind TEntry <BackSpace> { ttk::entry::Backspace %W }
# Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
-# Otherwise, the <KeyPress> class binding will fire and insert the character.
+# Otherwise, the <Key> class binding will fire and insert the character.
# Ditto for Escape, Return, and Tab.
#
-bind TEntry <Alt-KeyPress> {# nothing}
-bind TEntry <Meta-KeyPress> {# nothing}
-bind TEntry <Control-KeyPress> {# nothing}
-bind TEntry <Key-Escape> {# nothing}
-bind TEntry <Key-Return> {# nothing}
-bind TEntry <Key-KP_Enter> {# nothing}
-bind TEntry <Key-Tab> {# nothing}
+bind TEntry <Alt-Key> {# nothing}
+bind TEntry <Meta-Key> {# nothing}
+bind TEntry <Control-Key> {# nothing}
+bind TEntry <Escape> {# nothing}
+bind TEntry <Return> {# nothing}
+bind TEntry <KP_Enter> {# nothing}
+bind TEntry <Tab> {# nothing}
# Argh. Apparently on Windows, the NumLock modifier is interpreted
# as a Command modifier.
if {[tk windowingsystem] eq "aqua"} {
- bind TEntry <Command-KeyPress> {# nothing}
+ bind TEntry <Command-Key> {# nothing}
}
# Tk-on-Cocoa generates characters for these two keys. [Bug 2971663]
bind TEntry <<PrevLine>> {# nothing}
@@ -141,9 +148,9 @@
## Additional emacs-like bindings:
#
-bind TEntry <Control-Key-d> { ttk::entry::Delete %W }
-bind TEntry <Control-Key-h> { ttk::entry::Backspace %W }
-bind TEntry <Control-Key-k> { %W delete insert end }
+bind TEntry <Control-d> { ttk::entry::Delete %W }
+bind TEntry <Control-h> { ttk::entry::Backspace %W }
+bind TEntry <Control-k> { %W delete insert end }
# Bindings for IME text input.
@@ -351,7 +358,7 @@
# Triple-clicking enters "line-select" mode.
#
-## Press -- ButtonPress-1 binding.
+## Press -- Button-1 binding.
# Set the insertion cursor, claim the input focus, set up for
# future drag operations.
#
@@ -368,7 +375,7 @@
set State(anchor) [$w index insert]
}
-## Shift-Press -- Shift-ButtonPress-1 binding.
+## Shift-Press -- Shift-Button-1 binding.
# Extends the selection, sets anchor for future drag operations.
#
proc ttk::entry::Shift-Press {w x} {
@@ -517,7 +524,7 @@
### Button 2 binding procedures.
#
-## ScanMark -- ButtonPress-2 binding.
+## ScanMark -- Button-2 binding.
# Marks the start of a scan or primary transfer operation.
#
proc ttk::entry::ScanMark {w x} {
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/fonts.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/fonts.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/fonts.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -82,7 +82,7 @@
set F(family) "MS Sans Serif"
}
} else {
- if {[lsearch -exact [font families] Tahoma] != -1} {
+ if {[lsearch -exact [font families] Tahoma] >= 0} {
set F(family) "Tahoma"
} else {
set F(family) "MS Sans Serif"
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/menubutton.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/menubutton.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/menubutton.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -5,12 +5,12 @@
#
# Pulldown: Press menubutton, drag over menu, release to activate menu entry
# Popdown: Click menubutton to post menu
-# Keyboard: <Key-space> or accelerator key to post menu
+# Keyboard: <space> or accelerator key to post menu
#
# (In addition, when menu system is active, "dropdown" -- menu posts
# on mouse-over. Ttk menubuttons don't implement this).
#
-# For keyboard and popdown mode, we hand off to tk_popup and let
+# For keyboard and popdown mode, we hand off to tk_popup and let
# the built-in Tk bindings handle the rest of the interaction.
#
# ON X11:
@@ -19,16 +19,16 @@
# This won't work for Ttk menubuttons in pulldown mode,
# since we need to process the final <ButtonRelease> event,
# and this might be delivered to the menu. So instead we
-# rely on the passive grab that occurs on <ButtonPress> events,
+# rely on the passive grab that occurs on <Button> events,
# and transition to popdown mode when the mouse is released
# or dragged outside the menubutton.
-#
+#
# ON WINDOWS:
#
-# I'm not sure what the hell is going on here. [$menu post] apparently
+# I'm not sure what the hell is going on here. [$menu post] apparently
# sets up some kind of internal grab for native menus.
# On this platform, just use [tk_popup] for all menu actions.
-#
+#
# ON MACOS:
#
# Same probably applies here.
@@ -46,15 +46,15 @@
bind TMenubutton <Enter> { %W instate !disabled {%W state active } }
bind TMenubutton <Leave> { %W state !active }
-bind TMenubutton <Key-space> { ttk::menubutton::Popdown %W }
+bind TMenubutton <space> { ttk::menubutton::Popdown %W }
bind TMenubutton <<Invoke>> { ttk::menubutton::Popdown %W }
if {[tk windowingsystem] eq "x11"} {
- bind TMenubutton <ButtonPress-1> { ttk::menubutton::Pulldown %W }
+ bind TMenubutton <Button-1> { ttk::menubutton::Pulldown %W }
bind TMenubutton <ButtonRelease-1> { ttk::menubutton::TransferGrab %W }
bind TMenubutton <B1-Leave> { ttk::menubutton::TransferGrab %W }
} else {
- bind TMenubutton <ButtonPress-1> \
+ bind TMenubutton <Button-1> \
{ %W state pressed ; ttk::menubutton::Popdown %W }
bind TMenubutton <ButtonRelease-1> \
{ if {[winfo exists %W]} { %W state !pressed } }
@@ -97,7 +97,7 @@
}
below {
set entry ""
- incr y $bh
+ incr y $bh
}
left {
incr y $menuPad
@@ -105,7 +105,7 @@
}
right {
incr y $menuPad
- incr x $bw
+ incr x $bw
}
default {
incr y $bbh
@@ -182,7 +182,7 @@
# Pulldown (X11 only) --
# Called when Button1 is pressed on a menubutton.
-# Posts the menu; a subsequent ButtonRelease
+# Posts the menu; a subsequent ButtonRelease
# or Leave event will set a grab on the menu.
#
proc ttk::menubutton::Pulldown {mb} {
@@ -224,11 +224,11 @@
# FindMenuEntry --
# Hack to support tk_optionMenus.
# Returns the index of the menu entry with a matching -label,
-# -1 if not found.
+# "" if not found.
#
proc ttk::menubutton::FindMenuEntry {menu s} {
set last [$menu index last]
- if {$last eq "none"} {
+ if {$last eq "none" || $last eq ""} {
return ""
}
for {set i 0} {$i <= $last} {incr i} {
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/notebook.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/notebook.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/notebook.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -6,11 +6,11 @@
variable TLNotebooks ;# See enableTraversal
}
-bind TNotebook <ButtonPress-1> { ttk::notebook::Press %W %x %y }
-bind TNotebook <Key-Right> { ttk::notebook::CycleTab %W 1; break }
-bind TNotebook <Key-Left> { ttk::notebook::CycleTab %W -1; break }
-bind TNotebook <Control-Key-Tab> { ttk::notebook::CycleTab %W 1; break }
-bind TNotebook <Control-Shift-Key-Tab> { ttk::notebook::CycleTab %W -1; break }
+bind TNotebook <Button-1> { ttk::notebook::Press %W %x %y }
+bind TNotebook <Right> { ttk::notebook::CycleTab %W 1; break }
+bind TNotebook <Left> { ttk::notebook::CycleTab %W -1; break }
+bind TNotebook <Control-Tab> { ttk::notebook::CycleTab %W 1; break }
+bind TNotebook <Control-Shift-Tab> { ttk::notebook::CycleTab %W -1; break }
catch {
bind TNotebook <Control-ISO_Left_Tab> { ttk::notebook::CycleTab %W -1; break }
}
@@ -43,7 +43,7 @@
}
# Press $nb $x $y --
-# ButtonPress-1 binding for notebook widgets.
+# Button-1 binding for notebook widgets.
# Activate the tab under the mouse cursor, if any.
#
proc ttk::notebook::Press {w x y} {
@@ -70,7 +70,7 @@
}
# MnemonicTab $nb $key --
-# Scan all tabs in the specified notebook for one with the
+# Scan all tabs in the specified notebook for one with the
# specified mnemonic. If found, returns path name of tab;
# otherwise returns ""
#
@@ -94,8 +94,8 @@
# Enable keyboard traversal for a notebook widget
# by adding bindings to the containing toplevel window.
#
-# TLNotebooks($top) keeps track of the list of all traversal-enabled
-# notebooks contained in the toplevel
+# TLNotebooks($top) keeps track of the list of all traversal-enabled
+# notebooks contained in the toplevel
#
proc ttk::notebook::enableTraversal {nb} {
variable TLNotebooks
@@ -105,18 +105,18 @@
if {![info exists TLNotebooks($top)]} {
# Augment $top bindings:
#
- bind $top <Control-Key-Next> {+ttk::notebook::TLCycleTab %W 1}
- bind $top <Control-Key-Prior> {+ttk::notebook::TLCycleTab %W -1}
- bind $top <Control-Key-Tab> {+ttk::notebook::TLCycleTab %W 1}
- bind $top <Control-Shift-Key-Tab> {+ttk::notebook::TLCycleTab %W -1}
+ bind $top <Control-Next> {+ttk::notebook::TLCycleTab %W 1}
+ bind $top <Control-Prior> {+ttk::notebook::TLCycleTab %W -1}
+ bind $top <Control-Tab> {+ttk::notebook::TLCycleTab %W 1}
+ bind $top <Control-Shift-Tab> {+ttk::notebook::TLCycleTab %W -1}
catch {
- bind $top <Control-Key-ISO_Left_Tab> {+ttk::notebook::TLCycleTab %W -1}
+ bind $top <Control-ISO_Left_Tab> {+ttk::notebook::TLCycleTab %W -1}
}
if {[tk windowingsystem] eq "aqua"} {
- bind $top <Option-KeyPress> \
+ bind $top <Option-Key> \
+[list ttk::notebook::MnemonicActivation $top %K]
} else {
- bind $top <Alt-KeyPress> \
+ bind $top <Alt-Key> \
+[list ttk::notebook::MnemonicActivation $top %K]
}
bind $top <Destroy> {+ttk::notebook::TLCleanup %W}
@@ -145,7 +145,7 @@
}
}
-# EnclosingNotebook $w --
+# EnclosingNotebook $w --
# Return the nearest traversal-enabled notebook widget
# that contains $w.
#
@@ -171,7 +171,7 @@
# TLCycleTab --
# toplevel binding procedure for Control-Tab / Control-Shift-Tab
-# Select the next/previous tab in the nearest ancestor notebook.
+# Select the next/previous tab in the nearest ancestor notebook.
#
proc ttk::notebook::TLCycleTab {w dir} {
set nb [EnclosingNotebook $w]
@@ -182,7 +182,7 @@
}
# MnemonicActivation $nb $key --
-# Alt-KeyPress binding procedure for mnemonic activation.
+# Alt-Key binding procedure for mnemonic activation.
# Scan all notebooks in specified toplevel for a tab with the
# the specified mnemonic. If found, activate it and return TCL_BREAK.
#
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/panedwindow.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/panedwindow.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/panedwindow.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -15,7 +15,7 @@
## Bindings:
#
-bind TPanedwindow <ButtonPress-1> { ttk::panedwindow::Press %W %x %y }
+bind TPanedwindow <Button-1> { ttk::panedwindow::Press %W %x %y }
bind TPanedwindow <B1-Motion> { ttk::panedwindow::Drag %W %x %y }
bind TPanedwindow <ButtonRelease-1> { ttk::panedwindow::Release %W %x %y }
@@ -62,13 +62,22 @@
#
proc ttk::panedwindow::ResetCursor {w} {
variable State
+
+ ttk::saveCursor $w State(userConfCursor) \
+ [list [ttk::cursor hresize] [ttk::cursor vresize]]
+
if {!$State(pressed)} {
- ttk::setCursor $w {}
+ ttk::setCursor $w $State(userConfCursor)
}
}
proc ttk::panedwindow::SetCursor {w x y} {
- set cursor ""
+ variable State
+
+ ttk::saveCursor $w State(userConfCursor) \
+ [list [ttk::cursor hresize] [ttk::cursor vresize]]
+
+ set cursor $State(userConfCursor)
if {[llength [$w identify $x $y]]} {
# Assume we're over a sash.
switch -- [$w cget -orient] {
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/scale.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/scale.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/scale.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -9,15 +9,15 @@
}
}
-bind TScale <ButtonPress-1> { ttk::scale::Press %W %x %y }
+bind TScale <Button-1> { ttk::scale::Press %W %x %y }
bind TScale <B1-Motion> { ttk::scale::Drag %W %x %y }
bind TScale <ButtonRelease-1> { ttk::scale::Release %W %x %y }
-bind TScale <ButtonPress-2> { ttk::scale::Jump %W %x %y }
+bind TScale <Button-2> { ttk::scale::Jump %W %x %y }
bind TScale <B2-Motion> { ttk::scale::Drag %W %x %y }
bind TScale <ButtonRelease-2> { ttk::scale::Release %W %x %y }
-bind TScale <ButtonPress-3> { ttk::scale::Jump %W %x %y }
+bind TScale <Button-3> { ttk::scale::Jump %W %x %y }
bind TScale <B3-Motion> { ttk::scale::Drag %W %x %y }
bind TScale <ButtonRelease-3> { ttk::scale::Release %W %x %y }
@@ -52,7 +52,7 @@
}
}
-# scale::Jump -- ButtonPress-2/3 binding for scale acts like
+# scale::Jump -- Button-2/3 binding for scale acts like
# Press except that clicking in the trough jumps to the
# clicked position.
proc ttk::scale::Jump {w x y} {
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/scrollbar.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/scrollbar.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/scrollbar.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -9,14 +9,35 @@
# State(first) -- value of -first at start of drag.
}
-bind TScrollbar <ButtonPress-1> { ttk::scrollbar::Press %W %x %y }
+bind TScrollbar <Button-1> { ttk::scrollbar::Press %W %x %y }
bind TScrollbar <B1-Motion> { ttk::scrollbar::Drag %W %x %y }
bind TScrollbar <ButtonRelease-1> { ttk::scrollbar::Release %W %x %y }
-bind TScrollbar <ButtonPress-2> { ttk::scrollbar::Jump %W %x %y }
+bind TScrollbar <Button-2> { ttk::scrollbar::Jump %W %x %y }
bind TScrollbar <B2-Motion> { ttk::scrollbar::Drag %W %x %y }
bind TScrollbar <ButtonRelease-2> { ttk::scrollbar::Release %W %x %y }
+# Redirect scrollwheel bindings to the scrollbar widget
+#
+# The shift-bindings scroll left/right (not up/down)
+# if a widget has both possibilities
+set eventList [list <MouseWheel> <Shift-MouseWheel>]
+switch [tk windowingsystem] {
+ aqua {
+ lappend eventList <Option-MouseWheel> <Shift-Option-MouseWheel>
+ }
+ x11 {
+ lappend eventList <Button-4> <Button-5> \
+ <Shift-Button-4> <Shift-Button-5>
+ # For tk 8.7, the event list will be extended by
+ # <Button-6> <Button-7>
+ }
+}
+foreach event $eventList {
+ bind TScrollbar $event [bind Scrollbar $event]
+}
+unset eventList event
+
proc ttk::scrollbar::Scroll {w n units} {
set cmd [$w cget -command]
if {$cmd ne ""} {
@@ -38,7 +59,7 @@
set State(yPress) $y
switch -glob -- [$w identify $x $y] {
- *uparrow -
+ *uparrow -
*leftarrow {
ttk::Repeatedly Scroll $w -1 units
}
@@ -46,6 +67,7 @@
*rightarrow {
ttk::Repeatedly Scroll $w 1 units
}
+ *grip -
*thumb {
set State(first) [lindex [$w get] 0]
}
@@ -68,7 +90,7 @@
proc ttk::scrollbar::Drag {w x y} {
variable State
if {![info exists State(first)]} {
- # Initial buttonpress was not on the thumb,
+ # Initial buttonpress was not on the thumb,
# or something screwy has happened. In either case, ignore:
return;
}
@@ -83,7 +105,7 @@
ttk::CancelRepeat
}
-# scrollbar::Jump -- ButtonPress-2 binding for scrollbars.
+# scrollbar::Jump -- Button-2 binding for scrollbars.
# Behaves exactly like scrollbar::Press, except that
# clicking in the trough jumps to the the selected position.
#
@@ -91,6 +113,7 @@
variable State
switch -glob -- [$w identify $x $y] {
+ *grip -
*thumb -
*trough {
set State(first) [$w fraction $x $y]
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/sizegrip.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/sizegrip.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/sizegrip.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -32,7 +32,7 @@
}
}
-bind TSizegrip <ButtonPress-1> { ttk::sizegrip::Press %W %X %Y }
+bind TSizegrip <Button-1> { ttk::sizegrip::Press %W %X %Y }
bind TSizegrip <B1-Motion> { ttk::sizegrip::Drag %W %X %Y }
bind TSizegrip <ButtonRelease-1> { ttk::sizegrip::Release %W %X %Y }
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/spinbox.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/spinbox.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/spinbox.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -12,13 +12,13 @@
ttk::copyBindings TEntry TSpinbox
bind TSpinbox <Motion> { ttk::spinbox::Motion %W %x %y }
-bind TSpinbox <ButtonPress-1> { ttk::spinbox::Press %W %x %y }
+bind TSpinbox <Button-1> { ttk::spinbox::Press %W %x %y }
bind TSpinbox <ButtonRelease-1> { ttk::spinbox::Release %W }
bind TSpinbox <Double-Button-1> { ttk::spinbox::DoubleClick %W %x %y }
bind TSpinbox <Triple-Button-1> {} ;# disable TEntry triple-click
-bind TSpinbox <KeyPress-Up> { event generate %W <<Increment>> }
-bind TSpinbox <KeyPress-Down> { event generate %W <<Decrement>> }
+bind TSpinbox <Up> { event generate %W <<Increment>> }
+bind TSpinbox <Down> { event generate %W <<Decrement>> }
bind TSpinbox <<Increment>> { ttk::spinbox::Spin %W +1 }
bind TSpinbox <<Decrement>> { ttk::spinbox::Spin %W -1 }
@@ -29,12 +29,14 @@
# Sets cursor.
#
proc ttk::spinbox::Motion {w x y} {
+ variable State
+ ttk::saveCursor $w State(userConfCursor) [ttk::cursor text]
if { [$w identify $x $y] eq "textarea"
- && [$w instate {!readonly !disabled}]
+ && [$w instate {!readonly !disabled}]
} {
ttk::setCursor $w text
} else {
- ttk::setCursor $w ""
+ ttk::setCursor $w $State(userConfCursor)
}
}
@@ -44,16 +46,16 @@
if {[$w instate disabled]} { return }
focus $w
switch -glob -- [$w identify $x $y] {
- *textarea { ttk::entry::Press $w $x }
+ *textarea { ttk::entry::Press $w $x }
*rightarrow -
- *uparrow { ttk::Repeatedly event generate $w <<Increment>> }
+ *uparrow { ttk::Repeatedly event generate $w <<Increment>> }
*leftarrow -
- *downarrow { ttk::Repeatedly event generate $w <<Decrement>> }
+ *downarrow { ttk::Repeatedly event generate $w <<Decrement>> }
*spinbutton {
if {$y * 2 >= [winfo height $w]} {
- set event <<Decrement>>
+ set event <<Decrement>>
} else {
- set event <<Increment>>
+ set event <<Increment>>
}
ttk::Repeatedly event generate $w $event
}
@@ -67,7 +69,7 @@
if {[$w instate disabled]} { return }
switch -glob -- [$w identify $x $y] {
- *textarea { SelectAll $w }
+ *textarea { SelectAll $w }
* { Press $w $x $y }
}
}
@@ -133,16 +135,31 @@
# -from, -to, and -increment.
#
proc ttk::spinbox::Spin {w dir} {
+ variable State
+
if {[$w instate disabled]} { return }
- set nvalues [llength [set values [$w cget -values]]]
- set value [$w get]
- if {$nvalues} {
- set current [lsearch -exact $values $value]
- set index [Adjust $w [expr {$current + $dir}] 0 [expr {$nvalues - 1}]]
- $w set [lindex $values $index]
+
+ if {![info exists State($w,values.length)]} {
+ set State($w,values.index) -1
+ set State($w,values.last) {}
+ }
+ set State($w,values) [$w cget -values]
+ set State($w,values.length) [llength $State($w,values)]
+
+ if {$State($w,values.length) > 0} {
+ set value [$w get]
+ set current $State($w,values.index)
+ if {$value ne $State($w,values.last)} {
+ set current [lsearch -exact $State($w,values) $value]
+ if {$current < 0} {set current -1}
+ }
+ set State($w,values.index) [Adjust $w [expr {$current + $dir}] 0 \
+ [expr {$State($w,values.length) - 1}]]
+ set State($w,values.last) [lindex $State($w,values) $State($w,values.index)]
+ $w set $State($w,values.last)
} else {
- if {[catch {
- set v [expr {[scan [$w get] %f] + $dir * [$w cget -increment]}]
+ if {[catch {
+ set v [expr {[scan [$w get] %f] + $dir * [$w cget -increment]}]
}]} {
set v [$w cget -from]
}
@@ -160,7 +177,7 @@
if {$fmt eq ""} {
# Try to guess a suitable -format based on -increment.
set delta [expr {abs([$w cget -increment])}]
- if {0 < $delta && $delta < 1} {
+ if {0 < $delta && $delta < 1} {
# NB: This guesses wrong if -increment has more than 1
# significant digit itself, e.g., -increment 0.25
set nsd [expr {int(ceil(-log10($delta)))}]
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/treeview.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/treeview.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/treeview.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -28,25 +28,25 @@
bind Treeview <Motion> { ttk::treeview::Motion %W %x %y }
bind Treeview <B1-Leave> { #nothing }
bind Treeview <Leave> { ttk::treeview::ActivateHeading {} {}}
-bind Treeview <ButtonPress-1> { ttk::treeview::Press %W %x %y }
-bind Treeview <Double-ButtonPress-1> { ttk::treeview::DoubleClick %W %x %y }
+bind Treeview <Button-1> { ttk::treeview::Press %W %x %y }
+bind Treeview <Double-Button-1> { ttk::treeview::DoubleClick %W %x %y }
bind Treeview <ButtonRelease-1> { ttk::treeview::Release %W %x %y }
bind Treeview <B1-Motion> { ttk::treeview::Drag %W %x %y }
-bind Treeview <KeyPress-Up> { ttk::treeview::Keynav %W up }
-bind Treeview <KeyPress-Down> { ttk::treeview::Keynav %W down }
-bind Treeview <KeyPress-Right> { ttk::treeview::Keynav %W right }
-bind Treeview <KeyPress-Left> { ttk::treeview::Keynav %W left }
-bind Treeview <KeyPress-Prior> { %W yview scroll -1 pages }
-bind Treeview <KeyPress-Next> { %W yview scroll 1 pages }
-bind Treeview <KeyPress-Return> { ttk::treeview::ToggleFocus %W }
-bind Treeview <KeyPress-space> { ttk::treeview::ToggleFocus %W }
+bind Treeview <Up> { ttk::treeview::Keynav %W up }
+bind Treeview <Down> { ttk::treeview::Keynav %W down }
+bind Treeview <Right> { ttk::treeview::Keynav %W right }
+bind Treeview <Left> { ttk::treeview::Keynav %W left }
+bind Treeview <Prior> { %W yview scroll -1 pages }
+bind Treeview <Next> { %W yview scroll 1 pages }
+bind Treeview <Return> { ttk::treeview::ToggleFocus %W }
+bind Treeview <space> { ttk::treeview::ToggleFocus %W }
-bind Treeview <Shift-ButtonPress-1> \
+bind Treeview <Shift-Button-1> \
{ ttk::treeview::Select %W %x %y extend }
bind Treeview <<ToggleSelection>> \
{ ttk::treeview::Select %W %x %y toggle }
-ttk::copyBindings TtkScrollable Treeview
+ttk::copyBindings TtkScrollable Treeview
### Binding procedures.
#
@@ -102,7 +102,11 @@
# Sets cursor, active element ...
#
proc ttk::treeview::Motion {w x y} {
- set cursor {}
+ variable State
+
+ ttk::saveCursor $w State(userConfCursor) [ttk::cursor hresize]
+
+ set cursor $State(userConfCursor)
set activeHeading {}
switch -- [$w identify region $x $y] {
@@ -127,7 +131,7 @@
# triggers a <Leave> event. A proc checking if the display column
# $State(activeHeading) is really still present or not could be
# written but it would need to check several special cases:
- # a. -displaycolumns "#all" or being an explicit columns list
+ # a. -displaycolumns "#all" or being an explicit columns list
# b. column #0 display is not governed by the -displaycolumn
# list but by the value of the -show option
# --> Let's rather catch the following line.
@@ -151,7 +155,7 @@
}
}
-## DoubleClick -- Double-ButtonPress-1 binding.
+## DoubleClick -- Double-Button-1 binding.
#
proc ttk::treeview::DoubleClick {w x y} {
if {[set row [$w identify row $x $y]] ne ""} {
@@ -161,7 +165,7 @@
}
}
-## Press -- ButtonPress binding.
+## Press -- Button binding.
#
proc ttk::treeview::Press {w x y} {
focus $w
@@ -261,9 +265,9 @@
## -selectmode none:
#
-proc ttk::treeview::select.choose.none {w item} { $w focus $item }
-proc ttk::treeview::select.toggle.none {w item} { $w focus $item }
-proc ttk::treeview::select.extend.none {w item} { $w focus $item }
+proc ttk::treeview::select.choose.none {w item} { $w focus $item; $w see $item }
+proc ttk::treeview::select.toggle.none {w item} { $w focus $item; $w see $item }
+proc ttk::treeview::select.extend.none {w item} { $w focus $item; $w see $item }
## -selectmode browse:
#
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/ttk.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/ttk.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/ttk.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -12,9 +12,9 @@
}
}
-source [file join $::ttk::library fonts.tcl]
-source [file join $::ttk::library cursors.tcl]
-source [file join $::ttk::library utils.tcl]
+source -encoding utf-8 [file join $::ttk::library fonts.tcl]
+source -encoding utf-8 [file join $::ttk::library cursors.tcl]
+source -encoding utf-8 [file join $::ttk::library utils.tcl]
## ttk::deprecated $old $new --
# Define $old command as a deprecated alias for $new command
@@ -97,18 +97,18 @@
### Load widget bindings.
#
-source [file join $::ttk::library button.tcl]
-source [file join $::ttk::library menubutton.tcl]
-source [file join $::ttk::library scrollbar.tcl]
-source [file join $::ttk::library scale.tcl]
-source [file join $::ttk::library progress.tcl]
-source [file join $::ttk::library notebook.tcl]
-source [file join $::ttk::library panedwindow.tcl]
-source [file join $::ttk::library entry.tcl]
-source [file join $::ttk::library combobox.tcl] ;# dependency: entry.tcl
-source [file join $::ttk::library spinbox.tcl] ;# dependency: entry.tcl
-source [file join $::ttk::library treeview.tcl]
-source [file join $::ttk::library sizegrip.tcl]
+source -encoding utf-8 [file join $::ttk::library button.tcl]
+source -encoding utf-8 [file join $::ttk::library menubutton.tcl]
+source -encoding utf-8 [file join $::ttk::library scrollbar.tcl]
+source -encoding utf-8 [file join $::ttk::library scale.tcl]
+source -encoding utf-8 [file join $::ttk::library progress.tcl]
+source -encoding utf-8 [file join $::ttk::library notebook.tcl]
+source -encoding utf-8 [file join $::ttk::library panedwindow.tcl]
+source -encoding utf-8 [file join $::ttk::library entry.tcl]
+source -encoding utf-8 [file join $::ttk::library combobox.tcl] ;# dependency: entry.tcl
+source -encoding utf-8 [file join $::ttk::library spinbox.tcl] ;# dependency: entry.tcl
+source -encoding utf-8 [file join $::ttk::library treeview.tcl]
+source -encoding utf-8 [file join $::ttk::library sizegrip.tcl]
## Label and Labelframe bindings:
# (not enough to justify their own file...)
@@ -122,7 +122,7 @@
variable library
# "default" always present:
- uplevel #0 [list source [file join $library defaults.tcl]]
+ uplevel #0 [list source -encoding utf-8 [file join $library defaults.tcl]]
set builtinThemes [style theme names]
foreach {theme scripts} {
@@ -135,7 +135,7 @@
} {
if {[lsearch -exact $builtinThemes $theme] >= 0} {
foreach script $scripts {
- uplevel #0 [list source [file join $library $script]]
+ uplevel #0 [list source -encoding utf-8 [file join $library $script]]
}
}
}
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/utils.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/utils.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/utils.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -58,7 +58,7 @@
}
## ttk::clickToFocus $w --
-# Utility routine, used in <ButtonPress-1> bindings --
+# Utility routine, used in <Button-1> bindings --
# Assign keyboard focus to the specified widget if -takefocus is enabled.
#
proc ttk::clickToFocus {w} {
@@ -278,9 +278,6 @@
# On OSX, Tk generates sensible values for the %D field in <MouseWheel> events.
#
# On Windows, %D must be scaled by a factor of 120.
-# In addition, Tk redirects mousewheel events to the window with
-# keyboard focus instead of sending them to the window under the pointer.
-# We do not attempt to fix that here, see also TIP#171.
#
# OSX conventionally uses Shift+MouseWheel for horizontal scrolling,
# and Option+MouseWheel for accelerated scrolling.
@@ -301,14 +298,14 @@
proc ttk::bindMouseWheel {bindtag callback} {
if {[tk windowingsystem] eq "x11"} {
- bind $bindtag <ButtonPress-4> "$callback -1"
- bind $bindtag <ButtonPress-5> "$callback +1"
+ bind $bindtag <Button-4> "$callback -1"
+ bind $bindtag <Button-5> "$callback +1"
}
if {[tk windowingsystem] eq "aqua"} {
- bind $bindtag <MouseWheel> [append callback { [expr {-(%D)}]} ]
- bind $bindtag <Option-MouseWheel> [append callback { [expr {-10 *(%D)}]} ]
+ bind $bindtag <MouseWheel> "$callback \[expr {-%D}\]"
+ bind $bindtag <Option-MouseWheel> "$callback \[expr {-10*%D}\]"
} else {
- bind $bindtag <MouseWheel> [append callback { [expr {-(%D / 120)}]}]
+ bind $bindtag <MouseWheel> "$callback \[expr {-%D/120)}\]"
}
}
@@ -321,10 +318,10 @@
#
if {[tk windowingsystem] eq "x11"} {
- bind TtkScrollable <ButtonPress-4> { %W yview scroll -5 units }
- bind TtkScrollable <ButtonPress-5> { %W yview scroll 5 units }
- bind TtkScrollable <Shift-ButtonPress-4> { %W xview scroll -5 units }
- bind TtkScrollable <Shift-ButtonPress-5> { %W xview scroll 5 units }
+ bind TtkScrollable <Button-4> { %W yview scroll -5 units }
+ bind TtkScrollable <Button-5> { %W yview scroll 5 units }
+ bind TtkScrollable <Shift-Button-4> { %W xview scroll -5 units }
+ bind TtkScrollable <Shift-Button-5> { %W xview scroll 5 units }
}
if {[tk windowingsystem] eq "aqua"} {
bind TtkScrollable <MouseWheel> \
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/vistaTheme.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/vistaTheme.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/vistaTheme.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -3,7 +3,7 @@
#
# The Vista theme can only be defined on Windows Vista and above. The theme
-# is created in C due to the need to assign a theme-enabled function for
+# is created in C due to the need to assign a theme-enabled function for
# detecting when themeing is disabled. On systems that cannot support the
# Vista theme, there will be no such theme created and we must not
# evaluate this script.
@@ -69,9 +69,9 @@
ttk::style layout TCombobox {
Combobox.border -sticky nswe -border 0 -children {
Combobox.rightdownarrow -side right -sticky ns
- Combobox.padding -expand 1 -sticky nswe -children {
+ Combobox.padding -sticky nswe -children {
Combobox.background -sticky nswe -children {
- Combobox.focus -expand 1 -sticky nswe -children {
+ Combobox.focus -sticky nswe -children {
Combobox.textarea -sticky nswe
}
}
@@ -138,7 +138,7 @@
Spinbox.background -sticky news -children {
Spinbox.padding -sticky news -children {
Spinbox.innerbg -sticky news -children {
- Spinbox.textarea -expand 1
+ Spinbox.textarea
}
}
Spinbox.uparrow -side top -sticky ens
@@ -151,7 +151,7 @@
-selectforeground [list !focus SystemWindowText] \
;
-
+
# SCROLLBAR elements (Vista includes a state for 'hover')
ttk::style element create Vertical.Scrollbar.uparrow vsapi \
SCROLLBAR 1 {disabled 4 pressed 3 active 2 hover 17 {} 1} \
@@ -196,14 +196,14 @@
Vertical.Progressbar.pbar -side bottom -sticky we
}
}
-
+
# Scale
ttk::style element create Horizontal.Scale.slider vsapi \
TRACKBAR 3 {disabled 5 focus 4 pressed 3 active 2 {} 1} \
-width 6 -height 12
ttk::style layout Horizontal.TScale {
- Scale.focus -expand 1 -sticky nswe -children {
- Horizontal.Scale.trough -expand 1 -sticky nswe -children {
+ Scale.focus -sticky nswe -children {
+ Horizontal.Scale.trough -sticky nswe -children {
Horizontal.Scale.track -sticky we
Horizontal.Scale.slider -side left -sticky {}
}
@@ -213,17 +213,17 @@
TRACKBAR 6 {disabled 5 focus 4 pressed 3 active 2 {} 1} \
-width 12 -height 6
ttk::style layout Vertical.TScale {
- Scale.focus -expand 1 -sticky nswe -children {
- Vertical.Scale.trough -expand 1 -sticky nswe -children {
+ Scale.focus -sticky nswe -children {
+ Vertical.Scale.trough -sticky nswe -children {
Vertical.Scale.track -sticky ns
Vertical.Scale.slider -side top -sticky {}
}
}
}
-
+
# Treeview
ttk::style configure Item -padding {4 0 0 0}
-
+
package provide ttk::theme::vista 1.0
}
}
Modified: trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/xpTheme.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/xpTheme.tcl 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tk8.6/ttk/xpTheme.tcl 2021-03-02 16:29:37 UTC (rev 58056)
@@ -28,13 +28,6 @@
ttk::style map TNotebook.Tab \
-expand [list selected {2 2 2 2}]
- # Treeview:
- ttk::style configure Heading -font TkHeadingFont
- ttk::style configure Treeview -background SystemWindow
- ttk::style map Treeview \
- -background [list selected SystemHighlight] \
- -foreground [list selected SystemHighlightText] ;
-
ttk::style configure TLabelframe.Label -foreground "#0046d5"
# OR: -padding {3 3 3 6}, which some apps seem to use.
Modified: trunk/Master/tlpkg/tltcl/lib/tkConfig.sh
===================================================================
--- trunk/Master/tlpkg/tltcl/lib/tkConfig.sh 2021-03-02 14:32:33 UTC (rev 58055)
+++ trunk/Master/tlpkg/tltcl/lib/tkConfig.sh 2021-03-02 16:29:37 UTC (rev 58056)
@@ -17,10 +17,10 @@
TK_VERSION='8.6'
TK_MAJOR_VERSION='8'
TK_MINOR_VERSION='6'
-TK_PATCH_LEVEL='.10'
+TK_PATCH_LEVEL='.11'
# -D flags for use with the C compiler.
-TK_DEFS='-DPACKAGE_NAME=\"\" -DPACKAGE_TARNAME=\"\" -DPACKAGE_VERSION=\"\" -DPACKAGE_STRING=\"\" -DPACKAGE_BUGREPORT=\"\" -DSTDC_HEADERS=1 -DTCL_THREADS=1 -DUSE_THREAD_ALLOC=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 -DMODULE_SCOPE=extern -DHAVE_NO_SEH=1 -DHAVE_CAST_TO_UNION=1 -DHAVE_UXTHEME_H=1 -DHAVE_VSSYM32_H=1 -DNDEBUG=1 -DTCL_CFG_OPTIMIZED=1 '
+TK_DEFS='-DPACKAGE_NAME=\"\" -DPACKAGE_TARNAME=\"\" -DPACKAGE_VERSION=\"\" -DPACKAGE_STRING=\"\" -DPACKAGE_BUGREPORT=\"\" -DSTDC_HEADERS=1 -DTCL_THREADS=1 -DUSE_THREAD_ALLOC=1 -DMODULE_SCOPE=extern -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_UXTHEME_H=1 -DHAVE_VSSYM32_H=1 -DNDEBUG=1 -DTCL_CFG_OPTIMIZED=1 '
# Flag, 1: we built a shared lib, 0 we didn't
TK_SHARED_BUILD=1
@@ -29,7 +29,7 @@
TK_DBGX=
# The name of the Tk library (may be either a .a file or a shared library):
-TK_LIB_FILE='libtk86.a'
+TK_LIB_FILE='libtk86.dll.a'
# Additional libraries to use when linking Tk.
TK_LIBS='-lnetapi32 -lkernel32 -luser32 -ladvapi32 -luserenv -lws2_32 -lgdi32 -lcomdlg32 -limm32 -lcomctl32 -lshell32 -luuid -lole32 -loleaut32'
@@ -36,11 +36,11 @@
# Top-level directory in which Tcl's platform-independent files are
# installed.
-TK_PREFIX='/tmp/siepo/tcltk'
+TK_PREFIX='/home/siepo/tltcl'
# Top-level directory in which Tcl's platform-specific files (e.g.
# executables) are installed.
-TK_EXEC_PREFIX='/tmp/siepo/tcltk'
+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.10/win -ltk86'
+TK_BUILD_LIB_SPEC='-L/home/siepo/xdrive/tltcl/tk8.6.11/win -ltk86'
# String to pass to linker to pick up the Tk library from its
# installed directory.
-TK_LIB_SPEC='-L/tmp/siepo/tcltk/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.10'
+TK_SRC_DIR='/home/siepo/xdrive/tltcl/tk8.6.11'
# 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.10/win -ltkstub86'
+TK_BUILD_STUB_LIB_SPEC='-L/home/siepo/xdrive/tltcl/tk8.6.11/win -ltkstub86'
# String to pass to linker to pick up the Tk stub library from its
# installed directory.
-TK_STUB_LIB_SPEC='-L/tmp/siepo/tcltk/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.10/win/libtkstub86.a'
+TK_BUILD_STUB_LIB_PATH='/home/siepo/xdrive/tltcl/tk8.6.11/win/libtkstub86.a'
# Path to the Tk stub library in the install directory.
-TK_STUB_LIB_PATH='/tmp/siepo/tcltk/lib/libtkstub86.a'
+TK_STUB_LIB_PATH='/home/siepo/tltcl/lib/libtkstub86.a'
More information about the tex-live-commits
mailing list.