File Coverage

blib/lib/Locale/gettext_pp.pm

Criterion	Covered	Total	%
statement	314	346	90.7
branch	116	196	59.1
condition	49	101	48.5
subroutine	42	42	100.0
pod	24	24	100.0
total	545	709	76.8

#! /bin/false

# vim: set autoindent shiftwidth=4 tabstop=4:

# Pure Perl implementation of Uniforum message translation.
# Copyright (C) 2002-2017 Guido Flohr ,
# 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 .

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 = ;
    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__