1121 lines
28 KiB
Perl
1121 lines
28 KiB
Perl
#! /bin/false
|
|
|
|
# vim: set autoindent shiftwidth=4 tabstop=4:
|
|
|
|
# Pure Perl implementation of Uniforum message translation.
|
|
# 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 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 General Public License for more details.
|
|
|
|
# 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;
|
|
|
|
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);
|
|
|
|
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;
|
|
}
|
|
}
|
|
}
|
|
|
|
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) {
|
|
eval <<'EOF';
|
|
sub LC_MESSAGES()
|
|
{
|
|
local $!; # Do not clobber errno!
|
|
|
|
return &POSIX::LC_MESSAGES;
|
|
}
|
|
EOF
|
|
} elsif ($five_ok) {
|
|
eval <<'EOF';
|
|
sub LC_MESSAGES()
|
|
{
|
|
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;
|
|
}
|
|
EOF
|
|
} else {
|
|
eval <<'EOF';
|
|
sub LC_MESSAGES()
|
|
{
|
|
local $!; # Do not clobber errno!
|
|
|
|
# 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)
|
|
],
|
|
);
|
|
|
|
@EXPORT_OK = qw (gettext
|
|
dgettext
|
|
dcgettext
|
|
ngettext
|
|
dngettext
|
|
dcngettext
|
|
pgettext
|
|
dpgettext
|
|
dcpgettext
|
|
npgettext
|
|
dnpgettext
|
|
dcnpgettext
|
|
textdomain
|
|
bindtextdomain
|
|
bind_textdomain_codeset
|
|
nl_putenv
|
|
setlocale
|
|
LC_CTYPE
|
|
LC_NUMERIC
|
|
LC_TIME
|
|
LC_COLLATE
|
|
LC_MONETARY
|
|
LC_MESSAGES
|
|
LC_ALL);
|
|
@ISA = qw (Exporter);
|
|
|
|
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;
|
|
}
|
|
|
|
sub LC_CTYPE()
|
|
{
|
|
&POSIX::LC_CTYPE;
|
|
}
|
|
|
|
sub LC_TIME()
|
|
{
|
|
&POSIX::LC_TIME;
|
|
}
|
|
|
|
sub LC_COLLATE()
|
|
{
|
|
&POSIX::LC_COLLATE;
|
|
}
|
|
|
|
sub LC_MONETARY()
|
|
{
|
|
&POSIX::LC_MONETARY;
|
|
}
|
|
|
|
sub 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;
|
|
}
|
|
|
|
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;
|
|
}
|
|
}
|
|
|
|
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;
|
|
}
|
|
|
|
sub gettext($)
|
|
{
|
|
my ($msgid) = @_;
|
|
|
|
return dcnpgettext ('', undef, $msgid, undef, undef, undef);
|
|
}
|
|
|
|
sub dgettext($$)
|
|
{
|
|
my ($domainname, $msgid) = @_;
|
|
|
|
return dcnpgettext ($domainname, undef, $msgid, undef, undef, undef);
|
|
}
|
|
|
|
sub dcgettext($$$)
|
|
{
|
|
my ($domainname, $msgid, $category) = @_;
|
|
|
|
return dcnpgettext ($domainname, undef, $msgid, undef, undef, undef);
|
|
}
|
|
|
|
sub ngettext($$$)
|
|
{
|
|
my ($msgid, $msgid_plural, $n) = @_;
|
|
|
|
return dcnpgettext ('', undef, $msgid, $msgid_plural, $n, undef);
|
|
}
|
|
|
|
sub dngettext($$$$)
|
|
{
|
|
my ($domainname, $msgid, $msgid_plural, $n) = @_;
|
|
|
|
return dcnpgettext ($domainname, undef, $msgid, $msgid_plural, $n, undef);
|
|
}
|
|
|
|
sub dcngettext($$$$$)
|
|
{
|
|
my ($domainname, $msgid, $msgid_plural, $n, $category) = @_;
|
|
|
|
return dcnpgettext ($domainname, undef, $msgid, $msgid_plural, $n, , $category);
|
|
}
|
|
|
|
|
|
sub pgettext($$)
|
|
{
|
|
my ($msgctxt, $msgid) = @_;
|
|
|
|
return dcnpgettext ('', $msgctxt, $msgid, undef, undef, undef);
|
|
}
|
|
|
|
sub dpgettext($$$)
|
|
{
|
|
my ($domainname, $msgctxt, $msgid) = @_;
|
|
|
|
return dcnpgettext ($domainname, $msgctxt, $msgid, undef, undef, undef);
|
|
}
|
|
|
|
sub dcpgettext($$$$)
|
|
{
|
|
my ($domainname, $msgctxt, $msgid, $category) = @_;
|
|
|
|
return dcnpgettext ($domainname, $msgctxt, $msgid, undef, undef, undef);
|
|
}
|
|
|
|
sub npgettext($$$$)
|
|
{
|
|
my ($msgctxt, $msgid, $msgid_plural, $n) = @_;
|
|
|
|
return dcnpgettext ('', $msgctxt, $msgid, $msgid_plural, $n, undef);
|
|
}
|
|
|
|
sub dnpgettext($$$$$)
|
|
{
|
|
my ($domainname, $msgctxt, $msgid, $msgid_plural, $n) = @_;
|
|
|
|
return dcnpgettext ($domainname, $msgctxt, $msgid, $msgid_plural, $n, undef);
|
|
}
|
|
|
|
# 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 ($)
|
|
{
|
|
my ($envspec) = @_;
|
|
return unless defined $envspec;
|
|
return unless length $envspec;
|
|
return if substr ($envspec, 0, 1) eq '=';
|
|
|
|
my ($var, $value) = split /=/, $envspec, 2;
|
|
|
|
# In Perl we *could* set empty environment variables even under
|
|
# MS-DOS, but for compatibility reasons, we implement the
|
|
# brain-damaged behavior of the Microsoft putenv().
|
|
if ($^O eq 'MSWin32') {
|
|
$value = '' unless defined $value;
|
|
if (length $value) {
|
|
$ENV{$var} = $value;
|
|
} else {
|
|
delete $ENV{$var};
|
|
}
|
|
} else {
|
|
if (defined $value) {
|
|
$ENV{$var} = $value;
|
|
} else {
|
|
delete $ENV{$var};
|
|
}
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
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 ($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';
|
|
}
|
|
|
|
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 $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__
|
|
|
|
=head1 NAME
|
|
|
|
Locale::gettext_pp - Pure Perl Implementation of Uniforum Message Translation
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use Locale::gettext_pp qw(:locale_h :libintl_h);
|
|
|
|
gettext $msgid;
|
|
dgettext $domainname, $msgid;
|
|
dcgettext $domainname, $msgid, LC_MESSAGES;
|
|
ngettext $msgid, $msgid_plural, $count;
|
|
dngettext $domainname, $msgid, $msgid_plural, $count;
|
|
dcngettext $domainname, $msgid, $msgid_plural, $count, LC_MESSAGES;
|
|
pgettext $msgctxt, $msgid;
|
|
dpgettext $domainname, $msgctxt, $msgid;
|
|
dcpgettext $domainname, $msgctxt, $msgid, LC_MESSAGES;
|
|
npgettext $msgctxt, $msgid, $msgid_plural, $count;
|
|
dnpgettext $domainname, $msgctxt, $msgid, $msgid_plural, $count;
|
|
dcnpgettext $domainname, $msgctxt, $msgid, $msgid_plural, $count, LC_MESSAGES;
|
|
textdomain $domainname;
|
|
bindtextdomain $domainname, $directory;
|
|
bind_textdomain_codeset $domainname, $encoding;
|
|
my $category = LC_CTYPE;
|
|
my $category = LC_NUMERIC;
|
|
my $category = LC_TIME;
|
|
my $category = LC_COLLATE;
|
|
my $category = LC_MONETARY;
|
|
my $category = LC_MESSAGES;
|
|
my $category = LC_ALL;
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
The module B<Locale::gettext_pp> is the low-level interface to
|
|
message translation according to the Uniforum approach that is
|
|
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
|
|
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
|
|
imported explicitly or via an export tag (L<"EXPORT TAGS">).
|
|
|
|
=over 4
|
|
|
|
=item B<gettext MSGID>
|
|
|
|
See L<Locale::Messages/FUNCTIONS>.
|
|
|
|
=item B<dgettext TEXTDOMAIN, MSGID>
|
|
|
|
See L<Locale::Messages/FUNCTIONS>.
|
|
|
|
=item B<dcgettext TEXTDOMAIN, MSGID, CATEGORY>
|
|
|
|
See L<Locale::Messages/FUNCTIONS>.
|
|
|
|
=item B<ngettext MSGID, MSGID_PLURAL, COUNT>
|
|
|
|
See L<Locale::Messages/FUNCTIONS>.
|
|
|
|
=item B<dngettext TEXTDOMAIN, MSGID, MSGID_PLURAL, COUNT>
|
|
|
|
See L<Locale::Messages/FUNCTIONS>.
|
|
|
|
=item B<dcngettext TEXTDOMAIN, MSGID, MSGID_PLURAL, COUNT, CATEGORY>
|
|
|
|
See L<Locale::Messages/FUNCTIONS>.
|
|
|
|
=item B<pgettext MSGCTXT, MSGID>
|
|
|
|
See L<Locale::Messages/FUNCTIONS>.
|
|
|
|
=item B<dpgettext TEXTDOMAIN, MSGCTXT, MSGID>
|
|
|
|
See L<Locale::Messages/FUNCTIONS>.
|
|
|
|
=item B<dcpgettext TEXTDOMAIN, MSGCTXT, MSGID, CATEGORY>
|
|
|
|
See L<Locale::Messages/FUNCTIONS>.
|
|
|
|
=item B<npgettext MSGCTXT, MSGID, MSGID_PLURAL, COUNT>
|
|
|
|
See L<Locale::Messages/FUNCTIONS>.
|
|
|
|
=item B<dnpgettext TEXTDOMAIN, MSGCTXT, MSGID, MSGID_PLURAL, COUNT>
|
|
|
|
See L<Locale::Messages/FUNCTIONS>.
|
|
|
|
=item B<dcnpgettext TEXTDOMAIN, MSGCTXT, MSGID, MSGID_PLURAL, COUNT, CATEGORY>
|
|
|
|
See L<Locale::Messages/FUNCTIONS>.
|
|
|
|
=item B<textdomain TEXTDOMAIN>
|
|
|
|
See L<Locale::Messages/FUNCTIONS>.
|
|
|
|
=item B<bindtextdomain TEXTDOMAIN, DIRECTORY>
|
|
|
|
See L<Locale::Messages/FUNCTIONS>.
|
|
|
|
=item B<bind_textdomain_codeset TEXTDOMAIN, ENCODING>
|
|
|
|
=item B<nl_putenv ENVSPEC>
|
|
|
|
See L<Locale::Messages/FUNCTIONS>.
|
|
|
|
=item B<setlocale>
|
|
|
|
See L<Locale::Messages/FUNCTIONS>.
|
|
|
|
=back
|
|
|
|
=head1 CONSTANTS
|
|
|
|
You can (maybe) get the same constants from POSIX(3); see there for
|
|
a detailed description
|
|
|
|
=over 4
|
|
|
|
=item B<LC_CTYPE>
|
|
|
|
=item B<LC_NUMERIC>
|
|
|
|
=item B<LC_TIME>
|
|
|
|
=item B<LC_COLLATE>
|
|
|
|
=item B<LC_MONETARY>
|
|
|
|
=item B<LC_MESSAGES>
|
|
|
|
=item B<LC_ALL>
|
|
|
|
See L<Locale::Messages/CONSTANTS> for more information.
|
|
|
|
=back
|
|
|
|
=head1 EXPORT TAGS
|
|
|
|
This module does not export anything unless explicitly requested.
|
|
You can import groups of functions via two tags:
|
|
|
|
=over 4
|
|
|
|
=item B<use Locale::gettext_pp qw(':locale_h')>
|
|
|
|
Imports the functions that are normally defined in the C include
|
|
file F<locale.h>:
|
|
|
|
=over 8
|
|
|
|
=item B<gettext()>
|
|
|
|
=item B<dgettext()>
|
|
|
|
=item B<dcgettext()>
|
|
|
|
=item B<ngettext()>
|
|
|
|
=item B<dngettext()>
|
|
|
|
=item B<dcngettext()>
|
|
|
|
=item B<pgettext()>
|
|
|
|
Introduced with libintl-perl 1.17.
|
|
|
|
=item B<dpgettext()>
|
|
|
|
Introduced with libintl-perl 1.17.
|
|
|
|
=item B<dcpgettext()>
|
|
|
|
Introduced with libintl-perl 1.17.
|
|
|
|
=item B<npgettext()>
|
|
|
|
Introduced with libintl-perl 1.17.
|
|
|
|
=item B<dnpgettext()>
|
|
|
|
Introduced with libintl-perl 1.17.
|
|
|
|
=item B<dcnpgettext()>
|
|
|
|
Introduced with libintl-perl 1.17.
|
|
|
|
=item B<textdomain()>
|
|
|
|
=item B<bindtextdomain()>
|
|
|
|
=item B<bind_textdomain_codeset()>
|
|
|
|
=back
|
|
|
|
=item B<use Locale::gettext_pp (':libintl_h')>
|
|
|
|
Imports the locale category constants:
|
|
|
|
=over 8
|
|
|
|
=item B<LC_CTYPE>
|
|
|
|
=item B<LC_NUMERIC>
|
|
|
|
=item B<LC_TIME>
|
|
|
|
=item B<LC_COLLATE>
|
|
|
|
=item B<LC_MONETARY>
|
|
|
|
=item B<LC_MESSAGES>
|
|
|
|
=item B<LC_ALL>
|
|
|
|
=back
|
|
|
|
=back
|
|
|
|
=head1 AUTHOR
|
|
|
|
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
|
|
|
|
Locale::TextDomain(3pm), Locale::Messages(3pm), Encode(3pm),
|
|
perllocale(3pm), POSIX(3pm), perl(1), gettext(1), gettext(3)
|
|
|
|
=cut
|
|
|
|
Local Variables:
|
|
mode: perl
|
|
perl-indent-level: 4
|
|
perl-continued-statement-offset: 4
|
|
perl-continued-brace-offset: 0
|
|
perl-brace-offset: -4
|
|
perl-brace-imaginary-offset: 0
|
|
perl-label-offset: -4
|
|
tab-width: 4
|
|
End:
|