diff options
author | Norbert Preining <norbert@preining.info> | 2020-04-11 03:09:12 +0000 |
---|---|---|
committer | Norbert Preining <norbert@preining.info> | 2020-04-11 03:09:12 +0000 |
commit | c2697fc286a1e2c94fd9968b76be6f4a6d2114cd (patch) | |
tree | 1dc2cfb07cb032740483dd8be7c74aff66b70352 /systems/texlive/tlnet/tlpkg/tltcl/lib/tcl8 | |
parent | 25111608e6aa05042b0c6f83009262e1973d7a45 (diff) |
CTAN sync 202004110309
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tltcl/lib/tcl8')
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} + } + +} |