1# msgcat.tcl -- 2# 3# This file defines various procedures which implement a 4# message catalog facility for Tcl programs. It should be 5# loaded with the command "package require msgcat". 6# 7# Copyright (c) 1998-2000 by Ajuba Solutions. 8# Copyright (c) 1998 by Mark Harrison. 9# 10# See the file "license.terms" for information on usage and redistribution 11# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 12# 13# RCS: @(#) $Id: msgcat.tcl,v 1.26.4.2 2009/12/17 16:30:12 dgp Exp $ 14 15package require Tcl 8.5 16# When the version number changes, be sure to update the pkgIndex.tcl file, 17# and the installation directory in the Makefiles. 18package provide msgcat 1.4.3 19 20namespace eval msgcat { 21 namespace export mc mcload mclocale mcmax mcmset mcpreferences mcset \ 22 mcunknown 23 24 # Records the current locale as passed to mclocale 25 variable Locale "" 26 27 # Records the list of locales to search 28 variable Loclist {} 29 30 # Records the mapping between source strings and translated strings. The 31 # dict key is of the form "<locale> <namespace> <src>", where locale and 32 # namespace should be themselves dict values and the value is 33 # the translated string. 34 variable Msgs [dict create] 35 36 # Map of language codes used in Windows registry to those of ISO-639 37 if { $::tcl_platform(platform) eq "windows" } { 38 variable WinRegToISO639 [dict create {*}{ 39 01 ar 0401 ar_SA 0801 ar_IQ 0c01 ar_EG 1001 ar_LY 1401 ar_DZ 40 1801 ar_MA 1c01 ar_TN 2001 ar_OM 2401 ar_YE 2801 ar_SY 41 2c01 ar_JO 3001 ar_LB 3401 ar_KW 3801 ar_AE 3c01 ar_BH 42 4001 ar_QA 43 02 bg 0402 bg_BG 44 03 ca 0403 ca_ES 45 04 zh 0404 zh_TW 0804 zh_CN 0c04 zh_HK 1004 zh_SG 1404 zh_MO 46 05 cs 0405 cs_CZ 47 06 da 0406 da_DK 48 07 de 0407 de_DE 0807 de_CH 0c07 de_AT 1007 de_LU 1407 de_LI 49 08 el 0408 el_GR 50 09 en 0409 en_US 0809 en_GB 0c09 en_AU 1009 en_CA 1409 en_NZ 51 1809 en_IE 1c09 en_ZA 2009 en_JM 2409 en_GD 2809 en_BZ 52 2c09 en_TT 3009 en_ZW 3409 en_PH 53 0a es 040a es_ES 080a es_MX 0c0a es_ES@modern 100a es_GT 140a es_CR 54 180a es_PA 1c0a es_DO 200a es_VE 240a es_CO 280a es_PE 55 2c0a es_AR 300a es_EC 340a es_CL 380a es_UY 3c0a es_PY 56 400a es_BO 440a es_SV 480a es_HN 4c0a es_NI 500a es_PR 57 0b fi 040b fi_FI 58 0c fr 040c fr_FR 080c fr_BE 0c0c fr_CA 100c fr_CH 140c fr_LU 59 180c fr_MC 60 0d he 040d he_IL 61 0e hu 040e hu_HU 62 0f is 040f is_IS 63 10 it 0410 it_IT 0810 it_CH 64 11 ja 0411 ja_JP 65 12 ko 0412 ko_KR 66 13 nl 0413 nl_NL 0813 nl_BE 67 14 no 0414 no_NO 0814 nn_NO 68 15 pl 0415 pl_PL 69 16 pt 0416 pt_BR 0816 pt_PT 70 17 rm 0417 rm_CH 71 18 ro 0418 ro_RO 72 19 ru 73 1a hr 041a hr_HR 081a sr_YU 0c1a sr_YU@cyrillic 74 1b sk 041b sk_SK 75 1c sq 041c sq_AL 76 1d sv 041d sv_SE 081d sv_FI 77 1e th 041e th_TH 78 1f tr 041f tr_TR 79 20 ur 0420 ur_PK 0820 ur_IN 80 21 id 0421 id_ID 81 22 uk 0422 uk_UA 82 23 be 0423 be_BY 83 24 sl 0424 sl_SI 84 25 et 0425 et_EE 85 26 lv 0426 lv_LV 86 27 lt 0427 lt_LT 87 28 tg 0428 tg_TJ 88 29 fa 0429 fa_IR 89 2a vi 042a vi_VN 90 2b hy 042b hy_AM 91 2c az 042c az_AZ@latin 082c az_AZ@cyrillic 92 2d eu 93 2e wen 042e wen_DE 94 2f mk 042f mk_MK 95 30 bnt 0430 bnt_TZ 96 31 ts 0431 ts_ZA 97 33 ven 0433 ven_ZA 98 34 xh 0434 xh_ZA 99 35 zu 0435 zu_ZA 100 36 af 0436 af_ZA 101 37 ka 0437 ka_GE 102 38 fo 0438 fo_FO 103 39 hi 0439 hi_IN 104 3a mt 043a mt_MT 105 3b se 043b se_NO 106 043c gd_UK 083c ga_IE 107 3d yi 043d yi_IL 108 3e ms 043e ms_MY 083e ms_BN 109 3f kk 043f kk_KZ 110 40 ky 0440 ky_KG 111 41 sw 0441 sw_KE 112 42 tk 0442 tk_TM 113 43 uz 0443 uz_UZ@latin 0843 uz_UZ@cyrillic 114 44 tt 0444 tt_RU 115 45 bn 0445 bn_IN 116 46 pa 0446 pa_IN 117 47 gu 0447 gu_IN 118 48 or 0448 or_IN 119 49 ta 120 4a te 044a te_IN 121 4b kn 044b kn_IN 122 4c ml 044c ml_IN 123 4d as 044d as_IN 124 4e mr 044e mr_IN 125 4f sa 044f sa_IN 126 50 mn 127 51 bo 0451 bo_CN 128 52 cy 0452 cy_GB 129 53 km 0453 km_KH 130 54 lo 0454 lo_LA 131 55 my 0455 my_MM 132 56 gl 0456 gl_ES 133 57 kok 0457 kok_IN 134 58 mni 0458 mni_IN 135 59 sd 136 5a syr 045a syr_TR 137 5b si 045b si_LK 138 5c chr 045c chr_US 139 5d iu 045d iu_CA 140 5e am 045e am_ET 141 5f ber 045f ber_MA 142 60 ks 0460 ks_PK 0860 ks_IN 143 61 ne 0461 ne_NP 0861 ne_IN 144 62 fy 0462 fy_NL 145 63 ps 146 64 tl 0464 tl_PH 147 65 div 0465 div_MV 148 66 bin 0466 bin_NG 149 67 ful 0467 ful_NG 150 68 ha 0468 ha_NG 151 69 nic 0469 nic_NG 152 6a yo 046a yo_NG 153 70 ibo 0470 ibo_NG 154 71 kau 0471 kau_NG 155 72 om 0472 om_ET 156 73 ti 0473 ti_ET 157 74 gn 0474 gn_PY 158 75 cpe 0475 cpe_US 159 76 la 0476 la_VA 160 77 so 0477 so_SO 161 78 sit 0478 sit_CN 162 79 pap 0479 pap_AN 163 }] 164 } 165} 166 167# msgcat::mc -- 168# 169# Find the translation for the given string based on the current 170# locale setting. Check the local namespace first, then look in each 171# parent namespace until the source is found. If additional args are 172# specified, use the format command to work them into the traslated 173# string. 174# 175# Arguments: 176# src The string to translate. 177# args Args to pass to the format command 178# 179# Results: 180# Returns the translated string. Propagates errors thrown by the 181# format command. 182 183proc msgcat::mc {src args} { 184 # Check for the src in each namespace starting from the local and 185 # ending in the global. 186 187 variable Msgs 188 variable Loclist 189 variable Locale 190 191 set ns [uplevel 1 [list ::namespace current]] 192 193 while {$ns != ""} { 194 foreach loc $Loclist { 195 if {[dict exists $Msgs $loc $ns $src]} { 196 if {[llength $args] == 0} { 197 return [dict get $Msgs $loc $ns $src] 198 } else { 199 return [format [dict get $Msgs $loc $ns $src] {*}$args] 200 } 201 } 202 } 203 set ns [namespace parent $ns] 204 } 205 # we have not found the translation 206 return [uplevel 1 [list [namespace origin mcunknown] \ 207 $Locale $src {*}$args]] 208} 209 210# msgcat::mclocale -- 211# 212# Query or set the current locale. 213# 214# Arguments: 215# newLocale (Optional) The new locale string. Locale strings 216# should be composed of one or more sublocale parts 217# separated by underscores (e.g. en_US). 218# 219# Results: 220# Returns the current locale. 221 222proc msgcat::mclocale {args} { 223 variable Loclist 224 variable Locale 225 set len [llength $args] 226 227 if {$len > 1} { 228 return -code error "wrong # args: should be\ 229 \"[lindex [info level 0] 0] ?newLocale?\"" 230 } 231 232 if {$len == 1} { 233 set newLocale [lindex $args 0] 234 if {$newLocale ne [file tail $newLocale]} { 235 return -code error "invalid newLocale value \"$newLocale\":\ 236 could be path to unsafe code." 237 } 238 set Locale [string tolower $newLocale] 239 set Loclist {} 240 set word "" 241 foreach part [split $Locale _] { 242 set word [string trim "${word}_${part}" _] 243 if {$word ne [lindex $Loclist 0]} { 244 set Loclist [linsert $Loclist 0 $word] 245 } 246 } 247 lappend Loclist {} 248 set Locale [lindex $Loclist 0] 249 } 250 return $Locale 251} 252 253# msgcat::mcpreferences -- 254# 255# Fetch the list of locales used to look up strings, ordered from 256# most preferred to least preferred. 257# 258# Arguments: 259# None. 260# 261# Results: 262# Returns an ordered list of the locales preferred by the user. 263 264proc msgcat::mcpreferences {} { 265 variable Loclist 266 return $Loclist 267} 268 269# msgcat::mcload -- 270# 271# Attempt to load message catalogs for each locale in the 272# preference list from the specified directory. 273# 274# Arguments: 275# langdir The directory to search. 276# 277# Results: 278# Returns the number of message catalogs that were loaded. 279 280proc msgcat::mcload {langdir} { 281 set x 0 282 foreach p [mcpreferences] { 283 if { $p eq {} } { 284 set p ROOT 285 } 286 set langfile [file join $langdir $p.msg] 287 if {[file exists $langfile]} { 288 incr x 289 uplevel 1 [list ::source -encoding utf-8 $langfile] 290 } 291 } 292 return $x 293} 294 295# msgcat::mcset -- 296# 297# Set the translation for a given string in a specified locale. 298# 299# Arguments: 300# locale The locale to use. 301# src The source string. 302# dest (Optional) The translated string. If omitted, 303# the source string is used. 304# 305# Results: 306# Returns the new locale. 307 308proc msgcat::mcset {locale src {dest ""}} { 309 variable Msgs 310 if {[llength [info level 0]] == 3} { ;# dest not specified 311 set dest $src 312 } 313 314 set ns [uplevel 1 [list ::namespace current]] 315 316 set locale [string tolower $locale] 317 318 # create nested dictionaries if they do not exist 319 if {![dict exists $Msgs $locale]} { 320 dict set Msgs $locale [dict create] 321 } 322 if {![dict exists $Msgs $locale $ns]} { 323 dict set Msgs $locale $ns [dict create] 324 } 325 dict set Msgs $locale $ns $src $dest 326 return $dest 327} 328 329# msgcat::mcmset -- 330# 331# Set the translation for multiple strings in a specified locale. 332# 333# Arguments: 334# locale The locale to use. 335# pairs One or more src/dest pairs (must be even length) 336# 337# Results: 338# Returns the number of pairs processed 339 340proc msgcat::mcmset {locale pairs } { 341 variable Msgs 342 343 set length [llength $pairs] 344 if {$length % 2} { 345 return -code error "bad translation list:\ 346 should be \"[lindex [info level 0] 0] locale {src dest ...}\"" 347 } 348 349 set locale [string tolower $locale] 350 set ns [uplevel 1 [list ::namespace current]] 351 352 # create nested dictionaries if they do not exist 353 if {![dict exists $Msgs $locale]} { 354 dict set Msgs $locale [dict create] 355 } 356 if {![dict exists $Msgs $locale $ns]} { 357 dict set Msgs $locale $ns [dict create] 358 } 359 foreach {src dest} $pairs { 360 dict set Msgs $locale $ns $src $dest 361 } 362 363 return $length 364} 365 366# msgcat::mcunknown -- 367# 368# This routine is called by msgcat::mc if a translation cannot 369# be found for a string. This routine is intended to be replaced 370# by an application specific routine for error reporting 371# purposes. The default behavior is to return the source string. 372# If additional args are specified, the format command will be used 373# to work them into the traslated string. 374# 375# Arguments: 376# locale The current locale. 377# src The string to be translated. 378# args Args to pass to the format command 379# 380# Results: 381# Returns the translated value. 382 383proc msgcat::mcunknown {locale src args} { 384 if {[llength $args]} { 385 return [format $src {*}$args] 386 } else { 387 return $src 388 } 389} 390 391# msgcat::mcmax -- 392# 393# Calculates the maximum length of the translated strings of the given 394# list. 395# 396# Arguments: 397# args strings to translate. 398# 399# Results: 400# Returns the length of the longest translated string. 401 402proc msgcat::mcmax {args} { 403 set max 0 404 foreach string $args { 405 set translated [uplevel 1 [list [namespace origin mc] $string]] 406 set len [string length $translated] 407 if {$len>$max} { 408 set max $len 409 } 410 } 411 return $max 412} 413 414# Convert the locale values stored in environment variables to a form 415# suitable for passing to [mclocale] 416proc msgcat::ConvertLocale {value} { 417 # Assume $value is of form: $language[_$territory][.$codeset][@modifier] 418 # Convert to form: $language[_$territory][_$modifier] 419 # 420 # Comment out expanded RE version -- bugs alleged 421 # regexp -expanded { 422 # ^ # Match all the way to the beginning 423 # ([^_.@]*) # Match "lanugage"; ends with _, ., or @ 424 # (_([^.@]*))? # Match (optional) "territory"; starts with _ 425 # ([.]([^@]*))? # Match (optional) "codeset"; starts with . 426 # (@(.*))? # Match (optional) "modifier"; starts with @ 427 # $ # Match all the way to the end 428 # } $value -> language _ territory _ codeset _ modifier 429 if {![regexp {^([^_.@]+)(_([^.@]*))?([.]([^@]*))?(@(.*))?$} $value \ 430 -> language _ territory _ codeset _ modifier]} { 431 return -code error "invalid locale '$value': empty language part" 432 } 433 set ret $language 434 if {[string length $territory]} { 435 append ret _$territory 436 } 437 if {[string length $modifier]} { 438 append ret _$modifier 439 } 440 return $ret 441} 442 443# Initialize the default locale 444proc msgcat::Init {} { 445 global env tcl_platform 446 447 # 448 # set default locale, try to get from environment 449 # 450 foreach varName {LC_ALL LC_MESSAGES LANG} { 451 if {[info exists env($varName)] && ("" ne $env($varName))} { 452 if {![catch { 453 mclocale [ConvertLocale $env($varName)] 454 }]} { 455 return 456 } 457 } 458 } 459 # 460 # On Darwin, fallback to current CFLocale identifier if available. 461 # 462 if {[info exists ::tcl::mac::locale] && $::tcl::mac::locale ne ""} { 463 if {![catch { 464 mclocale [ConvertLocale $::tcl::mac::locale] 465 }]} { 466 return 467 } 468 } 469 # 470 # The rest of this routine is special processing for Windows; 471 # all other platforms, get out now. 472 # 473 if {$tcl_platform(platform) ne "windows"} { 474 mclocale C 475 return 476 } 477 # 478 # On Windows, try to set locale depending on registry settings, 479 # or fall back on locale of "C". 480 # 481 set key {HKEY_CURRENT_USER\Control Panel\International} 482 if {[catch { 483 package require registry 484 set locale [registry get $key "locale"] 485 }]} { 486 mclocale C 487 return 488 } 489 # 490 # Keep trying to match against smaller and smaller suffixes 491 # of the registry value, since the latter hexadigits appear 492 # to determine general language and earlier hexadigits determine 493 # more precise information, such as territory. For example, 494 # 0409 - English - United States 495 # 0809 - English - United Kingdom 496 # Add more translations to the WinRegToISO639 array above. 497 # 498 variable WinRegToISO639 499 set locale [string tolower $locale] 500 while {[string length $locale]} { 501 if {![catch { 502 mclocale [ConvertLocale [dict get $WinRegToISO639 $locale]] 503 }]} { 504 return 505 } 506 set locale [string range $locale 1 end] 507 } 508 # 509 # No translation known. Fall back on "C" locale 510 # 511 mclocale C 512} 513msgcat::Init 514