summaryrefslogtreecommitdiffstats
path: root/library/msgcat/msgcat.tcl
blob: e1dbd16c8d5c1c0dd14a39c4b7ee16d090800d28 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
# 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) 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.12 2002/04/19 23:09:37 dgp Exp $

package require Tcl 8.2
package provide msgcat 1.2.3

namespace eval msgcat {
    namespace export mc mcload mclocale mcmax mcmset mcpreferences mcset \
	    mcunknown

    # Records the current locale as passed to mclocale
    variable locale ""

    # Records the list of locales to search
    variable loclist {}

    # Records the mapping between source strings and translated strings.  The
    # array key is of the form "<locale>,<namespace>,<src>" and the value is
    # the translated string.
    array set msgs {}
}

# 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.
#
# Arguments:
#	src	The string to translate.
#	args	Args to pass to the format command
#
# Results:
#	Returns the translatd string.  Propagates errors thrown by the 
#	format command.

proc msgcat::mc {src args} {
    # Check for the src in each namespace starting from the local and
    # ending in the global.

    set ns [uplevel 1 [list ::namespace current]]
    
    while {$ns != ""} {
	foreach loc $::msgcat::loclist {
	    if {[info exists ::msgcat::msgs($loc,$ns,$src)]} {
		if {[llength $args] == 0} {
		    return $::msgcat::msgs($loc,$ns,$src)
		} else {
		    return [eval \
			    [list format $::msgcat::msgs($loc,$ns,$src)] \
			    $args]
		}
	    }
	}
	set ns [namespace parent $ns]
    }
    # we have not found the translation
    return [uplevel 1 [list [::namespace origin mcunknown] \
	    $::msgcat::locale $src] $args]
}

# 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 current locale.

proc msgcat::mclocale {args} {
    set len [llength $args]

    if {$len > 1} {
	error {wrong # args: should be "mclocale ?newLocale?"}
    }

    set args [string tolower $args]
    if {$len == 1} {
	set ::msgcat::locale $args
	set ::msgcat::loclist {}
	set word ""
	foreach part [split $args _] {
	    set word [string trimleft "${word}_${part}" _]
	    set ::msgcat::loclist [linsert $::msgcat::loclist 0 $word]
	}
    }
    return $::msgcat::locale
}

# 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 {} {
    return $::msgcat::loclist
}

# 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} {
    set x 0
    foreach p [::msgcat::mcpreferences] {
	set langfile [file join $langdir $p.msg]
	if {[file exists $langfile]} {
	    incr x
	    set fid [open $langfile "r"]
	    fconfigure $fid -encoding utf-8
            uplevel 1 [read $fid]
	    close $fid
	}
    }
    return $x
}

# 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 ""}} {
    if {[string equal $dest ""]} {
	set dest $src
    }

    set ns [uplevel 1 [list ::namespace current]]

    set ::msgcat::msgs([string tolower $locale],$ns,$src) $dest
    return $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 } {

    set length [llength $pairs]
    if {$length % 2} {
	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 ::msgcat::msgs($locale,$ns,$src) $dest
    }
    
    return $length
}

# msgcat::mcunknown --
#
#	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.
#
# 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 {locale src args} {
    if {[llength $args]} {
	return [eval [list format $src] $args]
    } else {
	return $src
    }
}

# msgcat::mcmax --
#
#	Calculates the maximun 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 len [string length [msgcat::mc $string]]
        if {$len>$max} {
            set max $len
        }
    }
    return $max
}

# Initialize the default locale

namespace eval msgcat {
    # set default locale, try to get from environment
    if {[info exists ::env(LANG)]} {
        mclocale $::env(LANG)
    } else {
        if { $tcl_platform(platform) == "windows" } {
            # try to set locale depending on registry settings
            #
            set key {HKEY_CURRENT_USER\Control Panel\International}
            if {[catch {package require registry}] || \
		    [catch {registry get $key "locale"} locale]} {
                mclocale "C"
            } else {
		
                #
                # Clean up registry value for translating LCID value
                # by using only the last 2 digits, since first
                # 2 digits appear to be the country...  For example
                #     0409 - English - United States
                #     0809 - English - United Kingdom
                #
                set locale [string trimleft $locale "0"]
                set locale [string range $locale end-1 end]
                set locale [string tolower $locale]
                switch -- $locale {
		    01      { mclocale "ar" }
		    02      { mclocale "bg" }
		    03      { mclocale "ca" }
		    04      { mclocale "zh" }
		    05      { mclocale "cs" }
		    06      { mclocale "da" }
		    07      { mclocale "de" }
		    08      { mclocale "el" }
		    09      { mclocale "en" }
		    0a      { mclocale "es" }
		    0b      { mclocale "fi" }
		    0c      { mclocale "fr" }
		    0d      { mclocale "he" }
		    0e      { mclocale "hu" }
		    0f      { mclocale "is" }
		    10      { mclocale "it" }
		    11      { mclocale "ja" }
		    12      { mclocale "ko" }
		    13      { mclocale "da" }
		    14      { mclocale "no" }
		    15      { mclocale "pl" }
		    16      { mclocale "pt" }
		    
		    default  { mclocale "C" }
		}
            }
        } else {
            mclocale "C"
        }
    }
}