File Coverage

blib/lib/Locale/Messages.pm

Criterion	Covered	Total	%
statement	162	183	88.5
branch	10	22	45.4
condition	28	36	77.7
subroutine	49	56	87.5
pod	28	28	100.0
total	277	325	85.2

#! /bin/false

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

# 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::Messages;

use strict;

use File::Spec;

use vars qw ($package @EXPORT_OK %EXPORT_TAGS @ISA $VERSION);

$VERSION = '1.31';

# Try to load the C version first.
$package = 'gettext_xs';

# Do not load from current working directory.
local @INC = grep { File::Spec->file_name_is_absolute($_) } @INC;

eval <<'EOF';
require Locale::gettext_xs;
my $version = Locale::gettext_xs::__gettext_xs_version();
die "Version: version mismatch ($VERSION vs. $version)" unless $version eq $VERSION;
EOF
my $no_xs = $@;

# There are systems where setlocale() and the LC_ constants are not
# defined at all, see https://rt.cpan.org/Ticket/Display.html?id=98109
#
# On such systems, we always fall back to gettext_dumb.
if ($no_xs) {
    eval {
        require POSIX;
        # void
        POSIX::setlocale(POSIX::LC_ALL());
    };
    if ($@) {
        $package = 'gettext_dumb';
        require Locale::gettext_dumb;
    } else {
        $package = 'gettext_pp';
        require Locale::gettext_pp;
    }
}

require Exporter;
@ISA = qw (Exporter);
%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 (select_package
				 turn_utf_8_on
				 turn_utf_8_off
				 gettext
				 dgettext
				 dcgettext
				 ngettext
				 dngettext
				 dcngettext
				 pgettext
				 dpgettext
				 dcpgettext
				 npgettext
				 dnpgettext
				 dcnpgettext
				 textdomain
				 bindtextdomain
				 bind_textdomain_codeset
				 bind_textdomain_filter
                 nl_putenv
                 setlocale
				 LC_CTYPE
				 LC_NUMERIC
				 LC_TIME
				 LC_COLLATE
				 LC_MONETARY
				 LC_MESSAGES
				 LC_ALL);

BEGIN {
	my ($has_encode, $has_bytes);

	if ($] >= 5.006) {
		unless (defined $has_encode) {
			eval "require Encode";
			$has_encode = !$@;
		}

		unless ($has_encode || defined $has_bytes) {
			eval "use bytes";
			$has_bytes = !$@;
		}
	}

	# Turn the UTF-8 flag on or off unconditionally.  The prototypes
	# allow an optional second parameter, so that you can use the
	# functions as callbacks to bind_textdomain_filter.
	if ($has_encode) {
		eval <<'EOF';
sub turn_utf_8_on($;$)
{
	Encode::_utf8_on ($_[0]);
	return $_[0];
}

sub turn_utf_8_off($;$)
{
	Encode::_utf8_off ($_[0]);
	return $_[0];
}

EOF
	} elsif ($has_bytes) {
		eval <<'EOF';
sub turn_utf_8_on($;$)
{
	$_[0] = pack "U0C*", unpack "C*", $_[0];
}

sub turn_utf_8_off($;$)
{
	use bytes;
	$_[0] = join "", split //, $_[0];
}

EOF
	} else {
		eval <<'EOF';
sub turn_utf_8_on($;$)
{
	return $_[0];
}

sub turn_utf_8_off($;$)
{
	return $_[0];
}

EOF
	}
}

# The textdomain could be undef.  We avoid a warning by specifying
# a filter for the undefined textdomain.
my %filters = (undef => \&turn_utf_8_off);

sub select_package {
    my ($pkg, $compatibility) = @_;

    # Compatibility quirk for a bug pre 1.17:
    if (__PACKAGE__ eq $pkg && defined $compatibility) {
        $pkg = $compatibility;
    }

    if ($no_xs && 'gettext_xs' eq $pkg) {
        $pkg = 'gettext_pp';
    }

    if (defined $pkg && 'gettext_pp' eq $pkg) {
        # This branch is not unnecessary.  The next (elsif) branch does
        # essentially the same but catches compilation errors.
        require Locale::gettext_pp;
        $package = 'gettext_pp';
    } elsif (defined $pkg) {
        my $filename = "Locale::$pkg";
        $filename =~ s{::|\'}{/};
	$filename .= '.pm';
        eval { require $filename };
	$package = $pkg unless $@;
    } else {
        eval "require Locale::gettext_xs";
        $package = 'gettext_xs' unless $@;
    }

    return $package;
}

sub bind_textdomain_filter ($;$$) {
	my ($textdomain, $coderef, $data) = @_;

	$filters{$textdomain} = [ $coderef, $data ];

	return 1;
}

sub textdomain (;$) {
    my $function = "Locale::${package}::textdomain";

    no strict 'refs';
    &$function;
}

sub bindtextdomain ($;$) {
    my $function = "Locale::${package}::bindtextdomain";

    no strict 'refs';
    &$function;
}

sub bind_textdomain_codeset ($;$) {
    my $function = "Locale::${package}::bind_textdomain_codeset";

    no strict 'refs';
    &$function;
}

sub gettext ($) {
    my $textdomain = textdomain;
    $filters{$textdomain} ||= [ \&turn_utf_8_off ];
    my $cb = $filters{$textdomain};

    my $function = "Locale::${package}::gettext";

    no strict 'refs';
    $cb->[0] (&$function, $cb->[1]);
}

sub dgettext($$) {
    my $cb = $filters{$_[0]} ||= [ \&turn_utf_8_off ];

    my $function = "Locale::${package}::dgettext";

    no strict 'refs';
    $cb->[0] (&$function, $cb->[1]);
}

sub dcgettext($$$) {
    my $cb = $filters{$_[0]} ||= [ \&turn_utf_8_off ];

    my $function = "Locale::${package}::dcgettext";

    no strict 'refs';
    $cb->[0] (&$function, $cb->[1]);
}

sub ngettext($$$) {
    my $textdomain = textdomain;
    $filters{$textdomain} ||= [ \&turn_utf_8_off ];
    my $cb = $filters{$textdomain};

    my $function = "Locale::${package}::ngettext";

    no strict 'refs';
    $cb->[0] (&$function, $cb->[1]);
}

sub dngettext($$$$) {
    my $cb = $filters{$_[0]} ||= [ \&turn_utf_8_off ];

    my $function = "Locale::${package}::dngettext";

    no strict 'refs';
    $cb->[0] (&$function, $cb->[1]);
}

sub dcngettext($$$$$) {
    my $cb = $filters{$_[0]} ||= [ \&turn_utf_8_off ];

    my $function = "Locale::${package}::dcngettext";

    no strict 'refs';
    $cb->[0] (&$function, $cb->[1]);
}

sub pgettext($$) {
    my $textdomain = textdomain;
    $filters{$textdomain} ||= [ \&turn_utf_8_off ];
    my $cb = $filters{$textdomain};

    my $function = "Locale::${package}::pgettext";

    no strict 'refs';
    $cb->[0] (&$function, $cb->[1]);
}

sub dpgettext($$$) {
    my $cb = $filters{$_[0]} ||= [ \&turn_utf_8_off ];

    my $function = "Locale::${package}::dpgettext";

    no strict 'refs';
    $cb->[0] (&$function, $cb->[1]);
}

sub dcpgettext($$$$) {
    my $cb = $filters{$_[0]} ||= [ \&turn_utf_8_off ];

    my $function = "Locale::${package}::dcpgettext";

    no strict 'refs';
    $cb->[0] (&$function, $cb->[1]);
}

sub npgettext($$$$) {
    my $cb = $filters{$_[0]} ||= [ \&turn_utf_8_off ];

    my $function = "Locale::${package}::npgettext";

    no strict 'refs';
    $cb->[0] (&$function, $cb->[1]);
}

sub dnpgettext($$$$$) {
    my $cb = $filters{$_[0]} ||= [ \&turn_utf_8_off ];

    my $function = "Locale::${package}::dnpgettext";

    no strict 'refs';
    $cb->[0] (&$function, $cb->[1]);
}

sub dcnpgettext($$$$$$) {
    my $cb = $filters{$_[0]} ||= [ \&turn_utf_8_off ];

    my $function = "Locale::${package}::dcnpgettext";

    no strict 'refs';
    $cb->[0] (&$function, $cb->[1]);
}

sub setlocale($;$) {
    my $function = "Locale::${package}::setlocale";

    no strict 'refs';
    &$function;
}

sub nl_putenv($) {
    my $function = "Locale::${package}::nl_putenv";

    no strict 'refs';
    &$function;
}

sub LC_NUMERIC {
    my $function = "Locale::${package}::LC_NUMERIC";

    no strict 'refs';
    &$function;
}

sub LC_CTYPE {
    my $function = "Locale::${package}::LC_CTYPE";

    no strict 'refs';
    &$function;
}

sub LC_TIME {
    my $function = "Locale::${package}::LC_TIME";

    no strict 'refs';
    &$function;
}

sub LC_COLLATE {
    my $function = "Locale::${package}::LC_COLLATE";

    no strict 'refs';
    &$function;
}

sub LC_MONETARY {
    my $function = "Locale::${package}::LC_MONETARY";

    no strict 'refs';
    &$function;
}

sub LC_MESSAGES {
    my $function = "Locale::${package}::LC_MESSAGES";

    no strict 'refs';
    &$function;
}

sub LC_ALL {
    my $function = "Locale::${package}::LC_ALL";

    no strict 'refs';
    &$function;
}

1;

__END__