diff options
Diffstat (limited to 'tcl8.6/library/msgcat/msgcat.tcl')
| -rw-r--r-- | tcl8.6/library/msgcat/msgcat.tcl | 1210 |
1 files changed, 0 insertions, 1210 deletions
diff --git a/tcl8.6/library/msgcat/msgcat.tcl b/tcl8.6/library/msgcat/msgcat.tcl deleted file mode 100644 index a43f13e..0000000 --- a/tcl8.6/library/msgcat/msgcat.tcl +++ /dev/null @@ -1,1210 +0,0 @@ -# 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.0 - -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 |