1package Locale::Maketext::Simple;
2$Locale::Maketext::Simple::VERSION = '0.21';
3
4use strict;
5use 5.005;
6
7=head1 NAME
8
9Locale::Maketext::Simple - Simple interface to Locale::Maketext::Lexicon
10
11=head1 VERSION
12
13This document describes version 0.18 of Locale::Maketext::Simple,
14released Septermber 8, 2006.
15
16=head1 SYNOPSIS
17
18Minimal 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
27More 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
45This module is a simple wrapper around B<Locale::Maketext::Lexicon>,
46designed to alleviate the need of creating I<Language Classes> for
47module authors.
48
49The language used is chosen from the loc_lang call. If a lookup is not
50possible, the i-default language will be used. If the lookup is not in the
51i-default language, then the key will be returned.
52
53If B<Locale::Maketext::Lexicon> is not present, it implements a
54minimal localization function by simply interpolating C<[_1]> with
55the first argument, C<[_2]> with the second, etc.  Interpolated
56function like C<[quant,_1]> are treated as C<[_1]>, with the sole
57exception of C<[tense,_1,X]>, which will append C<ing> to C<_1> when
58X is C<present>, or appending C<ed> to <_1> otherwise.
59
60=head1 OPTIONS
61
62All options are passed either via the C<use> statement, or via an
63explicit C<import>.
64
65=head2 Class
66
67By default, B<Locale::Maketext::Simple> draws its source from the
68calling package's F<auto/> directory; you can override this behaviour
69by explicitly specifying another package as C<Class>.
70
71=head2 Path
72
73If your PO and MO files are under a path elsewhere than C<auto/>,
74you may specify it using the C<Path> option.
75
76=head2 Style
77
78By default, this module uses the C<maketext> style of C<[_1]> and
79C<[quant,_1]> for interpolation.  Alternatively, you can specify the
80C<gettext> style, which uses C<%1> and C<%quant(%1)> for interpolation.
81
82This option is case-insensitive.
83
84=head2 Export
85
86By default, this module exports a single function, C<loc>, into its
87caller's namespace.  You can set it to another name, or set it to
88an empty string to disable exporting.
89
90=head2 Subclass
91
92By default, this module creates an C<::I18N> subclass under the
93caller's package (or the package specified by C<Class>), and stores
94lexicon data in its subclasses.  You can assign a name other than
95C<I18N> via this option.
96
97=head2 Decode
98
99If set to a true value, source entries will be converted into
100utf8-strings (available in Perl 5.6.1 or later).  This feature
101needs the B<Encode> or B<Encode::compat> module.
102
103=head2 Encoding
104
105Specifies an encoding to store lexicon entries, instead of
106utf8-strings.  If set to C<locale>, the encoding from the current
107locale setting is used.  Implies a true value for C<Decode>.
108
109=cut
110
111sub 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
127my %Loc;
128
129sub reload_loc { %Loc = () }
130
131sub 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
203sub 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
224sub _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
261sub _escape {
262    my $text = shift;
263    $text =~ s/\b_([1-9]\d*)/%$1/g;
264    return $text;
265}
266
267sub _unescape {
268    join(',', map {
269        /\A(\s*)%([1-9]\d*|\*)(\s*)\z/ ? "$1_$2$3" : $_
270    } split(/,/, $_[0]));
271}
272
273sub 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
2971;
298
299=head1 ACKNOWLEDGMENTS
300
301Thanks to Jos I. Boumans for suggesting this module to be written.
302
303Thanks to Chia-Liang Kao for suggesting C<Path> and C<loc_lang>.
304
305=head1 SEE ALSO
306
307L<Locale::Maketext>, L<Locale::Maketext::Lexicon>
308
309=head1 AUTHORS
310
311Audrey Tang E<lt>cpan@audreyt.orgE<gt>
312
313=head1 COPYRIGHT
314
315Copyright 2003, 2004, 2005, 2006 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
316
317This software is released under the MIT license cited below.  Additionally,
318when this software is distributed with B<Perl Kit, Version 5>, you may also
319redistribute it and/or modify it under the same terms as Perl itself.
320
321=head2 The "MIT" License
322
323Permission is hereby granted, free of charge, to any person obtaining a copy
324of this software and associated documentation files (the "Software"), to deal
325in the Software without restriction, including without limitation the rights
326to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
327copies of the Software, and to permit persons to whom the Software is
328furnished to do so, subject to the following conditions:
329
330The above copyright notice and this permission notice shall be included in
331all copies or substantial portions of the Software.
332
333THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
334OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
335FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
336THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
337LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
338FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
339DEALINGS IN THE SOFTWARE.
340
341=cut
342