summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tltcl/lib/tcl8/8.5
diff options
context:
space:
mode:
authorSiep Kroonenberg <siepo@cybercomm.nl>2020-03-17 20:46:21 +0000
committerSiep Kroonenberg <siepo@cybercomm.nl>2020-03-17 20:46:21 +0000
commit450bc12eba9ebc61c597b70a633eb1e37ab92180 (patch)
tree8985a7de63a8ae88e499d497d684da7f00c8c993 /Master/tlpkg/tltcl/lib/tcl8/8.5
parent412579d4e7fdcc86bf649615419fb560809bc8f3 (diff)
New Tcl/Tk for Windows. No longer a single-file kit.
git-svn-id: svn://tug.org/texlive/trunk@54375 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tltcl/lib/tcl8/8.5')
-rw-r--r--Master/tlpkg/tltcl/lib/tcl8/8.5/msgcat-1.6.1.tm1210
-rw-r--r--Master/tlpkg/tltcl/lib/tcl8/8.5/tcltest-2.5.1.tm3446
2 files changed, 4656 insertions, 0 deletions
diff --git a/Master/tlpkg/tltcl/lib/tcl8/8.5/msgcat-1.6.1.tm b/Master/tlpkg/tltcl/lib/tcl8/8.5/msgcat-1.6.1.tm
new file mode 100644
index 00000000000..646bc179e42
--- /dev/null
+++ b/Master/tlpkg/tltcl/lib/tcl8/8.5/msgcat-1.6.1.tm
@@ -0,0 +1,1210 @@
+# msgcat.tcl --
+#
+# This file defines various procedures which implement a
+# message catalog facility for Tcl programs. It should be
+# loaded with the command "package require msgcat".
+#
+# Copyright (c) 2010-2015 by Harald Oehlmann.
+# Copyright (c) 1998-2000 by Ajuba Solutions.
+# Copyright (c) 1998 by Mark Harrison.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require Tcl 8.5-
+# When the version number changes, be sure to update the pkgIndex.tcl file,
+# and the installation directory in the Makefiles.
+package provide msgcat 1.6.1
+
+namespace eval msgcat {
+ namespace export mc mcexists mcload mclocale mcmax mcmset mcpreferences mcset\
+ mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\
+ mcpackageconfig mcpackagelocale
+
+ # Records the list of locales to search
+ variable Loclist {}
+
+ # List of currently loaded locales
+ variable LoadedLocales {}
+
+ # Records the locale of the currently sourced message catalogue file
+ variable FileLocale
+
+ # Configuration values per Package (e.g. client namespace).
+ # The dict key is of the form "<option> <namespace>" and the value is the
+ # configuration option. A nonexisting key is an unset option.
+ variable PackageConfig [dict create mcfolder {} loadcmd {} changecmd {}\
+ unknowncmd {} loadedlocales {} loclist {}]
+
+ # Records the mapping between source strings and translated strings. The
+ # dict key is of the form "<namespace> <locale> <src>", where locale and
+ # namespace should be themselves dict values and the value is
+ # the translated string.
+ variable Msgs [dict create]
+
+ # Map of language codes used in Windows registry to those of ISO-639
+ if {[info sharedlibextension] eq ".dll"} {
+ variable WinRegToISO639 [dict create {*}{
+ 01 ar 0401 ar_SA 0801 ar_IQ 0c01 ar_EG 1001 ar_LY 1401 ar_DZ
+ 1801 ar_MA 1c01 ar_TN 2001 ar_OM 2401 ar_YE 2801 ar_SY
+ 2c01 ar_JO 3001 ar_LB 3401 ar_KW 3801 ar_AE 3c01 ar_BH
+ 4001 ar_QA
+ 02 bg 0402 bg_BG
+ 03 ca 0403 ca_ES
+ 04 zh 0404 zh_TW 0804 zh_CN 0c04 zh_HK 1004 zh_SG 1404 zh_MO
+ 05 cs 0405 cs_CZ
+ 06 da 0406 da_DK
+ 07 de 0407 de_DE 0807 de_CH 0c07 de_AT 1007 de_LU 1407 de_LI
+ 08 el 0408 el_GR
+ 09 en 0409 en_US 0809 en_GB 0c09 en_AU 1009 en_CA 1409 en_NZ
+ 1809 en_IE 1c09 en_ZA 2009 en_JM 2409 en_GD 2809 en_BZ
+ 2c09 en_TT 3009 en_ZW 3409 en_PH
+ 0a es 040a es_ES 080a es_MX 0c0a es_ES@modern 100a es_GT 140a es_CR
+ 180a es_PA 1c0a es_DO 200a es_VE 240a es_CO 280a es_PE
+ 2c0a es_AR 300a es_EC 340a es_CL 380a es_UY 3c0a es_PY
+ 400a es_BO 440a es_SV 480a es_HN 4c0a es_NI 500a es_PR
+ 0b fi 040b fi_FI
+ 0c fr 040c fr_FR 080c fr_BE 0c0c fr_CA 100c fr_CH 140c fr_LU
+ 180c fr_MC
+ 0d he 040d he_IL
+ 0e hu 040e hu_HU
+ 0f is 040f is_IS
+ 10 it 0410 it_IT 0810 it_CH
+ 11 ja 0411 ja_JP
+ 12 ko 0412 ko_KR
+ 13 nl 0413 nl_NL 0813 nl_BE
+ 14 no 0414 no_NO 0814 nn_NO
+ 15 pl 0415 pl_PL
+ 16 pt 0416 pt_BR 0816 pt_PT
+ 17 rm 0417 rm_CH
+ 18 ro 0418 ro_RO 0818 ro_MO
+ 19 ru 0819 ru_MO
+ 1a hr 041a hr_HR 081a sr_YU 0c1a sr_YU@cyrillic
+ 1b sk 041b sk_SK
+ 1c sq 041c sq_AL
+ 1d sv 041d sv_SE 081d sv_FI
+ 1e th 041e th_TH
+ 1f tr 041f tr_TR
+ 20 ur 0420 ur_PK 0820 ur_IN
+ 21 id 0421 id_ID
+ 22 uk 0422 uk_UA
+ 23 be 0423 be_BY
+ 24 sl 0424 sl_SI
+ 25 et 0425 et_EE
+ 26 lv 0426 lv_LV
+ 27 lt 0427 lt_LT
+ 28 tg 0428 tg_TJ
+ 29 fa 0429 fa_IR
+ 2a vi 042a vi_VN
+ 2b hy 042b hy_AM
+ 2c az 042c az_AZ@latin 082c az_AZ@cyrillic
+ 2d eu
+ 2e wen 042e wen_DE
+ 2f mk 042f mk_MK
+ 30 bnt 0430 bnt_TZ
+ 31 ts 0431 ts_ZA
+ 32 tn
+ 33 ven 0433 ven_ZA
+ 34 xh 0434 xh_ZA
+ 35 zu 0435 zu_ZA
+ 36 af 0436 af_ZA
+ 37 ka 0437 ka_GE
+ 38 fo 0438 fo_FO
+ 39 hi 0439 hi_IN
+ 3a mt 043a mt_MT
+ 3b se 043b se_NO
+ 043c gd_UK 083c ga_IE
+ 3d yi 043d yi_IL
+ 3e ms 043e ms_MY 083e ms_BN
+ 3f kk 043f kk_KZ
+ 40 ky 0440 ky_KG
+ 41 sw 0441 sw_KE
+ 42 tk 0442 tk_TM
+ 43 uz 0443 uz_UZ@latin 0843 uz_UZ@cyrillic
+ 44 tt 0444 tt_RU
+ 45 bn 0445 bn_IN
+ 46 pa 0446 pa_IN
+ 47 gu 0447 gu_IN
+ 48 or 0448 or_IN
+ 49 ta
+ 4a te 044a te_IN
+ 4b kn 044b kn_IN
+ 4c ml 044c ml_IN
+ 4d as 044d as_IN
+ 4e mr 044e mr_IN
+ 4f sa 044f sa_IN
+ 50 mn
+ 51 bo 0451 bo_CN
+ 52 cy 0452 cy_GB
+ 53 km 0453 km_KH
+ 54 lo 0454 lo_LA
+ 55 my 0455 my_MM
+ 56 gl 0456 gl_ES
+ 57 kok 0457 kok_IN
+ 58 mni 0458 mni_IN
+ 59 sd
+ 5a syr 045a syr_TR
+ 5b si 045b si_LK
+ 5c chr 045c chr_US
+ 5d iu 045d iu_CA
+ 5e am 045e am_ET
+ 5f ber 045f ber_MA
+ 60 ks 0460 ks_PK 0860 ks_IN
+ 61 ne 0461 ne_NP 0861 ne_IN
+ 62 fy 0462 fy_NL
+ 63 ps
+ 64 tl 0464 tl_PH
+ 65 div 0465 div_MV
+ 66 bin 0466 bin_NG
+ 67 ful 0467 ful_NG
+ 68 ha 0468 ha_NG
+ 69 nic 0469 nic_NG
+ 6a yo 046a yo_NG
+ 70 ibo 0470 ibo_NG
+ 71 kau 0471 kau_NG
+ 72 om 0472 om_ET
+ 73 ti 0473 ti_ET
+ 74 gn 0474 gn_PY
+ 75 cpe 0475 cpe_US
+ 76 la 0476 la_VA
+ 77 so 0477 so_SO
+ 78 sit 0478 sit_CN
+ 79 pap 0479 pap_AN
+ }]
+ }
+}
+
+# msgcat::mc --
+#
+# Find the translation for the given string based on the current
+# locale setting. Check the local namespace first, then look in each
+# parent namespace until the source is found. If additional args are
+# specified, use the format command to work them into the traslated
+# string.
+# If no catalog item is found, mcunknown is called in the caller frame
+# and its result is returned.
+#
+# Arguments:
+# src The string to translate.
+# args Args to pass to the format command
+#
+# Results:
+# Returns the translated string. Propagates errors thrown by the
+# format command.
+
+proc msgcat::mc {src args} {
+ # this may be replaced by:
+ # return [mcget -namespace [uplevel 1 [list ::namespace current]] --\
+ # $src {*}$args]
+
+ # Check for the src in each namespace starting from the local and
+ # ending in the global.
+
+ variable Msgs
+ variable Loclist
+
+ set ns [uplevel 1 [list ::namespace current]]
+ set loclist [PackagePreferences $ns]
+
+ set nscur $ns
+ while {$nscur != ""} {
+ foreach loc $loclist {
+ if {[dict exists $Msgs $nscur $loc $src]} {
+ return [DefaultUnknown "" [dict get $Msgs $nscur $loc $src]\
+ {*}$args]
+ }
+ }
+ set nscur [namespace parent $nscur]
+ }
+ # call package local or default unknown command
+ set args [linsert $args 0 [lindex $loclist 0] $src]
+ switch -exact -- [Invoke unknowncmd $args $ns result 1] {
+ 0 { return [uplevel 1 [linsert $args 0 [namespace origin mcunknown]]] }
+ 1 { return [DefaultUnknown {*}$args] }
+ default { return $result }
+ }
+}
+
+# msgcat::mcexists --
+#
+# Check if a catalog item is set or if mc would invoke mcunknown.
+#
+# Arguments:
+# -exactnamespace Only check the exact namespace and no
+# parent namespaces
+# -exactlocale Only check the exact locale and not all members
+# of the preferences list
+# src Message catalog key
+#
+# Results:
+# true if an adequate catalog key was found
+
+proc msgcat::mcexists {args} {
+
+ variable Msgs
+ variable Loclist
+ variable PackageConfig
+
+ set ns [uplevel 1 [list ::namespace current]]
+ set loclist [PackagePreferences $ns]
+
+ while {[llength $args] != 1} {
+ set args [lassign $args option]
+ switch -glob -- $option {
+ -exactnamespace { set exactnamespace 1 }
+ -exactlocale { set loclist [lrange $loclist 0 0] }
+ -* { return -code error "unknown option \"$option\"" }
+ default {
+ return -code error "wrong # args: should be\
+ \"[lindex [info level 0] 0] ?-exactnamespace?\
+ ?-exactlocale? src\""
+ }
+ }
+ }
+ set src [lindex $args 0]
+
+ while {$ns ne ""} {
+ foreach loc $loclist {
+ if {[dict exists $Msgs $ns $loc $src]} {
+ return 1
+ }
+ }
+ if {[info exists exactnamespace]} {return 0}
+ set ns [namespace parent $ns]
+ }
+ return 0
+}
+
+# msgcat::mclocale --
+#
+# Query or set the current locale.
+#
+# Arguments:
+# newLocale (Optional) The new locale string. Locale strings
+# should be composed of one or more sublocale parts
+# separated by underscores (e.g. en_US).
+#
+# Results:
+# Returns the normalized set locale.
+
+proc msgcat::mclocale {args} {
+ variable Loclist
+ variable LoadedLocales
+ set len [llength $args]
+
+ if {$len > 1} {
+ return -code error "wrong # args: should be\
+ \"[lindex [info level 0] 0] ?newLocale?\""
+ }
+
+ if {$len == 1} {
+ set newLocale [string tolower [lindex $args 0]]
+ if {$newLocale ne [file tail $newLocale]} {
+ return -code error "invalid newLocale value \"$newLocale\":\
+ could be path to unsafe code."
+ }
+ if {[lindex $Loclist 0] ne $newLocale} {
+ set Loclist [GetPreferences $newLocale]
+
+ # locale not loaded jet
+ LoadAll $Loclist
+ # Invoke callback
+ Invoke changecmd $Loclist
+ }
+ }
+ return [lindex $Loclist 0]
+}
+
+# msgcat::GetPreferences --
+#
+# Get list of locales from a locale.
+# The first element is always the lowercase locale.
+# Other elements have one component separated by "_" less.
+# Multiple "_" are seen as one separator: de__ch_spec de__ch de {}
+#
+# Arguments:
+# Locale.
+#
+# Results:
+# Locale list
+
+proc msgcat::GetPreferences {locale} {
+ set locale [string tolower $locale]
+ set loclist [list $locale]
+ while {-1 !=[set pos [string last "_" $locale]]} {
+ set locale [string range $locale 0 $pos-1]
+ if { "_" ne [string index $locale end] } {
+ lappend loclist $locale
+ }
+ }
+ if {"" ne [lindex $loclist end]} {
+ lappend loclist {}
+ }
+ return $loclist
+}
+
+# msgcat::mcpreferences --
+#
+# Fetch the list of locales used to look up strings, ordered from
+# most preferred to least preferred.
+#
+# Arguments:
+# None.
+#
+# Results:
+# Returns an ordered list of the locales preferred by the user.
+
+proc msgcat::mcpreferences {} {
+ variable Loclist
+ return $Loclist
+}
+
+# msgcat::mcloadedlocales --
+#
+# Get or change the list of currently loaded default locales
+#
+# The following subcommands are available:
+# loaded
+# Get the current list of loaded locales
+# clear
+# Remove all loaded locales not present in mcpreferences.
+#
+# Arguments:
+# subcommand One of loaded or clear
+#
+# Results:
+# Empty string, if not stated differently for the subcommand
+
+proc msgcat::mcloadedlocales {subcommand} {
+ variable Loclist
+ variable LoadedLocales
+ variable Msgs
+ variable PackageConfig
+ switch -exact -- $subcommand {
+ clear {
+ # Remove all locales not contained in Loclist
+ # skip any packages with package locale
+ set LoadedLocales $Loclist
+ foreach ns [dict keys $Msgs] {
+ if {![dict exists $PackageConfig loclist $ns]} {
+ foreach locale [dict keys [dict get $Msgs $ns]] {
+ if {$locale ni $Loclist} {
+ dict unset Msgs $ns $locale
+ }
+ }
+ }
+ }
+ }
+ loaded { return $LoadedLocales }
+ default {
+ return -code error "unknown subcommand \"$subcommand\": must be\
+ clear, or loaded"
+ }
+ }
+ return
+}
+
+# msgcat::mcpackagelocale --
+#
+# Get or change the package locale of the calling package.
+#
+# The following subcommands are available:
+# set
+# Set a package locale.
+# This may load message catalog files and may clear message catalog
+# items, if the former locale was the default locale.
+# Returns the normalized set locale.
+# The default locale is taken, if locale is not given.
+# get
+# Get the locale valid for this package.
+# isset
+# Returns true, if a package locale is set
+# unset
+# Unset the package locale and activate the default locale.
+# This loads message catalog file which where missing in the package
+# locale.
+# preferences
+# Return locale preference list valid for the package.
+# loaded
+# Return loaded locale list valid for the current package.
+# clear
+# If the current package has a package locale, remove all package
+# locales not containes in package mcpreferences.
+# It is an error to call this without a package locale set.
+#
+# The subcommands get, preferences and loaded return the corresponding
+# default data, if no package locale is set.
+#
+# Arguments:
+# subcommand see list above
+# locale package locale (only set subcommand)
+#
+# Results:
+# Empty string, if not stated differently for the subcommand
+
+proc msgcat::mcpackagelocale {subcommand {locale ""}} {
+ # todo: implement using an ensemble
+ variable Loclist
+ variable LoadedLocales
+ variable Msgs
+ variable PackageConfig
+ # Check option
+ # check if required item is exactly provided
+ if {[llength [info level 0]] == 2} {
+ # locale not given
+ unset locale
+ } else {
+ # locale given
+ if {$subcommand in
+ {"get" "isset" "unset" "preferences" "loaded" "clear"} } {
+ return -code error "wrong # args: should be\
+ \"[lrange [info level 0] 0 1]\""
+ }
+ set locale [string tolower $locale]
+ }
+ set ns [uplevel 1 {::namespace current}]
+
+ switch -exact -- $subcommand {
+ get { return [lindex [PackagePreferences $ns] 0] }
+ preferences { return [PackagePreferences $ns] }
+ loaded { return [PackageLocales $ns] }
+ present { return [expr {$locale in [PackageLocales $ns]} ]}
+ isset { return [dict exists $PackageConfig loclist $ns] }
+ set { # set a package locale or add a package locale
+
+ # Copy the default locale if no package locale set so far
+ if {![dict exists $PackageConfig loclist $ns]} {
+ dict set PackageConfig loclist $ns $Loclist
+ dict set PackageConfig loadedlocales $ns $LoadedLocales
+ }
+
+ # Check if changed
+ set loclist [dict get $PackageConfig loclist $ns]
+ if {! [info exists locale] || $locale eq [lindex $loclist 0] } {
+ return [lindex $loclist 0]
+ }
+
+ # Change loclist
+ set loclist [GetPreferences $locale]
+ set locale [lindex $loclist 0]
+ dict set PackageConfig loclist $ns $loclist
+
+ # load eventual missing locales
+ set loadedLocales [dict get $PackageConfig loadedlocales $ns]
+ if {$locale in $loadedLocales} { return $locale }
+ set loadLocales [ListComplement $loadedLocales $loclist]
+ dict set PackageConfig loadedlocales $ns\
+ [concat $loadedLocales $loadLocales]
+ Load $ns $loadLocales
+ return $locale
+ }
+ clear { # Remove all locales not contained in Loclist
+ if {![dict exists $PackageConfig loclist $ns]} {
+ return -code error "clear only when package locale set"
+ }
+ set loclist [dict get $PackageConfig loclist $ns]
+ dict set PackageConfig loadedlocales $ns $loclist
+ if {[dict exists $Msgs $ns]} {
+ foreach locale [dict keys [dict get $Msgs $ns]] {
+ if {$locale ni $loclist} {
+ dict unset Msgs $ns $locale
+ }
+ }
+ }
+ }
+ unset { # unset package locale and restore default locales
+
+ if { ![dict exists $PackageConfig loclist $ns] } { return }
+
+ # unset package locale
+ set loadLocales [ListComplement\
+ [dict get $PackageConfig loadedlocales $ns] $LoadedLocales]
+ dict unset PackageConfig loadedlocales $ns
+ dict unset PackageConfig loclist $ns
+
+ # unset keys not in global loaded locales
+ if {[dict exists $Msgs $ns]} {
+ foreach locale [dict keys [dict get $Msgs $ns]] {
+ if {$locale ni $LoadedLocales} {
+ dict unset Msgs $ns $locale
+ }
+ }
+ }
+
+ # Add missing locales
+ Load $ns $loadLocales
+ }
+ default {
+ return -code error "unknown subcommand \"$subcommand\": must be\
+ clear, get, isset, loaded, present, set, or unset"
+ }
+ }
+ return
+}
+
+# msgcat::mcforgetpackage --
+#
+# Remove any data of the calling package from msgcat
+#
+
+proc msgcat::mcforgetpackage {} {
+ # todo: this may be implemented using an ensemble
+ variable PackageConfig
+ variable Msgs
+ set ns [uplevel 1 {::namespace current}]
+ # Remove MC items
+ dict unset Msgs $ns
+ # Remove config items
+ foreach key [dict keys $PackageConfig] {
+ dict unset PackageConfig $key $ns
+ }
+ return
+}
+
+# msgcat::mcpackageconfig --
+#
+# Get or modify the per caller namespace (e.g. packages) config options.
+#
+# Available subcommands are:
+#
+# get get the current value or an error if not set.
+# isset return true, if the option is set
+# set set the value (see also distinct option).
+# Returns the number of loaded message files.
+# unset Clear option. return "".
+#
+# Available options are:
+#
+# mcfolder
+# The message catalog folder of the package.
+# This is automatically set by mcload.
+# If the value is changed using the set subcommand, an evntual
+# loadcmd is invoked and all message files of the package locale are
+# loaded.
+#
+# loadcmd
+# The command gets executed before a message file would be
+# sourced for this module.
+# The command is invoked with the expanded locale list to load.
+# The command is not invoked if the registering package namespace
+# is not present.
+# This callback might also be used as an alternative to message
+# files.
+# If the value is changed using the set subcommand, the callback is
+# directly invoked with the current file locale list. No file load is
+# executed.
+#
+# changecmd
+# The command is invoked, after an executed locale change.
+# Appended argument is expanded mcpreferences.
+#
+# unknowncmd
+# Use a package locale mcunknown procedure instead the global one.
+# The appended arguments are identical to mcunknown.
+# A default unknown handler is used if set to the empty string.
+# This consists in returning the key if no arguments are given.
+# With given arguments, format is used to process the arguments.
+#
+# Arguments:
+# subcommand Operation on the package
+# option The package option to get or set.
+# ?value? Eventual value for the subcommand
+#
+# Results:
+# Depends on the subcommand and option and is described there
+
+proc msgcat::mcpackageconfig {subcommand option {value ""}} {
+ variable PackageConfig
+ # get namespace
+ set ns [uplevel 1 {::namespace current}]
+
+ if {$option ni {"mcfolder" "loadcmd" "changecmd" "unknowncmd"}} {
+ return -code error "bad option \"$option\": must be mcfolder, loadcmd,\
+ changecmd, or unknowncmd"
+ }
+
+ # check if value argument is exactly provided
+ if {[llength [info level 0]] == 4 } {
+ # value provided
+ if {$subcommand in {"get" "isset" "unset"}} {
+ return -code error "wrong # args: should be\
+ \"[lrange [info level 0] 0 2] value\""
+ }
+ } elseif {$subcommand eq "set"} {
+ return -code error\
+ "wrong # args: should be \"[lrange [info level 0] 0 2]\""
+ }
+
+ # Execute subcommands
+ switch -exact -- $subcommand {
+ get { # Operation get return current value
+ if {![dict exists $PackageConfig $option $ns]} {
+ return -code error "package option \"$option\" not set"
+ }
+ return [dict get $PackageConfig $option $ns]
+ }
+ isset { return [dict exists $PackageConfig $option $ns] }
+ unset { dict unset PackageConfig $option $ns }
+ set { # Set option
+
+ if {$option eq "mcfolder"} {
+ set value [file normalize $value]
+ }
+ # Check if changed
+ if { [dict exists $PackageConfig $option $ns]
+ && $value eq [dict get $PackageConfig $option $ns] } {
+ return 0
+ }
+
+ # set new value
+ dict set PackageConfig $option $ns $value
+
+ # Reload pending message catalogs
+ switch -exact -- $option {
+ mcfolder { return [Load $ns [PackageLocales $ns]] }
+ loadcmd { return [Load $ns [PackageLocales $ns] 1] }
+ }
+ return 0
+ }
+ default {
+ return -code error "unknown subcommand \"$subcommand\":\
+ must be get, isset, set, or unset"
+ }
+ }
+ return
+}
+
+# msgcat::PackagePreferences --
+#
+# Return eventual present package preferences or the default list if not
+# present.
+#
+# Arguments:
+# ns Package namespace
+#
+# Results:
+# locale list
+
+proc msgcat::PackagePreferences {ns} {
+ variable PackageConfig
+ if {[dict exists $PackageConfig loclist $ns]} {
+ return [dict get $PackageConfig loclist $ns]
+ }
+ variable Loclist
+ return $Loclist
+}
+
+# msgcat::PackageLocales --
+#
+# Return eventual present package locales or the default list if not
+# present.
+#
+# Arguments:
+# ns Package namespace
+#
+# Results:
+# locale list
+
+proc msgcat::PackageLocales {ns} {
+ variable PackageConfig
+ if {[dict exists $PackageConfig loadedlocales $ns]} {
+ return [dict get $PackageConfig loadedlocales $ns]
+ }
+ variable LoadedLocales
+ return $LoadedLocales
+}
+
+# msgcat::ListComplement --
+#
+# Build the complement of two lists.
+# Return a list with all elements in list2 but not in list1.
+# Optionally return the intersection.
+#
+# Arguments:
+# list1 excluded list
+# list2 included list
+# inlistname If not "", write in this variable the intersection list
+#
+# Results:
+# list with all elements in list2 but not in list1
+
+proc msgcat::ListComplement {list1 list2 {inlistname ""}} {
+ if {"" ne $inlistname} {
+ upvar 1 $inlistname inlist
+ }
+ set inlist {}
+ set outlist {}
+ foreach item $list2 {
+ if {$item in $list1} {
+ lappend inlist $item
+ } else {
+ lappend outlist $item
+ }
+ }
+ return $outlist
+}
+
+# msgcat::mcload --
+#
+# Attempt to load message catalogs for each locale in the
+# preference list from the specified directory.
+#
+# Arguments:
+# langdir The directory to search.
+#
+# Results:
+# Returns the number of message catalogs that were loaded.
+
+proc msgcat::mcload {langdir} {
+ return [uplevel 1 [list\
+ [namespace origin mcpackageconfig] set mcfolder $langdir]]
+}
+
+# msgcat::LoadAll --
+#
+# Load a list of locales for all packages not having a package locale
+# list.
+#
+# Arguments:
+# langdir The directory to search.
+#
+# Results:
+# Returns the number of message catalogs that were loaded.
+
+proc msgcat::LoadAll {locales} {
+ variable PackageConfig
+ variable LoadedLocales
+ if {0 == [llength $locales]} { return {} }
+ # filter jet unloaded locales
+ set locales [ListComplement $LoadedLocales $locales]
+ if {0 == [llength $locales]} { return {} }
+ lappend LoadedLocales {*}$locales
+
+ set packages [lsort -unique [concat\
+ [dict keys [dict get $PackageConfig loadcmd]]\
+ [dict keys [dict get $PackageConfig mcfolder]]]]
+ foreach ns $packages {
+ if {! [dict exists $PackageConfig loclist $ns] } {
+ Load $ns $locales
+ }
+ }
+ return $locales
+}
+
+# msgcat::Load --
+#
+# Invoke message load callback and load message catalog files.
+#
+# Arguments:
+# ns Namespace (equal package) to load the message catalog.
+# locales List of locales to load.
+# callbackonly true if only callback should be invoked
+#
+# Results:
+# Returns the number of message catalogs that were loaded.
+
+proc msgcat::Load {ns locales {callbackonly 0}} {
+ variable FileLocale
+ variable PackageConfig
+ variable LoadedLocals
+
+ if {0 == [llength $locales]} { return 0 }
+
+ # Invoke callback
+ Invoke loadcmd $locales $ns
+
+ if {$callbackonly || ![dict exists $PackageConfig mcfolder $ns]} {
+ return 0
+ }
+
+ # Invoke file load
+ set langdir [dict get $PackageConfig mcfolder $ns]
+
+ # Save the file locale if we are recursively called
+ if {[info exists FileLocale]} {
+ set nestedFileLocale $FileLocale
+ }
+ set x 0
+ foreach p $locales {
+ if {$p eq {}} {
+ set p ROOT
+ }
+ set langfile [file join $langdir $p.msg]
+ if {[file exists $langfile]} {
+ incr x
+ set FileLocale [string tolower\
+ [file tail [file rootname $langfile]]]
+ if {"root" eq $FileLocale} {
+ set FileLocale ""
+ }
+ namespace inscope $ns [list ::source -encoding utf-8 $langfile]
+ unset FileLocale
+ }
+ }
+ if {[info exists nestedFileLocale]} {
+ set FileLocale $nestedFileLocale
+ }
+ return $x
+}
+
+# msgcat::Invoke --
+#
+# Invoke a set of registered callbacks.
+# The callback is only invoked, if its registered namespace exists.
+#
+# Arguments:
+# index Index into PackageConfig to get callback command
+# arglist parameters to the callback invocation
+# ns (Optional) package to call.
+# If not given or empty, check all registered packages.
+# resultname Variable to save the callback result of the last called
+# callback to. May be set to "" to discard the result.
+# failerror (0) Fail on error if true. Otherwise call bgerror.
+#
+# Results:
+# Possible values:
+# - 0: no valid command registered
+# - 1: registered command was the empty string
+# - 2: registered command called, resultname is set
+# - 3: registered command failed
+# If multiple commands are called, the maximum of all results is returned.
+
+proc msgcat::Invoke {index arglist {ns ""} {resultname ""} {failerror 0}} {
+ variable PackageConfig
+ variable Config
+ if {"" ne $resultname} {
+ upvar 1 $resultname result
+ }
+ if {"" eq $ns} {
+ set packageList [dict keys [dict get $PackageConfig $index]]
+ } else {
+ set packageList [list $ns]
+ }
+ set ret 0
+ foreach ns $packageList {
+ if {[dict exists $PackageConfig $index $ns] && [namespace exists $ns]} {
+ set cmd [dict get $PackageConfig $index $ns]
+ if {"" eq $cmd} {
+ if {$ret == 0} {set ret 1}
+ } else {
+ if {$failerror} {
+ set result [namespace inscope $ns $cmd {*}$arglist]
+ set ret 2
+ } elseif {1 == [catch {
+ set result [namespace inscope $ns $cmd {*}$arglist]
+ if {$ret < 2} {set ret 2}
+ } err derr]} {
+ after idle [concat [::interp bgerror ""]\
+ [list $err $derr]]
+ set ret 3
+ }
+ }
+ }
+ }
+ return $ret
+}
+
+# msgcat::mcset --
+#
+# Set the translation for a given string in a specified locale.
+#
+# Arguments:
+# locale The locale to use.
+# src The source string.
+# dest (Optional) The translated string. If omitted,
+# the source string is used.
+#
+# Results:
+# Returns the new locale.
+
+proc msgcat::mcset {locale src {dest ""}} {
+ variable Msgs
+ if {[llength [info level 0]] == 3} { ;# dest not specified
+ set dest $src
+ }
+
+ set ns [uplevel 1 [list ::namespace current]]
+
+ set locale [string tolower $locale]
+
+ dict set Msgs $ns $locale $src $dest
+ return $dest
+}
+
+# msgcat::mcflset --
+#
+# Set the translation for a given string in the current file locale.
+#
+# Arguments:
+# src The source string.
+# dest (Optional) The translated string. If omitted,
+# the source string is used.
+#
+# Results:
+# Returns the new locale.
+
+proc msgcat::mcflset {src {dest ""}} {
+ variable FileLocale
+ variable Msgs
+
+ if {![info exists FileLocale]} {
+ return -code error "must only be used inside a message catalog loaded\
+ with ::msgcat::mcload"
+ }
+ return [uplevel 1 [list [namespace origin mcset] $FileLocale $src $dest]]
+}
+
+# msgcat::mcmset --
+#
+# Set the translation for multiple strings in a specified locale.
+#
+# Arguments:
+# locale The locale to use.
+# pairs One or more src/dest pairs (must be even length)
+#
+# Results:
+# Returns the number of pairs processed
+
+proc msgcat::mcmset {locale pairs} {
+ variable Msgs
+
+ set length [llength $pairs]
+ if {$length % 2} {
+ return -code error "bad translation list:\
+ should be \"[lindex [info level 0] 0] locale {src dest ...}\""
+ }
+
+ set locale [string tolower $locale]
+ set ns [uplevel 1 [list ::namespace current]]
+
+ foreach {src dest} $pairs {
+ dict set Msgs $ns $locale $src $dest
+ }
+
+ return [expr {$length / 2}]
+}
+
+# msgcat::mcflmset --
+#
+# Set the translation for multiple strings in the mc file locale.
+#
+# Arguments:
+# pairs One or more src/dest pairs (must be even length)
+#
+# Results:
+# Returns the number of pairs processed
+
+proc msgcat::mcflmset {pairs} {
+ variable FileLocale
+ variable Msgs
+
+ if {![info exists FileLocale]} {
+ return -code error "must only be used inside a message catalog loaded\
+ with ::msgcat::mcload"
+ }
+ return [uplevel 1 [list [namespace origin mcmset] $FileLocale $pairs]]
+}
+
+# msgcat::mcunknown --
+#
+# This routine is called by msgcat::mc if a translation cannot
+# be found for a string and no unknowncmd is set for the current
+# package. This routine is intended to be replaced
+# by an application specific routine for error reporting
+# purposes. The default behavior is to return the source string.
+# If additional args are specified, the format command will be used
+# to work them into the traslated string.
+#
+# Arguments:
+# locale The current locale.
+# src The string to be translated.
+# args Args to pass to the format command
+#
+# Results:
+# Returns the translated value.
+
+proc msgcat::mcunknown {args} {
+ return [uplevel 1 [list [namespace origin DefaultUnknown] {*}$args]]
+}
+
+# msgcat::DefaultUnknown --
+#
+# This routine is called by msgcat::mc if a translation cannot
+# be found for a string in the following circumstances:
+# - Default global handler, if mcunknown is not redefined.
+# - Per package handler, if the package sets unknowncmd to the empty
+# string.
+# It returna the source string if the argument list is empty.
+# If additional args are specified, the format command will be used
+# to work them into the traslated string.
+#
+# Arguments:
+# locale (unused) The current locale.
+# src The string to be translated.
+# args Args to pass to the format command
+#
+# Results:
+# Returns the translated value.
+
+proc msgcat::DefaultUnknown {locale src args} {
+ if {[llength $args]} {
+ return [format $src {*}$args]
+ } else {
+ return $src
+ }
+}
+
+# msgcat::mcmax --
+#
+# Calculates the maximum length of the translated strings of the given
+# list.
+#
+# Arguments:
+# args strings to translate.
+#
+# Results:
+# Returns the length of the longest translated string.
+
+proc msgcat::mcmax {args} {
+ set max 0
+ foreach string $args {
+ set translated [uplevel 1 [list [namespace origin mc] $string]]
+ set len [string length $translated]
+ if {$len>$max} {
+ set max $len
+ }
+ }
+ return $max
+}
+
+# Convert the locale values stored in environment variables to a form
+# suitable for passing to [mclocale]
+proc msgcat::ConvertLocale {value} {
+ # Assume $value is of form: $language[_$territory][.$codeset][@modifier]
+ # Convert to form: $language[_$territory][_$modifier]
+ #
+ # Comment out expanded RE version -- bugs alleged
+ # regexp -expanded {
+ # ^ # Match all the way to the beginning
+ # ([^_.@]*) # Match "lanugage"; ends with _, ., or @
+ # (_([^.@]*))? # Match (optional) "territory"; starts with _
+ # ([.]([^@]*))? # Match (optional) "codeset"; starts with .
+ # (@(.*))? # Match (optional) "modifier"; starts with @
+ # $ # Match all the way to the end
+ # } $value -> language _ territory _ codeset _ modifier
+ if {![regexp {^([^_.@]+)(_([^.@]*))?([.]([^@]*))?(@(.*))?$} $value \
+ -> language _ territory _ codeset _ modifier]} {
+ return -code error "invalid locale '$value': empty language part"
+ }
+ set ret $language
+ if {[string length $territory]} {
+ append ret _$territory
+ }
+ if {[string length $modifier]} {
+ append ret _$modifier
+ }
+ return $ret
+}
+
+# Initialize the default locale
+proc msgcat::Init {} {
+ global env
+
+ #
+ # set default locale, try to get from environment
+ #
+ foreach varName {LC_ALL LC_MESSAGES LANG} {
+ if {[info exists env($varName)] && ("" ne $env($varName))} {
+ if {![catch {
+ mclocale [ConvertLocale $env($varName)]
+ }]} {
+ return
+ }
+ }
+ }
+ #
+ # On Darwin, fallback to current CFLocale identifier if available.
+ #
+ if {[info exists ::tcl::mac::locale] && $::tcl::mac::locale ne ""} {
+ if {![catch {
+ mclocale [ConvertLocale $::tcl::mac::locale]
+ }]} {
+ return
+ }
+ }
+ #
+ # The rest of this routine is special processing for Windows or
+ # Cygwin. All other platforms, get out now.
+ #
+ if {([info sharedlibextension] ne ".dll")
+ || [catch {package require registry}]} {
+ mclocale C
+ return
+ }
+ #
+ # On Windows or Cygwin, try to set locale depending on registry
+ # settings, or fall back on locale of "C".
+ #
+
+ # On Vista and later:
+ # HCU/Control Panel/Desktop : PreferredUILanguages is for language packs,
+ # HCU/Control Pannel/International : localName is the default locale.
+ #
+ # They contain the local string as RFC5646, composed of:
+ # [a-z]{2,3} : language
+ # -[a-z]{4} : script (optional, translated by table Latn->latin)
+ # -[a-z]{2}|[0-9]{3} : territory (optional, numerical region codes not used)
+ # (-.*)* : variant, extension, private use (optional, not used)
+ # Those are translated to local strings.
+ # Examples: de-CH -> de_ch, sr-Latn-CS -> sr_cs@latin, es-419 -> es
+ #
+ foreach key {{HKEY_CURRENT_USER\Control Panel\Desktop} {HKEY_CURRENT_USER\Control Panel\International}}\
+ value {PreferredUILanguages localeName} {
+ if {![catch {registry get $key $value} localeName]
+ && [regexp {^([a-z]{2,3})(?:-([a-z]{4}))?(?:-([a-z]{2}))?(?:-.+)?$}\
+ [string tolower $localeName] match locale script territory]} {
+ if {"" ne $territory} {
+ append locale _ $territory
+ }
+ set modifierDict [dict create latn latin cyrl cyrillic]
+ if {[dict exists $modifierDict $script]} {
+ append locale @ [dict get $modifierDict $script]
+ }
+ if {![catch {mclocale [ConvertLocale $locale]}]} {
+ return
+ }
+ }
+ }
+
+ # then check value locale which contains a numerical language ID
+ if {[catch {
+ set locale [registry get $key "locale"]
+ }]} {
+ mclocale C
+ return
+ }
+ #
+ # Keep trying to match against smaller and smaller suffixes
+ # of the registry value, since the latter hexadigits appear
+ # to determine general language and earlier hexadigits determine
+ # more precise information, such as territory. For example,
+ # 0409 - English - United States
+ # 0809 - English - United Kingdom
+ # Add more translations to the WinRegToISO639 array above.
+ #
+ variable WinRegToISO639
+ set locale [string tolower $locale]
+ while {[string length $locale]} {
+ if {![catch {
+ mclocale [ConvertLocale [dict get $WinRegToISO639 $locale]]
+ }]} {
+ return
+ }
+ set locale [string range $locale 1 end]
+ }
+ #
+ # No translation known. Fall back on "C" locale
+ #
+ mclocale C
+}
+msgcat::Init
diff --git a/Master/tlpkg/tltcl/lib/tcl8/8.5/tcltest-2.5.1.tm b/Master/tlpkg/tltcl/lib/tcl8/8.5/tcltest-2.5.1.tm
new file mode 100644
index 00000000000..a7a68c757f9
--- /dev/null
+++ b/Master/tlpkg/tltcl/lib/tcl8/8.5/tcltest-2.5.1.tm
@@ -0,0 +1,3446 @@
+# tcltest.tcl --
+#
+# This file contains support code for the Tcl test suite. It
+# defines the tcltest namespace and finds and defines the output
+# directory, constraints available, output and error channels,
+# etc. used by Tcl tests. See the tcltest man page for more
+# details.
+#
+# This design was based on the Tcl testing approach designed and
+# initially implemented by Mary Ann May-Pumphrey of Sun
+# Microsystems.
+#
+# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 2000 by Ajuba Solutions
+# Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
+# All rights reserved.
+
+package require Tcl 8.5- ;# -verbose line uses [info frame]
+namespace eval tcltest {
+
+ # When the version number changes, be sure to update the pkgIndex.tcl file,
+ # and the install directory in the Makefiles. When the minor version
+ # changes (new feature) be sure to update the man page as well.
+ variable Version 2.5.1
+
+ # Compatibility support for dumb variables defined in tcltest 1
+ # Do not use these. Call [package provide Tcl] and [info patchlevel]
+ # yourself. You don't need tcltest to wrap it for you.
+ variable version [package provide Tcl]
+ variable patchLevel [info patchlevel]
+
+##### Export the public tcltest procs; several categories
+ #
+ # Export the main functional commands that do useful things
+ namespace export cleanupTests loadTestedCommands makeDirectory \
+ makeFile removeDirectory removeFile runAllTests test
+
+ # Export configuration commands that control the functional commands
+ namespace export configure customMatch errorChannel interpreter \
+ outputChannel testConstraint
+
+ # Export commands that are duplication (candidates for deprecation)
+ namespace export bytestring ;# dups [encoding convertfrom identity]
+ namespace export debug ;# [configure -debug]
+ namespace export errorFile ;# [configure -errfile]
+ namespace export limitConstraints ;# [configure -limitconstraints]
+ namespace export loadFile ;# [configure -loadfile]
+ namespace export loadScript ;# [configure -load]
+ namespace export match ;# [configure -match]
+ namespace export matchFiles ;# [configure -file]
+ namespace export matchDirectories ;# [configure -relateddir]
+ namespace export normalizeMsg ;# application of [customMatch]
+ namespace export normalizePath ;# [file normalize] (8.4)
+ namespace export outputFile ;# [configure -outfile]
+ namespace export preserveCore ;# [configure -preservecore]
+ namespace export singleProcess ;# [configure -singleproc]
+ namespace export skip ;# [configure -skip]
+ namespace export skipFiles ;# [configure -notfile]
+ namespace export skipDirectories ;# [configure -asidefromdir]
+ namespace export temporaryDirectory ;# [configure -tmpdir]
+ namespace export testsDirectory ;# [configure -testdir]
+ namespace export verbose ;# [configure -verbose]
+ namespace export viewFile ;# binary encoding [read]
+ namespace export workingDirectory ;# [cd] [pwd]
+
+ # Export deprecated commands for tcltest 1 compatibility
+ namespace export getMatchingFiles mainThread restoreState saveState \
+ threadReap
+
+ # tcltest::normalizePath --
+ #
+ # This procedure resolves any symlinks in the path thus creating
+ # a path without internal redirection. It assumes that the
+ # incoming path is absolute.
+ #
+ # Arguments
+ # pathVar - name of variable containing path to modify.
+ #
+ # Results
+ # The path is modified in place.
+ #
+ # Side Effects:
+ # None.
+ #
+ proc normalizePath {pathVar} {
+ upvar 1 $pathVar path
+ set oldpwd [pwd]
+ catch {cd $path}
+ set path [pwd]
+ cd $oldpwd
+ return $path
+ }
+
+##### Verification commands used to test values of variables and options
+ #
+ # Verification command that accepts everything
+ proc AcceptAll {value} {
+ return $value
+ }
+
+ # Verification command that accepts valid Tcl lists
+ proc AcceptList { list } {
+ return [lrange $list 0 end]
+ }
+
+ # Verification command that accepts a glob pattern
+ proc AcceptPattern { pattern } {
+ return [AcceptAll $pattern]
+ }
+
+ # Verification command that accepts integers
+ proc AcceptInteger { level } {
+ return [incr level 0]
+ }
+
+ # Verification command that accepts boolean values
+ proc AcceptBoolean { boolean } {
+ return [expr {$boolean && $boolean}]
+ }
+
+ # Verification command that accepts (syntactically) valid Tcl scripts
+ proc AcceptScript { script } {
+ if {![info complete $script]} {
+ return -code error "invalid Tcl script: $script"
+ }
+ return $script
+ }
+
+ # Verification command that accepts (converts to) absolute pathnames
+ proc AcceptAbsolutePath { path } {
+ return [file join [pwd] $path]
+ }
+
+ # Verification command that accepts existing readable directories
+ proc AcceptReadable { path } {
+ if {![file readable $path]} {
+ return -code error "\"$path\" is not readable"
+ }
+ return $path
+ }
+ proc AcceptDirectory { directory } {
+ set directory [AcceptAbsolutePath $directory]
+ if {![file exists $directory]} {
+ return -code error "\"$directory\" does not exist"
+ }
+ if {![file isdir $directory]} {
+ return -code error "\"$directory\" is not a directory"
+ }
+ return [AcceptReadable $directory]
+ }
+
+##### Initialize internal arrays of tcltest, but only if the caller
+ # has not already pre-initialized them. This is done to support
+ # compatibility with older tests that directly access internals
+ # rather than go through command interfaces.
+ #
+ proc ArrayDefault {varName value} {
+ variable $varName
+ if {[array exists $varName]} {
+ return
+ }
+ if {[info exists $varName]} {
+ # Pre-initialized value is a scalar: destroy it!
+ unset $varName
+ }
+ array set $varName $value
+ }
+
+ # save the original environment so that it can be restored later
+ ArrayDefault originalEnv [array get ::env]
+
+ # initialize numTests array to keep track of the number of tests
+ # that pass, fail, and are skipped.
+ ArrayDefault numTests [list Total 0 Passed 0 Skipped 0 Failed 0]
+
+ # createdNewFiles will store test files as indices and the list of
+ # files (that should not have been) left behind by the test files
+ # as values.
+ ArrayDefault createdNewFiles {}
+
+ # initialize skippedBecause array to keep track of constraints that
+ # kept tests from running; a constraint name of "userSpecifiedSkip"
+ # means that the test appeared on the list of tests that matched the
+ # -skip value given to the flag; "userSpecifiedNonMatch" means that
+ # the test didn't match the argument given to the -match flag; both
+ # of these constraints are counted only if tcltest::debug is set to
+ # true.
+ ArrayDefault skippedBecause {}
+
+ # initialize the testConstraints array to keep track of valid
+ # predefined constraints (see the explanation for the
+ # InitConstraints proc for more details).
+ ArrayDefault testConstraints {}
+
+##### Initialize internal variables of tcltest, but only if the caller
+ # has not already pre-initialized them. This is done to support
+ # compatibility with older tests that directly access internals
+ # rather than go through command interfaces.
+ #
+ proc Default {varName value {verify AcceptAll}} {
+ variable $varName
+ if {![info exists $varName]} {
+ variable $varName [$verify $value]
+ } else {
+ variable $varName [$verify [set $varName]]
+ }
+ }
+
+ # Save any arguments that we might want to pass through to other
+ # programs. This is used by the -args flag.
+ # FINDUSER
+ Default parameters {}
+
+ # Count the number of files tested (0 if runAllTests wasn't called).
+ # runAllTests will set testSingleFile to false, so stats will
+ # not be printed until runAllTests calls the cleanupTests proc.
+ # The currentFailure var stores the boolean value of whether the
+ # current test file has had any failures. The failFiles list
+ # stores the names of test files that had failures.
+ Default numTestFiles 0 AcceptInteger
+ Default testSingleFile true AcceptBoolean
+ Default currentFailure false AcceptBoolean
+ Default failFiles {} AcceptList
+
+ # Tests should remove all files they create. The test suite will
+ # check the current working dir for files created by the tests.
+ # filesMade keeps track of such files created using the makeFile and
+ # makeDirectory procedures. filesExisted stores the names of
+ # pre-existing files.
+ #
+ # Note that $filesExisted lists only those files that exist in
+ # the original [temporaryDirectory].
+ Default filesMade {} AcceptList
+ Default filesExisted {} AcceptList
+ proc FillFilesExisted {} {
+ variable filesExisted
+
+ # Save the names of files that already exist in the scratch directory.
+ foreach file [glob -nocomplain -directory [temporaryDirectory] *] {
+ lappend filesExisted [file tail $file]
+ }
+
+ # After successful filling, turn this into a no-op.
+ proc FillFilesExisted args {}
+ }
+
+ # Kept only for compatibility
+ Default constraintsSpecified {} AcceptList
+ trace add variable constraintsSpecified read [namespace code {
+ set constraintsSpecified [array names testConstraints] ;#}]
+
+ # tests that use threads need to know which is the main thread
+ Default mainThread 1
+ variable mainThread
+ if {[info commands thread::id] ne {}} {
+ set mainThread [thread::id]
+ } elseif {[info commands testthread] ne {}} {
+ set mainThread [testthread id]
+ }
+
+ # Set workingDirectory to [pwd]. The default output directory for
+ # Tcl tests is the working directory. Whenever this value changes
+ # change to that directory.
+ variable workingDirectory
+ trace add variable workingDirectory write \
+ [namespace code {cd $workingDirectory ;#}]
+
+ Default workingDirectory [pwd] AcceptAbsolutePath
+ proc workingDirectory { {dir ""} } {
+ variable workingDirectory
+ if {[llength [info level 0]] == 1} {
+ return $workingDirectory
+ }
+ set workingDirectory [AcceptAbsolutePath $dir]
+ }
+
+ # Set the location of the execuatble
+ Default tcltest [info nameofexecutable]
+ trace add variable tcltest write [namespace code {testConstraint stdio \
+ [eval [ConstraintInitializer stdio]] ;#}]
+
+ # save the platform information so it can be restored later
+ Default originalTclPlatform [array get ::tcl_platform]
+
+ # If a core file exists, save its modification time.
+ if {[file exists [file join [workingDirectory] core]]} {
+ Default coreModTime \
+ [file mtime [file join [workingDirectory] core]]
+ }
+
+ # stdout and stderr buffers for use when we want to store them
+ Default outData {}
+ Default errData {}
+
+ # keep track of test level for nested test commands
+ variable testLevel 0
+
+ # the variables and procs that existed when saveState was called are
+ # stored in a variable of the same name
+ Default saveState {}
+
+ # Internationalization support -- used in [SetIso8859_1_Locale] and
+ # [RestoreLocale]. Those commands are used in cmdIL.test.
+
+ if {![info exists [namespace current]::isoLocale]} {
+ variable isoLocale fr
+ switch -- $::tcl_platform(platform) {
+ "unix" {
+
+ # Try some 'known' values for some platforms:
+
+ switch -exact -- $::tcl_platform(os) {
+ "FreeBSD" {
+ set isoLocale fr_FR.ISO_8859-1
+ }
+ HP-UX {
+ set isoLocale fr_FR.iso88591
+ }
+ Linux -
+ IRIX {
+ set isoLocale fr
+ }
+ default {
+
+ # Works on SunOS 4 and Solaris, and maybe
+ # others... Define it to something else on your
+ # system if you want to test those.
+
+ set isoLocale iso_8859_1
+ }
+ }
+ }
+ "windows" {
+ set isoLocale French
+ }
+ }
+ }
+
+ variable ChannelsWeOpened; array set ChannelsWeOpened {}
+ # output goes to stdout by default
+ Default outputChannel stdout
+ proc outputChannel { {filename ""} } {
+ variable outputChannel
+ variable ChannelsWeOpened
+
+ # This is very subtle and tricky, so let me try to explain.
+ # (Hopefully this longer comment will be clear when I come
+ # back in a few months, unlike its predecessor :) )
+ #
+ # The [outputChannel] command (and underlying variable) have to
+ # be kept in sync with the [configure -outfile] configuration
+ # option ( and underlying variable Option(-outfile) ). This is
+ # accomplished with a write trace on Option(-outfile) that will
+ # update [outputChannel] whenver a new value is written. That
+ # much is easy.
+ #
+ # The trick is that in order to maintain compatibility with
+ # version 1 of tcltest, we must allow every configuration option
+ # to get its inital value from command line arguments. This is
+ # accomplished by setting initial read traces on all the
+ # configuration options to parse the command line option the first
+ # time they are read. These traces are cancelled whenever the
+ # program itself calls [configure].
+ #
+ # OK, then so to support tcltest 1 compatibility, it seems we want
+ # to get the return from [outputFile] to trigger the read traces,
+ # just in case.
+ #
+ # BUT! A little known feature of Tcl variable traces is that
+ # traces are disabled during the handling of other traces. So,
+ # if we trigger read traces on Option(-outfile) and that triggers
+ # command line parsing which turns around and sets an initial
+ # value for Option(-outfile) -- <whew!> -- the write trace that
+ # would keep [outputChannel] in sync with that new initial value
+ # would not fire!
+ #
+ # SO, finally, as a workaround, instead of triggering read traces
+ # by invoking [outputFile], we instead trigger the same set of
+ # read traces by invoking [debug]. Any command that reads a
+ # configuration option would do. [debug] is just a handy one.
+ # The end result is that we support tcltest 1 compatibility and
+ # keep outputChannel and -outfile in sync in all cases.
+ debug
+
+ if {[llength [info level 0]] == 1} {
+ return $outputChannel
+ }
+ if {[info exists ChannelsWeOpened($outputChannel)]} {
+ close $outputChannel
+ unset ChannelsWeOpened($outputChannel)
+ }
+ switch -exact -- $filename {
+ stderr -
+ stdout {
+ set outputChannel $filename
+ }
+ default {
+ set outputChannel [open $filename a]
+ set ChannelsWeOpened($outputChannel) 1
+
+ # If we created the file in [temporaryDirectory], then
+ # [cleanupTests] will delete it, unless we claim it was
+ # already there.
+ set outdir [normalizePath [file dirname \
+ [file join [pwd] $filename]]]
+ if {$outdir eq [temporaryDirectory]} {
+ variable filesExisted
+ FillFilesExisted
+ set filename [file tail $filename]
+ if {$filename ni $filesExisted} {
+ lappend filesExisted $filename
+ }
+ }
+ }
+ }
+ return $outputChannel
+ }
+
+ # errors go to stderr by default
+ Default errorChannel stderr
+ proc errorChannel { {filename ""} } {
+ variable errorChannel
+ variable ChannelsWeOpened
+
+ # This is subtle and tricky. See the comment above in
+ # [outputChannel] for a detailed explanation.
+ debug
+
+ if {[llength [info level 0]] == 1} {
+ return $errorChannel
+ }
+ if {[info exists ChannelsWeOpened($errorChannel)]} {
+ close $errorChannel
+ unset ChannelsWeOpened($errorChannel)
+ }
+ switch -exact -- $filename {
+ stderr -
+ stdout {
+ set errorChannel $filename
+ }
+ default {
+ set errorChannel [open $filename a]
+ set ChannelsWeOpened($errorChannel) 1
+
+ # If we created the file in [temporaryDirectory], then
+ # [cleanupTests] will delete it, unless we claim it was
+ # already there.
+ set outdir [normalizePath [file dirname \
+ [file join [pwd] $filename]]]
+ if {$outdir eq [temporaryDirectory]} {
+ variable filesExisted
+ FillFilesExisted
+ set filename [file tail $filename]
+ if {$filename ni $filesExisted} {
+ lappend filesExisted $filename
+ }
+ }
+ }
+ }
+ return $errorChannel
+ }
+
+##### Set up the configurable options
+ #
+ # The configurable options of the package
+ variable Option; array set Option {}
+
+ # Usage strings for those options
+ variable Usage; array set Usage {}
+
+ # Verification commands for those options
+ variable Verify; array set Verify {}
+
+ # Initialize the default values of the configurable options that are
+ # historically associated with an exported variable. If that variable
+ # is already set, support compatibility by accepting its pre-set value.
+ # Use [trace] to establish ongoing connection between the deprecated
+ # exported variable and the modern option kept as a true internal var.
+ # Also set up usage string and value testing for the option.
+ proc Option {option value usage {verify AcceptAll} {varName {}}} {
+ variable Option
+ variable Verify
+ variable Usage
+ variable OptionControlledVariables
+ variable DefaultValue
+ set Usage($option) $usage
+ set Verify($option) $verify
+ set DefaultValue($option) $value
+ if {[catch {$verify $value} msg]} {
+ return -code error $msg
+ } else {
+ set Option($option) $msg
+ }
+ if {[string length $varName]} {
+ variable $varName
+ if {[info exists $varName]} {
+ if {[catch {$verify [set $varName]} msg]} {
+ return -code error $msg
+ } else {
+ set Option($option) $msg
+ }
+ unset $varName
+ }
+ namespace eval [namespace current] \
+ [list upvar 0 Option($option) $varName]
+ # Workaround for Bug (now Feature Request) 572889. Grrrr....
+ # Track all the variables tied to options
+ lappend OptionControlledVariables $varName
+ # Later, set auto-configure read traces on all
+ # of them, since a single trace on Option does not work.
+ proc $varName {{value {}}} [subst -nocommands {
+ if {[llength [info level 0]] == 2} {
+ Configure $option [set value]
+ }
+ return [Configure $option]
+ }]
+ }
+ }
+
+ proc MatchingOption {option} {
+ variable Option
+ set match [array names Option $option*]
+ switch -- [llength $match] {
+ 0 {
+ set sorted [lsort [array names Option]]
+ set values [join [lrange $sorted 0 end-1] ", "]
+ append values ", or [lindex $sorted end]"
+ return -code error "unknown option $option: should be\
+ one of $values"
+ }
+ 1 {
+ return [lindex $match 0]
+ }
+ default {
+ # Exact match trumps ambiguity
+ if {$option in $match} {
+ return $option
+ }
+ set values [join [lrange $match 0 end-1] ", "]
+ append values ", or [lindex $match end]"
+ return -code error "ambiguous option $option:\
+ could match $values"
+ }
+ }
+ }
+
+ proc EstablishAutoConfigureTraces {} {
+ variable OptionControlledVariables
+ foreach varName [concat $OptionControlledVariables Option] {
+ variable $varName
+ trace add variable $varName read [namespace code {
+ ProcessCmdLineArgs ;#}]
+ }
+ }
+
+ proc RemoveAutoConfigureTraces {} {
+ variable OptionControlledVariables
+ foreach varName [concat $OptionControlledVariables Option] {
+ variable $varName
+ foreach pair [trace info variable $varName] {
+ lassign $pair op cmd
+ if {($op eq "read") &&
+ [string match *ProcessCmdLineArgs* $cmd]} {
+ trace remove variable $varName $op $cmd
+ }
+ }
+ }
+ # Once the traces are removed, this can become a no-op
+ proc RemoveAutoConfigureTraces {} {}
+ }
+
+ proc Configure args {
+ variable Option
+ variable Verify
+ set n [llength $args]
+ if {$n == 0} {
+ return [lsort [array names Option]]
+ }
+ if {$n == 1} {
+ if {[catch {MatchingOption [lindex $args 0]} option]} {
+ return -code error $option
+ }
+ return $Option($option)
+ }
+ while {[llength $args] > 1} {
+ if {[catch {MatchingOption [lindex $args 0]} option]} {
+ return -code error $option
+ }
+ if {[catch {$Verify($option) [lindex $args 1]} value]} {
+ return -code error "invalid $option\
+ value \"[lindex $args 1]\": $value"
+ }
+ set Option($option) $value
+ set args [lrange $args 2 end]
+ }
+ if {[llength $args]} {
+ if {[catch {MatchingOption [lindex $args 0]} option]} {
+ return -code error $option
+ }
+ return -code error "missing value for option $option"
+ }
+ }
+ proc configure args {
+ if {[llength $args] > 1} {
+ RemoveAutoConfigureTraces
+ }
+ set code [catch {Configure {*}$args} msg]
+ return -code $code $msg
+ }
+
+ proc AcceptVerbose { level } {
+ set level [AcceptList $level]
+ set levelMap {
+ l list
+ p pass
+ b body
+ s skip
+ t start
+ e error
+ l line
+ m msec
+ u usec
+ }
+ set levelRegexp "^([join [dict values $levelMap] |])\$"
+ if {[llength $level] == 1} {
+ if {![regexp $levelRegexp $level]} {
+ # translate single characters abbreviations to expanded list
+ set level [string map $levelMap [split $level {}]]
+ }
+ }
+ set valid [list]
+ foreach v $level {
+ if {[regexp $levelRegexp $v]} {
+ lappend valid $v
+ }
+ }
+ return $valid
+ }
+
+ proc IsVerbose {level} {
+ variable Option
+ return [expr {[lsearch -exact $Option(-verbose) $level] != -1}]
+ }
+
+ # Default verbosity is to show bodies of failed tests
+ Option -verbose {body error} {
+ Takes any combination of the values 'p', 's', 'b', 't', 'e' and 'l'.
+ Test suite will display all passed tests if 'p' is specified, all
+ skipped tests if 's' is specified, the bodies of failed tests if
+ 'b' is specified, and when tests start if 't' is specified.
+ ErrorInfo is displayed if 'e' is specified. Source file line
+ information of failed tests is displayed if 'l' is specified.
+ } AcceptVerbose verbose
+
+ # Match and skip patterns default to the empty list, except for
+ # matchFiles, which defaults to all .test files in the
+ # testsDirectory and matchDirectories, which defaults to all
+ # directories.
+ Option -match * {
+ Run all tests within the specified files that match one of the
+ list of glob patterns given.
+ } AcceptList match
+
+ Option -skip {} {
+ Skip all tests within the specified tests (via -match) and files
+ that match one of the list of glob patterns given.
+ } AcceptList skip
+
+ Option -file *.test {
+ Run tests in all test files that match the glob pattern given.
+ } AcceptPattern matchFiles
+
+ # By default, skip files that appear to be SCCS lock files.
+ Option -notfile l.*.test {
+ Skip all test files that match the glob pattern given.
+ } AcceptPattern skipFiles
+
+ Option -relateddir * {
+ Run tests in directories that match the glob pattern given.
+ } AcceptPattern matchDirectories
+
+ Option -asidefromdir {} {
+ Skip tests in directories that match the glob pattern given.
+ } AcceptPattern skipDirectories
+
+ # By default, don't save core files
+ Option -preservecore 0 {
+ If 2, save any core files produced during testing in the directory
+ specified by -tmpdir. If 1, notify the user if core files are
+ created.
+ } AcceptInteger preserveCore
+
+ # debug output doesn't get printed by default; debug level 1 spits
+ # up only the tests that were skipped because they didn't match or
+ # were specifically skipped. A debug level of 2 would spit up the
+ # tcltest variables and flags provided; a debug level of 3 causes
+ # some additional output regarding operations of the test harness.
+ # The tcltest package currently implements only up to debug level 3.
+ Option -debug 0 {
+ Internal debug level
+ } AcceptInteger debug
+
+ proc SetSelectedConstraints args {
+ variable Option
+ foreach c $Option(-constraints) {
+ testConstraint $c 1
+ }
+ }
+ Option -constraints {} {
+ Do not skip the listed constraints listed in -constraints.
+ } AcceptList
+ trace add variable Option(-constraints) write \
+ [namespace code {SetSelectedConstraints ;#}]
+
+ # Don't run only the "-constraint" specified tests by default
+ proc ClearUnselectedConstraints args {
+ variable Option
+ variable testConstraints
+ if {!$Option(-limitconstraints)} {return}
+ foreach c [array names testConstraints] {
+ if {$c ni $Option(-constraints)} {
+ testConstraint $c 0
+ }
+ }
+ }
+ Option -limitconstraints 0 {
+ whether to run only tests with the constraints
+ } AcceptBoolean limitConstraints
+ trace add variable Option(-limitconstraints) write \
+ [namespace code {ClearUnselectedConstraints ;#}]
+
+ # A test application has to know how to load the tested commands
+ # into the interpreter.
+ Option -load {} {
+ Specifies the script to load the tested commands.
+ } AcceptScript loadScript
+
+ # Default is to run each test file in a separate process
+ Option -singleproc 0 {
+ whether to run all tests in one process
+ } AcceptBoolean singleProcess
+
+ proc AcceptTemporaryDirectory { directory } {
+ set directory [AcceptAbsolutePath $directory]
+ if {![file exists $directory]} {
+ file mkdir $directory
+ }
+ set directory [AcceptDirectory $directory]
+ if {![file writable $directory]} {
+ if {[workingDirectory] eq $directory} {
+ # Special exception: accept the default value
+ # even if the directory is not writable
+ return $directory
+ }
+ return -code error "\"$directory\" is not writeable"
+ }
+ return $directory
+ }
+
+ # Directory where files should be created
+ Option -tmpdir [workingDirectory] {
+ Save temporary files in the specified directory.
+ } AcceptTemporaryDirectory temporaryDirectory
+ trace add variable Option(-tmpdir) write \
+ [namespace code {normalizePath Option(-tmpdir) ;#}]
+
+ # Tests should not rely on the current working directory.
+ # Files that are part of the test suite should be accessed relative
+ # to [testsDirectory]
+ Option -testdir [workingDirectory] {
+ Search tests in the specified directory.
+ } AcceptDirectory testsDirectory
+ trace add variable Option(-testdir) write \
+ [namespace code {normalizePath Option(-testdir) ;#}]
+
+ proc AcceptLoadFile { file } {
+ if {$file eq {}} {return $file}
+ set file [file join [temporaryDirectory] $file]
+ return [AcceptReadable $file]
+ }
+ proc ReadLoadScript {args} {
+ variable Option
+ if {$Option(-loadfile) eq {}} {return}
+ set tmp [open $Option(-loadfile) r]
+ loadScript [read $tmp]
+ close $tmp
+ }
+ Option -loadfile {} {
+ Read the script to load the tested commands from the specified file.
+ } AcceptLoadFile loadFile
+ trace add variable Option(-loadfile) write [namespace code ReadLoadScript]
+
+ proc AcceptOutFile { file } {
+ if {[string equal stderr $file]} {return $file}
+ if {[string equal stdout $file]} {return $file}
+ return [file join [temporaryDirectory] $file]
+ }
+
+ # output goes to stdout by default
+ Option -outfile stdout {
+ Send output from test runs to the specified file.
+ } AcceptOutFile outputFile
+ trace add variable Option(-outfile) write \
+ [namespace code {outputChannel $Option(-outfile) ;#}]
+
+ # errors go to stderr by default
+ Option -errfile stderr {
+ Send errors from test runs to the specified file.
+ } AcceptOutFile errorFile
+ trace add variable Option(-errfile) write \
+ [namespace code {errorChannel $Option(-errfile) ;#}]
+
+ proc loadIntoSlaveInterpreter {slave args} {
+ variable Version
+ interp eval $slave [package ifneeded tcltest $Version]
+ interp eval $slave "tcltest::configure {*}{$args}"
+ interp alias $slave ::tcltest::ReportToMaster \
+ {} ::tcltest::ReportedFromSlave
+ }
+ proc ReportedFromSlave {total passed skipped failed because newfiles} {
+ variable numTests
+ variable skippedBecause
+ variable createdNewFiles
+ incr numTests(Total) $total
+ incr numTests(Passed) $passed
+ incr numTests(Skipped) $skipped
+ incr numTests(Failed) $failed
+ foreach {constraint count} $because {
+ incr skippedBecause($constraint) $count
+ }
+ foreach {testfile created} $newfiles {
+ lappend createdNewFiles($testfile) {*}$created
+ }
+ return
+ }
+}
+
+#####################################################################
+
+# tcltest::Debug* --
+#
+# Internal helper procedures to write out debug information
+# dependent on the chosen level. A test shell may overide
+# them, f.e. to redirect the output into a different
+# channel, or even into a GUI.
+
+# tcltest::DebugPuts --
+#
+# Prints the specified string if the current debug level is
+# higher than the provided level argument.
+#
+# Arguments:
+# level The lowest debug level triggering the output
+# string The string to print out.
+#
+# Results:
+# Prints the string. Nothing else is allowed.
+#
+# Side Effects:
+# None.
+#
+
+proc tcltest::DebugPuts {level string} {
+ variable debug
+ if {$debug >= $level} {
+ puts $string
+ }
+ return
+}
+
+# tcltest::DebugPArray --
+#
+# Prints the contents of the specified array if the current
+# debug level is higher than the provided level argument
+#
+# Arguments:
+# level The lowest debug level triggering the output
+# arrayvar The name of the array to print out.
+#
+# Results:
+# Prints the contents of the array. Nothing else is allowed.
+#
+# Side Effects:
+# None.
+#
+
+proc tcltest::DebugPArray {level arrayvar} {
+ variable debug
+
+ if {$debug >= $level} {
+ catch {upvar 1 $arrayvar $arrayvar}
+ parray $arrayvar
+ }
+ return
+}
+
+# Define our own [parray] in ::tcltest that will inherit use of the [puts]
+# defined in ::tcltest. NOTE: Ought to construct with [info args] and
+# [info default], but can't be bothered now. If [parray] changes, then
+# this will need changing too.
+auto_load ::parray
+proc tcltest::parray {a {pattern *}} [info body ::parray]
+
+# tcltest::DebugDo --
+#
+# Executes the script if the current debug level is greater than
+# the provided level argument
+#
+# Arguments:
+# level The lowest debug level triggering the execution.
+# script The tcl script executed upon a debug level high enough.
+#
+# Results:
+# Arbitrary side effects, dependent on the executed script.
+#
+# Side Effects:
+# None.
+#
+
+proc tcltest::DebugDo {level script} {
+ variable debug
+
+ if {$debug >= $level} {
+ uplevel 1 $script
+ }
+ return
+}
+
+#####################################################################
+
+proc tcltest::Warn {msg} {
+ puts [outputChannel] "WARNING: $msg"
+}
+
+# tcltest::mainThread
+#
+# Accessor command for tcltest variable mainThread.
+#
+proc tcltest::mainThread { {new ""} } {
+ variable mainThread
+ if {[llength [info level 0]] == 1} {
+ return $mainThread
+ }
+ set mainThread $new
+}
+
+# tcltest::testConstraint --
+#
+# sets a test constraint to a value; to do multiple constraints,
+# call this proc multiple times. also returns the value of the
+# named constraint if no value was supplied.
+#
+# Arguments:
+# constraint - name of the constraint
+# value - new value for constraint (should be boolean) - if not
+# supplied, this is a query
+#
+# Results:
+# content of tcltest::testConstraints($constraint)
+#
+# Side effects:
+# none
+
+proc tcltest::testConstraint {constraint {value ""}} {
+ variable testConstraints
+ variable Option
+ DebugPuts 3 "entering testConstraint $constraint $value"
+ if {[llength [info level 0]] == 2} {
+ return $testConstraints($constraint)
+ }
+ # Check for boolean values
+ if {[catch {expr {$value && $value}} msg]} {
+ return -code error $msg
+ }
+ if {[limitConstraints] && ($constraint ni $Option(-constraints))} {
+ set value 0
+ }
+ set testConstraints($constraint) $value
+}
+
+# tcltest::interpreter --
+#
+# the interpreter name stored in tcltest::tcltest
+#
+# Arguments:
+# executable name
+#
+# Results:
+# content of tcltest::tcltest
+#
+# Side effects:
+# None.
+
+proc tcltest::interpreter { {interp ""} } {
+ variable tcltest
+ if {[llength [info level 0]] == 1} {
+ return $tcltest
+ }
+ set tcltest $interp
+}
+
+#####################################################################
+
+# tcltest::AddToSkippedBecause --
+#
+# Increments the variable used to track how many tests were
+# skipped because of a particular constraint.
+#
+# Arguments:
+# constraint The name of the constraint to be modified
+#
+# Results:
+# Modifies tcltest::skippedBecause; sets the variable to 1 if
+# didn't previously exist - otherwise, it just increments it.
+#
+# Side effects:
+# None.
+
+proc tcltest::AddToSkippedBecause { constraint {value 1}} {
+ # add the constraint to the list of constraints that kept tests
+ # from running
+ variable skippedBecause
+
+ if {[info exists skippedBecause($constraint)]} {
+ incr skippedBecause($constraint) $value
+ } else {
+ set skippedBecause($constraint) $value
+ }
+ return
+}
+
+# tcltest::PrintError --
+#
+# Prints errors to tcltest::errorChannel and then flushes that
+# channel, making sure that all messages are < 80 characters per
+# line.
+#
+# Arguments:
+# errorMsg String containing the error to be printed
+#
+# Results:
+# None.
+#
+# Side effects:
+# None.
+
+proc tcltest::PrintError {errorMsg} {
+ set InitialMessage "Error: "
+ set InitialMsgLen [string length $InitialMessage]
+ puts -nonewline [errorChannel] $InitialMessage
+
+ # Keep track of where the end of the string is.
+ set endingIndex [string length $errorMsg]
+
+ if {$endingIndex < (80 - $InitialMsgLen)} {
+ puts [errorChannel] $errorMsg
+ } else {
+ # Print up to 80 characters on the first line, including the
+ # InitialMessage.
+ set beginningIndex [string last " " [string range $errorMsg 0 \
+ [expr {80 - $InitialMsgLen}]]]
+ puts [errorChannel] [string range $errorMsg 0 $beginningIndex]
+
+ while {$beginningIndex ne "end"} {
+ puts -nonewline [errorChannel] \
+ [string repeat " " $InitialMsgLen]
+ if {($endingIndex - $beginningIndex)
+ < (80 - $InitialMsgLen)} {
+ puts [errorChannel] [string trim \
+ [string range $errorMsg $beginningIndex end]]
+ break
+ } else {
+ set newEndingIndex [expr {[string last " " \
+ [string range $errorMsg $beginningIndex \
+ [expr {$beginningIndex
+ + (80 - $InitialMsgLen)}]
+ ]] + $beginningIndex}]
+ if {($newEndingIndex <= 0)
+ || ($newEndingIndex <= $beginningIndex)} {
+ set newEndingIndex end
+ }
+ puts [errorChannel] [string trim \
+ [string range $errorMsg \
+ $beginningIndex $newEndingIndex]]
+ set beginningIndex $newEndingIndex
+ }
+ }
+ }
+ flush [errorChannel]
+ return
+}
+
+# tcltest::SafeFetch --
+#
+# The following trace procedure makes it so that we can safely
+# refer to non-existent members of the testConstraints array
+# without causing an error. Instead, reading a non-existent
+# member will return 0. This is necessary because tests are
+# allowed to use constraint "X" without ensuring that
+# testConstraints("X") is defined.
+#
+# Arguments:
+# n1 - name of the array (testConstraints)
+# n2 - array key value (constraint name)
+# op - operation performed on testConstraints (generally r)
+#
+# Results:
+# none
+#
+# Side effects:
+# sets testConstraints($n2) to 0 if it's referenced but never
+# before used
+
+proc tcltest::SafeFetch {n1 n2 op} {
+ variable testConstraints
+ DebugPuts 3 "entering SafeFetch $n1 $n2 $op"
+ if {$n2 eq {}} {return}
+ if {![info exists testConstraints($n2)]} {
+ if {[catch {testConstraint $n2 [eval [ConstraintInitializer $n2]]}]} {
+ testConstraint $n2 0
+ }
+ }
+}
+
+# tcltest::ConstraintInitializer --
+#
+# Get or set a script that when evaluated in the tcltest namespace
+# will return a boolean value with which to initialize the
+# associated constraint.
+#
+# Arguments:
+# constraint - name of the constraint initialized by the script
+# script - the initializer script
+#
+# Results
+# boolean value of the constraint - enabled or disabled
+#
+# Side effects:
+# Constraint is initialized for future reference by [test]
+proc tcltest::ConstraintInitializer {constraint {script ""}} {
+ variable ConstraintInitializer
+ DebugPuts 3 "entering ConstraintInitializer $constraint $script"
+ if {[llength [info level 0]] == 2} {
+ return $ConstraintInitializer($constraint)
+ }
+ # Check for boolean values
+ if {![info complete $script]} {
+ return -code error "ConstraintInitializer must be complete script"
+ }
+ set ConstraintInitializer($constraint) $script
+}
+
+# tcltest::InitConstraints --
+#
+# Call all registered constraint initializers to force initialization
+# of all known constraints.
+# See the tcltest man page for the list of built-in constraints defined
+# in this procedure.
+#
+# Arguments:
+# none
+#
+# Results:
+# The testConstraints array is reset to have an index for each
+# built-in test constraint.
+#
+# Side Effects:
+# None.
+#
+
+proc tcltest::InitConstraints {} {
+ variable ConstraintInitializer
+ initConstraintsHook
+ foreach constraint [array names ConstraintInitializer] {
+ testConstraint $constraint
+ }
+}
+
+proc tcltest::DefineConstraintInitializers {} {
+ ConstraintInitializer singleTestInterp {singleProcess}
+
+ # All the 'pc' constraints are here for backward compatibility and
+ # are not documented. They have been replaced with equivalent 'win'
+ # constraints.
+
+ ConstraintInitializer unixOnly \
+ {string equal $::tcl_platform(platform) unix}
+ ConstraintInitializer macOnly \
+ {string equal $::tcl_platform(platform) macintosh}
+ ConstraintInitializer pcOnly \
+ {string equal $::tcl_platform(platform) windows}
+ ConstraintInitializer winOnly \
+ {string equal $::tcl_platform(platform) windows}
+
+ ConstraintInitializer unix {testConstraint unixOnly}
+ ConstraintInitializer mac {testConstraint macOnly}
+ ConstraintInitializer pc {testConstraint pcOnly}
+ ConstraintInitializer win {testConstraint winOnly}
+
+ ConstraintInitializer unixOrPc \
+ {expr {[testConstraint unix] || [testConstraint pc]}}
+ ConstraintInitializer macOrPc \
+ {expr {[testConstraint mac] || [testConstraint pc]}}
+ ConstraintInitializer unixOrWin \
+ {expr {[testConstraint unix] || [testConstraint win]}}
+ ConstraintInitializer macOrWin \
+ {expr {[testConstraint mac] || [testConstraint win]}}
+ ConstraintInitializer macOrUnix \
+ {expr {[testConstraint mac] || [testConstraint unix]}}
+
+ ConstraintInitializer nt {string equal $::tcl_platform(os) "Windows NT"}
+ ConstraintInitializer 95 {string equal $::tcl_platform(os) "Windows 95"}
+ ConstraintInitializer 98 {string equal $::tcl_platform(os) "Windows 98"}
+
+ # The following Constraints switches are used to mark tests that
+ # should work, but have been temporarily disabled on certain
+ # platforms because they don't and we haven't gotten around to
+ # fixing the underlying problem.
+
+ ConstraintInitializer tempNotPc {expr {![testConstraint pc]}}
+ ConstraintInitializer tempNotWin {expr {![testConstraint win]}}
+ ConstraintInitializer tempNotMac {expr {![testConstraint mac]}}
+ ConstraintInitializer tempNotUnix {expr {![testConstraint unix]}}
+
+ # The following Constraints switches are used to mark tests that
+ # crash on certain platforms, so that they can be reactivated again
+ # when the underlying problem is fixed.
+
+ ConstraintInitializer pcCrash {expr {![testConstraint pc]}}
+ ConstraintInitializer winCrash {expr {![testConstraint win]}}
+ ConstraintInitializer macCrash {expr {![testConstraint mac]}}
+ ConstraintInitializer unixCrash {expr {![testConstraint unix]}}
+
+ # Skip empty tests
+
+ ConstraintInitializer emptyTest {format 0}
+
+ # By default, tests that expose known bugs are skipped.
+
+ ConstraintInitializer knownBug {format 0}
+
+ # By default, non-portable tests are skipped.
+
+ ConstraintInitializer nonPortable {format 0}
+
+ # Some tests require user interaction.
+
+ ConstraintInitializer userInteraction {format 0}
+
+ # Some tests must be skipped if the interpreter is not in
+ # interactive mode
+
+ ConstraintInitializer interactive \
+ {expr {[info exists ::tcl_interactive] && $::tcl_interactive}}
+
+ # Some tests can only be run if the installation came from a CD
+ # image instead of a web image. Some tests must be skipped if you
+ # are running as root on Unix. Other tests can only be run if you
+ # are running as root on Unix.
+
+ ConstraintInitializer root {expr \
+ {($::tcl_platform(platform) eq "unix") &&
+ ($::tcl_platform(user) in {root {}})}}
+ ConstraintInitializer notRoot {expr {![testConstraint root]}}
+
+ # Set nonBlockFiles constraint: 1 means this platform supports
+ # setting files into nonblocking mode.
+
+ ConstraintInitializer nonBlockFiles {
+ set code [expr {[catch {set f [open defs r]}]
+ || [catch {chan configure $f -blocking off}]}]
+ catch {close $f}
+ set code
+ }
+
+ # Set asyncPipeClose constraint: 1 means this platform supports
+ # async flush and async close on a pipe.
+ #
+ # Test for SCO Unix - cannot run async flushing tests because a
+ # potential problem with select is apparently interfering.
+ # (Mark Diekhans).
+
+ ConstraintInitializer asyncPipeClose {expr {
+ !([string equal unix $::tcl_platform(platform)]
+ && ([catch {exec uname -X | fgrep {Release = 3.2v}}] == 0))}}
+
+ # Test to see if we have a broken version of sprintf with respect
+ # to the "e" format of floating-point numbers.
+
+ ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05}
+
+ # Test to see if execed commands such as cat, echo, rm and so forth
+ # are present on this machine.
+
+ ConstraintInitializer unixExecs {
+ set code 1
+ if {$::tcl_platform(platform) eq "macintosh"} {
+ set code 0
+ }
+ if {$::tcl_platform(platform) eq "windows"} {
+ if {[catch {
+ set file _tcl_test_remove_me.txt
+ makeFile {hello} $file
+ }]} {
+ set code 0
+ } elseif {
+ [catch {exec cat $file}] ||
+ [catch {exec echo hello}] ||
+ [catch {exec sh -c echo hello}] ||
+ [catch {exec wc $file}] ||
+ [catch {exec sleep 1}] ||
+ [catch {exec echo abc > $file}] ||
+ [catch {exec chmod 644 $file}] ||
+ [catch {exec rm $file}] ||
+ [llength [auto_execok mkdir]] == 0 ||
+ [llength [auto_execok fgrep]] == 0 ||
+ [llength [auto_execok grep]] == 0 ||
+ [llength [auto_execok ps]] == 0
+ } {
+ set code 0
+ }
+ removeFile $file
+ }
+ set code
+ }
+
+ ConstraintInitializer stdio {
+ set code 0
+ if {![catch {set f [open "|[list [interpreter]]" w]}]} {
+ if {![catch {puts $f exit}]} {
+ if {![catch {close $f}]} {
+ set code 1
+ }
+ }
+ }
+ set code
+ }
+
+ # Deliberately call socket with the wrong number of arguments. The
+ # error message you get will indicate whether sockets are available
+ # on this system.
+
+ ConstraintInitializer socket {
+ catch {socket} msg
+ string compare $msg "sockets are not available on this system"
+ }
+
+ # Check for internationalization
+ ConstraintInitializer hasIsoLocale {
+ if {[llength [info commands testlocale]] == 0} {
+ set code 0
+ } else {
+ set code [string length [SetIso8859_1_Locale]]
+ RestoreLocale
+ }
+ set code
+ }
+
+}
+#####################################################################
+
+# Usage and command line arguments processing.
+
+# tcltest::PrintUsageInfo
+#
+# Prints out the usage information for package tcltest. This can
+# be customized with the redefinition of [PrintUsageInfoHook].
+#
+# Arguments:
+# none
+#
+# Results:
+# none
+#
+# Side Effects:
+# none
+proc tcltest::PrintUsageInfo {} {
+ puts [Usage]
+ PrintUsageInfoHook
+}
+
+proc tcltest::Usage { {option ""} } {
+ variable Usage
+ variable Verify
+ if {[llength [info level 0]] == 1} {
+ set msg "Usage: [file tail [info nameofexecutable]] script "
+ append msg "?-help? ?flag value? ... \n"
+ append msg "Available flags (and valid input values) are:"
+
+ set max 0
+ set allOpts [concat -help [Configure]]
+ foreach opt $allOpts {
+ set foo [Usage $opt]
+ lassign $foo x type($opt) usage($opt)
+ set line($opt) " $opt $type($opt) "
+ set length($opt) [string length $line($opt)]
+ if {$length($opt) > $max} {set max $length($opt)}
+ }
+ set rest [expr {72 - $max}]
+ foreach opt $allOpts {
+ append msg \n$line($opt)
+ append msg [string repeat " " [expr {$max - $length($opt)}]]
+ set u [string trim $usage($opt)]
+ catch {append u " (default: \[[Configure $opt]])"}
+ regsub -all {\s*\n\s*} $u " " u
+ while {[string length $u] > $rest} {
+ set break [string wordstart $u $rest]
+ if {$break == 0} {
+ set break [string wordend $u 0]
+ }
+ append msg [string range $u 0 [expr {$break - 1}]]
+ set u [string trim [string range $u $break end]]
+ append msg \n[string repeat " " $max]
+ }
+ append msg $u
+ }
+ return $msg\n
+ } elseif {$option eq "-help"} {
+ return [list -help "" "Display this usage information."]
+ } else {
+ set type [lindex [info args $Verify($option)] 0]
+ return [list $option $type $Usage($option)]
+ }
+}
+
+# tcltest::ProcessFlags --
+#
+# process command line arguments supplied in the flagArray - this
+# is called by processCmdLineArgs. Modifies tcltest variables
+# according to the content of the flagArray.
+#
+# Arguments:
+# flagArray - array containing name/value pairs of flags
+#
+# Results:
+# sets tcltest variables according to their values as defined by
+# flagArray
+#
+# Side effects:
+# None.
+
+proc tcltest::ProcessFlags {flagArray} {
+ # Process -help first
+ if {"-help" in $flagArray} {
+ PrintUsageInfo
+ exit 1
+ }
+
+ if {[llength $flagArray] == 0} {
+ RemoveAutoConfigureTraces
+ } else {
+ set args $flagArray
+ while {[llength $args] > 1 && [catch {configure {*}$args} msg]} {
+
+ # Something went wrong parsing $args for tcltest options
+ # Check whether the problem is "unknown option"
+ if {[regexp {^unknown option (\S+):} $msg -> option]} {
+ # Could be this is an option the Hook knows about
+ set moreOptions [processCmdLineArgsAddFlagsHook]
+ if {$option ni $moreOptions} {
+ # Nope. Report the error, including additional options,
+ # but keep going
+ if {[llength $moreOptions]} {
+ append msg ", "
+ append msg [join [lrange $moreOptions 0 end-1] ", "]
+ append msg "or [lindex $moreOptions end]"
+ }
+ Warn $msg
+ }
+ } else {
+ # error is something other than "unknown option"
+ # notify user of the error; and exit
+ puts [errorChannel] $msg
+ exit 1
+ }
+
+ # To recover, find that unknown option and remove up to it.
+ # then retry
+ while {[lindex $args 0] ne $option} {
+ set args [lrange $args 2 end]
+ }
+ set args [lrange $args 2 end]
+ }
+ if {[llength $args] == 1} {
+ puts [errorChannel] \
+ "missing value for option [lindex $args 0]"
+ exit 1
+ }
+ }
+
+ # Call the hook
+ catch {
+ array set flag $flagArray
+ processCmdLineArgsHook [array get flag]
+ }
+ return
+}
+
+# tcltest::ProcessCmdLineArgs --
+#
+# This procedure must be run after constraint initialization is
+# set up (by [DefineConstraintInitializers]) because some constraints
+# can be overridden.
+#
+# Perform configuration according to the command-line options.
+#
+# Arguments:
+# none
+#
+# Results:
+# Sets the above-named variables in the tcltest namespace.
+#
+# Side Effects:
+# None.
+#
+
+proc tcltest::ProcessCmdLineArgs {} {
+ variable originalEnv
+ variable testConstraints
+
+ # The "argv" var doesn't exist in some cases, so use {}.
+ if {![info exists ::argv]} {
+ ProcessFlags {}
+ } else {
+ ProcessFlags $::argv
+ }
+
+ # Spit out everything you know if we're at a debug level 2 or
+ # greater
+ DebugPuts 2 "Flags passed into tcltest:"
+ if {[info exists ::env(TCLTEST_OPTIONS)]} {
+ DebugPuts 2 \
+ " ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)"
+ }
+ if {[info exists ::argv]} {
+ DebugPuts 2 " argv: $::argv"
+ }
+ DebugPuts 2 "tcltest::debug = [debug]"
+ DebugPuts 2 "tcltest::testsDirectory = [testsDirectory]"
+ DebugPuts 2 "tcltest::workingDirectory = [workingDirectory]"
+ DebugPuts 2 "tcltest::temporaryDirectory = [temporaryDirectory]"
+ DebugPuts 2 "tcltest::outputChannel = [outputChannel]"
+ DebugPuts 2 "tcltest::errorChannel = [errorChannel]"
+ DebugPuts 2 "Original environment (tcltest::originalEnv):"
+ DebugPArray 2 originalEnv
+ DebugPuts 2 "Constraints:"
+ DebugPArray 2 testConstraints
+}
+
+#####################################################################
+
+# Code to run the tests goes here.
+
+# tcltest::TestPuts --
+#
+# Used to redefine puts in test environment. Stores whatever goes
+# out on stdout in tcltest::outData and stderr in errData before
+# sending it on to the regular puts.
+#
+# Arguments:
+# same as standard puts
+#
+# Results:
+# none
+#
+# Side effects:
+# Intercepts puts; data that would otherwise go to stdout, stderr,
+# or file channels specified in outputChannel and errorChannel
+# does not get sent to the normal puts function.
+namespace eval tcltest::Replace {
+ namespace export puts
+}
+proc tcltest::Replace::puts {args} {
+ variable [namespace parent]::outData
+ variable [namespace parent]::errData
+ switch [llength $args] {
+ 1 {
+ # Only the string to be printed is specified
+ append outData [lindex $args 0]\n
+ return
+ # return [Puts [lindex $args 0]]
+ }
+ 2 {
+ # Either -nonewline or channelId has been specified
+ if {[lindex $args 0] eq "-nonewline"} {
+ append outData [lindex $args end]
+ return
+ # return [Puts -nonewline [lindex $args end]]
+ } else {
+ set channel [lindex $args 0]
+ set newline \n
+ }
+ }
+ 3 {
+ if {[lindex $args 0] eq "-nonewline"} {
+ # Both -nonewline and channelId are specified, unless
+ # it's an error. -nonewline is supposed to be argv[0].
+ set channel [lindex $args 1]
+ set newline ""
+ }
+ }
+ }
+
+ if {[info exists channel]} {
+ if {$channel in [list [[namespace parent]::outputChannel] stdout]} {
+ append outData [lindex $args end]$newline
+ return
+ } elseif {$channel in [list [[namespace parent]::errorChannel] stderr]} {
+ append errData [lindex $args end]$newline
+ return
+ }
+ }
+
+ # If we haven't returned by now, we don't know how to handle the
+ # input. Let puts handle it.
+ return [Puts {*}$args]
+}
+
+# tcltest::Eval --
+#
+# Evaluate the script in the test environment. If ignoreOutput is
+# false, store data sent to stderr and stdout in outData and
+# errData. Otherwise, ignore this output altogether.
+#
+# Arguments:
+# script Script to evaluate
+# ?ignoreOutput? Indicates whether or not to ignore output
+# sent to stdout & stderr
+#
+# Results:
+# result from running the script
+#
+# Side effects:
+# Empties the contents of outData and errData before running a
+# test if ignoreOutput is set to 0.
+
+proc tcltest::Eval {script {ignoreOutput 1}} {
+ variable outData
+ variable errData
+ DebugPuts 3 "[lindex [info level 0] 0] called"
+ if {!$ignoreOutput} {
+ set outData {}
+ set errData {}
+ rename ::puts [namespace current]::Replace::Puts
+ namespace eval :: [list namespace import [namespace origin Replace::puts]]
+ namespace import Replace::puts
+ }
+ set result [uplevel 1 $script]
+ if {!$ignoreOutput} {
+ namespace forget puts
+ namespace eval :: namespace forget puts
+ rename [namespace current]::Replace::Puts ::puts
+ }
+ return $result
+}
+
+# tcltest::CompareStrings --
+#
+# compares the expected answer to the actual answer, depending on
+# the mode provided. Mode determines whether a regexp, exact,
+# glob or custom comparison is done.
+#
+# Arguments:
+# actual - string containing the actual result
+# expected - pattern to be matched against
+# mode - type of comparison to be done
+#
+# Results:
+# result of the match
+#
+# Side effects:
+# None.
+
+proc tcltest::CompareStrings {actual expected mode} {
+ variable CustomMatch
+ if {![info exists CustomMatch($mode)]} {
+ return -code error "No matching command registered for `-match $mode'"
+ }
+ set match [namespace eval :: $CustomMatch($mode) [list $expected $actual]]
+ if {[catch {expr {$match && $match}} result]} {
+ return -code error "Invalid result from `-match $mode' command: $result"
+ }
+ return $match
+}
+
+# tcltest::customMatch --
+#
+# registers a command to be called when a particular type of
+# matching is required.
+#
+# Arguments:
+# nickname - Keyword for the type of matching
+# cmd - Incomplete command that implements that type of matching
+# when completed with expected string and actual string
+# and then evaluated.
+#
+# Results:
+# None.
+#
+# Side effects:
+# Sets the variable tcltest::CustomMatch
+
+proc tcltest::customMatch {mode script} {
+ variable CustomMatch
+ if {![info complete $script]} {
+ return -code error \
+ "invalid customMatch script; can't evaluate after completion"
+ }
+ set CustomMatch($mode) $script
+}
+
+# tcltest::SubstArguments list
+#
+# This helper function takes in a list of words, then perform a
+# substitution on the list as though each word in the list is a separate
+# argument to the Tcl function. For example, if this function is
+# invoked as:
+#
+# SubstArguments {$a {$a}}
+#
+# Then it is as though the function is invoked as:
+#
+# SubstArguments $a {$a}
+#
+# This code is adapted from Paul Duffin's function "SplitIntoWords".
+# The original function can be found on:
+#
+# http://purl.org/thecliff/tcl/wiki/858.html
+#
+# Results:
+# a list containing the result of the substitution
+#
+# Exceptions:
+# An error may occur if the list containing unbalanced quote or
+# unknown variable.
+#
+# Side Effects:
+# None.
+#
+
+proc tcltest::SubstArguments {argList} {
+
+ # We need to split the argList up into tokens but cannot use list
+ # operations as they throw away some significant quoting, and
+ # [split] ignores braces as it should. Therefore what we do is
+ # gradually build up a string out of whitespace seperated strings.
+ # We cannot use [split] to split the argList into whitespace
+ # separated strings as it throws away the whitespace which maybe
+ # important so we have to do it all by hand.
+
+ set result {}
+ set token ""
+
+ while {[string length $argList]} {
+ # Look for the next word containing a quote: " { }
+ if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \
+ $argList all]} {
+ # Get the text leading up to this word, but not including
+ # this word, from the argList.
+ set text [string range $argList 0 \
+ [expr {[lindex $all 0] - 1}]]
+ # Get the word with the quote
+ set word [string range $argList \
+ [lindex $all 0] [lindex $all 1]]
+
+ # Remove all text up to and including the word from the
+ # argList.
+ set argList [string range $argList \
+ [expr {[lindex $all 1] + 1}] end]
+ } else {
+ # Take everything up to the end of the argList.
+ set text $argList
+ set word {}
+ set argList {}
+ }
+
+ if {$token ne {}} {
+ # If we saw a word with quote before, then there is a
+ # multi-word token starting with that word. In this case,
+ # add the text and the current word to this token.
+ append token $text $word
+ } else {
+ # Add the text to the result. There is no need to parse
+ # the text because it couldn't be a part of any multi-word
+ # token. Then start a new multi-word token with the word
+ # because we need to pass this token to the Tcl parser to
+ # check for balancing quotes
+ append result $text
+ set token $word
+ }
+
+ if { [catch {llength $token} length] == 0 && $length == 1} {
+ # The token is a valid list so add it to the result.
+ # lappend result [string trim $token]
+ append result \{$token\}
+ set token {}
+ }
+ }
+
+ # If the last token has not been added to the list then there
+ # is a problem.
+ if { [string length $token] } {
+ error "incomplete token \"$token\""
+ }
+
+ return $result
+}
+
+
+# tcltest::test --
+#
+# This procedure runs a test and prints an error message if the test
+# fails. If verbose has been set, it also prints a message even if the
+# test succeeds. The test will be skipped if it doesn't match the
+# match variable, if it matches an element in skip, or if one of the
+# elements of "constraints" turns out not to be true.
+#
+# If testLevel is 1, then this is a top level test, and we record
+# pass/fail information; otherwise, this information is not logged and
+# is not added to running totals.
+#
+# Attributes:
+# Only description is a required attribute. All others are optional.
+# Default values are indicated.
+#
+# constraints - A list of one or more keywords, each of which
+# must be the name of an element in the array
+# "testConstraints". If any of these elements is
+# zero, the test is skipped. This attribute is
+# optional; default is {}
+# body - Script to run to carry out the test. It must
+# return a result that can be checked for
+# correctness. This attribute is optional;
+# default is {}
+# result - Expected result from script. This attribute is
+# optional; default is {}.
+# output - Expected output sent to stdout. This attribute
+# is optional; default is {}.
+# errorOutput - Expected output sent to stderr. This attribute
+# is optional; default is {}.
+# returnCodes - Expected return codes. This attribute is
+# optional; default is {0 2}.
+# errorCode - Expected error code. This attribute is
+# optional; default is {*}. It is a glob pattern.
+# If given, returnCodes defaults to {1}.
+# setup - Code to run before $script (above). This
+# attribute is optional; default is {}.
+# cleanup - Code to run after $script (above). This
+# attribute is optional; default is {}.
+# match - specifies type of matching to do on result,
+# output, errorOutput; this must be a string
+# previously registered by a call to [customMatch].
+# The strings exact, glob, and regexp are pre-registered
+# by the tcltest package. Default value is exact.
+#
+# Arguments:
+# name - Name of test, in the form foo-1.2.
+# description - Short textual description of the test, to
+# help humans understand what it does.
+#
+# Results:
+# None.
+#
+# Side effects:
+# Just about anything is possible depending on the test.
+#
+
+proc tcltest::test {name description args} {
+ global tcl_platform
+ variable testLevel
+ variable coreModTime
+ DebugPuts 3 "test $name $args"
+ DebugDo 1 {
+ variable TestNames
+ catch {
+ puts "test name '$name' re-used; prior use in $TestNames($name)"
+ }
+ set TestNames($name) [info script]
+ }
+
+ FillFilesExisted
+ incr testLevel
+
+ # Pre-define everything to null except output and errorOutput. We
+ # determine whether or not to trap output based on whether or not
+ # these variables (output & errorOutput) are defined.
+ lassign {} constraints setup cleanup body result returnCodes errorCode match
+
+ # Set the default match mode
+ set match exact
+
+ # Set the default match values for return codes (0 is the standard
+ # expected return value if everything went well; 2 represents
+ # 'return' being used in the test script).
+ set returnCodes [list 0 2]
+
+ # Set the default error code pattern
+ set errorCode "*"
+
+ # The old test format can't have a 3rd argument (constraints or
+ # script) that starts with '-'.
+ if {[string match -* [lindex $args 0]] || ([llength $args] <= 1)} {
+ if {[llength $args] == 1} {
+ set list [SubstArguments [lindex $args 0]]
+ foreach {element value} $list {
+ set testAttributes($element) $value
+ }
+ foreach item {constraints match setup body cleanup \
+ result returnCodes errorCode output errorOutput} {
+ if {[info exists testAttributes(-$item)]} {
+ set testAttributes(-$item) [uplevel 1 \
+ ::concat $testAttributes(-$item)]
+ }
+ }
+ } else {
+ array set testAttributes $args
+ }
+
+ set validFlags {-setup -cleanup -body -result -returnCodes \
+ -errorCode -match -output -errorOutput -constraints}
+
+ foreach flag [array names testAttributes] {
+ if {$flag ni $validFlags} {
+ incr testLevel -1
+ set sorted [lsort $validFlags]
+ set options [join [lrange $sorted 0 end-1] ", "]
+ append options ", or [lindex $sorted end]"
+ return -code error "bad option \"$flag\": must be $options"
+ }
+ }
+
+ # store whatever the user gave us
+ foreach item [array names testAttributes] {
+ set [string trimleft $item "-"] $testAttributes($item)
+ }
+
+ # Check the values supplied for -match
+ variable CustomMatch
+ if {$match ni [array names CustomMatch]} {
+ incr testLevel -1
+ set sorted [lsort [array names CustomMatch]]
+ set values [join [lrange $sorted 0 end-1] ", "]
+ append values ", or [lindex $sorted end]"
+ return -code error "bad -match value \"$match\":\
+ must be $values"
+ }
+
+ # Replace symbolic valies supplied for -returnCodes
+ foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} {
+ set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes]
+ }
+ # errorCode without returnCode 1 is meaningless
+ if {$errorCode ne "*" && 1 ni $returnCodes} {
+ set returnCodes 1
+ }
+ } else {
+ # This is parsing for the old test command format; it is here
+ # for backward compatibility.
+ set result [lindex $args end]
+ if {[llength $args] == 2} {
+ set body [lindex $args 0]
+ } elseif {[llength $args] == 3} {
+ set constraints [lindex $args 0]
+ set body [lindex $args 1]
+ } else {
+ incr testLevel -1
+ return -code error "wrong # args:\
+ should be \"test name desc ?options?\""
+ }
+ }
+
+ if {[Skipped $name $constraints]} {
+ incr testLevel -1
+ return
+ }
+
+ # Save information about the core file.
+ if {[preserveCore]} {
+ if {[file exists [file join [workingDirectory] core]]} {
+ set coreModTime [file mtime [file join [workingDirectory] core]]
+ }
+ }
+
+ # First, run the setup script
+ set code [catch {uplevel 1 $setup} setupMsg]
+ if {$code == 1} {
+ set errorInfo(setup) $::errorInfo
+ set errorCodeRes(setup) $::errorCode
+ }
+ set setupFailure [expr {$code != 0}]
+
+ # Only run the test body if the setup was successful
+ if {!$setupFailure} {
+
+ # Register startup time
+ if {[IsVerbose msec] || [IsVerbose usec]} {
+ set timeStart [clock microseconds]
+ }
+
+ # Verbose notification of $body start
+ if {[IsVerbose start]} {
+ puts [outputChannel] "---- $name start"
+ flush [outputChannel]
+ }
+
+ set command [list [namespace origin RunTest] $name $body]
+ if {[info exists output] || [info exists errorOutput]} {
+ set testResult [uplevel 1 [list [namespace origin Eval] $command 0]]
+ } else {
+ set testResult [uplevel 1 [list [namespace origin Eval] $command 1]]
+ }
+ lassign $testResult actualAnswer returnCode
+ if {$returnCode == 1} {
+ set errorInfo(body) $::errorInfo
+ set errorCodeRes(body) $::errorCode
+ }
+ }
+
+ # check if the return code matched the expected return code
+ set codeFailure 0
+ if {!$setupFailure && ($returnCode ni $returnCodes)} {
+ set codeFailure 1
+ }
+ set errorCodeFailure 0
+ if {!$setupFailure && !$codeFailure && $returnCode == 1 && \
+ ![string match $errorCode $errorCodeRes(body)]} {
+ set errorCodeFailure 1
+ }
+
+ # If expected output/error strings exist, we have to compare
+ # them. If the comparison fails, then so did the test.
+ set outputFailure 0
+ variable outData
+ if {[info exists output] && !$codeFailure} {
+ if {[set outputCompare [catch {
+ CompareStrings $outData $output $match
+ } outputMatch]] == 0} {
+ set outputFailure [expr {!$outputMatch}]
+ } else {
+ set outputFailure 1
+ }
+ }
+
+ set errorFailure 0
+ variable errData
+ if {[info exists errorOutput] && !$codeFailure} {
+ if {[set errorCompare [catch {
+ CompareStrings $errData $errorOutput $match
+ } errorMatch]] == 0} {
+ set errorFailure [expr {!$errorMatch}]
+ } else {
+ set errorFailure 1
+ }
+ }
+
+ # check if the answer matched the expected answer
+ # Only check if we ran the body of the test (no setup failure)
+ if {$setupFailure || $codeFailure} {
+ set scriptFailure 0
+ } elseif {[set scriptCompare [catch {
+ CompareStrings $actualAnswer $result $match
+ } scriptMatch]] == 0} {
+ set scriptFailure [expr {!$scriptMatch}]
+ } else {
+ set scriptFailure 1
+ }
+
+ # Always run the cleanup script
+ set code [catch {uplevel 1 $cleanup} cleanupMsg]
+ if {$code == 1} {
+ set errorInfo(cleanup) $::errorInfo
+ set errorCodeRes(cleanup) $::errorCode
+ }
+ set cleanupFailure [expr {$code != 0}]
+
+ set coreFailure 0
+ set coreMsg ""
+ # check for a core file first - if one was created by the test,
+ # then the test failed
+ if {[preserveCore]} {
+ if {[file exists [file join [workingDirectory] core]]} {
+ # There's only a test failure if there is a core file
+ # and (1) there previously wasn't one or (2) the new
+ # one is different from the old one.
+ if {[info exists coreModTime]} {
+ if {$coreModTime != [file mtime \
+ [file join [workingDirectory] core]]} {
+ set coreFailure 1
+ }
+ } else {
+ set coreFailure 1
+ }
+
+ if {([preserveCore] > 1) && ($coreFailure)} {
+ append coreMsg "\nMoving file to:\
+ [file join [temporaryDirectory] core-$name]"
+ catch {file rename -force -- \
+ [file join [workingDirectory] core] \
+ [file join [temporaryDirectory] core-$name]
+ } msg
+ if {$msg ne {}} {
+ append coreMsg "\nError:\
+ Problem renaming core file: $msg"
+ }
+ }
+ }
+ }
+
+ if {[IsVerbose msec] || [IsVerbose usec]} {
+ set t [expr {[clock microseconds] - $timeStart}]
+ if {[IsVerbose usec]} {
+ puts [outputChannel] "++++ $name took $t μs"
+ }
+ if {[IsVerbose msec]} {
+ puts [outputChannel] "++++ $name took [expr {round($t/1000.)}] ms"
+ }
+ }
+
+ # if we didn't experience any failures, then we passed
+ variable numTests
+ if {!($setupFailure || $cleanupFailure || $coreFailure
+ || $outputFailure || $errorFailure || $codeFailure
+ || $errorCodeFailure || $scriptFailure)} {
+ if {$testLevel == 1} {
+ incr numTests(Passed)
+ if {[IsVerbose pass]} {
+ puts [outputChannel] "++++ $name PASSED"
+ }
+ }
+ incr testLevel -1
+ return
+ }
+
+ # We know the test failed, tally it...
+ if {$testLevel == 1} {
+ incr numTests(Failed)
+ }
+
+ # ... then report according to the type of failure
+ variable currentFailure true
+ if {![IsVerbose body]} {
+ set body ""
+ }
+ puts [outputChannel] "\n"
+ if {[IsVerbose line]} {
+ if {![catch {set testFrame [info frame -1]}] &&
+ [dict get $testFrame type] eq "source"} {
+ set testFile [dict get $testFrame file]
+ set testLine [dict get $testFrame line]
+ } else {
+ set testFile [file normalize [uplevel 1 {info script}]]
+ if {[file readable $testFile]} {
+ set testFd [open $testFile r]
+ set testLine [expr {[lsearch -regexp \
+ [split [read $testFd] "\n"] \
+ "^\[ \t\]*test [string map {. \\.} $name] "] + 1}]
+ close $testFd
+ }
+ }
+ if {[info exists testLine]} {
+ puts [outputChannel] "$testFile:$testLine: error: test failed:\
+ $name [string trim $description]"
+ }
+ }
+ puts [outputChannel] "==== $name\
+ [string trim $description] FAILED"
+ if {[string length $body]} {
+ puts [outputChannel] "==== Contents of test case:"
+ puts [outputChannel] $body
+ }
+ if {$setupFailure} {
+ puts [outputChannel] "---- Test setup\
+ failed:\n$setupMsg"
+ if {[info exists errorInfo(setup)]} {
+ puts [outputChannel] "---- errorInfo(setup): $errorInfo(setup)"
+ puts [outputChannel] "---- errorCode(setup): $errorCodeRes(setup)"
+ }
+ }
+ if {$scriptFailure} {
+ if {$scriptCompare} {
+ puts [outputChannel] "---- Error testing result: $scriptMatch"
+ } else {
+ puts [outputChannel] "---- Result was:\n$actualAnswer"
+ puts [outputChannel] "---- Result should have been\
+ ($match matching):\n$result"
+ }
+ }
+ if {$errorCodeFailure} {
+ puts [outputChannel] "---- Error code was: '$errorCodeRes(body)'"
+ puts [outputChannel] "---- Error code should have been: '$errorCode'"
+ }
+ if {$codeFailure} {
+ switch -- $returnCode {
+ 0 { set msg "Test completed normally" }
+ 1 { set msg "Test generated error" }
+ 2 { set msg "Test generated return exception" }
+ 3 { set msg "Test generated break exception" }
+ 4 { set msg "Test generated continue exception" }
+ default { set msg "Test generated exception" }
+ }
+ puts [outputChannel] "---- $msg; Return code was: $returnCode"
+ puts [outputChannel] "---- Return code should have been\
+ one of: $returnCodes"
+ if {[IsVerbose error]} {
+ if {[info exists errorInfo(body)] && (1 ni $returnCodes)} {
+ puts [outputChannel] "---- errorInfo: $errorInfo(body)"
+ puts [outputChannel] "---- errorCode: $errorCodeRes(body)"
+ }
+ }
+ }
+ if {$outputFailure} {
+ if {$outputCompare} {
+ puts [outputChannel] "---- Error testing output: $outputMatch"
+ } else {
+ puts [outputChannel] "---- Output was:\n$outData"
+ puts [outputChannel] "---- Output should have been\
+ ($match matching):\n$output"
+ }
+ }
+ if {$errorFailure} {
+ if {$errorCompare} {
+ puts [outputChannel] "---- Error testing errorOutput: $errorMatch"
+ } else {
+ puts [outputChannel] "---- Error output was:\n$errData"
+ puts [outputChannel] "---- Error output should have\
+ been ($match matching):\n$errorOutput"
+ }
+ }
+ if {$cleanupFailure} {
+ puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg"
+ if {[info exists errorInfo(cleanup)]} {
+ puts [outputChannel] "---- errorInfo(cleanup): $errorInfo(cleanup)"
+ puts [outputChannel] "---- errorCode(cleanup): $errorCodeRes(cleanup)"
+ }
+ }
+ if {$coreFailure} {
+ puts [outputChannel] "---- Core file produced while running\
+ test! $coreMsg"
+ }
+ puts [outputChannel] "==== $name FAILED\n"
+
+ incr testLevel -1
+ return
+}
+
+# Skipped --
+#
+# Given a test name and it constraints, returns a boolean indicating
+# whether the current configuration says the test should be skipped.
+#
+# Side Effects: Maintains tally of total tests seen and tests skipped.
+#
+proc tcltest::Skipped {name constraints} {
+ variable testLevel
+ variable numTests
+ variable testConstraints
+
+ if {$testLevel == 1} {
+ incr numTests(Total)
+ }
+ # skip the test if it's name matches an element of skip
+ foreach pattern [skip] {
+ if {[string match $pattern $name]} {
+ if {$testLevel == 1} {
+ incr numTests(Skipped)
+ DebugDo 1 {AddToSkippedBecause userSpecifiedSkip}
+ }
+ return 1
+ }
+ }
+ # skip the test if it's name doesn't match any element of match
+ set ok 0
+ foreach pattern [match] {
+ if {[string match $pattern $name]} {
+ set ok 1
+ break
+ }
+ }
+ if {!$ok} {
+ if {$testLevel == 1} {
+ incr numTests(Skipped)
+ DebugDo 1 {AddToSkippedBecause userSpecifiedNonMatch}
+ }
+ return 1
+ }
+ if {$constraints eq {}} {
+ # If we're limited to the listed constraints and there aren't
+ # any listed, then we shouldn't run the test.
+ if {[limitConstraints]} {
+ AddToSkippedBecause userSpecifiedLimitConstraint
+ if {$testLevel == 1} {
+ incr numTests(Skipped)
+ }
+ return 1
+ }
+ } else {
+ # "constraints" argument exists;
+ # make sure that the constraints are satisfied.
+
+ set doTest 0
+ if {[string match {*[$\[]*} $constraints] != 0} {
+ # full expression, e.g. {$foo > [info tclversion]}
+ catch {set doTest [uplevel #0 [list expr $constraints]]}
+ } elseif {[regexp {[^.:_a-zA-Z0-9 \n\r\t]+} $constraints] != 0} {
+ # something like {a || b} should be turned into
+ # $testConstraints(a) || $testConstraints(b).
+ regsub -all {[.\w]+} $constraints {$testConstraints(&)} c
+ catch {set doTest [eval [list expr $c]]}
+ } elseif {![catch {llength $constraints}]} {
+ # just simple constraints such as {unixOnly fonts}.
+ set doTest 1
+ foreach constraint $constraints {
+ if {(![info exists testConstraints($constraint)]) \
+ || (!$testConstraints($constraint))} {
+ set doTest 0
+
+ # store the constraint that kept the test from
+ # running
+ set constraints $constraint
+ break
+ }
+ }
+ }
+
+ if {!$doTest} {
+ if {[IsVerbose skip]} {
+ puts [outputChannel] "++++ $name SKIPPED: $constraints"
+ }
+
+ if {$testLevel == 1} {
+ incr numTests(Skipped)
+ AddToSkippedBecause $constraints
+ }
+ return 1
+ }
+ }
+ return 0
+}
+
+# RunTest --
+#
+# This is where the body of a test is evaluated. The combination of
+# [RunTest] and [Eval] allows the output and error output of the test
+# body to be captured for comparison against the expected values.
+
+proc tcltest::RunTest {name script} {
+ DebugPuts 3 "Running $name {$script}"
+
+ # If there is no "memory" command (because memory debugging isn't
+ # enabled), then don't attempt to use the command.
+
+ if {[llength [info commands memory]] == 1} {
+ memory tag $name
+ }
+
+ set code [catch {uplevel 1 $script} actualAnswer]
+
+ return [list $actualAnswer $code]
+}
+
+#####################################################################
+
+# tcltest::cleanupTestsHook --
+#
+# This hook allows a harness that builds upon tcltest to specify
+# additional things that should be done at cleanup.
+#
+
+if {[llength [info commands tcltest::cleanupTestsHook]] == 0} {
+ proc tcltest::cleanupTestsHook {} {}
+}
+
+# tcltest::cleanupTests --
+#
+# Remove files and dirs created using the makeFile and makeDirectory
+# commands since the last time this proc was invoked.
+#
+# Print the names of the files created without the makeFile command
+# since the tests were invoked.
+#
+# Print the number tests (total, passed, failed, and skipped) since the
+# tests were invoked.
+#
+# Restore original environment (as reported by special variable env).
+#
+# Arguments:
+# calledFromAllFile - if 0, behave as if we are running a single
+# test file within an entire suite of tests. if we aren't running
+# a single test file, then don't report status. check for new
+# files created during the test run and report on them. if 1,
+# report collated status from all the test file runs.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# None
+#
+
+proc tcltest::cleanupTests {{calledFromAllFile 0}} {
+ variable filesMade
+ variable filesExisted
+ variable createdNewFiles
+ variable testSingleFile
+ variable numTests
+ variable numTestFiles
+ variable failFiles
+ variable skippedBecause
+ variable currentFailure
+ variable originalEnv
+ variable originalTclPlatform
+ variable coreModTime
+
+ FillFilesExisted
+ set testFileName [file tail [info script]]
+
+ # Hook to handle reporting to a parent interpreter
+ if {[llength [info commands [namespace current]::ReportToMaster]]} {
+ ReportToMaster $numTests(Total) $numTests(Passed) $numTests(Skipped) \
+ $numTests(Failed) [array get skippedBecause] \
+ [array get createdNewFiles]
+ set testSingleFile false
+ }
+
+ # Call the cleanup hook
+ cleanupTestsHook
+
+ # Remove files and directories created by the makeFile and
+ # makeDirectory procedures. Record the names of files in
+ # workingDirectory that were not pre-existing, and associate them
+ # with the test file that created them.
+
+ if {!$calledFromAllFile} {
+ foreach file $filesMade {
+ if {[file exists $file]} {
+ DebugDo 1 {Warn "cleanupTests deleting $file..."}
+ catch {file delete -force -- $file}
+ }
+ }
+ set currentFiles {}
+ foreach file [glob -nocomplain \
+ -directory [temporaryDirectory] *] {
+ lappend currentFiles [file tail $file]
+ }
+ set newFiles {}
+ foreach file $currentFiles {
+ if {$file ni $filesExisted} {
+ lappend newFiles $file
+ }
+ }
+ set filesExisted $currentFiles
+ if {[llength $newFiles] > 0} {
+ set createdNewFiles($testFileName) $newFiles
+ }
+ }
+
+ if {$calledFromAllFile || $testSingleFile} {
+
+ # print stats
+
+ puts -nonewline [outputChannel] "$testFileName:"
+ foreach index [list "Total" "Passed" "Skipped" "Failed"] {
+ puts -nonewline [outputChannel] \
+ "\t$index\t$numTests($index)"
+ }
+ puts [outputChannel] ""
+
+ # print number test files sourced
+ # print names of files that ran tests which failed
+
+ if {$calledFromAllFile} {
+ puts [outputChannel] \
+ "Sourced $numTestFiles Test Files."
+ set numTestFiles 0
+ if {[llength $failFiles] > 0} {
+ puts [outputChannel] \
+ "Files with failing tests: $failFiles"
+ set failFiles {}
+ }
+ }
+
+ # if any tests were skipped, print the constraints that kept
+ # them from running.
+
+ set constraintList [array names skippedBecause]
+ if {[llength $constraintList] > 0} {
+ puts [outputChannel] \
+ "Number of tests skipped for each constraint:"
+ foreach constraint [lsort $constraintList] {
+ puts [outputChannel] \
+ "\t$skippedBecause($constraint)\t$constraint"
+ unset skippedBecause($constraint)
+ }
+ }
+
+ # report the names of test files in createdNewFiles, and reset
+ # the array to be empty.
+
+ set testFilesThatTurded [lsort [array names createdNewFiles]]
+ if {[llength $testFilesThatTurded] > 0} {
+ puts [outputChannel] "Warning: files left behind:"
+ foreach testFile $testFilesThatTurded {
+ puts [outputChannel] \
+ "\t$testFile:\t$createdNewFiles($testFile)"
+ unset createdNewFiles($testFile)
+ }
+ }
+
+ # reset filesMade, filesExisted, and numTests
+
+ set filesMade {}
+ foreach index [list "Total" "Passed" "Skipped" "Failed"] {
+ set numTests($index) 0
+ }
+
+ # exit only if running Tk in non-interactive mode
+ # This should be changed to determine if an event
+ # loop is running, which is the real issue.
+ # Actually, this doesn't belong here at all. A package
+ # really has no business [exit]-ing an application.
+ if {![catch {package present Tk}] && ![testConstraint interactive]} {
+ exit
+ }
+ } else {
+
+ # if we're deferring stat-reporting until all files are sourced,
+ # then add current file to failFile list if any tests in this
+ # file failed
+
+ if {$currentFailure && ($testFileName ni $failFiles)} {
+ lappend failFiles $testFileName
+ }
+ set currentFailure false
+
+ # restore the environment to the state it was in before this package
+ # was loaded
+
+ set newEnv {}
+ set changedEnv {}
+ set removedEnv {}
+ foreach index [array names ::env] {
+ if {![info exists originalEnv($index)]} {
+ lappend newEnv $index
+ unset ::env($index)
+ }
+ }
+ foreach index [array names originalEnv] {
+ if {![info exists ::env($index)]} {
+ lappend removedEnv $index
+ set ::env($index) $originalEnv($index)
+ } elseif {$::env($index) ne $originalEnv($index)} {
+ lappend changedEnv $index
+ set ::env($index) $originalEnv($index)
+ }
+ }
+ if {[llength $newEnv] > 0} {
+ puts [outputChannel] \
+ "env array elements created:\t$newEnv"
+ }
+ if {[llength $changedEnv] > 0} {
+ puts [outputChannel] \
+ "env array elements changed:\t$changedEnv"
+ }
+ if {[llength $removedEnv] > 0} {
+ puts [outputChannel] \
+ "env array elements removed:\t$removedEnv"
+ }
+
+ set changedTclPlatform {}
+ foreach index [array names originalTclPlatform] {
+ if {$::tcl_platform($index) \
+ != $originalTclPlatform($index)} {
+ lappend changedTclPlatform $index
+ set ::tcl_platform($index) $originalTclPlatform($index)
+ }
+ }
+ if {[llength $changedTclPlatform] > 0} {
+ puts [outputChannel] "tcl_platform array elements\
+ changed:\t$changedTclPlatform"
+ }
+
+ if {[file exists [file join [workingDirectory] core]]} {
+ if {[preserveCore] > 1} {
+ puts "rename core file (> 1)"
+ puts [outputChannel] "produced core file! \
+ Moving file to: \
+ [file join [temporaryDirectory] core-$testFileName]"
+ catch {file rename -force -- \
+ [file join [workingDirectory] core] \
+ [file join [temporaryDirectory] core-$testFileName]
+ } msg
+ if {$msg ne {}} {
+ PrintError "Problem renaming file: $msg"
+ }
+ } else {
+ # Print a message if there is a core file and (1) there
+ # previously wasn't one or (2) the new one is different
+ # from the old one.
+
+ if {[info exists coreModTime]} {
+ if {$coreModTime != [file mtime \
+ [file join [workingDirectory] core]]} {
+ puts [outputChannel] "A core file was created!"
+ }
+ } else {
+ puts [outputChannel] "A core file was created!"
+ }
+ }
+ }
+ }
+ flush [outputChannel]
+ flush [errorChannel]
+ return
+}
+
+#####################################################################
+
+# Procs that determine which tests/test files to run
+
+# tcltest::GetMatchingFiles
+#
+# Looks at the patterns given to match and skip files and uses
+# them to put together a list of the tests that will be run.
+#
+# Arguments:
+# directory to search
+#
+# Results:
+# The constructed list is returned to the user. This will
+# primarily be used in 'all.tcl' files. It is used in
+# runAllTests.
+#
+# Side Effects:
+# None
+
+# a lower case version is needed for compatibility with tcltest 1.0
+proc tcltest::getMatchingFiles args {GetMatchingFiles {*}$args}
+
+proc tcltest::GetMatchingFiles { args } {
+ if {[llength $args]} {
+ set dirList $args
+ } else {
+ # Finding tests only in [testsDirectory] is normal operation.
+ # This procedure is written to accept multiple directory arguments
+ # only to satisfy version 1 compatibility.
+ set dirList [list [testsDirectory]]
+ }
+
+ set matchingFiles [list]
+ foreach directory $dirList {
+
+ # List files in $directory that match patterns to run.
+ set matchFileList [list]
+ foreach match [matchFiles] {
+ set matchFileList [concat $matchFileList \
+ [glob -directory $directory -types {b c f p s} \
+ -nocomplain -- $match]]
+ }
+
+ # List files in $directory that match patterns to skip.
+ set skipFileList [list]
+ foreach skip [skipFiles] {
+ set skipFileList [concat $skipFileList \
+ [glob -directory $directory -types {b c f p s} \
+ -nocomplain -- $skip]]
+ }
+
+ # Add to result list all files in match list and not in skip list
+ foreach file $matchFileList {
+ if {$file ni $skipFileList} {
+ lappend matchingFiles $file
+ }
+ }
+ }
+
+ if {[llength $matchingFiles] == 0} {
+ PrintError "No test files remain after applying your match and\
+ skip patterns!"
+ }
+ return $matchingFiles
+}
+
+# tcltest::GetMatchingDirectories --
+#
+# Looks at the patterns given to match and skip directories and
+# uses them to put together a list of the test directories that we
+# should attempt to run. (Only subdirectories containing an
+# "all.tcl" file are put into the list.)
+#
+# Arguments:
+# root directory from which to search
+#
+# Results:
+# The constructed list is returned to the user. This is used in
+# the primary all.tcl file.
+#
+# Side Effects:
+# None.
+
+proc tcltest::GetMatchingDirectories {rootdir} {
+
+ # Determine the skip list first, to avoid [glob]-ing over subdirectories
+ # we're going to throw away anyway. Be sure we skip the $rootdir if it
+ # comes up to avoid infinite loops.
+ set skipDirs [list $rootdir]
+ foreach pattern [skipDirectories] {
+ set skipDirs [concat $skipDirs [glob -directory $rootdir -types d \
+ -nocomplain -- $pattern]]
+ }
+
+ # Now step through the matching directories, prune out the skipped ones
+ # as you go.
+ set matchDirs [list]
+ foreach pattern [matchDirectories] {
+ foreach path [glob -directory $rootdir -types d -nocomplain -- \
+ $pattern] {
+ if {$path ni $skipDirs} {
+ set matchDirs [concat $matchDirs [GetMatchingDirectories $path]]
+ if {[file exists [file join $path all.tcl]]} {
+ lappend matchDirs $path
+ }
+ }
+ }
+ }
+
+ if {[llength $matchDirs] == 0} {
+ DebugPuts 1 "No test directories remain after applying match\
+ and skip patterns!"
+ }
+ return [lsort $matchDirs]
+}
+
+# tcltest::runAllTests --
+#
+# prints output and sources test files according to the match and
+# skip patterns provided. after sourcing test files, it goes on
+# to source all.tcl files in matching test subdirectories.
+#
+# Arguments:
+# shell being tested
+#
+# Results:
+# Whether there were any failures.
+#
+# Side effects:
+# None.
+
+proc tcltest::runAllTests { {shell ""} } {
+ variable testSingleFile
+ variable numTestFiles
+ variable numTests
+ variable failFiles
+ variable DefaultValue
+ set failFilesAccum {}
+
+ FillFilesExisted
+ if {[llength [info level 0]] == 1} {
+ set shell [interpreter]
+ }
+
+ set testSingleFile false
+
+ puts [outputChannel] "Tests running in interp: $shell"
+ puts [outputChannel] "Tests located in: [testsDirectory]"
+ puts [outputChannel] "Tests running in: [workingDirectory]"
+ puts [outputChannel] "Temporary files stored in\
+ [temporaryDirectory]"
+
+ # [file system] first available in Tcl 8.4
+ if {![catch {file system [testsDirectory]} result]
+ && ([lindex $result 0] ne "native")} {
+ # If we aren't running in the native filesystem, then we must
+ # run the tests in a single process (via 'source'), because
+ # trying to run then via a pipe will fail since the files don't
+ # really exist.
+ singleProcess 1
+ }
+
+ if {[singleProcess]} {
+ puts [outputChannel] \
+ "Test files sourced into current interpreter"
+ } else {
+ puts [outputChannel] \
+ "Test files run in separate interpreters"
+ }
+ if {[llength [skip]] > 0} {
+ puts [outputChannel] "Skipping tests that match: [skip]"
+ }
+ puts [outputChannel] "Running tests that match: [match]"
+
+ if {[llength [skipFiles]] > 0} {
+ puts [outputChannel] \
+ "Skipping test files that match: [skipFiles]"
+ }
+ if {[llength [matchFiles]] > 0} {
+ puts [outputChannel] \
+ "Only running test files that match: [matchFiles]"
+ }
+
+ set timeCmd {clock format [clock seconds]}
+ puts [outputChannel] "Tests began at [eval $timeCmd]"
+
+ # Run each of the specified tests
+ foreach file [lsort [GetMatchingFiles]] {
+ set tail [file tail $file]
+ puts [outputChannel] $tail
+ flush [outputChannel]
+
+ if {[singleProcess]} {
+ incr numTestFiles
+ uplevel 1 [list ::source $file]
+ } else {
+ # Pass along our configuration to the child processes.
+ # EXCEPT for the -outfile, because the parent process
+ # needs to read and process output of children.
+ set childargv [list]
+ foreach opt [Configure] {
+ if {$opt eq "-outfile"} {continue}
+ set value [Configure $opt]
+ # Don't bother passing default configuration options
+ if {$value eq $DefaultValue($opt)} {
+ continue
+ }
+ lappend childargv $opt $value
+ }
+ set cmd [linsert $childargv 0 | $shell $file]
+ if {[catch {
+ incr numTestFiles
+ set pipeFd [open $cmd "r"]
+ while {[gets $pipeFd line] >= 0} {
+ if {[regexp [join {
+ {^([^:]+):\t}
+ {Total\t([0-9]+)\t}
+ {Passed\t([0-9]+)\t}
+ {Skipped\t([0-9]+)\t}
+ {Failed\t([0-9]+)}
+ } ""] $line null testFile \
+ Total Passed Skipped Failed]} {
+ foreach index {Total Passed Skipped Failed} {
+ incr numTests($index) [set $index]
+ }
+ if {$Failed > 0} {
+ lappend failFiles $testFile
+ lappend failFilesAccum $testFile
+ }
+ } elseif {[regexp [join {
+ {^Number of tests skipped }
+ {for each constraint:}
+ {|^\t(\d+)\t(.+)$}
+ } ""] $line match skipped constraint]} {
+ if {[string match \t* $match]} {
+ AddToSkippedBecause $constraint $skipped
+ }
+ } else {
+ puts [outputChannel] $line
+ }
+ }
+ close $pipeFd
+ } msg]} {
+ puts [outputChannel] "Test file error: $msg"
+ # append the name of the test to a list to be reported
+ # later
+ lappend testFileFailures $file
+ }
+ }
+ }
+
+ # cleanup
+ puts [outputChannel] "\nTests ended at [eval $timeCmd]"
+ cleanupTests 1
+ if {[info exists testFileFailures]} {
+ puts [outputChannel] "\nTest files exiting with errors: \n"
+ foreach file $testFileFailures {
+ puts [outputChannel] " [file tail $file]\n"
+ }
+ }
+
+ # Checking for subdirectories in which to run tests
+ foreach directory [GetMatchingDirectories [testsDirectory]] {
+ set dir [file tail $directory]
+ puts [outputChannel] [string repeat ~ 44]
+ puts [outputChannel] "$dir test began at [eval $timeCmd]\n"
+
+ uplevel 1 [list ::source [file join $directory all.tcl]]
+
+ set endTime [eval $timeCmd]
+ puts [outputChannel] "\n$dir test ended at $endTime"
+ puts [outputChannel] ""
+ puts [outputChannel] [string repeat ~ 44]
+ }
+ return [expr {[info exists testFileFailures] || [llength $failFilesAccum]}]
+}
+
+#####################################################################
+
+# Test utility procs - not used in tcltest, but may be useful for
+# testing.
+
+# tcltest::loadTestedCommands --
+#
+# Uses the specified script to load the commands to test. Allowed to
+# be empty, as the tested commands could have been compiled into the
+# interpreter.
+#
+# Arguments
+# none
+#
+# Results
+# none
+#
+# Side Effects:
+# none.
+
+proc tcltest::loadTestedCommands {} {
+ return [uplevel 1 [loadScript]]
+}
+
+# tcltest::saveState --
+#
+# Save information regarding what procs and variables exist.
+#
+# Arguments:
+# none
+#
+# Results:
+# Modifies the variable saveState
+#
+# Side effects:
+# None.
+
+proc tcltest::saveState {} {
+ variable saveState
+ uplevel 1 [list ::set [namespace which -variable saveState]] \
+ {[::list [::info procs] [::info vars]]}
+ DebugPuts 2 "[lindex [info level 0] 0]: $saveState"
+ return
+}
+
+# tcltest::restoreState --
+#
+# Remove procs and variables that didn't exist before the call to
+# [saveState].
+#
+# Arguments:
+# none
+#
+# Results:
+# Removes procs and variables from your environment if they don't
+# exist in the saveState variable.
+#
+# Side effects:
+# None.
+
+proc tcltest::restoreState {} {
+ variable saveState
+ foreach p [uplevel 1 {::info procs}] {
+ if {($p ni [lindex $saveState 0]) && ("[namespace current]::$p" ne
+ [uplevel 1 [list ::namespace origin $p]])} {
+
+ DebugPuts 2 "[lindex [info level 0] 0]: Removing proc $p"
+ uplevel 1 [list ::catch [list ::rename $p {}]]
+ }
+ }
+ foreach p [uplevel 1 {::info vars}] {
+ if {$p ni [lindex $saveState 1]} {
+ DebugPuts 2 "[lindex [info level 0] 0]:\
+ Removing variable $p"
+ uplevel 1 [list ::catch [list ::unset $p]]
+ }
+ }
+ return
+}
+
+# tcltest::normalizeMsg --
+#
+# Removes "extra" newlines from a string.
+#
+# Arguments:
+# msg String to be modified
+#
+# Results:
+# string with extra newlines removed
+#
+# Side effects:
+# None.
+
+proc tcltest::normalizeMsg {msg} {
+ regsub "\n$" [string tolower $msg] "" msg
+ set msg [string map [list "\n\n" "\n"] $msg]
+ return [string map [list "\n\}" "\}"] $msg]
+}
+
+# tcltest::makeFile --
+#
+# Create a new file with the name <name>, and write <contents> to it.
+#
+# If this file hasn't been created via makeFile since the last time
+# cleanupTests was called, add it to the $filesMade list, so it will be
+# removed by the next call to cleanupTests.
+#
+# Arguments:
+# contents content of the new file
+# name name of the new file
+# directory directory name for new file
+#
+# Results:
+# absolute path to the file created
+#
+# Side effects:
+# None.
+
+proc tcltest::makeFile {contents name {directory ""}} {
+ variable filesMade
+ FillFilesExisted
+
+ if {[llength [info level 0]] == 3} {
+ set directory [temporaryDirectory]
+ }
+
+ set fullName [file join $directory $name]
+
+ DebugPuts 3 "[lindex [info level 0] 0]:\
+ putting ``$contents'' into $fullName"
+
+ set fd [open $fullName w]
+ chan configure $fd -translation lf
+ if {[string index $contents end] eq "\n"} {
+ puts -nonewline $fd $contents
+ } else {
+ puts $fd $contents
+ }
+ close $fd
+
+ if {$fullName ni $filesMade} {
+ lappend filesMade $fullName
+ }
+ return $fullName
+}
+
+# tcltest::removeFile --
+#
+# Removes the named file from the filesystem
+#
+# Arguments:
+# name file to be removed
+# directory directory from which to remove file
+#
+# Results:
+# return value from [file delete]
+#
+# Side effects:
+# None.
+
+proc tcltest::removeFile {name {directory ""}} {
+ variable filesMade
+ FillFilesExisted
+ if {[llength [info level 0]] == 2} {
+ set directory [temporaryDirectory]
+ }
+ set fullName [file join $directory $name]
+ DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName"
+ set idx [lsearch -exact $filesMade $fullName]
+ set filesMade [lreplace $filesMade $idx $idx]
+ if {$idx == -1} {
+ DebugDo 1 {
+ Warn "removeFile removing \"$fullName\":\n not created by makeFile"
+ }
+ }
+ if {![file isfile $fullName]} {
+ DebugDo 1 {
+ Warn "removeFile removing \"$fullName\":\n not a file"
+ }
+ }
+ if {[catch {file delete -- $fullName} msg ]} {
+ DebugDo 1 {
+ Warn "removeFile removing \"$fullName\":\n failed: $msg"
+ }
+ }
+ return
+}
+
+# tcltest::makeDirectory --
+#
+# Create a new dir with the name <name>.
+#
+# If this dir hasn't been created via makeDirectory since the last time
+# cleanupTests was called, add it to the $directoriesMade list, so it
+# will be removed by the next call to cleanupTests.
+#
+# Arguments:
+# name name of the new directory
+# directory directory in which to create new dir
+#
+# Results:
+# absolute path to the directory created
+#
+# Side effects:
+# None.
+
+proc tcltest::makeDirectory {name {directory ""}} {
+ variable filesMade
+ FillFilesExisted
+ if {[llength [info level 0]] == 2} {
+ set directory [temporaryDirectory]
+ }
+ set fullName [file join $directory $name]
+ DebugPuts 3 "[lindex [info level 0] 0]: creating $fullName"
+ file mkdir $fullName
+ if {$fullName ni $filesMade} {
+ lappend filesMade $fullName
+ }
+ return $fullName
+}
+
+# tcltest::removeDirectory --
+#
+# Removes a named directory from the file system.
+#
+# Arguments:
+# name Name of the directory to remove
+# directory Directory from which to remove
+#
+# Results:
+# return value from [file delete]
+#
+# Side effects:
+# None
+
+proc tcltest::removeDirectory {name {directory ""}} {
+ variable filesMade
+ FillFilesExisted
+ if {[llength [info level 0]] == 2} {
+ set directory [temporaryDirectory]
+ }
+ set fullName [file join $directory $name]
+ DebugPuts 3 "[lindex [info level 0] 0]: deleting $fullName"
+ set idx [lsearch -exact $filesMade $fullName]
+ set filesMade [lreplace $filesMade $idx $idx]
+ if {$idx == -1} {
+ DebugDo 1 {
+ Warn "removeDirectory removing \"$fullName\":\n not created\
+ by makeDirectory"
+ }
+ }
+ if {![file isdirectory $fullName]} {
+ DebugDo 1 {
+ Warn "removeDirectory removing \"$fullName\":\n not a directory"
+ }
+ }
+ return [file delete -force -- $fullName]
+}
+
+# tcltest::viewFile --
+#
+# reads the content of a file and returns it
+#
+# Arguments:
+# name of the file to read
+# directory in which file is located
+#
+# Results:
+# content of the named file
+#
+# Side effects:
+# None.
+
+proc tcltest::viewFile {name {directory ""}} {
+ FillFilesExisted
+ if {[llength [info level 0]] == 2} {
+ set directory [temporaryDirectory]
+ }
+ set fullName [file join $directory $name]
+ set f [open $fullName]
+ set data [read -nonewline $f]
+ close $f
+ return $data
+}
+
+# tcltest::bytestring --
+#
+# Construct a string that consists of the requested sequence of bytes,
+# as opposed to a string of properly formed UTF-8 characters.
+# This allows the tester to
+# 1. Create denormalized or improperly formed strings to pass to C
+# procedures that are supposed to accept strings with embedded NULL
+# bytes.
+# 2. Confirm that a string result has a certain pattern of bytes, for
+# instance to confirm that "\xe0\0" in a Tcl script is stored
+# internally in UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80".
+#
+# Generally, it's a bad idea to examine the bytes in a Tcl string or to
+# construct improperly formed strings in this manner, because it involves
+# exposing that Tcl uses UTF-8 internally.
+#
+# Arguments:
+# string being converted
+#
+# Results:
+# result fom encoding
+#
+# Side effects:
+# None
+
+proc tcltest::bytestring {string} {
+ return [encoding convertfrom identity $string]
+}
+
+# tcltest::OpenFiles --
+#
+# used in io tests, uses testchannel
+#
+# Arguments:
+# None.
+#
+# Results:
+# ???
+#
+# Side effects:
+# None.
+
+proc tcltest::OpenFiles {} {
+ if {[catch {testchannel open} result]} {
+ return {}
+ }
+ return $result
+}
+
+# tcltest::LeakFiles --
+#
+# used in io tests, uses testchannel
+#
+# Arguments:
+# None.
+#
+# Results:
+# ???
+#
+# Side effects:
+# None.
+
+proc tcltest::LeakFiles {old} {
+ if {[catch {testchannel open} new]} {
+ return {}
+ }
+ set leak {}
+ foreach p $new {
+ if {$p ni $old} {
+ lappend leak $p
+ }
+ }
+ return $leak
+}
+
+#
+# Internationalization / ISO support procs -- dl
+#
+
+# tcltest::SetIso8859_1_Locale --
+#
+# used in cmdIL.test, uses testlocale
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+#
+# Side effects:
+# None.
+
+proc tcltest::SetIso8859_1_Locale {} {
+ variable previousLocale
+ variable isoLocale
+ if {[info commands testlocale] != ""} {
+ set previousLocale [testlocale ctype]
+ testlocale ctype $isoLocale
+ }
+ return
+}
+
+# tcltest::RestoreLocale --
+#
+# used in cmdIL.test, uses testlocale
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+#
+# Side effects:
+# None.
+
+proc tcltest::RestoreLocale {} {
+ variable previousLocale
+ if {[info commands testlocale] != ""} {
+ testlocale ctype $previousLocale
+ }
+ return
+}
+
+# tcltest::threadReap --
+#
+# Kill all threads except for the main thread.
+# Do nothing if testthread is not defined.
+#
+# Arguments:
+# none.
+#
+# Results:
+# Returns the number of existing threads.
+#
+# Side Effects:
+# none.
+#
+
+proc tcltest::threadReap {} {
+ if {[info commands testthread] ne {}} {
+
+ # testthread built into tcltest
+
+ testthread errorproc ThreadNullError
+ while {[llength [testthread names]] > 1} {
+ foreach tid [testthread names] {
+ if {$tid != [mainThread]} {
+ catch {
+ testthread send -async $tid {testthread exit}
+ }
+ }
+ }
+ ## Enter a bit a sleep to give the threads enough breathing
+ ## room to kill themselves off, otherwise the end up with a
+ ## massive queue of repeated events
+ after 1
+ }
+ testthread errorproc ThreadError
+ return [llength [testthread names]]
+ } elseif {[info commands thread::id] ne {}} {
+
+ # Thread extension
+
+ thread::errorproc ThreadNullError
+ while {[llength [thread::names]] > 1} {
+ foreach tid [thread::names] {
+ if {$tid != [mainThread]} {
+ catch {thread::send -async $tid {thread::exit}}
+ }
+ }
+ ## Enter a bit a sleep to give the threads enough breathing
+ ## room to kill themselves off, otherwise the end up with a
+ ## massive queue of repeated events
+ after 1
+ }
+ thread::errorproc ThreadError
+ return [llength [thread::names]]
+ } else {
+ return 1
+ }
+ return 0
+}
+
+# Initialize the constraints and set up command line arguments
+namespace eval tcltest {
+ # Define initializers for all the built-in contraint definitions
+ DefineConstraintInitializers
+
+ # Set up the constraints in the testConstraints array to be lazily
+ # initialized by a registered initializer, or by "false" if no
+ # initializer is registered.
+ trace add variable testConstraints read [namespace code SafeFetch]
+
+ # Only initialize constraints at package load time if an
+ # [initConstraintsHook] has been pre-defined. This is only
+ # for compatibility support. The modern way to add a custom
+ # test constraint is to just call the [testConstraint] command
+ # straight away, without all this "hook" nonsense.
+ if {[namespace current] eq
+ [namespace qualifiers [namespace which initConstraintsHook]]} {
+ InitConstraints
+ } else {
+ proc initConstraintsHook {} {}
+ }
+
+ # Define the standard match commands
+ customMatch exact [list string equal]
+ customMatch glob [list string match]
+ customMatch regexp [list regexp --]
+
+ # If the TCLTEST_OPTIONS environment variable exists, configure
+ # tcltest according to the option values it specifies. This has
+ # the effect of resetting tcltest's default configuration.
+ proc ConfigureFromEnvironment {} {
+ upvar #0 env(TCLTEST_OPTIONS) options
+ if {[catch {llength $options} msg]} {
+ Warn "invalid TCLTEST_OPTIONS \"$options\":\n invalid\
+ Tcl list: $msg"
+ return
+ }
+ if {[llength $options] % 2} {
+ Warn "invalid TCLTEST_OPTIONS: \"$options\":\n should be\
+ -option value ?-option value ...?"
+ return
+ }
+ if {[catch {Configure {*}$options} msg]} {
+ Warn "invalid TCLTEST_OPTIONS: \"$options\":\n $msg"
+ return
+ }
+ }
+ if {[info exists ::env(TCLTEST_OPTIONS)]} {
+ ConfigureFromEnvironment
+ }
+
+ proc LoadTimeCmdLineArgParsingRequired {} {
+ set required false
+ if {[info exists ::argv] && ("-help" in $::argv)} {
+ # The command line asks for -help, so give it (and exit)
+ # right now. ([configure] does not process -help)
+ set required true
+ }
+ foreach hook { PrintUsageInfoHook processCmdLineArgsHook
+ processCmdLineArgsAddFlagsHook } {
+ if {[namespace current] eq
+ [namespace qualifiers [namespace which $hook]]} {
+ set required true
+ } else {
+ proc $hook args {}
+ }
+ }
+ return $required
+ }
+
+ # Only initialize configurable options from the command line arguments
+ # at package load time if necessary for backward compatibility. This
+ # lets the tcltest user call [configure] for themselves if they wish.
+ # Traces are established for auto-configuration from the command line
+ # if any configurable options are accessed before the user calls
+ # [configure].
+ if {[LoadTimeCmdLineArgParsingRequired]} {
+ ProcessCmdLineArgs
+ } else {
+ EstablishAutoConfigureTraces
+ }
+
+ package provide [namespace tail [namespace current]] $Version
+}
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-05 02:42:55 +0000