1package Locale::Maketext::Simple;
2$Locale::Maketext::Simple::VERSION = '0.21_01';
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 {
138        local @INC = @INC;
139        pop @INC if $INC[-1] eq '.';
140        require Locale::Maketext::Lexicon;
141        1
142    } or return;
143    $Locale::Maketext::Lexicon::VERSION > 0.20	    or return;
144    eval { require File::Spec; 1 }		    or return;
145
146    my $path = $args{Path} || $class->auto_path($args{Class}) or return;
147    my $pattern = File::Spec->catfile($path, '*.[pm]o');
148    my $decode = $args{Decode} || 0;
149    my $encoding = $args{Encoding} || undef;
150
151    $decode = 1 if $encoding;
152
153    $pattern =~ s{\\}{/}g; # to counter win32 paths
154
155    eval "
156	package $pkg;
157	use base 'Locale::Maketext';
158	Locale::Maketext::Lexicon->import({
159	    'i-default' => [ 'Auto' ],
160	    '*'	=> [ Gettext => \$pattern ],
161	    _decode => \$decode,
162	    _encoding => \$encoding,
163	});
164	*${pkg}::Lexicon = \\%${pkg}::i_default::Lexicon;
165	*tense = sub { \$_[1] . ((\$_[2] eq 'present') ? 'ing' : 'ed') }
166	    unless defined &tense;
167
168	1;
169    " or die $@;
170
171    my $lh = eval { $pkg->get_handle } or return;
172    my $style = lc($args{Style});
173    if ($style eq 'maketext') {
174	$Loc{$pkg} = sub {
175	    $lh->maketext(@_)
176	};
177    }
178    elsif ($style eq 'gettext') {
179	$Loc{$pkg} = sub {
180	    my $str = shift;
181            $str =~ s{([\~\[\]])}{~$1}g;
182            $str =~ s{
183                ([%\\]%)                        # 1 - escaped sequence
184            |
185                %   (?:
186                        ([A-Za-z#*]\w*)         # 2 - function call
187                            \(([^\)]*)\)        # 3 - arguments
188                    |
189                        ([1-9]\d*|\*)           # 4 - variable
190                    )
191            }{
192                $1 ? $1
193                   : $2 ? "\[$2,"._unescape($3)."]"
194                        : "[_$4]"
195            }egx;
196	    return $lh->maketext($str, @_);
197	};
198    }
199    else {
200	die "Unknown Style: $style";
201    }
202
203    return $Loc{$pkg}, sub {
204	$lh = $pkg->get_handle(@_);
205    };
206}
207
208sub default_loc {
209    my ($self, %args) = @_;
210    my $style = lc($args{Style});
211    if ($style eq 'maketext') {
212	return sub {
213	    my $str = shift;
214            $str =~ s{((?<!~)(?:~~)*)\[_([1-9]\d*|\*)\]}
215                     {$1%$2}g;
216            $str =~ s{((?<!~)(?:~~)*)\[([A-Za-z#*]\w*),([^\]]+)\]}
217                     {"$1%$2(" . _escape($3) . ')'}eg;
218	    _default_gettext($str, @_);
219	};
220    }
221    elsif ($style eq 'gettext') {
222	return \&_default_gettext;
223    }
224    else {
225	die "Unknown Style: $style";
226    }
227}
228
229sub _default_gettext {
230    my $str = shift;
231    $str =~ s{
232	%			# leading symbol
233	(?:			# either one of
234	    \d+			#   a digit, like %1
235	    |			#     or
236	    (\w+)\(		#   a function call -- 1
237		(?:		#     either
238		    %\d+	#	an interpolation
239		    |		#     or
240		    ([^,]*)	#	some string -- 2
241		)		#     end either
242		(?:		#     maybe followed
243		    ,		#       by a comma
244		    ([^),]*)	#       and a param -- 3
245		)?		#     end maybe
246		(?:		#     maybe followed
247		    ,		#       by another comma
248		    ([^),]*)	#       and a param -- 4
249		)?		#     end maybe
250		[^)]*		#     and other ignorable params
251	    \)			#   closing function call
252	)			# closing either one of
253    }{
254	my $digit = $2 || shift;
255	$digit . (
256	    $1 ? (
257		($1 eq 'tense') ? (($3 eq 'present') ? 'ing' : 'ed') :
258		($1 eq 'quant') ? ' ' . (($digit > 1) ? ($4 || "$3s") : $3) :
259		''
260	    ) : ''
261	);
262    }egx;
263    return $str;
264};
265
266sub _escape {
267    my $text = shift;
268    $text =~ s/\b_([1-9]\d*)/%$1/g;
269    return $text;
270}
271
272sub _unescape {
273    join(',', map {
274        /\A(\s*)%([1-9]\d*|\*)(\s*)\z/ ? "$1_$2$3" : $_
275    } split(/,/, $_[0]));
276}
277
278sub auto_path {
279    my ($self, $calldir) = @_;
280    $calldir =~ s#::#/#g;
281    my $path = $INC{$calldir . '.pm'} or return;
282
283    # Try absolute path name.
284    if ($^O eq 'MacOS') {
285	(my $malldir = $calldir) =~ tr#/#:#;
286	$path =~ s#^(.*)$malldir\.pm\z#$1auto:$malldir:#s;
287    } else {
288	$path =~ s#^(.*)$calldir\.pm\z#$1auto/$calldir/#;
289    }
290
291    return $path if -d $path;
292
293    # If that failed, try relative path with normal @INC searching.
294    $path = "auto/$calldir/";
295    foreach my $inc (@INC) {
296	return "$inc/$path" if -d "$inc/$path";
297    }
298
299    return;
300}
301
3021;
303
304=head1 ACKNOWLEDGMENTS
305
306Thanks to Jos I. Boumans for suggesting this module to be written.
307
308Thanks to Chia-Liang Kao for suggesting C<Path> and C<loc_lang>.
309
310=head1 SEE ALSO
311
312L<Locale::Maketext>, L<Locale::Maketext::Lexicon>
313
314=head1 AUTHORS
315
316Audrey Tang E<lt>cpan@audreyt.orgE<gt>
317
318=head1 COPYRIGHT
319
320Copyright 2003, 2004, 2005, 2006 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
321
322This software is released under the MIT license cited below.  Additionally,
323when this software is distributed with B<Perl Kit, Version 5>, you may also
324redistribute it and/or modify it under the same terms as Perl itself.
325
326=head2 The "MIT" License
327
328Permission is hereby granted, free of charge, to any person obtaining a copy
329of this software and associated documentation files (the "Software"), to deal
330in the Software without restriction, including without limitation the rights
331to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
332copies of the Software, and to permit persons to whom the Software is
333furnished to do so, subject to the following conditions:
334
335The above copyright notice and this permission notice shall be included in
336all copies or substantial portions of the Software.
337
338THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
339OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
340FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
341THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
342LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
343FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
344DEALINGS IN THE SOFTWARE.
345
346=cut
347