diff options
Diffstat (limited to 'macros/texinfo/texinfo/tp/maintain/lib/libintl-perl/lib/Locale/gettext_pp.pm')
-rw-r--r-- | macros/texinfo/texinfo/tp/maintain/lib/libintl-perl/lib/Locale/gettext_pp.pm | 1275 |
1 files changed, 683 insertions, 592 deletions
diff --git a/macros/texinfo/texinfo/tp/maintain/lib/libintl-perl/lib/Locale/gettext_pp.pm b/macros/texinfo/texinfo/tp/maintain/lib/libintl-perl/lib/Locale/gettext_pp.pm index 584bd5d730..98eeabcc57 100644 --- a/macros/texinfo/texinfo/tp/maintain/lib/libintl-perl/lib/Locale/gettext_pp.pm +++ b/macros/texinfo/texinfo/tp/maintain/lib/libintl-perl/lib/Locale/gettext_pp.pm @@ -1,26 +1,23 @@ #! /bin/false # vim: set autoindent shiftwidth=4 tabstop=4: -# $Id: gettext_pp.pm,v 1.1 2011-10-12 23:51:27 pertusus Exp $ # Pure Perl implementation of Uniforum message translation. -# Copyright (C) 2002-2009 Guido Flohr <guido@imperia.net>, +# Copyright (C) 2002-2017 Guido Flohr <guido.flohr@cantanea.com>, # all rights reserved. -# This program is free software; you can redistribute it and/or modify it -# under the terms of the GNU Library General Public License as published -# by the Free Software Foundation; either version 2, or (at your option) -# any later version. +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# Library General Public License for more details. +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. -# You should have received a copy of the GNU Library General Public -# License along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -# USA. +# You should have received a copy of the GNU General Public License +# along with this program. If not, see <http://www.gnu.org/licenses/>. package Locale::gettext_pp; @@ -29,151 +26,154 @@ use strict; require 5.004; use vars qw ($__gettext_pp_default_dir - $__gettext_pp_textdomain - $__gettext_pp_domain_bindings - $__gettext_pp_domain_codeset_bindings - $__gettext_pp_domains - $__gettext_pp_recoders - $__gettext_pp_unavailable_dirs - $__gettext_pp_domain_cache - $__gettext_pp_alias_cache - $__gettext_pp_context_glue); + $__gettext_pp_textdomain + $__gettext_pp_domain_bindings + $__gettext_pp_domain_codeset_bindings + $__gettext_pp_domains + $__gettext_pp_recoders + $__gettext_pp_unavailable_dirs + $__gettext_pp_domain_cache + $__gettext_pp_alias_cache + $__gettext_pp_context_glue); use locale; +use File::Spec; +use Locale::Messages; BEGIN { - $__gettext_pp_textdomain = 'messages'; - $__gettext_pp_domain_bindings = {}; - $__gettext_pp_domain_codeset_bindings = {}; - $__gettext_pp_domains = {}; - $__gettext_pp_recoders = {}; - $__gettext_pp_unavailable_dirs = {}; - $__gettext_pp_domain_cache = {}; - $__gettext_pp_alias_cache = {}; - # The separator between msgctxt and msgid in a .mo file. */ - $__gettext_pp_context_glue = "\004"; - - $__gettext_pp_default_dir = ''; - - for my $dir (qw (/usr/share/locale /usr/local/share/locale)) { - if (-d $dir) { - $__gettext_pp_default_dir = $dir; - last; - } - } + $__gettext_pp_textdomain = 'messages'; + $__gettext_pp_domain_bindings = {}; + $__gettext_pp_domain_codeset_bindings = {}; + $__gettext_pp_domains = {}; + $__gettext_pp_recoders = {}; + $__gettext_pp_unavailable_dirs = {}; + $__gettext_pp_domain_cache = {}; + $__gettext_pp_alias_cache = {}; + # The separator between msgctxt and msgid in a .mo file. */ + $__gettext_pp_context_glue = "\004"; + + $__gettext_pp_default_dir = ''; + + for my $dir (qw (/usr/share/locale /usr/local/share/locale)) { + if (-d $dir) { + $__gettext_pp_default_dir = $dir; + last; + } + } } BEGIN { - require POSIX; - require Exporter; - use IO::Handle; - require Locale::Recode; - - local $@; - my ($has_messages, $five_ok); - - $has_messages = eval '&POSIX::LC_MESSAGES'; - - unless (defined $has_messages && length $has_messages) { - $five_ok = ! grep {my $x = eval "&POSIX::$_" || 0; $x eq '5';} - qw (LC_CTYPE - LC_NUMERIC - LC_TIME - LC_COLLATE - LC_MONETARY - LC_ALL); - if ($five_ok) { - $five_ok = POSIX::setlocale (5, ''); - } - } - - if (defined $has_messages && length $has_messages) { + require POSIX; + require Exporter; + use IO::Handle; + require Locale::Recode; + + local $@; + my ($has_messages, $five_ok); + + $has_messages = eval '&POSIX::LC_MESSAGES'; + + unless (defined $has_messages && length $has_messages) { + $five_ok = ! grep {my $x = eval "&POSIX::$_" || 0; $x eq '5';} + qw (LC_CTYPE + LC_NUMERIC + LC_TIME + LC_COLLATE + LC_MONETARY + LC_ALL); + if ($five_ok) { + $five_ok = POSIX::setlocale (5, ''); + } + } + + if (defined $has_messages && length $has_messages) { eval <<'EOF'; sub LC_MESSAGES() { - local $!; # Do not clobber errno! - - return &POSIX::LC_MESSAGES; + local $!; # Do not clobber errno! + + return &POSIX::LC_MESSAGES; } EOF - } elsif ($five_ok) { + } elsif ($five_ok) { eval <<'EOF'; sub LC_MESSAGES() { - local $!; # Do not clobber errno! + local $!; # Do not clobber errno! - # Hack: POSIX.pm deems LC_MESSAGES an invalid macro until - # Perl 5.8.0. However, on LC_MESSAGES should be 5 ... - return 5; + # Hack: POSIX.pm deems LC_MESSAGES an invalid macro until + # Perl 5.8.0. However, on LC_MESSAGES should be 5 ... + return 5; } EOF - } else { + } else { eval <<'EOF'; sub LC_MESSAGES() { - local $!; # Do not clobber errno! + local $!; # Do not clobber errno! - # This fallback value is widely used, - # when LC_MESSAGES is not available. - return 1729; + # This fallback value is widely used, + # when LC_MESSAGES is not available. + return 1729; } EOF - } + } } use vars qw (%EXPORT_TAGS @EXPORT_OK @ISA $VERSION); %EXPORT_TAGS = (locale_h => [ qw ( - gettext - dgettext - dcgettext - ngettext - dngettext - dcngettext - pgettext - dpgettext - dcpgettext - npgettext - dnpgettext - dcnpgettext - textdomain - bindtextdomain - bind_textdomain_codeset - ) - ], - libintl_h => [ qw (LC_CTYPE - LC_NUMERIC - LC_TIME - LC_COLLATE - LC_MONETARY - LC_MESSAGES - LC_ALL) - ], - ); + gettext + dgettext + dcgettext + ngettext + dngettext + dcngettext + pgettext + dpgettext + dcpgettext + npgettext + dnpgettext + dcnpgettext + textdomain + bindtextdomain + bind_textdomain_codeset + ) + ], + libintl_h => [ qw (LC_CTYPE + LC_NUMERIC + LC_TIME + LC_COLLATE + LC_MONETARY + LC_MESSAGES + LC_ALL) + ], + ); @EXPORT_OK = qw (gettext - dgettext - dcgettext - ngettext - dngettext - dcngettext - pgettext - dpgettext - dcpgettext - npgettext - dnpgettext - dcnpgettext - textdomain - bindtextdomain - bind_textdomain_codeset + dgettext + dcgettext + ngettext + dngettext + dcngettext + pgettext + dpgettext + dcpgettext + npgettext + dnpgettext + dcnpgettext + textdomain + bindtextdomain + bind_textdomain_codeset nl_putenv - LC_CTYPE - LC_NUMERIC - LC_TIME - LC_COLLATE - LC_MONETARY - LC_MESSAGES - LC_ALL); + setlocale + LC_CTYPE + LC_NUMERIC + LC_TIME + LC_COLLATE + LC_MONETARY + LC_MESSAGES + LC_ALL); @ISA = qw (Exporter); my $has_nl_langinfo; @@ -181,264 +181,275 @@ my $has_nl_langinfo; sub __load_catalog; sub __load_domain; sub __locale_category; +sub __untaint_plural_header; +sub __compile_plural_function; sub LC_NUMERIC() { - &POSIX::LC_NUMERIC; + &POSIX::LC_NUMERIC; } sub LC_CTYPE() { - &POSIX::LC_CTYPE; + &POSIX::LC_CTYPE; } sub LC_TIME() { - &POSIX::LC_TIME; + &POSIX::LC_TIME; } sub LC_COLLATE() { - &POSIX::LC_COLLATE; + &POSIX::LC_COLLATE; } sub LC_MONETARY() { - &POSIX::LC_MONETARY; + &POSIX::LC_MONETARY; } sub LC_ALL() { - &POSIX::LC_ALL; + &POSIX::LC_ALL; } sub textdomain(;$) { - my $new_domain = shift; - - $__gettext_pp_textdomain = $new_domain if defined $new_domain && - length $new_domain; - - return $__gettext_pp_textdomain; + my $new_domain = shift; + + $__gettext_pp_textdomain = $new_domain if defined $new_domain && + length $new_domain; + + return $__gettext_pp_textdomain; } sub bindtextdomain($;$) { - my ($domain, $directory) = @_; - - my $retval; - if (defined $domain && length $domain) { - if (defined $directory && length $directory) { - $retval = $__gettext_pp_domain_bindings->{$domain} - = $directory; - } elsif (exists $__gettext_pp_domain_bindings->{$domain}) { - $retval = $__gettext_pp_domain_bindings->{$domain}; - } else { - $retval = $__gettext_pp_default_dir; - } - $retval = '/usr/share/locale' unless defined $retval && - length $retval; - return $retval; - } else { - return; - } + my ($domain, $directory) = @_; + + my $retval; + if (defined $domain && length $domain) { + if (defined $directory && length $directory) { + $retval = $__gettext_pp_domain_bindings->{$domain} + = $directory; + } elsif (exists $__gettext_pp_domain_bindings->{$domain}) { + $retval = $__gettext_pp_domain_bindings->{$domain}; + } else { + $retval = $__gettext_pp_default_dir; + } + $retval = '/usr/share/locale' unless defined $retval && + length $retval; + return $retval; + } else { + return; + } } sub bind_textdomain_codeset($;$) { - my ($domain, $codeset) = @_; - - if (defined $domain && length $domain) { - if (defined $codeset && length $codeset) { - return $__gettext_pp_domain_codeset_bindings->{$domain} = $codeset; - } elsif (exists $__gettext_pp_domain_codeset_bindings->{$domain}) { - return $__gettext_pp_domain_codeset_bindings->{$domain}; - } - } - - return; + my ($domain, $codeset) = @_; + + if (defined $domain && length $domain) { + if (defined $codeset && length $codeset) { + return $__gettext_pp_domain_codeset_bindings->{$domain} = $codeset; + } elsif (exists $__gettext_pp_domain_codeset_bindings->{$domain}) { + return $__gettext_pp_domain_codeset_bindings->{$domain}; + } + } + + return; } sub gettext($) { - my ($msgid) = @_; + my ($msgid) = @_; - return dcnpgettext ('', undef, $msgid, undef, undef, undef); + return dcnpgettext ('', undef, $msgid, undef, undef, undef); } sub dgettext($$) { - my ($domainname, $msgid) = @_; + my ($domainname, $msgid) = @_; - return dcnpgettext ($domainname, undef, $msgid, undef, undef, undef); + return dcnpgettext ($domainname, undef, $msgid, undef, undef, undef); } sub dcgettext($$$) { - my ($domainname, $msgid, $category) = @_; + my ($domainname, $msgid, $category) = @_; - return dcnpgettext ($domainname, undef, $msgid, undef, undef, undef); + return dcnpgettext ($domainname, undef, $msgid, undef, undef, undef); } sub ngettext($$$) { - my ($msgid, $msgid_plural, $n) = @_; + my ($msgid, $msgid_plural, $n) = @_; - return dcnpgettext ('', undef, $msgid, $msgid_plural, $n, undef); + return dcnpgettext ('', undef, $msgid, $msgid_plural, $n, undef); } sub dngettext($$$$) { - my ($domainname, $msgid, $msgid_plural, $n) = @_; + my ($domainname, $msgid, $msgid_plural, $n) = @_; - return dcnpgettext ($domainname, undef, $msgid, $msgid_plural, $n, undef); + return dcnpgettext ($domainname, undef, $msgid, $msgid_plural, $n, undef); } sub dcngettext($$$$$) { - my ($domainname, $msgid, $msgid_plural, $n, $category) = @_; + my ($domainname, $msgid, $msgid_plural, $n, $category) = @_; - return dcnpgettext ($domainname, undef, $msgid, $msgid_plural, $n, , $category); + return dcnpgettext ($domainname, undef, $msgid, $msgid_plural, $n, , $category); } sub pgettext($$) { - my ($msgctxt, $msgid) = @_; + my ($msgctxt, $msgid) = @_; - return dcnpgettext ('', $msgctxt, $msgid, undef, undef, undef); + return dcnpgettext ('', $msgctxt, $msgid, undef, undef, undef); } sub dpgettext($$$) { - my ($domainname, $msgctxt, $msgid) = @_; + my ($domainname, $msgctxt, $msgid) = @_; - return dcnpgettext ($domainname, $msgctxt, $msgid, undef, undef, undef); + return dcnpgettext ($domainname, $msgctxt, $msgid, undef, undef, undef); } sub dcpgettext($$$$) { - my ($domainname, $msgctxt, $msgid, $category) = @_; + my ($domainname, $msgctxt, $msgid, $category) = @_; - return dcnpgettext ($domainname, $msgctxt, $msgid, undef, undef, undef); + return dcnpgettext ($domainname, $msgctxt, $msgid, undef, undef, undef); } sub npgettext($$$$) { - my ($msgctxt, $msgid, $msgid_plural, $n) = @_; + my ($msgctxt, $msgid, $msgid_plural, $n) = @_; - return dcnpgettext ('', $msgctxt, $msgid, $msgid_plural, $n, undef); + return dcnpgettext ('', $msgctxt, $msgid, $msgid_plural, $n, undef); } sub dnpgettext($$$$$) { - my ($domainname, $msgctxt, $msgid, $msgid_plural, $n) = @_; + my ($domainname, $msgctxt, $msgid, $msgid_plural, $n) = @_; - return dcnpgettext ($domainname, $msgctxt, $msgid, $msgid_plural, $n, undef); + return dcnpgettext ($domainname, $msgctxt, $msgid, $msgid_plural, $n, undef); } -sub dcnpgettext($$$$$$) -{ - my ($domainname, $msgctxt, $msgid, $msgid_plural, $n, $category) = @_; - - return unless defined $msgid; - - my $plural = defined $msgid_plural; - my $msg_ctxt_id = defined $msgctxt ? join($__gettext_pp_context_glue, ($msgctxt, $msgid)) : $msgid; - - local $!; # Do not clobber errno! - - # This is also done in __load_domain but we need a proper value. - $domainname = $__gettext_pp_textdomain - unless defined $domainname && length $domainname; - - # Category is always LC_MESSAGES (other categories are ignored). - my $category_name = 'LC_MESSAGES'; - $category = LC_MESSAGES; - - my $domains = __load_domain ($domainname, $category, $category_name); - - my @trans = (); - my $domain; - my $found; - foreach my $this_domain (@$domains) { - if ($this_domain && defined $this_domain->{messages}->{$msg_ctxt_id}) { - @trans = @{$this_domain->{messages}->{$msg_ctxt_id}}; - shift @trans; - $domain = $this_domain; - $found = 1; - last; - } - } - @trans = ($msgid, $msgid_plural) unless @trans; - - my $trans = $trans[0]; - if ($plural) { - if ($domain) { - my $nplurals = 0; - ($nplurals, $plural) = &{$domain->{plural_func}} ($n); - $plural = 0 unless defined $plural; - $nplurals = 0 unless defined $nplurals; - $plural = 0 if $nplurals <= $plural; - } else { - $plural = $n != 1 || 0; - } - - $trans = $trans[$plural] if defined $trans[$plural]; - } - - if ($found && defined $domain->{po_header}->{charset}) { - my $input_codeset = $domain->{po_header}->{charset}; - # Convert into output charset. - my $output_codeset = $__gettext_pp_domain_codeset_bindings->{$domainname}; - - $output_codeset = $ENV{OUTPUT_CHARSET} unless defined $output_codeset; - $output_codeset = __get_codeset ($category, $category_name, - $domain->{locale_id}) - unless defined $output_codeset; - - unless (defined $output_codeset) { - # Still no point. - my $lc_ctype = __locale_category (POSIX::LC_CTYPE(), - 'LC_CTYPE'); - $output_codeset = $1 - if $lc_ctype =~ /^[a-z]{2}(?:_[A-Z]{2})?\.([^@]+)/; - } - - # No point. :-( - $output_codeset = $domain->{po_header}->{charset} - unless defined $output_codeset; - - if (exists $__gettext_pp_domain_cache->{$output_codeset}) { - $output_codeset = $__gettext_pp_domain_cache->{$output_codeset}; - } else { - $output_codeset = 'utf-8' if lc $output_codeset eq 'utf8'; - $output_codeset = - $__gettext_pp_domain_cache->{$output_codeset} = - Locale::Recode->resolveAlias ($output_codeset); - } - - if (defined $output_codeset && - $output_codeset ne $domain->{po_header}->{charset}) { - # We have to convert. - my $recoder; - - if (exists - $__gettext_pp_recoders->{$input_codeset}->{$output_codeset}) { - $recoder = $__gettext_pp_recoders->{$input_codeset}->{$output_codeset}; - } else { - $recoder = - $__gettext_pp_recoders->{$input_codeset}->{$output_codeset} = - Locale::Recode->new (from => $input_codeset, - to => $output_codeset, - ); - } - - $recoder->recode ($trans); - } - } - - return $trans; +# This is the actual implementation of dncpgettext. It is also used by the +# corresponding function in Locale::gettext_dumb. +sub _dcnpgettext_impl { + my ($domainname, $msgctxt, $msgid, $msgid_plural, $n, $category, + $locale) = @_; + + return unless defined $msgid; + + my $plural = defined $msgid_plural; + Locale::Messages::turn_utf_8_off($msgid); + Locale::Messages::turn_utf_8_off($msgctxt) if defined $msgctxt; + my $msg_ctxt_id = defined $msgctxt ? join($__gettext_pp_context_glue, ($msgctxt, $msgid)) : $msgid; + + local $!; # Do not clobber errno! + + # This is also done in __load_domain but we need a proper value. + $domainname = $__gettext_pp_textdomain + unless defined $domainname && length $domainname; + + # Category is always LC_MESSAGES (other categories are ignored). + my $category_name = 'LC_MESSAGES'; + $category = LC_MESSAGES; + + my $domains = __load_domain ($domainname, $category, $category_name, + $locale); + + my @trans = (); + my $domain; + my $found; + foreach my $this_domain (@$domains) { + if ($this_domain && defined $this_domain->{messages}->{$msg_ctxt_id}) { + @trans = @{$this_domain->{messages}->{$msg_ctxt_id}}; + shift @trans; + $domain = $this_domain; + $found = 1; + last; + } + } + @trans = ($msgid, $msgid_plural) unless @trans; + + my $trans = $trans[0]; + if ($plural) { + if ($domain) { + my $nplurals = 0; + ($nplurals, $plural) = &{$domain->{plural_func}} ($n); + $plural = 0 unless defined $plural; + $nplurals = 0 unless defined $nplurals; + $plural = 0 if $nplurals <= $plural; + } else { + $plural = $n != 1 || 0; + } + + $trans = $trans[$plural] if defined $trans[$plural]; + } + + if ($found && defined $domain->{po_header}->{charset}) { + my $input_codeset = $domain->{po_header}->{charset}; + # Convert into output charset. + my $output_codeset = $__gettext_pp_domain_codeset_bindings->{$domainname}; + + $output_codeset = $ENV{OUTPUT_CHARSET} unless defined $output_codeset; + $output_codeset = __get_codeset ($category, $category_name, + $domain->{locale_id}) + unless defined $output_codeset; + + unless (defined $output_codeset) { + # Still no point. + my $lc_ctype = __locale_category (POSIX::LC_CTYPE(), + 'LC_CTYPE'); + $output_codeset = $1 + if $lc_ctype =~ /^[a-z]{2}(?:_[A-Z]{2})?\.([^@]+)/; + } + + # No point. :-( + $output_codeset = $domain->{po_header}->{charset} + unless defined $output_codeset; + + if (exists $__gettext_pp_domain_cache->{$output_codeset}) { + $output_codeset = $__gettext_pp_domain_cache->{$output_codeset}; + } else { + $output_codeset = 'utf-8' if lc $output_codeset eq 'utf8'; + $output_codeset = + $__gettext_pp_domain_cache->{$output_codeset} = + Locale::Recode->resolveAlias ($output_codeset); + } + + if (defined $output_codeset && + $output_codeset ne $domain->{po_header}->{charset}) { + # We have to convert. + my $recoder; + + if (exists + $__gettext_pp_recoders->{$input_codeset}->{$output_codeset}) { + $recoder = $__gettext_pp_recoders->{$input_codeset}->{$output_codeset}; + } else { + $recoder = + $__gettext_pp_recoders->{$input_codeset}->{$output_codeset} = + Locale::Recode->new (from => $input_codeset, + to => $output_codeset, + ); + } + + $recoder->recode ($trans); + } + } + + return $trans; +} + +sub dcnpgettext ($$$$$$) { + return &_dcnpgettext_impl; } sub nl_putenv ($) @@ -471,311 +482,389 @@ sub nl_putenv ($) return 1; } -sub __load_domain -{ - my ($domainname, $category, $category_name) = @_; - - $domainname = $__gettext_pp_textdomain - unless defined $domainname && length $domainname; - - my $dir = bindtextdomain ($domainname, ''); - $dir = $__gettext_pp_default_dir unless defined $dir && length $dir; - return [] unless defined $dir && length $dir; - - my @locales; - my $cache_key; - - if (defined $ENV{LANGUAGE} && length $ENV{LANGUAGE}) { - @locales = split /:/, $ENV{LANGUAGE}; - $cache_key = $ENV{LANGUAGE}; - } else { - @locales = $cache_key = __locale_category ($category, $category_name); - } - - # Have we looked that one up already? - my $domains = $__gettext_pp_domain_cache->{$dir}->{$cache_key}->{$category_name}->{$domainname}; - - if (@locales && !defined $domains) { - my @dirs = ($dir); - my @tries = (@locales); - my %locale_lookup = map { $_ => $_ } @tries; - - foreach my $locale (@locales) { - if ($locale =~ /^([a-z][a-z]) - (?:(_[A-Z][A-Z])? - (\.[-_A-Za-z0-9]+)? - )? - (\@[-_A-Za-z0-9]+)?$/x) { - - if (defined $3) { - defined $2 ? - push @tries, $1 . $2 . $3 : push @tries, $1 . $3; - } - if (defined $2) { - push @tries, $1 . $2; - $locale_lookup{$1 . $2} = $locale; - } - if (defined $1) { - push @tries, $1 if defined $1; - $locale_lookup{$1} = $locale; - } - } - } - - push @dirs, $__gettext_pp_default_dir - if $__gettext_pp_default_dir && $dir ne $__gettext_pp_default_dir; - - my %seen = (); - foreach my $basedir (@dirs) { - foreach my $try (@tries) { - my $fulldir = "$basedir/$try/$category_name"; - - next if $seen{$fulldir}++; - - # If the cache for unavailable directories is removed, - # the three lines below should be replaced by: - # 'next unless -d $fulldir;' - next if $__gettext_pp_unavailable_dirs->{$fulldir}; - ++$__gettext_pp_unavailable_dirs->{$fulldir} and next - unless -d $fulldir; - - my $domain = __load_catalog $fulldir, $domainname; - next unless $domain; - - unless (defined $domain->{po_header}->{charset} && - length $domain->{po_header}->{charset} && - $try =~ /^(?:[a-z][a-z]) - (?:(?:_[A-Z][A-Z])? - (\.[-_A-Za-z0-9]+)? - )? - (?:\@[-_A-Za-z0-9]+)?$/x) { - $domain->{po_header}->{charset} = $1; - } - - if (defined $domain->{po_header}->{charset}) { - $domain->{po_header}->{charset} = - Locale::Recode->resolveAlias ($domain->{po_header}->{charset}); - } - $domain->{locale_id} = $locale_lookup{$try}; - push @$domains, $domain; - } - } - $__gettext_pp_domain_cache->{$dir}->{$cache_key}->{$category_name}->{$domainname} = $domains; - } - - $domains = [] unless defined $domains; - return $domains; +sub setlocale($;$) { + require POSIX; + &POSIX::setlocale; +} + +sub __selected_locales { + my ($locale, $category, $category_name) = @_; + + my @locales; + my $cache_key; + + if (defined $ENV{LANGUAGE} && length $ENV{LANGUAGE}) { + @locales = split /:/, $ENV{LANGUAGE}; + $cache_key = $ENV{LANGUAGE}; + } elsif (!defined $locale) { + # The system does not have LC_MESSAGES. Guess the value. + @locales = $cache_key = __locale_category ($category, + $category_name); + } else { + @locales = $cache_key = $locale; + } + + return $cache_key, @locales; +} + +sub __extend_locales { + my (@locales) = @_; + + my @tries = @locales; + my %locale_lookup = map { $_ => $_ } @tries; + + foreach my $locale (@locales) { + if ($locale =~ /^([a-z][a-z]) + (?:(_[A-Z][A-Z])? + (\.[-_A-Za-z0-9]+)? + )? + (\@[-_A-Za-z0-9]+)?$/x) { + + if (defined $3) { + defined $2 ? + push @tries, $1 . $2 . $3 : push @tries, $1 . $3; + $locale_lookup{$tries[-1]} = $locale; + } + if (defined $2) { + push @tries, $1 . $2; + $locale_lookup{$1 . $2} = $locale; + } + if (defined $1) { + push @tries, $1 if defined $1; + $locale_lookup{$1} = $locale; + } + } + } + + return \@tries, \%locale_lookup; +} + +sub __load_domain { + my ($domainname, $category, $category_name, $locale) = @_; + + # If no locale was selected for the requested locale category, + # l10n is disabled completely. This matches the behavior of GNU + # gettext. + if ($category != LC_MESSAGES) { + # Not supported. + return []; + } + + if (!defined $locale && $category != 1729) { + $locale = POSIX::setlocale ($category); + if (!defined $locale || 'C' eq $locale || 'POSIX' eq $locale) { + return []; + } + } + + $domainname = $__gettext_pp_textdomain + unless defined $domainname && length $domainname; + + my $dir = bindtextdomain ($domainname, ''); + $dir = $__gettext_pp_default_dir unless defined $dir && length $dir; + + return [] unless defined $dir && length $dir; + + my ($cache_key, @locales) = __selected_locales $locale, $category, $category_name; + + # Have we looked that one up already? + my $domains = $__gettext_pp_domain_cache->{$dir}->{$cache_key}->{$category_name}->{$domainname}; + return $domains if defined $domains; + return [] unless @locales; + + my @dirs = ($dir); + my ($tries, $lookup) = __extend_locales @locales; + + push @dirs, $__gettext_pp_default_dir + if $__gettext_pp_default_dir && $dir ne $__gettext_pp_default_dir; + + my %seen; + my %loaded; + foreach my $basedir (@dirs) { + foreach my $try (@$tries) { + # If we had already found a catalog for "xy_XY", do not try it + # again. + next if $loaded{$try}; + + my $fulldir = File::Spec->catfile($basedir, $try, $category_name); + next if $seen{$fulldir}++; + + # If the cache for unavailable directories is removed, + # the three lines below should be replaced by: + # 'next unless -d $fulldir;' + next if $__gettext_pp_unavailable_dirs->{$fulldir}; + ++$__gettext_pp_unavailable_dirs->{$fulldir} and next + unless -d $fulldir; + my $filename = File::Spec->catfile($fulldir, "$domainname.mo"); + my $domain = __load_catalog $filename, $try; + next unless $domain; + + $loaded{$try} = 1; + + $domain->{locale_id} = $lookup->{$try}; + push @$domains, $domain; + } + } + + $domains = [] unless defined $domains; + + $__gettext_pp_domain_cache->{$dir} + ->{$cache_key} + ->{$category_name} + ->{$domainname} = $domains; + + return $domains; } sub __load_catalog { - my ($directory, $domainname) = @_; - - my $filename = "$directory/$domainname.mo"; - - # Alternatively we could check the filename for evil characters ... - # (Important for CGIs). - return unless -f $filename && -r $filename; - - local $/; - local *HANDLE; - - open HANDLE, "<$filename" - or return; - binmode HANDLE; - my $raw = <HANDLE>; - close HANDLE; - - # Corrupted? - return if ! defined $raw || length $raw < 28; - - my $filesize = length $raw; - - # Read the magic number in order to determine the byte order. - my $domain = {}; - my $unpack = 'N'; - $domain->{potter} = unpack $unpack, substr $raw, 0, 4; - - if ($domain->{potter} == 0xde120495) { - $unpack = 'V'; - } elsif ($domain->{potter} != 0x950412de) { - return; - } - my $domain_unpack = $unpack x 6; - - my ($revision, $num_strings, $msgids_off, $msgstrs_off, - $hash_size, $hash_off) = - unpack (($unpack x 6), substr $raw, 4, 24); - - return unless $revision == 0; # Invalid revision number. - - $domain->{revision} = $revision; - $domain->{num_strings} = $num_strings; - $domain->{msgids_off} = $msgids_off; - $domain->{msgstrs_off} = $msgstrs_off; - $domain->{hash_size} = $hash_size; - $domain->{hash_off} = $hash_off; - - return if $msgids_off + 4 * $num_strings > $filesize; - return if $msgstrs_off + 4 * $num_strings > $filesize; - - my @orig_tab = unpack (($unpack x (2 * $num_strings)), - substr $raw, $msgids_off, 8 * $num_strings); - my @trans_tab = unpack (($unpack x (2 * $num_strings)), - substr $raw, $msgstrs_off, 8 * $num_strings); - - my $messages = {}; - - for (my $count = 0; $count < 2 * $num_strings; $count += 2) { - my $orig_length = $orig_tab[$count]; - my $orig_offset = $orig_tab[$count + 1]; - my $trans_length = $trans_tab[$count]; - my $trans_offset = $trans_tab[$count + 1]; - - return if $orig_offset + $orig_length > $filesize; - return if $trans_offset + $trans_length > $filesize; - - my @origs = split /\000/, substr $raw, $orig_offset, $orig_length; - my @trans = split /\000/, substr $raw, $trans_offset, $trans_length; - - # The singular is the key, the plural plus all translations is the - # value. - my $msgid = $origs[0]; - $msgid = '' unless defined $msgid && length $msgid; - my $msgstr = [ $origs[1], @trans ]; - $messages->{$msgid} = $msgstr; - } - - $domain->{messages} = $messages; - - # Try to find po header information. - my $po_header = {}; - my $null_entry = $messages->{''}->[1]; - if ($null_entry) { - my @lines = split /\n/, $null_entry; - foreach my $line (@lines) { - my ($key, $value) = split /:/, $line, 2; - $key =~ s/-/_/g; - $po_header->{lc $key} = $value; - } - } - $domain->{po_header} = $po_header; - - if (exists $domain->{po_header}->{content_type}) { - my $content_type = $domain->{po_header}->{content_type}; - if ($content_type =~ s/.*=//) { - $domain->{po_header}->{charset} = $content_type; - } - } - - my $code = $domain->{po_header}->{plural_forms} || ''; - - # Whitespace, locale-independent. - my $s = '[ \t\r\n\013\014]'; - - # Untaint the plural header. - # Keep line breaks as is (Perl 5_005 compatibility). - if ($code =~ m{^($s* - nplurals$s*=$s*[0-9]+ - $s*;$s* - plural$s*=$s*(?:$s|[-\?\|\&=!<>+*/\%:;a-zA-Z0-9_\(\)])+ - )}xms) { - $domain->{po_header}->{plural_forms} = $1; - } else { - $domain->{po_header}->{plural_forms} = ''; - } - - # Determine plural rules. - # The leading and trailing space is necessary to be able to match - # against word boundaries. - my $plural_func; - - if ($domain->{po_header}->{plural_forms}) { - my $code = ' ' . $domain->{po_header}->{plural_forms} . ' '; - $code =~ - s/([^_a-zA-Z0-9]|\A)([_a-z][_A-Za-z0-9]*)([^_a-zA-Z0-9])/$1\$$2$3/g; - - $code = "sub { my \$n = shift; - my (\$plural, \$nplurals); - $code; - return (\$nplurals, \$plural ? \$plural : 0); }"; - - # Now try to evaluate the code. There is no need to run the code in - # a Safe compartment. The above substitutions should have destroyed - # all evil code. Corrections are welcome! - $plural_func = eval $code; - undef $plural_func if $@; - } - - # Default is Germanic plural (which is incorrect for French). - $plural_func = eval "sub { (2, 1 != shift || 0) }" unless $plural_func; - - $domain->{plural_func} = $plural_func; - - return $domain; + my ($filename, $locale) = @_; + + # Alternatively we could check the filename for evil characters ... + # (Important for CGIs). + return unless -f $filename && -r $filename; + + local $/; + local *HANDLE; + + open HANDLE, "<$filename" + or return; + binmode HANDLE; + my $raw = <HANDLE>; + close HANDLE; + + # Corrupted? + return if ! defined $raw || length $raw < 28; + + my $filesize = length $raw; + + # Read the magic number in order to determine the byte order. + my $domain = { + filename => $filename + }; + my $unpack = 'N'; + $domain->{magic} = unpack $unpack, substr $raw, 0, 4; + + if ($domain->{magic} == 0xde120495) { + $unpack = 'V'; + } elsif ($domain->{magic} != 0x950412de) { + return; + } + my $domain_unpack = $unpack x 6; + + my ($revision, $num_strings, $msgids_off, $msgstrs_off, + $hash_size, $hash_off) = + unpack (($unpack x 6), substr $raw, 4, 24); + + my $major = $revision >> 16; + return if $major != 0; # Invalid revision number. + + $domain->{revision} = $revision; + $domain->{num_strings} = $num_strings; + $domain->{msgids_off} = $msgids_off; + $domain->{msgstrs_off} = $msgstrs_off; + $domain->{hash_size} = $hash_size; + $domain->{hash_off} = $hash_off; + + return if $msgids_off + 4 * $num_strings > $filesize; + return if $msgstrs_off + 4 * $num_strings > $filesize; + + my @orig_tab = unpack (($unpack x (2 * $num_strings)), + substr $raw, $msgids_off, 8 * $num_strings); + my @trans_tab = unpack (($unpack x (2 * $num_strings)), + substr $raw, $msgstrs_off, 8 * $num_strings); + + my $messages = {}; + + for (my $count = 0; $count < 2 * $num_strings; $count += 2) { + my $orig_length = $orig_tab[$count]; + my $orig_offset = $orig_tab[$count + 1]; + my $trans_length = $trans_tab[$count]; + my $trans_offset = $trans_tab[$count + 1]; + + return if $orig_offset + $orig_length > $filesize; + return if $trans_offset + $trans_length > $filesize; + + my @origs = split /\000/, substr $raw, $orig_offset, $orig_length; + my @trans = split /\000/, substr $raw, $trans_offset, $trans_length; + + # The singular is the key, the plural plus all translations is the + # value. + my $msgid = $origs[0]; + $msgid = '' unless defined $msgid && length $msgid; + my $msgstr = [ $origs[1], @trans ]; + $messages->{$msgid} = $msgstr; + } + + $domain->{messages} = $messages; + + # Try to find po header information. + my $po_header = {}; + my $null_entry = $messages->{''}->[1]; + if ($null_entry) { + my @lines = split /\n/, $null_entry; + foreach my $line (@lines) { + my ($key, $value) = split /:/, $line, 2; + $key =~ s/-/_/g; + $po_header->{lc $key} = $value; + } + } + $domain->{po_header} = $po_header; + + if (exists $domain->{po_header}->{content_type}) { + my $content_type = $domain->{po_header}->{content_type}; + if ($content_type =~ s/.*=//) { + $domain->{po_header}->{charset} = $content_type; + } + } + + my $code = $domain->{po_header}->{plural_forms} || ''; + + # Whitespace, locale-independent. + my $s = '[ \011-\015]'; + + # Untaint the plural header. + # Keep line breaks as is (Perl 5_005 compatibility). + $code = $domain->{po_header}->{plural_forms} + = __untaint_plural_header $code; + + $domain->{plural_func} = __compile_plural_function $code; + + unless (defined $domain->{po_header}->{charset} + && length $domain->{po_header}->{charset} + && $locale =~ /^(?:[a-z][a-z]) + (?:(?:_[A-Z][A-Z])? + (\.[-_A-Za-z0-9]+)? + )? + (?:\@[-_A-Za-z0-9]+)?$/x) { + $domain->{po_header}->{charset} = $1; + } + + if (defined $domain->{po_header}->{charset}) { + $domain->{po_header}->{charset} = + Locale::Recode->resolveAlias ($domain->{po_header}->{charset}); + } + + return $domain; } sub __locale_category { - my ($category, $category_name) = @_; - - local $@; - my $value = eval {POSIX::setlocale ($category)}; - - # We support only XPG syntax, i. e. - # language[_territory[.codeset]][@modifier]. - undef $value unless (defined $value && - length $value && - $value =~ /^[a-z][a-z] - (?:_[A-Z][A-Z] - (?:\.[-_A-Za-z0-9]+)? - )? - (?:\@[-_A-Za-z0-9]+)?$/x); - - unless ($value) { - $value = $ENV{LC_ALL}; - $value = $ENV{$category_name} unless defined $value && length $value; - $value = $ENV{LANG} unless defined $value && length $value; - return 'C' unless defined $value && length $value; - } - - return $value if $value ne 'C' && $value ne 'POSIX'; + my ($category, $category_name) = @_; + + local $@; + my $value = eval {POSIX::setlocale ($category)}; + + # We support only XPG syntax, i. e. + # language[_territory[.codeset]][@modifier]. + undef $value unless (defined $value && + length $value && + $value =~ /^[a-z][a-z] + (?:_[A-Z][A-Z] + (?:\.[-_A-Za-z0-9]+)? + )? + (?:\@[-_A-Za-z0-9]+)?$/x); + + unless ($value) { + $value = $ENV{LC_ALL}; + $value = $ENV{$category_name} unless defined $value && length $value; + $value = $ENV{LANG} unless defined $value && length $value; + return 'C' unless defined $value && length $value; + } + + return $value if $value ne 'C' && $value ne 'POSIX'; } sub __get_codeset { - my ($category, $category_name, $locale_id) = @_; - - local $@; - unless (defined $has_nl_langinfo) { - eval { - require I18N::Langinfo; - }; - $has_nl_langinfo = !$@; - } - - if ($has_nl_langinfo) { - # Try to set the locale via the specified id. - my $saved_locale = eval { POSIX::setlocale (LC_ALL) }; - my $saved_lc_all = $ENV{LC_ALL}; - - # Now try to set the locale via the environment. There is no - # point in calling the langinfo routines if this fails. - $ENV{LC_ALL} = $locale_id; - my $codeset; - my $lc_all = eval { POSIX::setlocale (LC_ALL, $locale_id); }; - $codeset = I18N::Langinfo::langinfo (I18N::Langinfo::CODESET()) - if defined $lc_all; - - if ($saved_locale) { - eval { POSIX::setlocale (LC_ALL, $saved_locale); } - } - return $codeset; - } - - return; + my ($category, $category_name, $locale_id) = @_; + + local $@; + unless (defined $has_nl_langinfo) { + eval { + require I18N::Langinfo; + }; + $has_nl_langinfo = !$@; + } + + if ($has_nl_langinfo) { + # Try to set the locale via the specified id. + my $saved_locale = eval { POSIX::setlocale (LC_ALL) }; + my $had_lc_all = exists $ENV{LC_ALL}; + my $saved_lc_all = $ENV{LC_ALL} if $had_lc_all; + + # Now try to set the locale via the environment. There is no + # point in calling the langinfo routines if this fails. + $ENV{LC_ALL} = $locale_id; + my $codeset; + my $lc_all = eval { POSIX::setlocale (LC_ALL, $locale_id); }; + $codeset = I18N::Langinfo::langinfo (I18N::Langinfo::CODESET()) + if defined $lc_all; + + # Restore environment. + if ($saved_locale) { + eval { POSIX::setlocale (LC_ALL, $saved_locale); } + } + if ($had_lc_all) { + $ENV{LC_ALL} = $saved_lc_all if $had_lc_all; + } else { + delete $ENV{LC_ALL}; + } + return $codeset; + } + + return; +} + +sub __untaint_plural_header { + my ($code) = @_; + + # Whitespace, locale-independent. + my $s = '[ \t\r\n\013\014]'; + + if ($code =~ m{^($s* + nplurals$s*=$s*[0-9]+ + $s*;$s* + plural$s*=$s*(?:$s|[-\?\|\&=!<>+*/\%:;a-zA-Z0-9_\(\)])+ + )}xms) { + return $1; + } + + return ''; } - + +sub __compile_plural_function { + my ($code) = @_; + + # The leading and trailing space is necessary to be able to match + # against word boundaries. + my $plural_func; + + if (length $code) { + my $code = ' ' . $code . ' '; + $code =~ + s/(?<=[^_a-zA-Z0-9])[_a-z][_A-Za-z0-9]*(?=[^_a-zA-Z0-9])/\$$&/gs; + + $code = "sub { my \$n = shift || 0; + my (\$plural, \$nplurals); + $code; + return (\$nplurals, \$plural ? \$plural : 0); }"; + + # Now try to evaluate the code. There is no need to run the code in + # a Safe compartment. The above substitutions should have destroyed + # all evil code. Corrections are welcome! + #warn $code; + $plural_func = eval $code; + #warn $@ if $@; + undef $plural_func if $@; + } + + # Default is Germanic plural (which is incorrect for French). + $plural_func = eval "sub { (2, 1 != shift || 0) }" unless $plural_func; + + return $plural_func; +} + 1; __END__ @@ -786,7 +875,7 @@ Locale::gettext_pp - Pure Perl Implementation of Uniforum Message Translation =head1 SYNOPSIS - use gettext_pp (:locale_h :libintl_h); + use Locale::gettext_pp qw(:locale_h :libintl_h); gettext $msgid; dgettext $domainname, $msgid; @@ -819,14 +908,14 @@ for example used in GNU gettext and Sun's Solaris. Normally you should not use this module directly, but the high level interface Locale::TextDomain(3) that provides a much simpler -interface. This description is therefore deliberately kept -brief. Please refer to the GNU gettext documentation available at +interface. This description is therefore deliberately kept +brief. Please refer to the GNU gettext documentation available at L<http://www.gnu.org/manual/gettext/> for in-depth and background information on the topic. =head1 FUNCTIONS -The module exports by default nothing. Every function has to be +The module exports by default nothing. Every function has to be imported explicitely or via an export tag (L<"EXPORT TAGS">). =over 4 @@ -893,6 +982,10 @@ See L<Locale::Messages/FUNCTIONS>. See L<Locale::Messages/FUNCTIONS>. +=item B<setlocale> + +See L<Locale::Messages/FUNCTIONS>. + =back =head1 CONSTANTS @@ -927,7 +1020,7 @@ You can import groups of functions via two tags: =over 4 -=item B<use Locale::gettext_pp (':locale_h')> +=item B<use Locale::gettext_pp qw(':locale_h')> Imports the functions that are normally defined in the C include file F<locale.h>: @@ -1004,11 +1097,9 @@ Imports the locale category constants: =head1 AUTHOR -Copyright (C) 2002-2009, Guido Flohr E<lt>guido@imperia.netE<gt>, all -rights reserved. See the source code for details. - -This software is contributed to the Perl community by Imperia -(L<http://www.imperia.net/>). +Copyright (C) 2002-2017 L<Guido Flohr|http://www.guido-flohr.net/> +(L<mailto:guido.flohr@cantanea.com>), all rights reserved. See the source +code for details!code for details! =head1 SEE ALSO |