local-lib5/lib/perl5/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