package CGI::Kwiki::I18N;
use strict;
use vars '@ISA';
my $init;
sub initialize {
my ($self, $use_utf8) = @_;
return if $init++;
eval { require Locale::Maketext; 1 } or return;
@ISA = ('Locale::Maketext');
$self->_import(
Class => 'CGI::Kwiki',
Style => 'gettext',
Export => 'gettext',
Path => substr(__FILE__, 0, -3),
Decode => 1,
Fail => !$use_utf8,
);
}
sub loc {
my $self = shift;
$self->initialize($] >= 5.008);
gettext_lang();
return gettext(@_);
}
sub _import {
my ($class, %args) = @_;
$args{Class} ||= caller;
$args{Style} ||= 'maketext';
$args{Export} ||= 'loc';
$args{Subclass} ||= 'I18N';
my ($loc, $loc_lang) = $class->load_loc(%args);
$loc ||= $class->default_loc(%args);
no strict 'refs';
*{caller(0) . "::$args{Export}"} = $loc if $args{Export};
*{caller(0) . "::$args{Export}_lang"} = $loc_lang || sub { 1 };
}
my %Loc;
sub load_loc {
my ($class, %args) = @_;
return if $args{Fail};
my $pkg = join('::', $args{Class}, $args{Subclass});
return $Loc{$pkg} if exists $Loc{$pkg};
eval { require File::Spec; 1 } or return;
my $path = $args{Path} || $class->auto_path($args{Class}) or return;
my $pattern = File::Spec->catfile($path, '*.[pm]o');
my $decode = $args{Decode} || 0;
$pattern =~ s{\\}{/}g; # to counter win32 paths
eval "
package $pkg;
use base 'Locale::Maketext';
%${pkg}::Lexicon = ( '_AUTO' => 1 );
CGI::Kwiki::I18N::Lexicon->import({
'*' => [ Gettext => \$pattern ],
_decode => \$decode,
});
1;
" or die $@;
my $lh = eval { $pkg->get_handle } or return;
my $style = lc($args{Style});
if ($style eq 'maketext') {
$Loc{$pkg} = $lh->can('maketext');
}
elsif ($style eq 'gettext') {
$Loc{$pkg} = sub {
my $str = shift;
$str =~ s/[\~\[\]]/~$&/g;
$str =~ s{(^|[^%\\])%([A-Za-z#*]\w*)\(([^\)]*)\)}
{"$1\[$2,"._unescape($3)."]"}eg;
$str =~ s/(^|[^%\\])%(\d+|\*)/$1\[_$2]/g;
return $lh->maketext($str, @_);
};
}
else {
die "Unknown Style: $style";
}
return $Loc{$pkg}, sub {
$lh = $pkg->get_handle(@_);
$lh = $pkg->get_handle(@_);
};
}
sub default_loc {
my ($self, %args) = @_;
my $style = lc($args{Style});
if ($style eq 'maketext') {
return sub {
my $str = shift;
$str =~ s/((?<!~)(?:~~)*)\[_(\d+)\]/$1%$2/g;
$str =~ s{((?<!~)(?:~~)*)\[([A-Za-z#*]\w*),([^\]]+)\]}
{"$1%$2("._escape($3).")"}eg;
$str =~ s/~([\[\]])/$1/g;
_default_gettext($str, @_);
};
}
elsif ($style eq 'gettext') {
return \&_default_gettext;
}
else {
die "Unknown Style: $style";
}
}
sub _default_gettext {
my $str = shift;
$str =~ s{
% # leading symbol
(?: # either one of
\d+ # a digit, like %1
| # or
(\w+)\( # a function call -- 1
%\d+ # with a digit
(?: # maybe followed
, # by a comma
([^),]*) # and a param -- 2
)? # end maybe
(?: # maybe followed
, # by another comma
([^),]*) # and a param -- 3
)? # end maybe
[^)]* # and other ignorable params
\) # closing function call
) # closing either one of
}{
my $digit = shift;
$digit . (
$1 ? (
($1 eq 'tense') ? (($2 eq ',present') ? 'ing' : 'ed') :
($1 eq 'quant') ? ' ' . (($digit > 1) ? ($3 || "$2s") : $2) :
''
) : ''
);
}egx;
return $str;
};
sub _escape {
my $text = shift;
$text =~ s/\b_(\d+)/%$1/;
return $text;
}
sub _unescape {
my $str = shift;
$str =~ s/(^|,)%(\d+|\*)(,|$)/$1_$2$3/g;
return $str;
}
sub auto_path {
my $calldir = shift;
$calldir =~ s#::#/#g;
my $path = $INC{$calldir . '.pm'} or return;
# Try absolute path name.
if ($^O eq 'MacOS') {
(my $malldir = $calldir) =~ tr#/#:#;
$path =~ s#^(.*)$malldir\.pm\z#$1auto:$malldir:#s;
} else {
$path =~ s#^(.*)$calldir\.pm\z#$1auto/$calldir/#;
}
return $path if -d $path;
# If that failed, try relative path with normal @INC searching.
$path = "auto/$calldir/";
foreach my $inc (@INC) {
return "$inc/$path" if -d "$inc/$path";
}
return;
}
package CGI::Kwiki::I18N::Lexicon;
use strict;
my %Opts;
sub option { shift if ref($_[0]); $Opts{lc $_[0]} }
sub set_option { shift if ref($_[0]); $Opts{lc $_[0]} = $_[1] }
sub import {
my $class = shift;
return unless @_;
my %entries;
if (UNIVERSAL::isa($_[0], 'HASH')) {
# a hashref with $lang as keys, [$format, $src ...] as values
%entries = %{$_[0]};
}
elsif (@_ % 2) {
%entries = ( '' => [ @_ ] );
}
# expand the wildcard entry
if (my $wild_entry = delete $entries{'*'}) {
while (my ($format, $src) = splice(@$wild_entry, 0, 2)) {
next if ref($src); # XXX: implement globbing for the 'Tie' backend
my $pattern = $src;
$pattern =~ s/\*(?=[^*]+$)/\([-\\w]+\)/g or next;
$pattern =~ s/\*/.*?/g;
require File::Glob;
foreach my $file (File::Glob::bsd_glob($src)) {
$file =~ /$pattern/ or next;
push @{$entries{$1}}, ($format => $file) if $1;
}
delete $entries{$1}
unless !defined($1)
or exists $entries{$1} and @{$entries{$1}};
}
}
%Opts = ();
foreach my $key (grep /^_/, keys %entries) {
set_option(lc(substr($key, 1)) => delete($entries{$key}));
}
while (my ($lang, $entry) = each %entries) {
my $export = caller;
if (length $lang) {
# normalize language tag to Maketext's subclass convention
$lang = lc($lang);
$lang =~ s/-/_/g;
$export .= "::$lang";
}
my @pairs = @{$entry||[]} or die "no format specified";
while (my ($format, $src) = splice(@pairs, 0, 2)) {
my @content = $class->lexicon_get($src, scalar caller, $lang);
no strict 'refs';
if (defined %{"$export\::Lexicon"}) {
# be very careful not to pollute the possibly tied lexicon
*{"$export\::Lexicon"} = {
%{"$export\::Lexicon"},
%{"$class\::$format"->parse(@content)},
};
}
else {
*{"$export\::Lexicon"} = "$class\::$format"->parse(@content);
}
push(@{"$export\::ISA"}, scalar caller) if length $lang;
}
}
}
sub lexicon_get {
my ($class, $src, $caller, $lang) = @_;
return unless defined $src;
foreach my $type (qw(ARRAY HASH SCALAR GLOB), ref($src)) {
next unless UNIVERSAL::isa($src, $type);
my $method = 'lexicon_get_' . lc($type);
die "cannot handle source $type for $src: no $method defined"
unless $class->can($method);
return $class->$method($src, $caller, $lang);
}
# default handler
return $class->lexicon_get_($src, $caller, $lang);
}
# assume filename - search path, open and return its contents
sub lexicon_get_ {
my ($class, $src, $caller, $lang) = @_;
require FileHandle;
require File::Spec;
my $fh = FileHandle->new;
my @path = split('::', $caller);
push @path, $lang if length $lang;
$src = (grep { -e } map {
my @subpath = @path[0..$_];
map { File::Spec->catfile($_, @subpath, $src) } @INC;
} -1 .. $#path)[-1] unless -e $src;
die "cannot find $_[1] (called by $_[2]) in \@INC" unless -e $src;
$fh->open($src) or die $!;
binmode($fh);
return <$fh>;
}
package CGI::Kwiki::I18N::Lexicon::Gettext;
use strict;
my ($InputEncoding, $OutputEncoding, $DoEncoding);
sub input_encoding { $InputEncoding };
sub output_encoding { $OutputEncoding };
sub parse {
my $self = shift;
my (%var, $key, @ret);
my @metadata;
$InputEncoding = $OutputEncoding = $DoEncoding = undef;
# Check for magic string of MO files
return parse_mo(join('', @_))
if ($_[0] =~ /^\x95\x04\x12\xde/ or $_[0] =~ /^\xde\x12\x04\x95/);
local $^W; # no 'uninitialized' warnings, please.
my $UseFuzzy = CGI::Kwiki::I18N::Lexicon::option('use_fuzzy');
# Parse PO files
foreach (@_) {
/^(msgid|msgstr) +"(.*)" *$/ ? do { # leading strings
$var{$1} = $2;
$key = $1;
} :
/^"(.*)" *$/ ? do { # continued strings
$var{$key} .= $1;
} :
/^#, +(.*) *$/ ? do { # control variables
$var{$_} = 1 for split(/,\s+/, $1);
} :
/^ *$/ && %var ? do { # interpolate string escapes
push @ret, (map transform($_), @var{'msgid', 'msgstr'})
if length $var{msgstr} and !$var{fuzzy} or $UseFuzzy;
push @metadata, parse_metadata($var{msgstr})
if $var{msgid} eq '';
%var = ();
} : ();
}
push @ret, map { transform($_) } @var{'msgid', 'msgstr'}
if length $var{msgstr};
push @metadata, parse_metadata($var{msgstr})
if $var{msgid} eq '';
return {@metadata, @ret};
}
sub parse_metadata {
return map {
(/^([^\x00-\x1f\x80-\xff :=]+):\s*(.*)$/) ?
($1 eq 'Content-Type') ? do {
my $enc = $2;
if ($enc =~ /\bcharset=\s*([-\w]+)/i) {
$InputEncoding = $1;
$OutputEncoding = CGI::Kwiki::I18N::Lexicon::option('encoding');
if ( CGI::Kwiki::I18N::Lexicon::option('decode') and
(!$OutputEncoding or $InputEncoding ne $OutputEncoding)) {
require Encode::compat if $] < 5.007001;
require Encode;
$DoEncoding = 1;
}
}
("__Content-Type", $enc);
} : ("__$1", $2)
: ();
} split(/\r*\n+\r*/, transform(pop));
}
sub transform {
my $str = shift;
$str = Encode::decode($InputEncoding, $str) if $DoEncoding and $InputEncoding;
$str =~ s/\\([0x]..|c?.)/qq{"\\$1"}/eeg;
$str =~ s/[\~\[\]]/~$&/g;
$str =~ s/(?<![%\\])%([A-Za-z#*]\w*)\(([^\)]*)\)/"\[$1,".unescape($2)."]"/eg;
$str =~ s/(?<![%\\])%(\d+|\*)/\[_$1]/g;
$str = Encode::encode($OutputEncoding, $str) if $DoEncoding and $OutputEncoding;
return $str;
}
sub unescape {
my $str = shift;
$str =~ s/(^|,)%(\d+|\*)(,|$)/$1_$2$3/g;
return $str;
}
1;
### Assorted non-loc()ed localizable strings ###
# loc('HomePage')
# loc('RecentChanges')
# loc('Preferences')
# loc('Blog')
# loc('New Page Name')
# loc('BrianIngerson')
# loc('HomePage')
# loc('???')
# loc('KwikiAbout')
# loc('KwikiBackup')
# loc('KwikiBlog')
# loc('KwikiCustomization')
# loc('KwikiFeatures')
# loc('KwikiFit')
# loc('KwikiFormattingRules')
# loc('KwikiHelpIndex')
# loc('KwikiHotKeys')
# loc('KwikiInstallation')
# loc('KwikiKnownBugs')
# loc('KwikiLogoImage')
# loc('KwikiModPerl')
# loc('KwikiFastCGI')
# loc('KwikiNavigation')
# loc('KwikiPod')
# loc('KwikiPrivacy')
# loc('KwikiPrivatePage')
# loc('KwikiSisters')
# loc('KwikiSlideShow')
# loc('KwikiTodo')
# loc('KwikiUpgrading')
# loc('KwikiUserName')
# loc('KwikiModule')
# loc('KwikiDriverModule')
# loc('KwikiConfigModule')
# loc('KwikiConfigYamlModule')
# loc('KwikiFormatterModule')
# loc('KwikiDatabaseModule')
# loc('KwikiMetadataModule')
# loc('KwikiDisplayModule')
# loc('KwikiEditModule')
# loc('KwikiTemplateModule')
# loc('KwikiCgiModule')
# loc('KwikiCookieModule')
# loc('KwikiSearchModule')
# loc('KwikiChangesModule')
# loc('KwikiPrefsModule')
# loc('KwikiNewModule')
# loc('KwikiPagesModule')
# loc('KwikiStyleModule')
# loc('KwikiScriptsModule')
# loc('KwikiJavascriptModule')
# loc('KwikiSlidesModule')