# 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) 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.
# RCS: @(#) $Id: msgcat.tcl,v 1.17.2.4 2004/08/13 21:45:16 dgp Exp $
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the installation directory in the Makefiles.
package provide
msgcat 1.3.3
namespace export mc mcload mclocale mcmax mcmset mcpreferences mcset
\
# Records the current locale as passed to mclocale
# Records the list of locales to search
# Records the mapping between source strings and translated strings. The
# array key is of the form "<locale>,<namespace>,<src>" and the value is
# Map of language codes used in Windows registry to those of ISO-639
array set WinRegToISO639
{
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
04 zh
0404 zh_TW
0804 zh_CN
0c04 zh_HK
1004 zh_SG
1404 zh_MO
07 de
0407 de_DE
0807 de_CH
0c07 de_AT
1007 de_LU
1407 de_LI
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
0c fr
040c fr_FR
080c fr_BE
0c0c fr_CA
100c fr_CH
140c fr_LU
10 it
0410 it_IT
0810 it_CH
13 nl
0413 nl_NL
0813 nl_BE
14 no
0414 no_NO
0814 nn_NO
16 pt
0416 pt_BR
0816 pt_PT
1a hr
041a hr_HR
081a sr_YU
0c1a sr_YU
@cyrillic
1d sv
041d sv_SE
081d sv_FI
20 ur
0420 ur_PK
0820 ur_IN
2c az
042c az_AZ
@latin
082c az_AZ
@cyrillic
3e ms
043e ms_MY
083e ms_BN
43 uz
0443 uz_UZ
@latin
0843 uz_UZ
@cyrillic
60 ks
0460 ks_PK
0860 ks_IN
61 ne
0461 ne_NP
0861 ne_IN
# 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
# src The string to translate.
# args Args to pass to the format command
# Returns the translatd string. Propagates errors thrown by the
proc msgcat::mc {src args
} {
# Check for the src in each namespace starting from the local and
set ns
[uplevel 1 [list ::namespace current
]]
if {[info exists Msgs
($loc,$ns,$src)]} {
if {[llength $args] == 0} {
return $Msgs($loc,$ns,$src)
[linsert $args 0 ::format $Msgs($loc,$ns,$src)]]
set ns
[namespace parent
$ns]
# we have not found the translation
[linsert $args 0 [::namespace origin mcunknown
] $Locale $src]]
# Query or set the current locale.
# newLocale (Optional) The new locale string. Locale strings
# should be composed of one or more sublocale parts
# separated by underscores (e.g. en_US).
# Returns the current locale.
proc msgcat::mclocale {args
} {
error {wrong
# args: should be "mclocale ?newLocale?"}
set newLocale
[lindex $args 0]
if {$newLocale ne
[file tail
$newLocale]} {
return -code error "invalid newLocale value \"$newLocale\":\
could be path to unsafe code."
set Locale
[string tolower
$newLocale]
foreach part
[split $Locale _
] {
set word
[string trimleft
"${word}_${part}" _
]
set Loclist
[linsert $Loclist 0 $word]
# msgcat::mcpreferences --
# Fetch the list of locales used to look up strings, ordered from
# most preferred to least preferred.
# Returns an ordered list of the locales preferred by the user.
proc msgcat::mcpreferences {} {
# Attempt to load message catalogs for each locale in the
# preference list from the specified directory.
# langdir The directory to search.
# Returns the number of message catalogs that were loaded.
proc msgcat::mcload {langdir
} {
foreach p
[mcpreferences
] {
set langfile
[file join $langdir $p.msg
]
if {[file exists
$langfile]} {
set fid
[open $langfile "r"]
fconfigure $fid -encoding utf-8
# Set the translation for a given string in a specified locale.
# locale The locale to use.
# dest (Optional) The translated string. If omitted,
# the source string is used.
# Returns the new locale.
proc msgcat::mcset {locale src
{dest
""}} {
if {[llength [info level
0]] == 3} { ;# dest not specified
set ns
[uplevel 1 [list ::namespace current
]]
set Msgs
([string tolower
$locale],$ns,$src) $dest
# Set the translation for multiple strings in a specified locale.
# locale The locale to use.
# pairs One or more src/dest pairs (must be even length)
# Returns the number of pairs processed
proc msgcat::mcmset {locale pairs
} {
set length
[llength $pairs]
error {bad translation
list: should be
"mcmset locale {src dest ...}"}
set locale
[string tolower
$locale]
set ns
[uplevel 1 [list ::namespace current
]]
foreach {src dest
} $pairs {
set Msgs
($locale,$ns,$src) $dest
# This routine is called by msgcat::mc if a translation cannot
# be found for a string. 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.
# locale The current locale.
# src The string to be translated.
# args Args to pass to the format command
# Returns the translated value.
proc msgcat::mcunknown {locale src args
} {
return [uplevel 1 [linsert $args 0 ::format $src]]
# Calculates the maximun length of the translated strings of the given
# args strings to translate.
# Returns the length of the longest translated string.
proc msgcat::mcmax {args
} {
set translated
[uplevel 1 [list [namespace origin mc
] $string]]
set len
[string length
$translated]
# 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
# ^ # 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"
if {[string length
$territory]} {
if {[string length
$modifier]} {
# Initialize the default locale
# set default locale, try to get from environment
foreach varName
{LC_ALL LC_MESSAGES LANG
} {
if {[info exists
::env($varName)]
&& ![string equal
"" $::env($varName)]} {
if {![catch {mclocale
[ConvertLocale
$::env($varName)]}]} {
# The rest of this routine is special processing for Windows;
# all other platforms, get out now.
if { ![string equal
$::tcl_platform(platform
) windows
] } {
# On Windows, try to set locale depending on registry settings,
# or fall back on locale of "C".
set key
{HKEY_CURRENT_USER
\Control Panel
\International
}
if {[catch {package require
registry}] \
||
[catch {registry get
$key "locale"} locale
]} {
# 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.
set locale
[string tolower
$locale]
while {[string length
$locale]} {
if {![catch {mclocale
[ConvertLocale
$WinRegToISO639($locale)]}]} {
set locale
[string range
$locale 1 end
]
# No translation known. Fall back on "C" locale