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