summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tltcl/lib/tcl8
diff options
context:
space:
mode:
authorNorbert Preining <norbert@preining.info>2020-04-11 03:09:12 +0000
committerNorbert Preining <norbert@preining.info>2020-04-11 03:09:12 +0000
commitc2697fc286a1e2c94fd9968b76be6f4a6d2114cd (patch)
tree1dc2cfb07cb032740483dd8be7c74aff66b70352 /systems/texlive/tlnet/tlpkg/tltcl/lib/tcl8
parent25111608e6aa05042b0c6f83009262e1973d7a45 (diff)
CTAN sync 202004110309
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tltcl/lib/tcl8')
-rw-r--r--systems/texlive/tlnet/tlpkg/tltcl/lib/tcl8/8.4/platform-1.0.14.tm397
-rw-r--r--systems/texlive/tlnet/tlpkg/tltcl/lib/tcl8/8.4/platform/shell-1.1.4.tm241
-rw-r--r--systems/texlive/tlnet/tlpkg/tltcl/lib/tcl8/8.5/msgcat-1.6.1.tm1210
-rw-r--r--systems/texlive/tlnet/tlpkg/tltcl/lib/tcl8/8.5/tcltest-2.5.1.tm3446
-rw-r--r--systems/texlive/tlnet/tlpkg/tltcl/lib/tcl8/8.6/http-2.9.1.tm3427
-rw-r--r--systems/texlive/tlnet/tlpkg/tltcl/lib/tcl8/8.6/tdbc/sqlite3-1.1.1.tm715
6 files changed, 9436 insertions, 0 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tltcl/lib/tcl8/8.4/platform-1.0.14.tm b/systems/texlive/tlnet/tlpkg/tltcl/lib/tcl8/8.4/platform-1.0.14.tm
new file mode 100644
index 0000000000..35a22a3153
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tltcl/lib/tcl8/8.4/platform-1.0.14.tm
@@ -0,0 +1,397 @@
+# -*- 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
+}
diff --git a/systems/texlive/tlnet/tlpkg/tltcl/lib/tcl8/8.4/platform/shell-1.1.4.tm b/systems/texlive/tlnet/tlpkg/tltcl/lib/tcl8/8.4/platform/shell-1.1.4.tm
new file mode 100644
index 0000000000..6eb9691018
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tltcl/lib/tcl8/8.4/platform/shell-1.1.4.tm
@@ -0,0 +1,241 @@
+
+# -*- tcl -*-
+# ### ### ### ######### ######### #########
+## Overview
+
+# Higher-level commands which invoke the functionality of this package
+# for an arbitrary tcl shell (tclsh, wish, ...). This is required by a
+# repository as while the tcl shell executing packages uses the same
+# platform in general as a repository application there can be
+# differences in detail (i.e. 32/64 bit builds).
+
+# ### ### ### ######### ######### #########
+## Requirements
+
+package require platform
+namespace eval ::platform::shell {}
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+# -- platform::shell::generic
+
+proc ::platform::shell::generic {shell} {
+ # Argument is the path to a tcl shell.
+
+ CHECK $shell
+ LOCATE base out
+
+ set code {}
+ # Forget any pre-existing platform package, it might be in
+ # conflict with this one.
+ lappend code {package forget platform}
+ # Inject our platform package
+ lappend code [list source $base]
+ # Query and print the architecture
+ lappend code {puts [platform::generic]}
+ # And done
+ lappend code {exit 0}
+
+ set arch [RUN $shell [join $code \n]]
+
+ if {$out} {file delete -force $base}
+ return $arch
+}
+
+# -- platform::shell::identify
+
+proc ::platform::shell::identify {shell} {
+ # Argument is the path to a tcl shell.
+
+ CHECK $shell
+ LOCATE base out
+
+ set code {}
+ # Forget any pre-existing platform package, it might be in
+ # conflict with this one.
+ lappend code {package forget platform}
+ # Inject our platform package
+ lappend code [list source $base]
+ # Query and print the architecture
+ lappend code {puts [platform::identify]}
+ # And done
+ lappend code {exit 0}
+
+ set arch [RUN $shell [join $code \n]]
+
+ if {$out} {file delete -force $base}
+ return $arch
+}
+
+# -- platform::shell::platform
+
+proc ::platform::shell::platform {shell} {
+ # Argument is the path to a tcl shell.
+
+ CHECK $shell
+
+ set code {}
+ lappend code {puts $tcl_platform(platform)}
+ lappend code {exit 0}
+
+ return [RUN $shell [join $code \n]]
+}
+
+# ### ### ### ######### ######### #########
+## Internal helper commands.
+
+proc ::platform::shell::CHECK {shell} {
+ if {![file exists $shell]} {
+ return -code error "Shell \"$shell\" does not exist"
+ }
+ if {![file executable $shell]} {
+ return -code error "Shell \"$shell\" is not executable (permissions)"
+ }
+ return
+}
+
+proc ::platform::shell::LOCATE {bv ov} {
+ upvar 1 $bv base $ov out
+
+ # Locate the platform package for injection into the specified
+ # shell. We are using package management to find it, whereever it
+ # is, instead of using hardwired relative paths. This allows us to
+ # install the two packages as TMs without breaking the code
+ # here. If the found package is wrapped we copy the code somewhere
+ # where the spawned shell will be able to read it.
+
+ # This code is brittle, it needs has to adapt to whatever changes
+ # are made to the TM code, i.e. the provide statement generated by
+ # tm.tcl
+
+ set pl [package ifneeded platform [package require platform]]
+ set base [lindex $pl end]
+
+ set out 0
+ if {[lindex [file system $base]] ne "native"} {
+ set temp [TEMP]
+ file copy -force $base $temp
+ set base $temp
+ set out 1
+ }
+ return
+}
+
+proc ::platform::shell::RUN {shell code} {
+ set c [TEMP]
+ set cc [open $c w]
+ puts $cc $code
+ close $cc
+
+ set e [TEMP]
+
+ set code [catch {
+ exec $shell $c 2> $e
+ } res]
+
+ file delete $c
+
+ if {$code} {
+ append res \n[read [set chan [open $e r]]][close $chan]
+ file delete $e
+ return -code error "Shell \"$shell\" is not executable ($res)"
+ }
+
+ file delete $e
+ return $res
+}
+
+proc ::platform::shell::TEMP {} {
+ set prefix platform
+
+ # This code is copied out of Tcllib's fileutil package.
+ # (TempFile/tempfile)
+
+ set tmpdir [DIR]
+
+ set chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
+ set nrand_chars 10
+ set maxtries 10
+ set access [list RDWR CREAT EXCL TRUNC]
+ set permission 0600
+ set channel ""
+ set checked_dir_writable 0
+ set mypid [pid]
+ for {set i 0} {$i < $maxtries} {incr i} {
+ set newname $prefix
+ for {set j 0} {$j < $nrand_chars} {incr j} {
+ append newname [string index $chars \
+ [expr {int(rand()*62)}]]
+ }
+ set newname [file join $tmpdir $newname]
+ if {[file exists $newname]} {
+ after 1
+ } else {
+ if {[catch {open $newname $access $permission} channel]} {
+ if {!$checked_dir_writable} {
+ set dirname [file dirname $newname]
+ if {![file writable $dirname]} {
+ return -code error "Directory $dirname is not writable"
+ }
+ set checked_dir_writable 1
+ }
+ } else {
+ # Success
+ close $channel
+ return [file normalize $newname]
+ }
+ }
+ }
+ if {$channel ne ""} {
+ return -code error "Failed to open a temporary file: $channel"
+ } else {
+ return -code error "Failed to find an unused temporary file name"
+ }
+}
+
+proc ::platform::shell::DIR {} {
+ # This code is copied out of Tcllib's fileutil package.
+ # (TempDir/tempdir)
+
+ global tcl_platform env
+
+ set attempdirs [list]
+
+ foreach tmp {TMPDIR TEMP TMP} {
+ if { [info exists env($tmp)] } {
+ lappend attempdirs $env($tmp)
+ }
+ }
+
+ switch $tcl_platform(platform) {
+ windows {
+ lappend attempdirs "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP"
+ }
+ macintosh {
+ set tmpdir $env(TRASH_FOLDER) ;# a better place?
+ }
+ default {
+ lappend attempdirs \
+ [file join / tmp] \
+ [file join / var tmp] \
+ [file join / usr tmp]
+ }
+ }
+
+ lappend attempdirs [pwd]
+
+ foreach tmp $attempdirs {
+ if { [file isdirectory $tmp] && [file writable $tmp] } {
+ return [file normalize $tmp]
+ }
+ }
+
+ # Fail if nothing worked.
+ return -code error "Unable to determine a proper directory for temporary files"
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide platform::shell 1.1.4
diff --git a/systems/texlive/tlnet/tlpkg/tltcl/lib/tcl8/8.5/msgcat-1.6.1.tm b/systems/texlive/tlnet/tlpkg/tltcl/lib/tcl8/8.5/msgcat-1.6.1.tm
new file mode 100644
index 0000000000..646bc179e4
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tltcl/lib/tcl8/8.5/msgcat-1.6.1.tm
@@ -0,0 +1,1210 @@
+# msgcat.tcl --
+#
+# This file defines various procedures which implement a
+# 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.
+#
+# 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.5-
+# When the version number changes, be sure to update the pkgIndex.tcl file,
+# and the installation directory in the Makefiles.
+package provide msgcat 1.6.1
+
+namespace eval msgcat {
+ namespace export mc mcexists mcload mclocale mcmax mcmset mcpreferences mcset\
+ mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\
+ mcpackageconfig mcpackagelocale
+
+ # Records the list of locales to search
+ variable Loclist {}
+
+ # List of currently loaded locales
+ variable LoadedLocales {}
+
+ # Records the locale of the currently sourced message catalogue file
+ variable FileLocale
+
+ # Configuration values per Package (e.g. client namespace).
+ # The dict key is of the form "<option> <namespace>" and the value is the
+ # configuration option. A nonexisting key is an unset option.
+ variable PackageConfig [dict create mcfolder {} loadcmd {} changecmd {}\
+ unknowncmd {} loadedlocales {} loclist {}]
+
+ # Records the mapping between source strings and translated strings. The
+ # dict key is of the form "<namespace> <locale> <src>", where locale and
+ # namespace should be themselves dict values and the value is
+ # the translated string.
+ variable Msgs [dict create]
+
+ # Map of language codes used in Windows registry to those of ISO-639
+ if {[info sharedlibextension] eq ".dll"} {
+ variable WinRegToISO639 [dict create {*}{
+ 01 ar 0401 ar_SA 0801 ar_IQ 0c01 ar_EG 1001 ar_LY 1401 ar_DZ
+ 1801 ar_MA 1c01 ar_TN 2001 ar_OM 2401 ar_YE 2801 ar_SY
+ 2c01 ar_JO 3001 ar_LB 3401 ar_KW 3801 ar_AE 3c01 ar_BH
+ 4001 ar_QA
+ 02 bg 0402 bg_BG
+ 03 ca 0403 ca_ES
+ 04 zh 0404 zh_TW 0804 zh_CN 0c04 zh_HK 1004 zh_SG 1404 zh_MO
+ 05 cs 0405 cs_CZ
+ 06 da 0406 da_DK
+ 07 de 0407 de_DE 0807 de_CH 0c07 de_AT 1007 de_LU 1407 de_LI
+ 08 el 0408 el_GR
+ 09 en 0409 en_US 0809 en_GB 0c09 en_AU 1009 en_CA 1409 en_NZ
+ 1809 en_IE 1c09 en_ZA 2009 en_JM 2409 en_GD 2809 en_BZ
+ 2c09 en_TT 3009 en_ZW 3409 en_PH
+ 0a es 040a es_ES 080a es_MX 0c0a es_ES@modern 100a es_GT 140a es_CR
+ 180a es_PA 1c0a es_DO 200a es_VE 240a es_CO 280a es_PE
+ 2c0a es_AR 300a es_EC 340a es_CL 380a es_UY 3c0a es_PY
+ 400a es_BO 440a es_SV 480a es_HN 4c0a es_NI 500a es_PR
+ 0b fi 040b fi_FI
+ 0c fr 040c fr_FR 080c fr_BE 0c0c fr_CA 100c fr_CH 140c fr_LU
+ 180c fr_MC
+ 0d he 040d he_IL
+ 0e hu 040e hu_HU
+ 0f is 040f is_IS
+ 10 it 0410 it_IT 0810 it_CH
+ 11 ja 0411 ja_JP
+ 12 ko 0412 ko_KR
+ 13 nl 0413 nl_NL 0813 nl_BE
+ 14 no 0414 no_NO 0814 nn_NO
+ 15 pl 0415 pl_PL
+ 16 pt 0416 pt_BR 0816 pt_PT
+ 17 rm 0417 rm_CH
+ 18 ro 0418 ro_RO 0818 ro_MO
+ 19 ru 0819 ru_MO
+ 1a hr 041a hr_HR 081a sr_YU 0c1a sr_YU@cyrillic
+ 1b sk 041b sk_SK
+ 1c sq 041c sq_AL
+ 1d sv 041d sv_SE 081d sv_FI
+ 1e th 041e th_TH
+ 1f tr 041f tr_TR
+ 20 ur 0420 ur_PK 0820 ur_IN
+ 21 id 0421 id_ID
+ 22 uk 0422 uk_UA
+ 23 be 0423 be_BY
+ 24 sl 0424 sl_SI
+ 25 et 0425 et_EE
+ 26 lv 0426 lv_LV
+ 27 lt 0427 lt_LT
+ 28 tg 0428 tg_TJ
+ 29 fa 0429 fa_IR
+ 2a vi 042a vi_VN
+ 2b hy 042b hy_AM
+ 2c az 042c az_AZ@latin 082c az_AZ@cyrillic
+ 2d eu
+ 2e wen 042e wen_DE
+ 2f mk 042f mk_MK
+ 30 bnt 0430 bnt_TZ
+ 31 ts 0431 ts_ZA
+ 32 tn
+ 33 ven 0433 ven_ZA
+ 34 xh 0434 xh_ZA
+ 35 zu 0435 zu_ZA
+ 36 af 0436 af_ZA
+ 37 ka 0437 ka_GE
+ 38 fo 0438 fo_FO
+ 39 hi 0439 hi_IN
+ 3a mt 043a mt_MT
+ 3b se 043b se_NO
+ 043c gd_UK 083c ga_IE
+ 3d yi 043d yi_IL
+ 3e ms 043e ms_MY 083e ms_BN
+ 3f kk 043f kk_KZ
+ 40 ky 0440 ky_KG
+ 41 sw 0441 sw_KE
+ 42 tk 0442 tk_TM
+ 43 uz 0443 uz_UZ@latin 0843 uz_UZ@cyrillic
+ 44 tt 0444 tt_RU
+ 45 bn 0445 bn_IN
+ 46 pa 0446 pa_IN
+ 47 gu 0447 gu_IN
+ 48 or 0448 or_IN
+ 49 ta
+ 4a te 044a te_IN
+ 4b kn 044b kn_IN
+ 4c ml 044c ml_IN
+ 4d as 044d as_IN
+ 4e mr 044e mr_IN
+ 4f sa 044f sa_IN
+ 50 mn
+ 51 bo 0451 bo_CN
+ 52 cy 0452 cy_GB
+ 53 km 0453 km_KH
+ 54 lo 0454 lo_LA
+ 55 my 0455 my_MM
+ 56 gl 0456 gl_ES
+ 57 kok 0457 kok_IN
+ 58 mni 0458 mni_IN
+ 59 sd
+ 5a syr 045a syr_TR
+ 5b si 045b si_LK
+ 5c chr 045c chr_US
+ 5d iu 045d iu_CA
+ 5e am 045e am_ET
+ 5f ber 045f ber_MA
+ 60 ks 0460 ks_PK 0860 ks_IN
+ 61 ne 0461 ne_NP 0861 ne_IN
+ 62 fy 0462 fy_NL
+ 63 ps
+ 64 tl 0464 tl_PH
+ 65 div 0465 div_MV
+ 66 bin 0466 bin_NG
+ 67 ful 0467 ful_NG
+ 68 ha 0468 ha_NG
+ 69 nic 0469 nic_NG
+ 6a yo 046a yo_NG
+ 70 ibo 0470 ibo_NG
+ 71 kau 0471 kau_NG
+ 72 om 0472 om_ET
+ 73 ti 0473 ti_ET
+ 74 gn 0474 gn_PY
+ 75 cpe 0475 cpe_US
+ 76 la 0476 la_VA
+ 77 so 0477 so_SO
+ 78 sit 0478 sit_CN
+ 79 pap 0479 pap_AN
+ }]
+ }
+}
+
+# msgcat::mc --
+#
+# Find the translation for the given string based on the current
+# locale setting. Check the local namespace first, then look in each
+# parent namespace until the source is found. If additional args are
+# specified, use the format command to work them into the traslated
+# string.
+# If no catalog item is found, mcunknown is called in the caller frame
+# and its result is returned.
+#
+# Arguments:
+# src The string to translate.
+# args Args to pass to the format command
+#
+# Results:
+# Returns the translated string. Propagates errors thrown by the
+# format command.
+
+proc msgcat::mc {src args} {
+ # this may be replaced by:
+ # return [mcget -namespace [uplevel 1 [list ::namespace current]] --\
+ # $src {*}$args]
+
+ # Check for the src in each namespace starting from the local and
+ # ending in the global.
+
+ variable Msgs
+ variable Loclist
+
+ set ns [uplevel 1 [list ::namespace current]]
+ set loclist [PackagePreferences $ns]
+
+ set nscur $ns
+ while {$nscur != ""} {
+ foreach loc $loclist {
+ if {[dict exists $Msgs $nscur $loc $src]} {
+ return [DefaultUnknown "" [dict get $Msgs $nscur $loc $src]\
+ {*}$args]
+ }
+ }
+ set nscur [namespace parent $nscur]
+ }
+ # call package local or default unknown command
+ set args [linsert $args 0 [lindex $loclist 0] $src]
+ switch -exact -- [Invoke unknowncmd $args $ns result 1] {
+ 0 { return [uplevel 1 [linsert $args 0 [namespace origin mcunknown]]] }
+ 1 { return [DefaultUnknown {*}$args] }
+ default { return $result }
+ }
+}
+
+# msgcat::mcexists --
+#
+# Check if a catalog item is set or if mc would invoke mcunknown.
+#
+# Arguments:
+# -exactnamespace Only check the exact namespace and no
+# parent namespaces
+# -exactlocale Only check the exact locale and not all members
+# of the preferences list
+# src Message catalog key
+#
+# Results:
+# true if an adequate catalog key was found
+
+proc msgcat::mcexists {args} {
+
+ variable Msgs
+ variable Loclist
+ variable PackageConfig
+
+ set ns [uplevel 1 [list ::namespace current]]
+ set loclist [PackagePreferences $ns]
+
+ while {[llength $args] != 1} {
+ set args [lassign $args option]
+ switch -glob -- $option {
+ -exactnamespace { set exactnamespace 1 }
+ -exactlocale { set loclist [lrange $loclist 0 0] }
+ -* { return -code error "unknown option \"$option\"" }
+ default {
+ return -code error "wrong # args: should be\
+ \"[lindex [info level 0] 0] ?-exactnamespace?\
+ ?-exactlocale? src\""
+ }
+ }
+ }
+ set src [lindex $args 0]
+
+ while {$ns ne ""} {
+ foreach loc $loclist {
+ if {[dict exists $Msgs $ns $loc $src]} {
+ return 1
+ }
+ }
+ if {[info exists exactnamespace]} {return 0}
+ set ns [namespace parent $ns]
+ }
+ return 0
+}
+
+# msgcat::mclocale --
+#
+# Query or set the current locale.
+#
+# Arguments:
+# newLocale (Optional) The new locale string. Locale strings
+# should be composed of one or more sublocale parts
+# separated by underscores (e.g. en_US).
+#
+# Results:
+# Returns the normalized set locale.
+
+proc msgcat::mclocale {args} {
+ variable Loclist
+ variable LoadedLocales
+ set len [llength $args]
+
+ if {$len > 1} {
+ return -code error "wrong # args: should be\
+ \"[lindex [info level 0] 0] ?newLocale?\""
+ }
+
+ if {$len == 1} {
+ set newLocale [string tolower [lindex $args 0]]
+ if {$newLocale ne [file tail $newLocale]} {
+ return -code error "invalid newLocale value \"$newLocale\":\
+ could be path to unsafe code."
+ }
+ if {[lindex $Loclist 0] ne $newLocale} {
+ set Loclist [GetPreferences $newLocale]
+
+ # locale not loaded jet
+ LoadAll $Loclist
+ # Invoke callback
+ Invoke changecmd $Loclist
+ }
+ }
+ return [lindex $Loclist 0]
+}
+
+# msgcat::GetPreferences --
+#
+# Get list of locales from a locale.
+# The first element is always the lowercase locale.
+# Other elements have one component separated by "_" less.
+# Multiple "_" are seen as one separator: de__ch_spec de__ch de {}
+#
+# Arguments:
+# Locale.
+#
+# Results:
+# Locale list
+
+proc msgcat::GetPreferences {locale} {
+ set locale [string tolower $locale]
+ set loclist [list $locale]
+ while {-1 !=[set pos [string last "_" $locale]]} {
+ set locale [string range $locale 0 $pos-1]
+ if { "_" ne [string index $locale end] } {
+ lappend loclist $locale
+ }
+ }
+ if {"" ne [lindex $loclist end]} {
+ lappend loclist {}
+ }
+ return $loclist
+}
+
+# msgcat::mcpreferences --
+#
+# Fetch the list of locales used to look up strings, ordered from
+# most preferred to least preferred.
+#
+# Arguments:
+# None.
+#
+# Results:
+# Returns an ordered list of the locales preferred by the user.
+
+proc msgcat::mcpreferences {} {
+ variable Loclist
+ return $Loclist
+}
+
+# msgcat::mcloadedlocales --
+#
+# Get or change the list of currently loaded default locales
+#
+# The following subcommands are available:
+# loaded
+# Get the current list of loaded locales
+# clear
+# Remove all loaded locales not present in mcpreferences.
+#
+# Arguments:
+# subcommand One of loaded or clear
+#
+# Results:
+# Empty string, if not stated differently for the subcommand
+
+proc msgcat::mcloadedlocales {subcommand} {
+ variable Loclist
+ variable LoadedLocales
+ variable Msgs
+ variable PackageConfig
+ switch -exact -- $subcommand {
+ clear {
+ # Remove all locales not contained in Loclist
+ # skip any packages with package locale
+ set LoadedLocales $Loclist
+ foreach ns [dict keys $Msgs] {
+ if {![dict exists $PackageConfig loclist $ns]} {
+ foreach locale [dict keys [dict get $Msgs $ns]] {
+ if {$locale ni $Loclist} {
+ dict unset Msgs $ns $locale
+ }
+ }
+ }
+ }
+ }
+ loaded { return $LoadedLocales }
+ default {
+ return -code error "unknown subcommand \"$subcommand\": must be\
+ clear, or loaded"
+ }
+ }
+ return
+}
+
+# msgcat::mcpackagelocale --
+#
+# Get or change the package locale of the calling package.
+#
+# The following subcommands are available:
+# set
+# Set a package locale.
+# This may load message catalog files and may clear message catalog
+# items, if the former locale was the default locale.
+# Returns the normalized set locale.
+# The default locale is taken, if locale is not given.
+# get
+# Get the locale valid for this package.
+# isset
+# Returns true, if a package locale is set
+# unset
+# Unset the package locale and activate the default locale.
+# This loads message catalog file which where missing in the package
+# locale.
+# preferences
+# Return locale preference list valid for the package.
+# loaded
+# Return loaded locale list valid for the current package.
+# clear
+# If the current package has a package locale, remove all package
+# locales not containes in package mcpreferences.
+# It is an error to call this without a package locale set.
+#
+# The subcommands get, preferences and loaded return the corresponding
+# default data, if no package locale is set.
+#
+# Arguments:
+# subcommand see list above
+# locale package locale (only set subcommand)
+#
+# Results:
+# Empty string, if not stated differently for the subcommand
+
+proc msgcat::mcpackagelocale {subcommand {locale ""}} {
+ # todo: implement using an ensemble
+ variable Loclist
+ variable LoadedLocales
+ variable Msgs
+ variable PackageConfig
+ # Check option
+ # check if required item is exactly provided
+ if {[llength [info level 0]] == 2} {
+ # locale not given
+ unset locale
+ } else {
+ # locale given
+ if {$subcommand in
+ {"get" "isset" "unset" "preferences" "loaded" "clear"} } {
+ return -code error "wrong # args: should be\
+ \"[lrange [info level 0] 0 1]\""
+ }
+ set locale [string tolower $locale]
+ }
+ set ns [uplevel 1 {::namespace current}]
+
+ switch -exact -- $subcommand {
+ get { return [lindex [PackagePreferences $ns] 0] }
+ preferences { return [PackagePreferences $ns] }
+ loaded { return [PackageLocales $ns] }
+ present { return [expr {$locale in [PackageLocales $ns]} ]}
+ isset { return [dict exists $PackageConfig loclist $ns] }
+ set { # set a package locale or add a package locale
+
+ # Copy the default locale if no package locale set so far
+ if {![dict exists $PackageConfig loclist $ns]} {
+ dict set PackageConfig loclist $ns $Loclist
+ dict set PackageConfig loadedlocales $ns $LoadedLocales
+ }
+
+ # Check if changed
+ set loclist [dict get $PackageConfig loclist $ns]
+ if {! [info exists locale] || $locale eq [lindex $loclist 0] } {
+ return [lindex $loclist 0]
+ }
+
+ # Change loclist
+ set loclist [GetPreferences $locale]
+ set locale [lindex $loclist 0]
+ dict set PackageConfig loclist $ns $loclist
+
+ # load eventual missing locales
+ set loadedLocales [dict get $PackageConfig loadedlocales $ns]
+ if {$locale in $loadedLocales} { return $locale }
+ set loadLocales [ListComplement $loadedLocales $loclist]
+ dict set PackageConfig loadedlocales $ns\
+ [concat $loadedLocales $loadLocales]
+ Load $ns $loadLocales
+ return $locale
+ }
+ clear { # Remove all locales not contained in Loclist
+ if {![dict exists $PackageConfig loclist $ns]} {
+ return -code error "clear only when package locale set"
+ }
+ set loclist [dict get $PackageConfig loclist $ns]
+ dict set PackageConfig loadedlocales $ns $loclist
+ if {[dict exists $Msgs $ns]} {
+ foreach locale [dict keys [dict get $Msgs $ns]] {
+ if {$locale ni $loclist} {
+ dict unset Msgs $ns $locale
+ }
+ }
+ }
+ }
+ unset { # unset package locale and restore default locales
+
+ if { ![dict exists $PackageConfig loclist $ns] } { return }
+
+ # unset package locale
+ set loadLocales [ListComplement\
+ [dict get $PackageConfig loadedlocales $ns] $LoadedLocales]
+ dict unset PackageConfig loadedlocales $ns
+ dict unset PackageConfig loclist $ns
+
+ # unset keys not in global loaded locales
+ if {[dict exists $Msgs $ns]} {
+ foreach locale [dict keys [dict get $Msgs $ns]] {
+ if {$locale ni $LoadedLocales} {
+ dict unset Msgs $ns $locale
+ }
+ }
+ }
+
+ # Add missing locales
+ Load $ns $loadLocales
+ }
+ default {
+ return -code error "unknown subcommand \"$subcommand\": must be\
+ clear, get, isset, loaded, present, set, or unset"
+ }
+ }
+ return
+}
+
+# msgcat::mcforgetpackage --
+#
+# Remove any data of the calling package from msgcat
+#
+
+proc msgcat::mcforgetpackage {} {
+ # todo: this may be implemented using an ensemble
+ variable PackageConfig
+ variable Msgs
+ set ns [uplevel 1 {::namespace current}]
+ # Remove MC items
+ dict unset Msgs $ns
+ # Remove config items
+ foreach key [dict keys $PackageConfig] {
+ dict unset PackageConfig $key $ns
+ }
+ return
+}
+
+# msgcat::mcpackageconfig --
+#
+# Get or modify the per caller namespace (e.g. packages) config options.
+#
+# Available subcommands are:
+#
+# get get the current value or an error if not set.
+# isset return true, if the option is set
+# set set the value (see also distinct option).
+# Returns the number of loaded message files.
+# unset Clear option. return "".
+#
+# Available options are:
+#
+# mcfolder
+# The message catalog folder of the package.
+# This is automatically set by mcload.
+# If the value is changed using the set subcommand, an evntual
+# loadcmd is invoked and all message files of the package locale are
+# loaded.
+#
+# loadcmd
+# The command gets executed before a message file would be
+# sourced for this module.
+# The command is invoked with the expanded locale list to load.
+# The command is not invoked if the registering package namespace
+# is not present.
+# This callback might also be used as an alternative to message
+# files.
+# If the value is changed using the set subcommand, the callback is
+# directly invoked with the current file locale list. No file load is
+# executed.
+#
+# changecmd
+# The command is invoked, after an executed locale change.
+# Appended argument is expanded mcpreferences.
+#
+# unknowncmd
+# Use a package locale mcunknown procedure instead the global one.
+# The appended arguments are identical to mcunknown.
+# A default unknown handler is used if set to the empty string.
+# This consists in returning the key if no arguments are given.
+# With given arguments, format is used to process the arguments.
+#
+# Arguments:
+# subcommand Operation on the package
+# option The package option to get or set.
+# ?value? Eventual value for the subcommand
+#
+# Results:
+# Depends on the subcommand and option and is described there
+
+proc msgcat::mcpackageconfig {subcommand option {value ""}} {
+ variable PackageConfig
+ # get namespace
+ set ns [uplevel 1 {::namespace current}]
+
+ if {$option ni {"mcfolder" "loadcmd" "changecmd" "unknowncmd"}} {
+ return -code error "bad option \"$option\": must be mcfolder, loadcmd,\
+ changecmd, or unknowncmd"
+ }
+
+ # check if value argument is exactly provided
+ if {[llength [info level 0]] == 4 } {
+ # value provided
+ if {$subcommand in {"get" "isset" "unset"}} {
+ return -code error "wrong # args: should be\
+ \"[lrange [info level 0] 0 2] value\""
+ }
+ } elseif {$subcommand eq "set"} {
+ return -code error\
+ "wrong # args: should be \"[lrange [info level 0] 0 2]\""
+ }
+
+ # Execute subcommands
+ switch -exact -- $subcommand {
+ get { # Operation get return current value
+ if {![dict exists $PackageConfig $option $ns]} {
+ return -code error "package option \"$option\" not set"
+ }
+ return [dict get $PackageConfig $option $ns]
+ }
+ isset { return [dict exists $PackageConfig $option $ns] }
+ unset { dict unset PackageConfig $option $ns }
+ set { # Set option
+
+ if {$option eq "mcfolder"} {
+ set value [file normalize $value]
+ }
+ # Check if changed
+ if { [dict exists $PackageConfig $option $ns]
+ && $value eq [dict get $PackageConfig $option $ns] } {
+ return 0
+ }
+
+ # set new value
+ dict set PackageConfig $option $ns $value
+
+ # Reload pending message catalogs
+ switch -exact -- $option {
+ mcfolder { return [Load $ns [PackageLocales $ns]] }
+ loadcmd { return [Load $ns [PackageLocales $ns] 1] }
+ }
+ return 0
+ }
+ default {
+ return -code error "unknown subcommand \"$subcommand\":\
+ must be get, isset, set, or unset"
+ }
+ }
+ return
+}
+
+# msgcat::PackagePreferences --
+#
+# Return eventual present package preferences or the default list if not
+# present.
+#
+# Arguments:
+# ns Package namespace
+#
+# Results:
+# locale list
+
+proc msgcat::PackagePreferences {ns} {
+ variable PackageConfig
+ if {[dict exists $PackageConfig loclist $ns]} {
+ return [dict get $PackageConfig loclist $ns]
+ }
+ variable Loclist
+ return $Loclist
+}
+
+# msgcat::PackageLocales --
+#
+# Return eventual present package locales or the default list if not
+# present.
+#
+# Arguments:
+# ns Package namespace
+#
+# Results:
+# locale list
+
+proc msgcat::PackageLocales {ns} {
+ variable PackageConfig
+ if {[dict exists $PackageConfig loadedlocales $ns]} {
+ return [dict get $PackageConfig loadedlocales $ns]
+ }
+ variable LoadedLocales
+ return $LoadedLocales
+}
+
+# msgcat::ListComplement --
+#
+# Build the complement of two lists.
+# Return a list with all elements in list2 but not in list1.
+# Optionally return the intersection.
+#
+# Arguments:
+# list1 excluded list
+# list2 included list
+# inlistname If not "", write in this variable the intersection list
+#
+# Results:
+# list with all elements in list2 but not in list1
+
+proc msgcat::ListComplement {list1 list2 {inlistname ""}} {
+ if {"" ne $inlistname} {
+ upvar 1 $inlistname inlist
+ }
+ set inlist {}
+ set outlist {}
+ foreach item $list2 {
+ if {$item in $list1} {
+ lappend inlist $item
+ } else {
+ lappend outlist $item
+ }
+ }
+ return $outlist
+}
+
+# msgcat::mcload --
+#
+# Attempt to load message catalogs for each locale in the
+# preference list from the specified directory.
+#
+# Arguments:
+# langdir The directory to search.
+#
+# Results:
+# Returns the number of message catalogs that were loaded.
+
+proc msgcat::mcload {langdir} {
+ return [uplevel 1 [list\
+ [namespace origin mcpackageconfig] set mcfolder $langdir]]
+}
+
+# msgcat::LoadAll --
+#
+# Load a list of locales for all packages not having a package locale
+# list.
+#
+# Arguments:
+# langdir The directory to search.
+#
+# Results:
+# Returns the number of message catalogs that were loaded.
+
+proc msgcat::LoadAll {locales} {
+ variable PackageConfig
+ variable LoadedLocales
+ if {0 == [llength $locales]} { return {} }
+ # filter jet unloaded locales
+ set locales [ListComplement $LoadedLocales $locales]
+ if {0 == [llength $locales]} { return {} }
+ lappend LoadedLocales {*}$locales
+
+ set packages [lsort -unique [concat\
+ [dict keys [dict get $PackageConfig loadcmd]]\
+ [dict keys [dict get $PackageConfig mcfolder]]]]
+ foreach ns $packages {
+ if {! [dict exists $PackageConfig loclist $ns] } {
+ Load $ns $locales
+ }
+ }
+ return $locales
+}
+
+# msgcat::Load --
+#
+# Invoke message load callback and load message catalog files.
+#
+# Arguments:
+# ns Namespace (equal package) to load the message catalog.
+# locales List of locales to load.
+# callbackonly true if only callback should be invoked
+#
+# Results:
+# Returns the number of message catalogs that were loaded.
+
+proc msgcat::Load {ns locales {callbackonly 0}} {
+ variable FileLocale
+ variable PackageConfig
+ variable LoadedLocals
+
+ if {0 == [llength $locales]} { return 0 }
+
+ # Invoke callback
+ Invoke loadcmd $locales $ns
+
+ if {$callbackonly || ![dict exists $PackageConfig mcfolder $ns]} {
+ return 0
+ }
+
+ # Invoke file load
+ set langdir [dict get $PackageConfig mcfolder $ns]
+
+ # Save the file locale if we are recursively called
+ if {[info exists FileLocale]} {
+ set nestedFileLocale $FileLocale
+ }
+ set x 0
+ foreach p $locales {
+ if {$p eq {}} {
+ set p ROOT
+ }
+ set langfile [file join $langdir $p.msg]
+ if {[file exists $langfile]} {
+ incr x
+ set FileLocale [string tolower\
+ [file tail [file rootname $langfile]]]
+ if {"root" eq $FileLocale} {
+ set FileLocale ""
+ }
+ namespace inscope $ns [list ::source -encoding utf-8 $langfile]
+ unset FileLocale
+ }
+ }
+ if {[info exists nestedFileLocale]} {
+ set FileLocale $nestedFileLocale
+ }
+ return $x
+}
+
+# msgcat::Invoke --
+#
+# Invoke a set of registered callbacks.
+# The callback is only invoked, if its registered namespace exists.
+#
+# Arguments:
+# index Index into PackageConfig to get callback command
+# arglist parameters to the callback invocation
+# ns (Optional) package to call.
+# If not given or empty, check all registered packages.
+# resultname Variable to save the callback result of the last called
+# callback to. May be set to "" to discard the result.
+# failerror (0) Fail on error if true. Otherwise call bgerror.
+#
+# Results:
+# Possible values:
+# - 0: no valid command registered
+# - 1: registered command was the empty string
+# - 2: registered command called, resultname is set
+# - 3: registered command failed
+# If multiple commands are called, the maximum of all results is returned.
+
+proc msgcat::Invoke {index arglist {ns ""} {resultname ""} {failerror 0}} {
+ variable PackageConfig
+ variable Config
+ if {"" ne $resultname} {
+ upvar 1 $resultname result
+ }
+ if {"" eq $ns} {
+ set packageList [dict keys [dict get $PackageConfig $index]]
+ } else {
+ set packageList [list $ns]
+ }
+ set ret 0
+ foreach ns $packageList {
+ if {[dict exists $PackageConfig $index $ns] && [namespace exists $ns]} {
+ set cmd [dict get $PackageConfig $index $ns]
+ if {"" eq $cmd} {
+ if {$ret == 0} {set ret 1}
+ } else {
+ if {$failerror} {
+ set result [namespace inscope $ns $cmd {*}$arglist]
+ set ret 2
+ } elseif {1 == [catch {
+ set result [namespace inscope $ns $cmd {*}$arglist]
+ if {$ret < 2} {set ret 2}
+ } err derr]} {
+ after idle [concat [::interp bgerror ""]\
+ [list $err $derr]]
+ set ret 3
+ }
+ }
+ }
+ }
+ return $ret
+}
+
+# msgcat::mcset --
+#
+# Set the translation for a given string in a specified locale.
+#
+# Arguments:
+# locale The locale to use.
+# src The source string.
+# dest (Optional) The translated string. If omitted,
+# the source string is used.
+#
+# Results:
+# Returns the new locale.
+
+proc msgcat::mcset {locale src {dest ""}} {
+ variable Msgs
+ if {[llength [info level 0]] == 3} { ;# dest not specified
+ set dest $src
+ }
+
+ set ns [uplevel 1 [list ::namespace current]]
+
+ set locale [string tolower $locale]
+
+ dict set Msgs $ns $locale $src $dest
+ return $dest
+}
+
+# msgcat::mcflset --
+#
+# Set the translation for a given string in the current file locale.
+#
+# Arguments:
+# src The source string.
+# dest (Optional) The translated string. If omitted,
+# the source string is used.
+#
+# Results:
+# Returns the new locale.
+
+proc msgcat::mcflset {src {dest ""}} {
+ variable FileLocale
+ variable Msgs
+
+ if {![info exists FileLocale]} {
+ return -code error "must only be used inside a message catalog loaded\
+ with ::msgcat::mcload"
+ }
+ return [uplevel 1 [list [namespace origin mcset] $FileLocale $src $dest]]
+}
+
+# msgcat::mcmset --
+#
+# Set the translation for multiple strings in a specified locale.
+#
+# Arguments:
+# locale The locale to use.
+# pairs One or more src/dest pairs (must be even length)
+#
+# Results:
+# Returns the number of pairs processed
+
+proc msgcat::mcmset {locale pairs} {
+ variable Msgs
+
+ set length [llength $pairs]
+ if {$length % 2} {
+ return -code error "bad translation list:\
+ should be \"[lindex [info level 0] 0] locale {src dest ...}\""
+ }
+
+ set locale [string tolower $locale]
+ set ns [uplevel 1 [list ::namespace current]]
+
+ foreach {src dest} $pairs {
+ dict set Msgs $ns $locale $src $dest
+ }
+
+ return [expr {$length / 2}]
+}
+
+# msgcat::mcflmset --
+#
+# Set the translation for multiple strings in the mc file locale.
+#
+# Arguments:
+# pairs One or more src/dest pairs (must be even length)
+#
+# Results:
+# Returns the number of pairs processed
+
+proc msgcat::mcflmset {pairs} {
+ variable FileLocale
+ variable Msgs
+
+ if {![info exists FileLocale]} {
+ return -code error "must only be used inside a message catalog loaded\
+ with ::msgcat::mcload"
+ }
+ return [uplevel 1 [list [namespace origin mcmset] $FileLocale $pairs]]
+}
+
+# msgcat::mcunknown --
+#
+# This routine is called by msgcat::mc if a translation cannot
+# be found for a string and no unknowncmd is set for the current
+# package. This routine is intended to be replaced
+# by an application specific routine for error reporting
+# purposes. The default behavior is to return the source string.
+# If additional args are specified, the format command will be used
+# to work them into the traslated string.
+#
+# Arguments:
+# locale The current locale.
+# src The string to be translated.
+# args Args to pass to the format command
+#
+# Results:
+# Returns the translated value.
+
+proc msgcat::mcunknown {args} {
+ return [uplevel 1 [list [namespace origin DefaultUnknown] {*}$args]]
+}
+
+# msgcat::DefaultUnknown --
+#
+# This routine is called by msgcat::mc if a translation cannot
+# be found for a string in the following circumstances:
+# - Default global handler, if mcunknown is not redefined.
+# - Per package handler, if the package sets unknowncmd to the empty
+# string.
+# It returna the source string if the argument list is empty.
+# If additional args are specified, the format command will be used
+# to work them into the traslated string.
+#
+# Arguments:
+# locale (unused) The current locale.
+# src The string to be translated.
+# args Args to pass to the format command
+#
+# Results:
+# Returns the translated value.
+
+proc msgcat::DefaultUnknown {locale src args} {
+ if {[llength $args]} {
+ return [format $src {*}$args]
+ } else {
+ return $src
+ }
+}
+
+# msgcat::mcmax --
+#
+# Calculates the maximum length of the translated strings of the given
+# list.
+#
+# Arguments:
+# args strings to translate.
+#
+# Results:
+# Returns the length of the longest translated string.
+
+proc msgcat::mcmax {args} {
+ set max 0
+ foreach string $args {
+ set translated [uplevel 1 [list [namespace origin mc] $string]]
+ set len [string length $translated]
+ if {$len>$max} {
+ set max $len
+ }
+ }
+ return $max
+}
+
+# Convert the locale values stored in environment variables to a form
+# suitable for passing to [mclocale]
+proc msgcat::ConvertLocale {value} {
+ # Assume $value is of form: $language[_$territory][.$codeset][@modifier]
+ # Convert to form: $language[_$territory][_$modifier]
+ #
+ # Comment out expanded RE version -- bugs alleged
+ # regexp -expanded {
+ # ^ # Match all the way to the beginning
+ # ([^_.@]*) # Match "lanugage"; ends with _, ., or @
+ # (_([^.@]*))? # Match (optional) "territory"; starts with _
+ # ([.]([^@]*))? # Match (optional) "codeset"; starts with .
+ # (@(.*))? # Match (optional) "modifier"; starts with @
+ # $ # Match all the way to the end
+ # } $value -> language _ territory _ codeset _ modifier
+ if {![regexp {^([^_.@]+)(_([^.@]*))?([.]([^@]*))?(@(.*))?$} $value \
+ -> language _ territory _ codeset _ modifier]} {
+ return -code error "invalid locale '$value': empty language part"
+ }
+ set ret $language
+ if {[string length $territory]} {
+ append ret _$territory
+ }
+ if {[string length $modifier]} {
+ append ret _$modifier
+ }
+ return $ret
+}
+
+# Initialize the default locale
+proc msgcat::Init {} {
+ global env
+
+ #
+ # set default locale, try to get from environment
+ #
+ foreach varName {LC_ALL LC_MESSAGES LANG} {
+ if {[info exists env($varName)] && ("" ne $env($varName))} {
+ if {![catch {
+ mclocale [ConvertLocale $env($varName)]
+ }]} {
+ return
+ }
+ }
+ }
+ #
+ # On Darwin, fallback to current CFLocale identifier if available.
+ #
+ if {[info exists ::tcl::mac::locale] && $::tcl::mac::locale ne ""} {
+ if {![catch {
+ mclocale [ConvertLocale $::tcl::mac::locale]
+ }]} {
+ return
+ }
+ }
+ #
+ # The rest of this routine is special processing for Windows or
+ # Cygwin. All other platforms, get out now.
+ #
+ if {([info sharedlibextension] ne ".dll")
+ || [catch {package require registry}]} {
+ mclocale C
+ return
+ }
+ #
+ # On Windows or Cygwin, try to set locale depending on registry
+ # settings, or fall back on locale of "C".
+ #
+
+ # On Vista and later:
+ # HCU/Control Panel/Desktop : PreferredUILanguages is for language packs,
+ # HCU/Control Pannel/International : localName is the default locale.
+ #
+ # They contain the local string as RFC5646, composed of:
+ # [a-z]{2,3} : language
+ # -[a-z]{4} : script (optional, translated by table Latn->latin)
+ # -[a-z]{2}|[0-9]{3} : territory (optional, numerical region codes not used)
+ # (-.*)* : variant, extension, private use (optional, not used)
+ # Those are translated to local strings.
+ # Examples: de-CH -> de_ch, sr-Latn-CS -> sr_cs@latin, es-419 -> es
+ #
+ foreach key {{HKEY_CURRENT_USER\Control Panel\Desktop} {HKEY_CURRENT_USER\Control Panel\International}}\
+ value {PreferredUILanguages localeName} {
+ if {![catch {registry get $key $value} localeName]
+ && [regexp {^([a-z]{2,3})(?:-([a-z]{4}))?(?:-([a-z]{2}))?(?:-.+)?$}\
+ [string tolower $localeName] match locale script territory]} {
+ if {"" ne $territory} {
+ append locale _ $territory
+ }
+ set modifierDict [dict create latn latin cyrl cyrillic]
+ if {[dict exists $modifierDict $script]} {
+ append locale @ [dict get $modifierDict $script]
+ }
+ if {![catch {mclocale [ConvertLocale $locale]}]} {
+ return
+ }
+ }
+ }
+
+ # then check value locale which contains a numerical language ID
+ if {[catch {
+ set locale [registry get $key "locale"]
+ }]} {
+ mclocale C
+ return
+ }
+ #
+ # Keep trying to match against smaller and smaller suffixes
+ # of the registry value, since the latter hexadigits appear
+ # to determine general language and earlier hexadigits determine
+ # more precise information, such as territory. For example,
+ # 0409 - English - United States
+ # 0809 - English - United Kingdom
+ # Add more translations to the WinRegToISO639 array above.
+ #
+ variable WinRegToISO639
+ set locale [string tolower $locale]
+ while {[string length $locale]} {
+ if {![catch {
+ mclocale [ConvertLocale [dict get $WinRegToISO639 $locale]]
+ }]} {
+ return
+ }
+ set locale [string range $locale 1 end]
+ }
+ #
+ # No translation known. Fall back on "C" locale
+ #
+ mclocale C
+}
+msgcat::Init
diff --git a/systems/texlive/tlnet/tlpkg/tltcl/lib/tcl8/8.5/tcltest-2.5.1.tm b/systems/texlive/tlnet/tlpkg/tltcl/lib/tcl8/8.5/tcltest-2.5.1.tm
new file mode 100644
index 0000000000..a7a68c757f
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tltcl/lib/tcl8/8.5/tcltest-2.5.1.tm
@@ -0,0 +1,3446 @@
+# 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
+}
diff --git a/systems/texlive/tlnet/tlpkg/tltcl/lib/tcl8/8.6/http-2.9.1.tm b/systems/texlive/tlnet/tlpkg/tltcl/lib/tcl8/8.6/http-2.9.1.tm
new file mode 100644
index 0000000000..0aa283f00d
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tltcl/lib/tcl8/8.6/http-2.9.1.tm
@@ -0,0 +1,3427 @@
+# 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@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:
diff --git a/systems/texlive/tlnet/tlpkg/tltcl/lib/tcl8/8.6/tdbc/sqlite3-1.1.1.tm b/systems/texlive/tlnet/tlpkg/tltcl/lib/tcl8/8.6/tdbc/sqlite3-1.1.1.tm
new file mode 100644
index 0000000000..f046f0610f
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tltcl/lib/tcl8/8.6/tdbc/sqlite3-1.1.1.tm
@@ -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.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}
+ }
+
+}