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 2006/11/03 00:34:52 hobbs Exp $ |
---|
14 | |
---|
15 | package 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. |
---|
18 | package provide msgcat 1.4.2 |
---|
19 | |
---|
20 | namespace 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 | |
---|
183 | proc 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 | |
---|
222 | proc 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 | |
---|
264 | proc 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 | |
---|
280 | proc 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 | |
---|
308 | proc 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 | |
---|
340 | proc 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 | |
---|
383 | proc 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 | |
---|
402 | proc 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] |
---|
416 | proc 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 |
---|
444 | proc msgcat::Init {} { |
---|
445 | # |
---|
446 | # set default locale, try to get from environment |
---|
447 | # |
---|
448 | foreach varName {LC_ALL LC_MESSAGES LANG} { |
---|
449 | if {[info exists ::env($varName)] && ("" ne $::env($varName))} { |
---|
450 | if {![catch { |
---|
451 | mclocale [ConvertLocale $::env($varName)] |
---|
452 | }]} { |
---|
453 | return |
---|
454 | } |
---|
455 | } |
---|
456 | } |
---|
457 | # |
---|
458 | # On Darwin, fallback to current CFLocale identifier if available. |
---|
459 | # |
---|
460 | if {$::tcl_platform(os) eq "Darwin" && $::tcl_platform(platform) eq "unix" |
---|
461 | && [info exists ::tcl::mac::locale] && $::tcl::mac::locale ne ""} { |
---|
462 | if {![catch { |
---|
463 | mclocale [ConvertLocale $::tcl::mac::locale] |
---|
464 | }]} { |
---|
465 | return |
---|
466 | } |
---|
467 | } |
---|
468 | # |
---|
469 | # The rest of this routine is special processing for Windows; |
---|
470 | # all other platforms, get out now. |
---|
471 | # |
---|
472 | if { $::tcl_platform(platform) ne "windows" } { |
---|
473 | mclocale C |
---|
474 | return |
---|
475 | } |
---|
476 | # |
---|
477 | # On Windows, try to set locale depending on registry settings, |
---|
478 | # or fall back on locale of "C". |
---|
479 | # |
---|
480 | set key {HKEY_CURRENT_USER\Control Panel\International} |
---|
481 | if {[catch {package require registry}] \ |
---|
482 | || [catch {registry get $key "locale"} locale]} { |
---|
483 | mclocale C |
---|
484 | return |
---|
485 | } |
---|
486 | # |
---|
487 | # Keep trying to match against smaller and smaller suffixes |
---|
488 | # of the registry value, since the latter hexadigits appear |
---|
489 | # to determine general language and earlier hexadigits determine |
---|
490 | # more precise information, such as territory. For example, |
---|
491 | # 0409 - English - United States |
---|
492 | # 0809 - English - United Kingdom |
---|
493 | # Add more translations to the WinRegToISO639 array above. |
---|
494 | # |
---|
495 | variable WinRegToISO639 |
---|
496 | set locale [string tolower $locale] |
---|
497 | while {[string length $locale]} { |
---|
498 | if {![catch { |
---|
499 | mclocale [ConvertLocale [dict get $WinRegToISO639 $locale]] |
---|
500 | }]} { |
---|
501 | return |
---|
502 | } |
---|
503 | set locale [string range $locale 1 end] |
---|
504 | } |
---|
505 | # |
---|
506 | # No translation known. Fall back on "C" locale |
---|
507 | # |
---|
508 | mclocale C |
---|
509 | } |
---|
510 | msgcat::Init |
---|