vcs.maemo.org Git - pkg-perl/blob - deb-src/libalien-wxwidgets-perl/libalien-wxwidgets-perl-0.50/inc/Locale/Maketext/Simple.pm

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