← Back to branch summary

~kosova/+junk/tuxfamily-twiki

« back to all changes in this revision

Viewing changes to foswiki/lib/CPAN/lib/Locale/Maketext/Lexicon.pm

  • Committer: James Michael DuPont
  • Date: 2009-07-18 19:58:49 UTC
  • Revision ID: jamesmikedupont@gmail.com-20090718195849-vgbmaht2ys791uo2
added foswiki

Show diffs side-by-side

added added

removed removed

Lines of Context:
foswiki/lib/CPAN/lib/Locale/Maketext/Lexicon.pm
 
1
package Locale::Maketext::Lexicon;
 
2
$Locale::Maketext::Lexicon::VERSION = '0.49';
 
3
 
 
4
use strict;
 
5
 
 
6
=head1 NAME
 
7
 
 
8
Locale::Maketext::Lexicon - Use other catalog formats in Maketext
 
9
 
 
10
=head1 VERSION
 
11
 
 
12
This document describes version 0.49 of Locale::Maketext::Lexicon,
 
13
released April 13, 2005.
 
14
 
 
15
=head1 SYNOPSIS
 
16
 
 
17
As part of a localization class, automatically glob for available
 
18
lexicons:
 
19
 
 
20
    package Hello::I18N;
 
21
    use base 'Locale::Maketext';
 
22
    use Locale::Maketext::Lexicon {
 
23
        '*' => [Gettext => '/usr/local/share/locale/*/LC_MESSAGES/hello.mo'],
 
24
        _decode => 1,   # decode lexicon entries into utf8-strings
 
25
    };
 
26
 
 
27
Explicitly specify languages, during compile- or run-time:
 
28
 
 
29
    package Hello::I18N;
 
30
    use base 'Locale::Maketext';
 
31
    use Locale::Maketext::Lexicon {
 
32
        de => [Gettext => 'hello_de.po'],
 
33
        fr => [
 
34
            Gettext => 'hello_fr.po',
 
35
            Gettext => 'local/hello/fr.po',
 
36
        ],
 
37
    };
 
38
    # ... incrementally add new lexicons
 
39
    Locale::Maketext::Lexicon->import({
 
40
        de => [Gettext => 'local/hello/de.po'],
 
41
    })
 
42
 
 
43
Alternatively, as part of a localization subclass:
 
44
 
 
45
    package Hello::I18N::de;
 
46
    use base 'Hello::I18N';
 
47
    use Locale::Maketext::Lexicon (Gettext => \*DATA);
 
48
    __DATA__
 
49
    # Some sample data
 
50
    msgid ""
 
51
    msgstr ""
 
52
    "Project-Id-Version: Hello 1.3.22.1\n"
 
53
    "MIME-Version: 1.0\n"
 
54
    "Content-Type: text/plain; charset=iso8859-1\n"
 
55
    "Content-Transfer-Encoding: 8bit\n"
 
56
 
 
57
    #: Hello.pm:10
 
58
    msgid "Hello, World!"
 
59
    msgstr "Hallo, Welt!"
 
60
 
 
61
    #: Hello.pm:11
 
62
    msgid "You have %quant(%1,piece) of mail."
 
63
    msgstr "Sie haben %quant(%1,Poststueck,Poststuecken)."
 
64
 
 
65
=head1 DESCRIPTION
 
66
 
 
67
This module provides lexicon-handling modules to read from other
 
68
localization formats, such as I<Gettext>, I<Msgcat>, and so on.
 
69
 
 
70
If you are unfamiliar with the concept of lexicon modules, please
 
71
consult L<Locale::Maketext> and L<http://www.autrijus.org/webl10n/>
 
72
first.
 
73
 
 
74
A command-line utility L<xgettext.pl> is also installed with this
 
75
module, for extracting translatable strings from source files.
 
76
 
 
77
=head2 The C<import> function
 
78
 
 
79
The C<import()> function accepts two forms of arguments:
 
80
 
 
81
=over 4
 
82
 
 
83
=item (I<format> => I<source> ... )
 
84
 
 
85
This form takes any number of argument pairs (usually one);
 
86
I<source> may be a file name, a filehandle, or an array reference.
 
87
 
 
88
For each such pair, it pass the contents specified by the second
 
89
argument to B<Locale::Maketext::Lexicon::I<format>>->parse as a
 
90
plain list, and export its return value as the C<%Lexicon> hash
 
91
in the calling package.
 
92
 
 
93
In the case that there are multiple such pairs, the lexicon
 
94
defined by latter ones overrides earlier ones.
 
95
 
 
96
=item { I<language> => [ I<format>, I<source> ... ] ... }
 
97
 
 
98
This form accepts a hash reference.  It will export a C<%Lexicon>
 
99
into the subclasses specified by each I<language>, using the process
 
100
described above.  It is designed to alleviate the need to set up a
 
101
separate subclass for each localized language, and just use the catalog
 
102
files.
 
103
 
 
104
This module will convert the I<language> arguments into lowercase,
 
105
and replace all C<-> with C<_>, so C<zh_TW> and C<zh-tw> will both
 
106
map to the C<zh_tw> subclass.
 
107
 
 
108
If I<language> begins with C<_>, it is taken as an option that
 
109
controls how lexicons are parsed.  See L</Options> for a list
 
110
of available options.
 
111
 
 
112
The C<*> is a special I<language>; it must be used in conjunction
 
113
with a filename that also contains C<*>; all matched files with
 
114
a valid language code in the place of C<*> will be automatically
 
115
prepared as a lexicon subclass.  If there is multiple C<*> in
 
116
the filename, the last one is used as the language name.
 
117
 
 
118
=back
 
119
 
 
120
=head2 Options
 
121
 
 
122
=over 4
 
123
 
 
124
=item C<_decode>
 
125
 
 
126
If set to a true value, source entries will be converted into
 
127
utf8-strings (available in Perl 5.6.1 or later).  This feature
 
128
needs the B<Encode> or B<Encode::compat> module.
 
129
 
 
130
Currently, only the C<Gettext> backend supports this option.
 
131
 
 
132
=item C<_encoding>
 
133
 
 
134
This option only has effect when C<_decode> is set to true.
 
135
It specifies an encoding to store lexicon entries, instead of
 
136
utf8-strings.
 
137
 
 
138
If C<_encoding> is set to C<locale>, the encoding from the
 
139
current locale setting is used.
 
140
 
 
141
=head2 Subclassing format handlers
 
142
 
 
143
If you wish to override how sources specified in different data types
 
144
are handled, please use a subclass that overrides C<lexicon_get_I<TYPE>>.
 
145
 
 
146
XXX: not documented well enough yet.  Patches welcome.
 
147
 
 
148
=head1 NOTES
 
149
 
 
150
When you attempt to localize an entry missing in the lexicon, Maketext
 
151
will throw an exception by default.  To inhibit this behaviour, override
 
152
the C<_AUTO> key in your language subclasses, for example:
 
153
 
 
154
    $Hello::I18N::en::Lexicon{_AUTO} = 1; # autocreate missing keys
 
155
 
 
156
If you want to implement a new C<Lexicon::*> backend module, please note
 
157
that C<parse()> takes an array containing the B<source strings> from the
 
158
specified filehandle or filename, which are I<not> C<chomp>ed.  Although
 
159
if the source is an array reference, its elements will probably not contain
 
160
any newline characters anyway.
 
161
 
 
162
The C<parse()> function should return a hash reference, which will be
 
163
assigned to the I<typeglob> (C<*Lexicon>) of the language module.  All
 
164
it amounts to is that if the returned reference points to a tied hash,
 
165
the C<%Lexicon> will be aliased to the same tied hash if it was not
 
166
initialized previously.
 
167
 
 
168
=cut
 
169
 
 
170
our %Opts;
 
171
sub option { shift if ref($_[0]); $Opts{lc $_[0]} }
 
172
sub set_option { shift if ref($_[0]); $Opts{lc $_[0]} = $_[1] }
 
173
 
 
174
sub encoding {
 
175
    my $encoding = option(@_, 'encoding') or return;
 
176
    return $encoding unless lc($encoding) eq 'locale';
 
177
 
 
178
    no warnings 'uninitialized';
 
179
    my ($country_language, $locale_encoding);
 
180
 
 
181
    local $@;
 
182
    eval {
 
183
        require I18N::Langinfo;
 
184
        $locale_encoding = I18N::Langinfo::langinfo(I18N::Langinfo::CODESET());
 
185
    } or eval {
 
186
        require Win32::Console;
 
187
        $locale_encoding = 'cp'.Win32::Console::OutputCP();
 
188
    };
 
189
    if (!$locale_encoding) {
 
190
        foreach my $key (qw( LANGUAGE LC_ALL LC_MESSAGES LANG )) {
 
191
            $ENV{$key} =~ /^([^.]+)\.([^.:]+)/ or next;
 
192
            ($country_language, $locale_encoding) = ($1, $2);
 
193
            last;
 
194
        }
 
195
    }
 
196
    if (defined $locale_encoding &&
 
197
        lc($locale_encoding) eq 'euc' &&
 
198
        defined $country_language) {
 
199
        if ($country_language =~ /^ja_JP|japan(?:ese)?$/i) {
 
200
            $locale_encoding = 'euc-jp';
 
201
        } elsif ($country_language =~ /^ko_KR|korean?$/i) {
 
202
            $locale_encoding = 'euc-kr';
 
203
        } elsif ($country_language =~ /^zh_CN|chin(?:a|ese)?$/i) {
 
204
            $locale_encoding = 'euc-cn';
 
205
        } elsif ($country_language =~ /^zh_TW|taiwan(?:ese)?$/i) {
 
206
            $locale_encoding = 'euc-tw';
 
207
        }
 
208
    }
 
209
 
 
210
    return $locale_encoding;
 
211
}
 
212
 
 
213
sub import {
 
214
    my $class = shift;
 
215
    return unless @_;
 
216
 
 
217
    my %entries;
 
218
    if (UNIVERSAL::isa($_[0], 'HASH')) {
 
219
        # a hashref with $lang as keys, [$format, $src ...] as values
 
220
        %entries = %{$_[0]};
 
221
    }
 
222
    elsif (@_ % 2) {
 
223
        %entries = ( '' => [ @_ ] );
 
224
    }
 
225
 
 
226
    # expand the wildcard entry
 
227
    if (my $wild_entry = delete $entries{'*'}) {
 
228
        while (my ($format, $src) = splice(@$wild_entry, 0, 2)) {
 
229
            next if ref($src); # XXX: implement globbing for the 'Tie' backend
 
230
 
 
231
            my $pattern = quotemeta($src);
 
232
            $pattern =~ s/\\\*(?=[^*]+$)/\([-\\w]+\)/g or next;
 
233
            $pattern =~ s/\\\*/.*?/g;
 
234
            $pattern =~ s/\\\?/./g;
 
235
            $pattern =~ s/\\\[/[/g;
 
236
            $pattern =~ s/\\\]/]/g;
 
237
            $pattern =~ s[\\\{(.*?)\\\\}][
 
238
                '(?:'.join('|', split(/,/, $1)).')'
 
239
            ]eg;
 
240
 
 
241
            require File::Glob;
 
242
            foreach my $file (File::Glob::bsd_glob($src)) {
 
243
                $file =~ /$pattern/ or next;
 
244
                push @{$entries{$1}}, ($format => $file) if $1;
 
245
            }
 
246
            delete $entries{$1}
 
247
                unless !defined($1)
 
248
                    or exists $entries{$1} and @{$entries{$1}};
 
249
        }
 
250
    }
 
251
 
 
252
    %Opts = ();
 
253
    foreach my $key (grep /^_/, keys %entries) {
 
254
        set_option(lc(substr($key, 1)) => delete($entries{$key}));
 
255
    }
 
256
    my $OptsRef = { %Opts };
 
257
 
 
258
    while (my ($lang, $entry) = each %entries) {
 
259
        my $export = caller;
 
260
 
 
261
        if (length $lang) {
 
262
            # normalize language tag to Maketext's subclass convention
 
263
            $lang = lc($lang);
 
264
            $lang =~ s/-/_/g;
 
265
            $export .= "::$lang";
 
266
        }
 
267
 
 
268
        my @pairs = @{$entry||[]} or die "no format specified";
 
269
 
 
270
        while (my ($format, $src) = splice(@pairs, 0, 2)) {
 
271
            if (defined($src) and !ref($src) and $src =~ /\*/) {
 
272
                unshift(@pairs, $format => $_) for File::Glob::bsd_glob($src);
 
273
                next;
 
274
            }
 
275
 
 
276
            local $@;
 
277
            my @content = eval {
 
278
                $class->lexicon_get($src, scalar caller, $lang);
 
279
            };
 
280
            next if $@ and $@ eq 'next';
 
281
            die $@ if $@;
 
282
 
 
283
            no strict 'refs';
 
284
            eval "use $class\::$format; 1" or die $@;
 
285
 
 
286
            if (defined %{"$export\::Lexicon"}) {
 
287
                if (ref(tied %{"$export\::Lexicon"}) eq __PACKAGE__) {
 
288
                    tied(%{"$export\::Lexicon"})->_force;
 
289
                }
 
290
                # be very careful not to pollute the possibly tied lexicon
 
291
                *{"$export\::Lexicon"} = {
 
292
                    %{"$export\::Lexicon"},
 
293
                    %{"$class\::$format"->parse(@content)},
 
294
                };
 
295
            }
 
296
            else {
 
297
                my $promise;
 
298
                tie %{"$export\::Lexicon"}, __PACKAGE__, {
 
299
                    Opts => $OptsRef,
 
300
                    Export => "$export\::Lexicon",
 
301
                    Class => "$class\::$format",
 
302
                    Content => \@content,
 
303
                };
 
304
            }
 
305
 
 
306
            push(@{"$export\::ISA"}, scalar caller) if length $lang;
 
307
        }
 
308
    }
 
309
}
 
310
 
 
311
sub TIEHASH {
 
312
    my ($class, $args) = @_;
 
313
    return bless($args, $class);
 
314
 
 
315
}
 
316
 
 
317
{
 
318
    no strict 'refs';
 
319
    sub _force {
 
320
        my $args = shift;
 
321
        if (!$args->{Done}++) {
 
322
            local *Opts = $args->{Opts};
 
323
            *{$args->{Export}} = $args->{Class}->parse(@{$args->{Content}});
 
324
        }
 
325
        return \%{$args->{Export}};
 
326
    }
 
327
    sub FETCH { _force($_[0])->{$_[1]} }
 
328
    sub EXISTS { _force($_[0])->{$_[1]} }
 
329
    sub DELETE { delete _force($_[0])->{$_[1]} }
 
330
    sub SCALAR { scalar %{_force($_[0])} }
 
331
    sub STORE { _force($_[0])->{$_[1]} = $_[2] }
 
332
    sub CLEAR { %{_force($_[0])->{$_[1]}} = () }
 
333
    sub NEXTKEY { each %{_force($_[0])} }
 
334
    sub FIRSTKEY {
 
335
        my $hash = _force($_[0]);
 
336
        my $a = scalar keys %$hash;
 
337
        each %$hash;
 
338
    }
 
339
}
 
340
 
 
341
sub lexicon_get {
 
342
    my ($class, $src, $caller, $lang) = @_;
 
343
    return unless defined $src;
 
344
 
 
345
    foreach my $type (qw(ARRAY HASH SCALAR GLOB), ref($src)) {
 
346
        next unless UNIVERSAL::isa($src, $type);
 
347
 
 
348
        my $method = 'lexicon_get_' . lc($type);
 
349
        die "cannot handle source $type for $src: no $method defined"
 
350
            unless $class->can($method);
 
351
 
 
352
        return $class->$method($src, $caller, $lang);
 
353
    }
 
354
 
 
355
    # default handler
 
356
    return $class->lexicon_get_($src, $caller, $lang);
 
357
}
 
358
 
 
359
# for scalarrefs and arrayrefs we just dereference the $src
 
360
sub lexicon_get_scalar { ${$_[1]} }
 
361
sub lexicon_get_array  { @{$_[1]} }
 
362
 
 
363
sub lexicon_get_hash   {
 
364
    my ($class, $src, $caller, $lang) = @_;
 
365
    return map { $_ => $src->{$_} } sort keys %$src;
 
366
}
 
367
 
 
368
sub lexicon_get_glob   {
 
369
    my ($class, $src, $caller, $lang) = @_;
 
370
 
 
371
    no strict 'refs';
 
372
 
 
373
    # be extra magical and check for DATA section
 
374
    if (eof($src) and $src eq \*{"$caller\::DATA"} or $src eq \*{"main\::DATA"}) {
 
375
        # okay, the *DATA isn't initiated yet. let's read.
 
376
        #
 
377
        require FileHandle;
 
378
        my $fh = FileHandle->new;
 
379
        my $package = ( ($src eq \*{"main\::DATA"}) ? 'main' : $caller );
 
380
 
 
381
        if ( $package eq 'main' and -e $0 ) {
 
382
            $fh->open($0) or die "Can't open $0: $!";
 
383
        }
 
384
        else {
 
385
            my $level = 1;
 
386
            while ( my ($pkg, $filename) = caller($level++) ) {
 
387
                next unless $pkg eq $package;
 
388
                next unless -e $filename;
 
389
                next;
 
390
 
 
391
                $fh->open($filename) or die "Can't open $filename: $!";
 
392
                last;
 
393
            }
 
394
        }
 
395
 
 
396
        while (<$fh>) {
 
397
            # okay, this isn't foolproof, but good enough
 
398
            last if /^__DATA__$/;
 
399
        }
 
400
 
 
401
        return <$fh>;
 
402
    }
 
403
 
 
404
    # fh containing the lines
 
405
    my $pos = tell($src);
 
406
    my @lines = <$src>;
 
407
    seek($src, $pos, 0);
 
408
    return @lines;
 
409
}
 
410
 
 
411
# assume filename - search path, open and return its contents
 
412
sub lexicon_get_ {
 
413
    my ($class, $src, $caller, $lang) = @_;
 
414
 
 
415
    require FileHandle;
 
416
    require File::Spec;
 
417
 
 
418
    my $fh = FileHandle->new;
 
419
    my @path = split('::', $caller);
 
420
    push @path, $lang if length $lang;
 
421
 
 
422
    $src = (grep { -e } map {
 
423
        my @subpath = @path[0..$_];
 
424
        map { File::Spec->catfile($_, @subpath, $src) } @INC;
 
425
    } -1 .. $#path)[-1] unless -e $src;
 
426
 
 
427
    defined $src or die 'next';
 
428
 
 
429
    $fh->open($src) or die "Cannot read $src (called by $caller): $!";
 
430
    binmode($fh);
 
431
    return <$fh>;
 
432
}
 
433
 
 
434
1;
 
435
 
 
436
=head1 ACKNOWLEDGMENTS
 
437
 
 
438
Thanks to Jesse Vincent for suggesting this module to be written.
 
439
 
 
440
Thanks also to Sean M. Burke for coming up with B<Locale::Maketext>
 
441
in the first place, and encouraging me to experiment with alternative
 
442
Lexicon syntaxes.
 
443
 
 
444
Thanks also to Yi Ma Mao for providing the MO file parsing subroutine,
 
445
as well as inspiring me to implement file globbing and transcoding
 
446
support.
 
447
 
 
448
See the F<AUTHORS> file in the distribution for a list of people who
 
449
have sent helpful patches, ideas or comments.
 
450
 
 
451
=head1 SEE ALSO
 
452
 
 
453
L<xgettext.pl> for extracting translatable strings from common template
 
454
systems and perl source files.
 
455
 
 
456
L<Locale::Maketext>, L<Locale::Maketext::Lexicon::Auto>,
 
457
L<Locale::Maketext::Lexicon::Gettext>, L<Locale::Maketext::Lexicon::Msgcat>,
 
458
L<Locale::Maketext::Lexicon::Tie>
 
459
 
 
460
=head1 AUTHORS
 
461
 
 
462
Autrijus Tang E<lt>autrijus@autrijus.orgE<gt>
 
463
 
 
464
=head1 COPYRIGHT
 
465
 
 
466
Copyright 2002, 2003, 2004, 2005 by Autrijus Tang E<lt>autrijus@autrijus.orgE<gt>.
 
467
 
 
468
This program is free software; you can redistribute it and/or 
 
469
modify it under the same terms as Perl itself.
 
470
 
 
471
See L<http://www.perl.com/perl/misc/Artistic.html>
 
472
 
 
473
=cut