Your IP : 216.73.216.45
8.4/platform/shell-1.1.4.tm 0000644 00000013531 15052370460 0011016 0 ustar 00
# -*- 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
8.4/platform-1.0.14.tm 0000644 00000023434 15052370460 0007772 0 ustar 00 # -*- 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
}
8.5/msgcat-1.6.1.tm 0000644 00000102217 15052370460 0007344 0 ustar 00 # 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
8.5/tcltest-2.4.1.tm 0000644 00000304037 15052370460 0007553 0 ustar 00 # 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.4.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}.
# 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 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]
# 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 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 \
-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]
}
} 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 errorCode(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 errorCode(body) $::errorCode
}
}
# check if the return code matched the expected return code
set codeFailure 0
if {!$setupFailure && ($returnCode ni $returnCodes)} {
set codeFailure 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 errorCode(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
|| $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): $errorCode(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 {$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: $errorCode(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): $errorCode(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:
# None.
#
# Side effects:
# None.
proc tcltest::runAllTests { {shell ""} } {
variable testSingleFile
variable numTestFiles
variable numTests
variable failFiles
variable DefaultValue
FillFilesExisted
if {[llength [info level 0]] == 1} {
set shell [interpreter]
}
set testSingleFile false
puts [outputChannel] "Tests running in interp: $shell"
puts [outputChannel] "Tests located in: [testsDirectory]"
puts [outputChannel] "Tests running in: [workingDirectory]"
puts [outputChannel] "Temporary files stored in\
[temporaryDirectory]"
# [file system] first available in Tcl 8.4
if {![catch {file system [testsDirectory]} result]
&& ([lindex $result 0] ne "native")} {
# If we aren't running in the native filesystem, then we must
# run the tests in a single process (via 'source'), because
# trying to run then via a pipe will fail since the files don't
# really exist.
singleProcess 1
}
if {[singleProcess]} {
puts [outputChannel] \
"Test files sourced into current interpreter"
} else {
puts [outputChannel] \
"Test files run in separate interpreters"
}
if {[llength [skip]] > 0} {
puts [outputChannel] "Skipping tests that match: [skip]"
}
puts [outputChannel] "Running tests that match: [match]"
if {[llength [skipFiles]] > 0} {
puts [outputChannel] \
"Skipping test files that match: [skipFiles]"
}
if {[llength [matchFiles]] > 0} {
puts [outputChannel] \
"Only running test files that match: [matchFiles]"
}
set timeCmd {clock format [clock seconds]}
puts [outputChannel] "Tests began at [eval $timeCmd]"
# Run each of the specified tests
foreach file [lsort [GetMatchingFiles]] {
set tail [file tail $file]
puts [outputChannel] $tail
flush [outputChannel]
if {[singleProcess]} {
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
}
} 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
}
#####################################################################
# 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"
}
}
return [file delete -- $fullName]
}
# 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
}
8.6/http-2.8.12.tm 0000644 00000125772 15052370460 0007146 0 ustar 00 # 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.8.12
namespace eval http {
# Allow resourcing to not clobber existing data
variable http
if {![info exists http]} {
array set http {
-accept */*
-proxyhost {}
-proxyport {}
-proxyfilter http::ProxyRequired
-urlencoding utf-8
}
# 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 socketmap
if {[info exists socketmap]} {
# Close but don't remove open sockets on re-init
foreach {url sock} [array get socketmap] {
catch {close $sock}
}
}
array set socketmap {}
}
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 register unregister
# Useful, but not exported: data size status code
}
# 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:
# Closes the socket
proc http::Finish {token {errormsg ""} {skipCB 0}} {
variable $token
upvar 0 $token state
global errorInfo errorCode
if {$errormsg ne ""} {
set state(error) [list $errormsg $errorInfo $errorCode]
set state(status) "error"
}
if { ($state(status) eq "timeout")
|| ($state(status) eq "error")
|| ([info exists state(-keepalive)] && !$state(-keepalive))
|| ([info exists state(connection)] && ($state(connection) eq "close"))
} {
CloseSocket $state(sock) $token
}
if {[info exists state(after)]} {
after cancel $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
}
}
}
# 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 second section.
proc ::http::CloseSocket {s {token {}}} {
variable socketmap
catch {fileevent $s readable {}}
set conn_id {}
if {$token ne ""} {
variable $token
upvar 0 $token state
if {[info exists state(socketinfo)]} {
set conn_id $state(socketinfo)
}
} else {
set map [array get socketmap]
set ndx [lsearch -exact $map $s]
if {$ndx != -1} {
incr ndx -1
set conn_id [lindex $map $ndx]
}
}
if {$conn_id eq {} || ![info exists socketmap($conn_id)]} {
Log "Closing socket $s (no connection info)"
if {[catch {close $s} err]} {
Log "Error: $err"
}
} else {
if {[info exists socketmap($conn_id)]} {
Log "Closing connection $conn_id (sock $socketmap($conn_id))"
if {[catch {close $socketmap($conn_id)} err]} {
Log "Error: $err"
}
unset socketmap($conn_id)
} else {
Log "Cannot close connection $conn_id - no socket in socket map"
}
}
}
# 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)]
variable $token
upvar 0 $token state
reset $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 connecting
meta {}
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
# If a timeout is specified we set up the after event and arrange for an
# asynchronous socket connection.
set sockopts [list -async]
if {$state(-timeout) > 0} {
set state(after) [after $state(-timeout) \
[list http::reset $token timeout]]
}
# 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)
# See if we are supposed to use a previously opened channel.
if {$state(-keepalive)} {
variable socketmap
if {[info exists socketmap($state(socketinfo))]} {
if {[catch {fconfigure $socketmap($state(socketinfo))}]} {
Log "WARNING: socket for $state(socketinfo) was closed"
unset socketmap($state(socketinfo))
} else {
set sock $socketmap($state(socketinfo))
Log "reusing socket $sock for $state(socketinfo)"
catch {fileevent $sock writable {}}
catch {fileevent $sock readable {}}
}
}
# don't automatically close this connection socket
set state(connection) {}
}
if {![info exists sock]} {
# Pass -myaddr directly to the socket command
if {[info exists state(-myaddr)]} {
lappend sockopts -myaddr $state(-myaddr)
}
if {[catch {eval $defcmd $sockopts $targetAddr} sock]} {
# 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) $sock
Finish $token "" 1
cleanup $token
return -code error $sock
}
}
set state(sock) $sock
Log "Using $sock for $state(socketinfo)" \
[expr {$state(-keepalive)?"keepalive":""}]
if {$state(-keepalive)} {
set socketmap($state(socketinfo)) $sock
}
if {![info exists phost]} {
set phost ""
}
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
}
}
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 $token
upvar 0 $token state
# 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
fconfigure $sock -translation {auto crlf} -buffersize $state(-blocksize)
# The following is disallowed in safe interpreters, but the socket is
# already in non-blocking mode in that case.
catch {fconfigure $sock -blocking off}
set how GET
if {$isQuery} {
set state(querylength) [string length $state(-query)]
if {$state(querylength) > 0} {
set how POST
set contDone 0
} else {
# There's no query data.
unset state(-query)
set isQuery 0
}
} elseif {$state(-validate)} {
set how HEAD
} elseif {$isQueryChannel} {
set how POST
# The query channel must be blocking for the async Write to
# work properly.
fconfigure $state(-querychannel) -blocking 1 -translation binary
set contDone 0
}
if {[info exists state(-method)] && $state(-method) ne ""} {
set how $state(-method)
}
# 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
if {[catch {
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)} {
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)]} {
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} {
if {!$content_type_seen} {
puts $sock "Content-Type: $state(-type)"
}
if {!$contDone} {
puts $sock "Content-Length: $state(querylength)"
}
puts $sock ""
fconfigure $sock -translation {auto binary}
fileevent $sock writable [list http::Write $token]
} else {
puts $sock ""
flush $sock
fileevent $sock readable [list http::Event $sock $token]
}
} err]} {
# The socket probably was never connected, or the connection dropped
# later.
# if state(status) is error, it means someone's already called Finish
# to do the above-described clean up.
if {$state(status) ne "error"} {
Finish $token $err
}
}
}
# Data access functions:
# Data - the URL data
# Status - the transaction status: ok, reset, eof, timeout
# 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 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 err "due to unexpected EOF"
if {
[eof $state(sock)] ||
[set err [fconfigure $state(sock) -error]] ne ""
} {
Finish $token "connect failed $err"
} else {
fileevent $state(sock) writable {}
::http::Connected $token $proto $phost $srvurl
}
return
}
# 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 $token
upvar 0 $token state
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.
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)]
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 {}
fileevent $sock readable [list http::Event $sock $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
#
# 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 $token
upvar 0 $token state
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"
}
}
CloseSocket $sock
return
}
if {$state(state) eq "connecting"} {
if {[catch {gets $sock state(http)} n]} {
return [Finish $token $n]
} elseif {$n >= 0} {
set state(state) "header"
}
} elseif {$state(state) eq "header"} {
if {[catch {gets $sock line} n]} {
return [Finish $token $n]
} elseif {$n == 0} {
# 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"
return
}
set state(state) body
# If doing a HEAD, then we won't get any body
if {$state(-validate)} {
Eof $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.
if {
!(([info exists state(connection)]
&& ($state(connection) eq "close"))
|| [info exists state(transfer)])
&& ($state(totalsize) == 0)
} {
Log "body size is 0 and no events likely - complete."
Eof $token
return
}
# We have to use binary translation to count bytes properly.
fconfigure $sock -translation binary
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 {}
CopyStart $sock $token
return
}
}
} elseif {$n > 0} {
# Process header lines
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
if {[catch {
if {[info exists state(-handler)]} {
set n [eval $state(-handler) [list $sock $token]]
} elseif {[info exists state(transfer_final)]} {
set line [getTextLine $sock]
set n [string length $line]
if {$n > 0} {
Log "found $n bytes following final chunk"
append state(transfer_final) $line
} else {
Log "final chunk part"
Eof $token
}
} elseif {
[info exists state(transfer)]
&& $state(transfer) eq "chunked"
} {
set size 0
set chunk [getTextLine $sock]
set n [string length $chunk]
if {[string trim $chunk] ne ""} {
scan $chunk %x size
if {$size != 0} {
set bl [fconfigure $sock -blocking]
fconfigure $sock -blocking 1
set chunk [read $sock $size]
fconfigure $sock -blocking $bl
set n [string length $chunk]
if {$n >= 0} {
append state(body) $chunk
}
if {$size != [string length $chunk]} {
Log "WARNING: mis-sized chunk:\
was [string length $chunk], should be $size"
}
getTextLine $sock
} else {
set state(transfer_final) {}
}
}
} else {
#Log "read non-chunk $state(currentsize) of $state(totalsize)"
set block [read $sock $state(-blocksize)]
set n [string length $block]
if {$n >= 0} {
append state(body) $block
}
}
if {[info exists state]} {
if {$n >= 0} {
incr state(currentsize) $n
}
# If Content-Length - check for end of data.
if {
($state(totalsize) > 0)
&& ($state(currentsize) >= $state(totalsize))
} {
Eof $token
}
}
} err]} {
return [Finish $token $err]
} else {
if {[info exists state(-progress)]} {
eval $state(-progress) \
[list $token $state(totalsize) $state(currentsize)]
}
}
}
# catch as an Eof above may have closed the socket already
if {![catch {eof $sock} eof] && $eof} {
if {[info exists $token]} {
set state(connection) close
Eof $token
} else {
# open connection closed on a token that has been cleaned up.
CloseSocket $sock
}
return
}
}
# 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 {"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 blocking crlf mode
#
# Arguments
# sock The socket receiving input.
#
# Results:
# The line of text, without trailing newline
proc http::getTextLine {sock} {
set tr [fconfigure $sock -translation]
set bl [fconfigure $sock -blocking]
fconfigure $sock -translation crlf -blocking 1
set r [gets $sock]
fconfigure $sock -translation $tr -blocking $bl
return $r
}
# 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 {
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"
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)
}
Eof $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} {
Eof $token
} else {
CopyStart $sock $token 0
}
}
# http::Eof
#
# Handle eof on the socket
#
# Arguments
# token The token returned from http::geturl
#
# Side Effects
# Clean up the socket
proc http::Eof {token {force 0}} {
variable $token
upvar 0 $token state
if {$state(state) eq "header"} {
# Premature eof
set state(status) eof
} else {
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: $err"
return [Finish $token $err]
}
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
}
# 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} {
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
}
# 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::make-transformation-chunked {chan command} {
set lambda {{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
}
}
}}
coroutine dechunk$chan ::apply $lambda $chan $command
chan event $chan readable [namespace origin dechunk$chan]
return
}
# Local variables:
# indent-tabs-mode: t
# End: