File Coverage

lib/ExtUtils/MakeMaker/Locale.pm

Criterion	Covered	Total	%
statement	51	108	47.2
branch	11	72	15.2
condition	10	28	35.7
subroutine	11	20	55.0
pod	3	3	100.0
total	86	231	37.2

package ExtUtils::MakeMaker::Locale;

use strict;
use warnings;
our $VERSION = "7.78";
$VERSION =~ tr/_//d;

use base 'Exporter';
our @EXPORT_OK = qw(
    decode_argv env
    $ENCODING_LOCALE $ENCODING_LOCALE_FS
    $ENCODING_CONSOLE_IN $ENCODING_CONSOLE_OUT
);

use Encode ();
use Encode::Alias ();

our $ENCODING_LOCALE;
our $ENCODING_LOCALE_FS;
our $ENCODING_CONSOLE_IN;
our $ENCODING_CONSOLE_OUT;

sub DEBUG () { 0 }

sub _init {
    if ($^O eq "MSWin32") {
	unless ($ENCODING_LOCALE) {
	    # Try to obtain what the Windows ANSI code page is
	    eval {
		unless (defined &GetConsoleCP) {
		    require Win32;
                    # manually "import" it since Win32->import refuses
		    *GetConsoleCP = sub { &Win32::GetConsoleCP } if defined &Win32::GetConsoleCP;
		}
		unless (defined &GetConsoleCP) {
		    require Win32::API;
		    Win32::API->Import('kernel32', 'int GetConsoleCP()');
		}
		if (defined &GetConsoleCP) {
		    my $cp = GetConsoleCP();
		    $ENCODING_LOCALE = "cp$cp" if $cp;
		}
	    };
	}

	unless ($ENCODING_CONSOLE_IN) {
            # only test one since set together
            unless (defined &GetInputCP) {
                eval {
                    require Win32;
                    eval {
                        local $SIG{__WARN__} = sub {} if ( "$]" < 5.014 ); # suppress deprecation warning for inherited AUTOLOAD of Win32::GetConsoleCP()
                        Win32::GetConsoleCP();
                    };
                    # manually "import" it since Win32->import refuses
                    *GetInputCP = sub { &Win32::GetConsoleCP } if defined &Win32::GetConsoleCP;
                    *GetOutputCP = sub { &Win32::GetConsoleOutputCP } if defined &Win32::GetConsoleOutputCP;
                };
                unless (defined &GetInputCP) {
                    eval {
                        # try Win32::Console module for codepage to use
                        require Win32::Console;
                        *GetInputCP = sub { &Win32::Console::InputCP }
                            if defined &Win32::Console::InputCP;
                        *GetOutputCP = sub { &Win32::Console::OutputCP }
                            if defined &Win32::Console::OutputCP;
                    };
                }
                unless (defined &GetInputCP) {
                    # final fallback
                    *GetInputCP = *GetOutputCP = sub {
                        # another fallback that could work is:
                        # reg query HKLM\System\CurrentControlSet\Control\Nls\CodePage /v ACP
                        ((qx(chcp) || '') =~ /^Active code page: (\d+)/)
                            ? $1 : ();
                    };
                }
	    }
            my $cp = GetInputCP();
            $ENCODING_CONSOLE_IN = "cp$cp" if $cp;
            $cp = GetOutputCP();
            $ENCODING_CONSOLE_OUT = "cp$cp" if $cp;
	}
    }

    unless ($ENCODING_LOCALE) {
	eval {
	    require I18N::Langinfo;
	    $ENCODING_LOCALE = I18N::Langinfo::langinfo(I18N::Langinfo::CODESET());

	    # Workaround of Encode < v2.25.  The "646" encoding  alias was
	    # introduced in Encode-2.25, but we don't want to require that version
	    # quite yet.  Should avoid the CPAN testers failure reported from
	    # openbsd-4.7/perl-5.10.0 combo.
	    $ENCODING_LOCALE = "ascii" if $ENCODING_LOCALE eq "646";

	    # https://rt.cpan.org/Ticket/Display.html?id=66373
	    $ENCODING_LOCALE = "hp-roman8" if $^O eq "hpux" && $ENCODING_LOCALE eq "roman8";
	};
	$ENCODING_LOCALE ||= $ENCODING_CONSOLE_IN;
    }

    # Workaround of Encode < v2.71 for "cp65000" and "cp65001"
    # The "cp65000" and "cp65001" aliases were added in [Encode v2.71](https://github.com/dankogai/p5-encode/commit/7874bd95aa10967a3b5dbae333d16bcd703ac6c6)
    # via commit .
    # This will avoid test failures for Win32 machines using the UTF-7 or UTF-8 code pages.
    $ENCODING_LOCALE = 'UTF-7' if $ENCODING_LOCALE && lc($ENCODING_LOCALE) eq "cp65000";
    $ENCODING_LOCALE = 'utf-8-strict' if $ENCODING_LOCALE && lc($ENCODING_LOCALE) eq "cp65001";

    if ($^O eq "darwin") {
	$ENCODING_LOCALE_FS ||= "UTF-8";
    }

    # final fallback
    $ENCODING_LOCALE ||= $^O eq "MSWin32" ? "cp1252" : "UTF-8";
    $ENCODING_LOCALE_FS ||= $ENCODING_LOCALE;
    $ENCODING_CONSOLE_IN ||= $ENCODING_LOCALE;
    $ENCODING_CONSOLE_OUT ||= $ENCODING_CONSOLE_IN;

    unless (Encode::find_encoding($ENCODING_LOCALE)) {
	my $foundit;
	if (lc($ENCODING_LOCALE) eq "gb18030") {
	    eval {
		require Encode::HanExtra;
	    };
	    if ($@) {
		die "Need Encode::HanExtra to be installed to support locale codeset ($ENCODING_LOCALE), stopped";
	    }
	    $foundit++ if Encode::find_encoding($ENCODING_LOCALE);
	}
	die "The locale codeset ($ENCODING_LOCALE) isn't one that perl can decode, stopped"
	    unless $foundit;

    }

    # use Data::Dump; ddx $ENCODING_LOCALE, $ENCODING_LOCALE_FS, $ENCODING_CONSOLE_IN, $ENCODING_CONSOLE_OUT;
}

_init();
Encode::Alias::define_alias(sub {
    no strict 'refs';
    no warnings 'once';
    return ${"ENCODING_" . uc(shift)};
}, "locale");

sub _flush_aliases {
    no strict 'refs';
    for my $a (sort keys %Encode::Alias::Alias) {
	if (defined ${"ENCODING_" . uc($a)}) {
	    delete $Encode::Alias::Alias{$a};
	    warn "Flushed alias cache for $a" if DEBUG;
	}
    }
}

sub reinit {
    $ENCODING_LOCALE = shift;
    $ENCODING_LOCALE_FS = shift;
    $ENCODING_CONSOLE_IN = $ENCODING_LOCALE;
    $ENCODING_CONSOLE_OUT = $ENCODING_LOCALE;
    _init();
    _flush_aliases();
}

sub decode_argv {
    die if defined wantarray;
    for (@ARGV) {
	$_ = Encode::decode(locale => $_, @_);
    }
}

sub env {
    my $k = Encode::encode(locale => shift);
    my $old = $ENV{$k};
    if (@_) {
	my $v = shift;
	if (defined $v) {
	    $ENV{$k} = Encode::encode(locale => $v);
	}
	else {
	    delete $ENV{$k};
	}
    }
    return Encode::decode(locale => $old) if defined wantarray;
}

1;

__END__