Move Locale::Maketext::Simple from ext/ to dist/
[perl.git] / dist / Locale-Maketext-Simple / lib / Locale / Maketext / Simple.pm
1 package Locale::Maketext::Simple;
2 $Locale::Maketext::Simple::VERSION = '0.21';
3
4 use strict;
5 use 5.005;
6
7 =head1 NAME
8
9 Locale::Maketext::Simple - Simple interface to Locale::Maketext::Lexicon
10
11 =head1 VERSION
12
13 This document describes version 0.18 of Locale::Maketext::Simple,
14 released Septermber 8, 2006.
15
16 =head1 SYNOPSIS
17
18 Minimal setup (looks for F<auto/Foo/*.po> and F<auto/Foo/*.mo>):
19
20     package Foo;
21     use Locale::Maketext::Simple;       # exports 'loc'
22     loc_lang('fr');                     # set language to French
23     sub hello {
24         print loc("Hello, [_1]!", "World");
25     }
26
27 More sophisticated example:
28
29     package Foo::Bar;
30     use Locale::Maketext::Simple (
31         Class       => 'Foo',       # search in auto/Foo/
32         Style       => 'gettext',   # %1 instead of [_1]
33         Export      => 'maketext',  # maketext() instead of loc()
34         Subclass    => 'L10N',      # Foo::L10N instead of Foo::I18N
35         Decode      => 1,           # decode entries to unicode-strings
36         Encoding    => 'locale',    # but encode lexicons in current locale
37                                     # (needs Locale::Maketext::Lexicon 0.36)
38     );
39     sub japh {
40         print maketext("Just another %1 hacker", "Perl");
41     }
42
43 =head1 DESCRIPTION
44
45 This module is a simple wrapper around B<Locale::Maketext::Lexicon>,
46 designed to alleviate the need of creating I<Language Classes> for
47 module authors.
48
49 The language used is chosen from the loc_lang call. If a lookup is not
50 possible, the i-default language will be used. If the lookup is not in the
51 i-default language, then the key will be returned.
52
53 If B<Locale::Maketext::Lexicon> is not present, it implements a
54 minimal localization function by simply interpolating C<[_1]> with
55 the first argument, C<[_2]> with the second, etc.  Interpolated
56 function like C<[quant,_1]> are treated as C<[_1]>, with the sole
57 exception of C<[tense,_1,X]>, which will append C<ing> to C<_1> when
58 X is C<present>, or appending C<ed> to <_1> otherwise.
59
60 =head1 OPTIONS
61
62 All options are passed either via the C<use> statement, or via an
63 explicit C<import>.
64
65 =head2 Class
66
67 By default, B<Locale::Maketext::Simple> draws its source from the
68 calling package's F<auto/> directory; you can override this behaviour
69 by explicitly specifying another package as C<Class>.
70
71 =head2 Path
72
73 If your PO and MO files are under a path elsewhere than C<auto/>,
74 you may specify it using the C<Path> option.
75
76 =head2 Style
77
78 By default, this module uses the C<maketext> style of C<[_1]> and
79 C<[quant,_1]> for interpolation.  Alternatively, you can specify the
80 C<gettext> style, which uses C<%1> and C<%quant(%1)> for interpolation.
81
82 This option is case-insensitive.
83
84 =head2 Export
85
86 By default, this module exports a single function, C<loc>, into its
87 caller's namespace.  You can set it to another name, or set it to
88 an empty string to disable exporting.
89
90 =head2 Subclass
91
92 By default, this module creates an C<::I18N> subclass under the
93 caller's package (or the package specified by C<Class>), and stores
94 lexicon data in its subclasses.  You can assign a name other than
95 C<I18N> via this option.
96
97 =head2 Decode
98
99 If set to a true value, source entries will be converted into
100 utf8-strings (available in Perl 5.6.1 or later).  This feature
101 needs the B<Encode> or B<Encode::compat> module.
102
103 =head2 Encoding
104
105 Specifies an encoding to store lexicon entries, instead of
106 utf8-strings.  If set to C<locale>, the encoding from the current
107 locale setting is used.  Implies a true value for C<Decode>.
108
109 =cut
110
111 sub import {
112     my ($class, %args) = @_;
113
114     $args{Class}    ||= caller;
115     $args{Style}    ||= 'maketext';
116     $args{Export}   ||= 'loc';
117     $args{Subclass} ||= 'I18N';
118
119     my ($loc, $loc_lang) = $class->load_loc(%args);
120     $loc ||= $class->default_loc(%args);
121
122     no strict 'refs';
123     *{caller(0) . "::$args{Export}"} = $loc if $args{Export};
124     *{caller(0) . "::$args{Export}_lang"} = $loc_lang || sub { 1 };
125 }
126
127 my %Loc;
128
129 sub reload_loc { %Loc = () }
130
131 sub load_loc {
132     my ($class, %args) = @_;
133
134     my $pkg = join('::', grep { defined and length } $args{Class}, $args{Subclass});
135     return $Loc{$pkg} if exists $Loc{$pkg};
136
137     eval { require Locale::Maketext::Lexicon; 1 }   or return;
138     $Locale::Maketext::Lexicon::VERSION > 0.20      or return;
139     eval { require File::Spec; 1 }                  or return;
140
141     my $path = $args{Path} || $class->auto_path($args{Class}) or return;
142     my $pattern = File::Spec->catfile($path, '*.[pm]o');
143     my $decode = $args{Decode} || 0;
144     my $encoding = $args{Encoding} || undef;
145
146     $decode = 1 if $encoding;
147
148     $pattern =~ s{\\}{/}g; # to counter win32 paths
149
150     eval "
151         package $pkg;
152         use base 'Locale::Maketext';
153         Locale::Maketext::Lexicon->import({
154             'i-default' => [ 'Auto' ],
155             '*' => [ Gettext => \$pattern ],
156             _decode => \$decode,
157             _encoding => \$encoding,
158         });
159         *${pkg}::Lexicon = \\%${pkg}::i_default::Lexicon;
160         *tense = sub { \$_[1] . ((\$_[2] eq 'present') ? 'ing' : 'ed') }
161             unless defined &tense;
162
163         1;
164     " or die $@;
165
166     my $lh = eval { $pkg->get_handle } or return;
167     my $style = lc($args{Style});
168     if ($style eq 'maketext') {
169         $Loc{$pkg} = sub {
170             $lh->maketext(@_)
171         };
172     }
173     elsif ($style eq 'gettext') {
174         $Loc{$pkg} = sub {
175             my $str = shift;
176             $str =~ s{([\~\[\]])}{~$1}g;
177             $str =~ s{
178                 ([%\\]%)                        # 1 - escaped sequence
179             |
180                 %   (?:
181                         ([A-Za-z#*]\w*)         # 2 - function call
182                             \(([^\)]*)\)        # 3 - arguments
183                     |
184                         ([1-9]\d*|\*)           # 4 - variable
185                     )
186             }{
187                 $1 ? $1
188                    : $2 ? "\[$2,"._unescape($3)."]"
189                         : "[_$4]"
190             }egx;
191             return $lh->maketext($str, @_);
192         };
193     }
194     else {
195         die "Unknown Style: $style";
196     }
197
198     return $Loc{$pkg}, sub {
199         $lh = $pkg->get_handle(@_);
200     };
201 }
202
203 sub default_loc {
204     my ($self, %args) = @_;
205     my $style = lc($args{Style});
206     if ($style eq 'maketext') {
207         return sub {
208             my $str = shift;
209             $str =~ s{((?<!~)(?:~~)*)\[_([1-9]\d*|\*)\]}
210                      {$1%$2}g;
211             $str =~ s{((?<!~)(?:~~)*)\[([A-Za-z#*]\w*),([^\]]+)\]}
212                      {"$1%$2(" . _escape($3) . ')'}eg;
213             _default_gettext($str, @_);
214         };
215     }
216     elsif ($style eq 'gettext') {
217         return \&_default_gettext;
218     }
219     else {
220         die "Unknown Style: $style";
221     }
222 }
223
224 sub _default_gettext {
225     my $str = shift;
226     $str =~ s{
227         %                       # leading symbol
228         (?:                     # either one of
229             \d+                 #   a digit, like %1
230             |                   #     or
231             (\w+)\(             #   a function call -- 1
232                 (?:             #     either
233                     %\d+        #       an interpolation
234                     |           #     or
235                     ([^,]*)     #       some string -- 2
236                 )               #     end either
237                 (?:             #     maybe followed
238                     ,           #       by a comma
239                     ([^),]*)    #       and a param -- 3
240                 )?              #     end maybe
241                 (?:             #     maybe followed
242                     ,           #       by another comma
243                     ([^),]*)    #       and a param -- 4
244                 )?              #     end maybe
245                 [^)]*           #     and other ignorable params
246             \)                  #   closing function call
247         )                       # closing either one of
248     }{
249         my $digit = $2 || shift;
250         $digit . (
251             $1 ? (
252                 ($1 eq 'tense') ? (($3 eq 'present') ? 'ing' : 'ed') :
253                 ($1 eq 'quant') ? ' ' . (($digit > 1) ? ($4 || "$3s") : $3) :
254                 ''
255             ) : ''
256         );
257     }egx;
258     return $str;
259 };
260
261 sub _escape {
262     my $text = shift;
263     $text =~ s/\b_([1-9]\d*)/%$1/g;
264     return $text;
265 }
266
267 sub _unescape {
268     join(',', map {
269         /\A(\s*)%([1-9]\d*|\*)(\s*)\z/ ? "$1_$2$3" : $_
270     } split(/,/, $_[0]));
271 }
272
273 sub auto_path {
274     my ($self, $calldir) = @_;
275     $calldir =~ s#::#/#g;
276     my $path = $INC{$calldir . '.pm'} or return;
277
278     # Try absolute path name.
279     if ($^O eq 'MacOS') {
280         (my $malldir = $calldir) =~ tr#/#:#;
281         $path =~ s#^(.*)$malldir\.pm\z#$1auto:$malldir:#s;
282     } else {
283         $path =~ s#^(.*)$calldir\.pm\z#$1auto/$calldir/#;
284     }
285
286     return $path if -d $path;
287
288     # If that failed, try relative path with normal @INC searching.
289     $path = "auto/$calldir/";
290     foreach my $inc (@INC) {
291         return "$inc/$path" if -d "$inc/$path";
292     }
293
294     return;
295 }
296
297 1;
298
299 =head1 ACKNOWLEDGMENTS
300
301 Thanks to Jos I. Boumans for suggesting this module to be written.
302
303 Thanks to Chia-Liang Kao for suggesting C<Path> and C<loc_lang>.
304
305 =head1 SEE ALSO
306
307 L<Locale::Maketext>, L<Locale::Maketext::Lexicon>
308
309 =head1 AUTHORS
310
311 Audrey Tang E<lt>cpan@audreyt.orgE<gt>
312
313 =head1 COPYRIGHT
314
315 Copyright 2003, 2004, 2005, 2006 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
316
317 This software is released under the MIT license cited below.  Additionally,
318 when this software is distributed with B<Perl Kit, Version 5>, you may also
319 redistribute it and/or modify it under the same terms as Perl itself.
320
321 =head2 The "MIT" License
322
323 Permission is hereby granted, free of charge, to any person obtaining a copy
324 of this software and associated documentation files (the "Software"), to deal
325 in the Software without restriction, including without limitation the rights
326 to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
327 copies of the Software, and to permit persons to whom the Software is
328 furnished to do so, subject to the following conditions:
329
330 The above copyright notice and this permission notice shall be included in
331 all copies or substantial portions of the Software.
332
333 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
334 OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
335 FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
336 THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
337 LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
338 FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
339 DEALINGS IN THE SOFTWARE.
340
341 =cut