This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to Locale-Maketext-1.10. As change #25547 did not make it
[perl5.git] / lib / Locale / Maketext.pm
CommitLineData
9378c581 1
1189c245 2# Time-stamp: "2004-03-30 16:33:31 AST"
9378c581
JH
3
4require 5;
5package Locale::Maketext;
6use strict;
7use vars qw( @ISA $VERSION $MATCH_SUPERS $USING_LANGUAGE_TAGS
14be35aa 8 $USE_LITERALS $MATCH_SUPERS_TIGHTLY);
9378c581 9use Carp ();
1189c245 10use I18N::LangTags 0.30 ();
9378c581
JH
11
12#--------------------------------------------------------------------------
13
14BEGIN { unless(defined &DEBUG) { *DEBUG = sub () {0} } }
15 # define the constant 'DEBUG' at compile-time
16
1edf7ee9 17$VERSION = "1.10_01";
9378c581
JH
18@ISA = ();
19
20$MATCH_SUPERS = 1;
14be35aa
AMS
21$MATCH_SUPERS_TIGHTLY = 1;
22$USING_LANGUAGE_TAGS = 1;
9378c581
JH
23 # Turning this off is somewhat of a security risk in that little or no
24 # checking will be done on the legality of tokens passed to the
25 # eval("use $module_name") in _try_use. If you turn this off, you have
26 # to do your own taint checking.
27
28$USE_LITERALS = 1 unless defined $USE_LITERALS;
29 # a hint for compiling bracket-notation things.
30
31my %isa_scan = ();
32
33###########################################################################
34
35sub quant {
36 my($handle, $num, @forms) = @_;
37
38 return $num if @forms == 0; # what should this mean?
39 return $forms[2] if @forms > 2 and $num == 0; # special zeroth case
40
41 # Normal case:
42 # Note that the formatting of $num is preserved.
43 return( $handle->numf($num) . ' ' . $handle->numerate($num, @forms) );
44 # Most human languages put the number phrase before the qualified phrase.
45}
46
47
48sub numerate {
49 # return this lexical item in a form appropriate to this number
50 my($handle, $num, @forms) = @_;
51 my $s = ($num == 1);
52
53 return '' unless @forms;
54 if(@forms == 1) { # only the headword form specified
55 return $s ? $forms[0] : ($forms[0] . 's'); # very cheap hack.
56 } else { # sing and plural were specified
57 return $s ? $forms[0] : $forms[1];
58 }
59}
60
61#--------------------------------------------------------------------------
62
63sub numf {
64 my($handle, $num) = @_[0,1];
65 if($num < 10_000_000_000 and $num > -10_000_000_000 and $num == int($num)) {
66 $num += 0; # Just use normal integer stringification.
67 # Specifically, don't let %G turn ten million into 1E+007
68 } else {
69 $num = CORE::sprintf("%G", $num);
70 # "CORE::" is there to avoid confusion with the above sub sprintf.
71 }
72 while( $num =~ s/^([-+]?\d+)(\d{3})/$1,$2/s ) {1} # right from perlfaq5
73 # The initial \d+ gobbles as many digits as it can, and then we
74 # backtrack so it un-eats the rightmost three, and then we
75 # insert the comma there.
76
77 $num =~ tr<.,><,.> if ref($handle) and $handle->{'numf_comma'};
78 # This is just a lame hack instead of using Number::Format
79 return $num;
80}
81
82sub sprintf {
83 no integer;
84 my($handle, $format, @params) = @_;
85 return CORE::sprintf($format, @params);
86 # "CORE::" is there to avoid confusion with myself!
87}
88
89#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#
90
91use integer; # vroom vroom... applies to the whole rest of the module
92
93sub language_tag {
94 my $it = ref($_[0]) || $_[0];
95 return undef unless $it =~ m/([^':]+)(?:::)?$/s;
96 $it = lc($1);
97 $it =~ tr<_><->;
98 return $it;
99}
100
101sub encoding {
102 my $it = $_[0];
103 return(
104 (ref($it) && $it->{'encoding'})
105 || "iso-8859-1" # Latin-1
106 );
107}
108
109#--------------------------------------------------------------------------
110
111sub fallback_languages { return('i-default', 'en', 'en-US') }
112
113sub fallback_language_classes { return () }
114
115#--------------------------------------------------------------------------
116
117sub fail_with { # an actual attribute method!
118 my($handle, @params) = @_;
119 return unless ref($handle);
120 $handle->{'fail'} = $params[0] if @params;
121 return $handle->{'fail'};
122}
123
124#--------------------------------------------------------------------------
125
126sub failure_handler_auto {
127 # Meant to be used like:
128 # $handle->fail_with('failure_handler_auto')
129
130 my($handle, $phrase, @params) = @_;
131 $handle->{'failure_lex'} ||= {};
132 my $lex = $handle->{'failure_lex'};
133
134 my $value;
135 $lex->{$phrase} ||= ($value = $handle->_compile($phrase));
136
137 # Dumbly copied from sub maketext:
138 {
139 local $SIG{'__DIE__'};
140 eval { $value = &$value($handle, @_) };
141 }
142 # If we make it here, there was an exception thrown in the
143 # call to $value, and so scream:
144 if($@) {
145 my $err = $@;
146 # pretty up the error message
147 $err =~ s<\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?>
148 <\n in bracket code [compiled line $1],>s;
149 #$err =~ s/\n?$/\n/s;
150 Carp::croak "Error in maketexting \"$phrase\":\n$err as used";
151 # Rather unexpected, but suppose that the sub tried calling
152 # a method that didn't exist.
153 } else {
154 return $value;
155 }
156}
157
158#==========================================================================
159
160sub new {
161 # Nothing fancy!
162 my $class = ref($_[0]) || $_[0];
163 my $handle = bless {}, $class;
164 $handle->init;
165 return $handle;
166}
167
168sub init { return } # no-op
169
170###########################################################################
171
172sub maketext {
173 # Remember, this can fail. Failure is controllable many ways.
174 Carp::croak "maketext requires at least one parameter" unless @_ > 1;
175
176 my($handle, $phrase) = splice(@_,0,2);
177
5350a4e5
SH
178 # Don't interefere with $@ in case that's being interpolated into the msg.
179 local $@;
180
9378c581
JH
181 # Look up the value:
182
183 my $value;
184 foreach my $h_r (
185 @{ $isa_scan{ref($handle) || $handle} || $handle->_lex_refs }
186 ) {
187 print "* Looking up \"$phrase\" in $h_r\n" if DEBUG;
188 if(exists $h_r->{$phrase}) {
189 print " Found \"$phrase\" in $h_r\n" if DEBUG;
190 unless(ref($value = $h_r->{$phrase})) {
191 # Nonref means it's not yet compiled. Compile and replace.
192 $value = $h_r->{$phrase} = $handle->_compile($value);
193 }
194 last;
195 } elsif($phrase !~ m/^_/s and $h_r->{'_AUTO'}) {
196 # it's an auto lex, and this is an autoable key!
197 print " Automaking \"$phrase\" into $h_r\n" if DEBUG;
198
199 $value = $h_r->{$phrase} = $handle->_compile($phrase);
200 last;
201 }
202 print " Not found in $h_r, nor automakable\n" if DEBUG > 1;
203 # else keep looking
204 }
205
206 unless(defined($value)) {
207 print "! Lookup of \"$phrase\" in/under ", ref($handle) || $handle,
208 " fails.\n" if DEBUG;
209 if(ref($handle) and $handle->{'fail'}) {
210 print "WARNING0: maketext fails looking for <$phrase>\n" if DEBUG;
211 my $fail;
212 if(ref($fail = $handle->{'fail'}) eq 'CODE') { # it's a sub reference
213 return &{$fail}($handle, $phrase, @_);
214 # If it ever returns, it should return a good value.
215 } else { # It's a method name
216 return $handle->$fail($phrase, @_);
217 # If it ever returns, it should return a good value.
218 }
219 } else {
220 # All we know how to do is this;
221 Carp::croak("maketext doesn't know how to say:\n$phrase\nas needed");
222 }
223 }
224
225 return $$value if ref($value) eq 'SCALAR';
226 return $value unless ref($value) eq 'CODE';
227
228 {
229 local $SIG{'__DIE__'};
230 eval { $value = &$value($handle, @_) };
231 }
232 # If we make it here, there was an exception thrown in the
233 # call to $value, and so scream:
234 if($@) {
235 my $err = $@;
236 # pretty up the error message
237 $err =~ s<\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?>
238 <\n in bracket code [compiled line $1],>s;
239 #$err =~ s/\n?$/\n/s;
240 Carp::croak "Error in maketexting \"$phrase\":\n$err as used";
241 # Rather unexpected, but suppose that the sub tried calling
242 # a method that didn't exist.
243 } else {
244 return $value;
245 }
246}
247
248###########################################################################
249
250sub get_handle { # This is a constructor and, yes, it CAN FAIL.
251 # Its class argument has to be the base class for the current
252 # application's l10n files.
14be35aa 253
9378c581
JH
254 my($base_class, @languages) = @_;
255 $base_class = ref($base_class) || $base_class;
256 # Complain if they use __PACKAGE__ as a project base class?
1189c245
RGS
257
258 if( @languages ) {
259 DEBUG and print "Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
260 if($USING_LANGUAGE_TAGS) { # An explicit language-list was given!
261 @languages =
262 map {; $_, I18N::LangTags::alternate_language_tags($_) }
263 # Catch alternation
264 map I18N::LangTags::locale2language_tag($_),
265 # If it's a lg tag, fine, pass thru (untainted)
266 # If it's a locale ID, try converting to a lg tag (untainted),
267 # otherwise nix it.
268 @languages;
269 DEBUG and print "Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
270 }
271 } else {
272 @languages = $base_class->_ambient_langprefs;
273 }
274
14be35aa
AMS
275 @languages = $base_class->_langtag_munging(@languages);
276
277 my %seen;
278 foreach my $module_name ( map { $base_class . "::" . $_ } @languages ) {
279 next unless length $module_name; # sanity
280 next if $seen{$module_name}++ # Already been here, and it was no-go
281 || !&_try_use($module_name); # Try to use() it, but can't it.
282 return($module_name->new); # Make it!
9378c581
JH
283 }
284
14be35aa
AMS
285 return undef; # Fail!
286}
287
288###########################################################################
289
290sub _langtag_munging {
291 my($base_class, @languages) = @_;
292
1189c245
RGS
293 # We have all these DEBUG statements because otherwise it's hard as hell
294 # to diagnose ifwhen something goes wrong.
295
14be35aa 296 DEBUG and print "Lgs1: ", map("<$_>", @languages), "\n";
9378c581
JH
297
298 if($USING_LANGUAGE_TAGS) {
14be35aa 299 DEBUG and print "Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
cb0af213
AMS
300 @languages = $base_class->_add_supers( @languages );
301
1189c245
RGS
302 push @languages, I18N::LangTags::panic_languages(@languages);
303 DEBUG and print "After adding panic languages:\n",
304 " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
9378c581
JH
305
306 push @languages, $base_class->fallback_languages;
307 # You are free to override fallback_languages to return empty-list!
14be35aa 308 DEBUG and print "Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
9378c581 309
1189c245 310 @languages = # final bit of processing to turn them into classname things
9378c581
JH
311 map {
312 my $it = $_; # copy
313 $it =~ tr<-A-Z><_a-z>; # lc, and turn - to _
314 $it =~ tr<_a-z0-9><>cd; # remove all but a-z0-9_
315 $it;
316 } @languages
317 ;
14be35aa
AMS
318 DEBUG and print "Nearing end of munging:\n",
319 " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
320 } else {
321 DEBUG and print "Bypassing language-tags.\n",
322 " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
9378c581 323 }
14be35aa
AMS
324
325 DEBUG and print "Before adding fallback classes:\n",
326 " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
9378c581
JH
327
328 push @languages, $base_class->fallback_language_classes;
329 # You are free to override that to return whatever.
330
14be35aa
AMS
331 DEBUG and print "Finally:\n",
332 " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
9378c581 333
14be35aa
AMS
334 return @languages;
335}
336
337###########################################################################
338
339sub _ambient_langprefs {
1189c245
RGS
340 require I18N::LangTags::Detect;
341 return I18N::LangTags::Detect::detect();
14be35aa
AMS
342}
343
344###########################################################################
345
346sub _add_supers {
347 my($base_class, @languages) = @_;
348
349 if(!$MATCH_SUPERS) {
350 # Nothing
351 DEBUG and print "Bypassing any super-matching.\n",
352 " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
353
354 } elsif( $MATCH_SUPERS_TIGHTLY ) {
355 DEBUG and print "Before adding new supers tightly:\n",
356 " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
1189c245 357 @languages = I18N::LangTags::implicate_supers( @languages );
14be35aa
AMS
358 DEBUG and print "After adding new supers tightly:\n",
359 " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
360
361 } else {
1189c245
RGS
362 DEBUG and print "Before adding supers to end:\n",
363 " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
364 @languages = I18N::LangTags::implicate_supers_strictly( @languages );
14be35aa
AMS
365 DEBUG and print "After adding supers to end:\n",
366 " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
367 }
368
369 return @languages;
9378c581
JH
370}
371
372###########################################################################
373#
374# This is where most people should stop reading.
375#
376###########################################################################
377
f600d105
JH
378use Locale::Maketext::GutsLoader;
379
f918d677
JH
380###########################################################################
381
9378c581
JH
382my %tried = ();
383 # memoization of whether we've used this module, or found it unusable.
384
385sub _try_use { # Basically a wrapper around "require Modulename"
386 # "Many men have tried..." "They tried and failed?" "They tried and died."
387 return $tried{$_[0]} if exists $tried{$_[0]}; # memoization
388
389 my $module = $_[0]; # ASSUME sane module name!
390 { no strict 'refs';
391 return($tried{$module} = 1)
392 if defined(%{$module . "::Lexicon"}) or defined(@{$module . "::ISA"});
393 # weird case: we never use'd it, but there it is!
394 }
395
396 print " About to use $module ...\n" if DEBUG;
397 {
398 local $SIG{'__DIE__'};
399 eval "require $module"; # used to be "use $module", but no point in that.
400 }
401 if($@) {
402 print "Error using $module \: $@\n" if DEBUG > 1;
403 return $tried{$module} = 0;
404 } else {
405 print " OK, $module is used\n" if DEBUG;
406 return $tried{$module} = 1;
407 }
408}
409
410#--------------------------------------------------------------------------
411
412sub _lex_refs { # report the lexicon references for this handle's class
413 # returns an arrayREF!
414 no strict 'refs';
415 my $class = ref($_[0]) || $_[0];
416 print "Lex refs lookup on $class\n" if DEBUG > 1;
417 return $isa_scan{$class} if exists $isa_scan{$class}; # memoization!
418
419 my @lex_refs;
420 my $seen_r = ref($_[1]) ? $_[1] : {};
421
422 if( defined( *{$class . '::Lexicon'}{'HASH'} )) {
423 push @lex_refs, *{$class . '::Lexicon'}{'HASH'};
424 print "%" . $class . "::Lexicon contains ",
425 scalar(keys %{$class . '::Lexicon'}), " entries\n" if DEBUG;
426 }
427
ff5ad48a
JH
428 # Implements depth(height?)-first recursive searching of superclasses.
429 # In hindsight, I suppose I could have just used Class::ISA!
9378c581
JH
430 foreach my $superclass (@{$class . "::ISA"}) {
431 print " Super-class search into $superclass\n" if DEBUG;
432 next if $seen_r->{$superclass}++;
433 push @lex_refs, @{&_lex_refs($superclass, $seen_r)}; # call myself
434 }
435
436 $isa_scan{$class} = \@lex_refs; # save for next time
437 return \@lex_refs;
438}
439
440sub clear_isa_scan { %isa_scan = (); return; } # end on a note of simplicity!
441
442###########################################################################
4431;
444
f918d677
JH
445__END__
446
447HEY YOU! You need some FOOD!
448
449
450 ~~ Tangy Moroccan Carrot Salad ~~
451
452* 6 to 8 medium carrots, peeled and then sliced in 1/4-inch rounds
453* 1/4 teaspoon chile powder (cayenne, chipotle, ancho, or the like)
454* 1 tablespoon ground cumin
455* 1 tablespoon honey
456* The juice of about a half a big lemon, or of a whole smaller one
457* 1/3 cup olive oil
458* 1 tablespoon of fresh dill, washed and chopped fine
459* Pinch of salt, maybe a pinch of pepper
460
461Cook the carrots in a pot of boiling water until just tender -- roughly
462six minutes. (Just don't let them get mushy!) Drain the carrots.
463
464In a largish bowl, combine the lemon juice, the cumin, the chile
465powder, and the honey. Mix well.
466Add the olive oil and whisk it together well. Add the dill and stir.
467
468Add the warm carrots to the bowl and toss it all to coat the carrots
469well. Season with salt and pepper, to taste.
470
471Serve warm or at room temperature.
472
473The measurements here are very approximate, and you should feel free to
474improvise and experiment. It's a very forgiving recipe. For example,
475you could easily halve or double the amount of cumin, or use chopped mint
476leaves instead of dill, or lime juice instead of lemon, et cetera.
477
478[end]
cb0af213 479