File Coverage

blib/lib/encoding.pm

Criterion	Covered	Total	%
statement	90	143	62.9
branch	25	68	36.7
condition	6	19	31.5
subroutine	15	16	93.7
pod	0	1	0.0
total	136	247	55.0

# $Id: encoding.pm,v 2.20 2017/06/10 17:23:50 dankogai Exp $
package encoding;
our $VERSION = sprintf "%d.%02d", q$Revision: 2.20 $ =~ /(\d+)/g;

use Encode;
use strict;
use warnings;
use Config;

use constant {
    DEBUG => !!$ENV{PERL_ENCODE_DEBUG},
    HAS_PERLIO => eval { require PerlIO::encoding; PerlIO::encoding->VERSION(0.02) },
    PERL_5_21_7 => $^V && $^V ge v5.21.7, # lexically scoped
};

sub _exception {
    my $name = shift;
    $] > 5.008 and return 0;    # 5.8.1 or higher then no
    my %utfs = map { $_ => 1 }
      qw(utf8 UCS-2BE UCS-2LE UTF-16 UTF-16BE UTF-16LE
      UTF-32 UTF-32BE UTF-32LE);
    $utfs{$name} or return 0;    # UTFs or no
    require Config;
    Config->import();
    our %Config;
    return $Config{perl_patchlevel} ? 0 : 1    # maintperl then no
}

sub in_locale { $^H & ( $locale::hint_bits || 0 ) }

sub _get_locale_encoding {
    my $locale_encoding;

    if ($^O eq 'MSWin32') {
        my @tries = (
            # First try to get the OutputCP. This will work only if we
            # are attached to a console
            'Win32.pm' => 'Win32::GetConsoleOutputCP',
            'Win32/Console.pm' => 'Win32::Console::OutputCP',
            # If above failed, this means that we are a GUI app
            # Let's assume that the ANSI codepage is what matters
            'Win32.pm' => 'Win32::GetACP',
        );
        while (@tries) {
            my $cp = eval {
                require $tries[0];
                no strict 'refs';
                &{$tries[1]}()
            };
            if ($cp) {
                if ($cp == 65001) { # Code page for UTF-8
                    $locale_encoding = 'UTF-8';
                } else {
                    $locale_encoding = 'cp' . $cp;
                }
                return $locale_encoding;
            }
            splice(@tries, 0, 2)
        }
    }

    # I18N::Langinfo isn't available everywhere
    $locale_encoding = eval {
        require I18N::Langinfo;
        find_encoding(
            I18N::Langinfo::langinfo( I18N::Langinfo::CODESET() )
        )->name
    };
    return $locale_encoding if defined $locale_encoding;

    eval {
        require POSIX;
        # Get the current locale
        # Remember that MSVCRT impl is quite different from Unixes
        my $locale = POSIX::setlocale(POSIX::LC_CTYPE());
        if ( $locale =~ /^([^.]+)\.([^.@]+)(?:@.*)?$/ ) {
            my $country_language;
            ( $country_language, $locale_encoding ) = ( $1, $2 );

            # Could do more heuristics based on the country and language
            # since we have Locale::Country and Locale::Language available.
            # TODO: get a database of Language -> Encoding mappings
            # (the Estonian database at http://www.eki.ee/letter/
            # would be excellent!) --jhi
            if (lc($locale_encoding) eq 'euc') {
                if ( $country_language =~ /^ja_JP|japan(?:ese)?$/i ) {
                    $locale_encoding = 'euc-jp';
                }
                elsif ( $country_language =~ /^ko_KR|korean?$/i ) {
                    $locale_encoding = 'euc-kr';
                }
                elsif ( $country_language =~ /^zh_CN|chin(?:a|ese)$/i ) {
                    $locale_encoding = 'euc-cn';
                }
                elsif ( $country_language =~ /^zh_TW|taiwan(?:ese)?$/i ) {
                    $locale_encoding = 'euc-tw';
                }
                else {
                    require Carp;
                    Carp::croak(
                        "encoding: Locale encoding '$locale_encoding' too ambiguous"
                    );
                }
            }
        }
    };

    return $locale_encoding;
}

sub import {

    if ( ord("A") == 193 ) {
        require Carp;
        Carp::croak("encoding: pragma does not support EBCDIC platforms");
    }

    my $deprecate =
        ($] >= 5.017 and !$Config{usecperl})
        ? "Use of the encoding pragma is deprecated" : 0;

    my $class = shift;
    my $name  = shift;
    if (!$name){
	require Carp;
        Carp::croak("encoding: no encoding specified.");
    }
    if ( $name eq ':_get_locale_encoding' ) {    # used by lib/open.pm
        my $caller = caller();
        {
            no strict 'refs';
            *{"${caller}::_get_locale_encoding"} = \&_get_locale_encoding;
        }
        return;
    }
    $name = _get_locale_encoding() if $name eq ':locale';
    BEGIN { strict->unimport('hashpairs') if $] >= 5.027 and $^V =~ /c$/; }
    my %arg = @_;
    $name = $ENV{PERL_ENCODING} unless defined $name;
    my $enc = find_encoding($name);
    unless ( defined $enc ) {
        require Carp;
        Carp::croak("encoding: Unknown encoding '$name'");
    }
    $name = $enc->name;    # canonize
    unless ( $arg{Filter} ) {
        if ($] >= 5.025003 and !$Config{usecperl}) {
            require Carp;
            Carp::croak("The encoding pragma is no longer supported. Check cperl");
        }
        warnings::warnif("deprecated",$deprecate) if $deprecate;

        DEBUG and warn "_exception($name) = ", _exception($name);
        if (! _exception($name)) {
            if (!PERL_5_21_7) {
                ${^ENCODING} = $enc;
            }
            else {
                # Starting with 5.21.7, this pragma uses a shadow variable
                # designed explicitly for it, ${^E_NCODING}, to enforce
                # lexical scope; instead of ${^ENCODING}.
                $^H{'encoding'} = 1;
                ${^E_NCODING} = $enc;
            }
        }
        if (! HAS_PERLIO ) {
            return 1;
        }
    }
    else {
        warnings::warnif("deprecated",$deprecate) if $deprecate;

        defined( ${^ENCODING} ) and undef ${^ENCODING};
        undef ${^E_NCODING} if PERL_5_21_7;

        # implicitly 'use utf8'
        require utf8;      # to fetch $utf8::hint_bits;
        $^H |= $utf8::hint_bits;
        eval {
            require Filter::Util::Call;
            Filter::Util::Call->import;
            filter_add(
                sub {
                    my $status = filter_read();
                    if ( $status > 0 ) {
                        $_ = $enc->decode( $_, 1 );
                        DEBUG and warn $_;
                    }
                    $status;
                }
            );
            1;
        } and DEBUG and warn "Filter installed";
    }
    defined ${^UNICODE} and ${^UNICODE} != 0 and return 1;
    for my $h (qw(STDIN STDOUT)) {
        if ( $arg{$h} ) {
            unless ( defined find_encoding( $arg{$h} ) ) {
                require Carp;
                Carp::croak(
                    "encoding: Unknown encoding for $h, '$arg{$h}'");
            }
            eval { binmode( $h, ":raw :encoding($arg{$h})" ) };
        }
        else {
            unless ( exists $arg{$h} ) {
                eval {
                    no warnings 'uninitialized';
                    binmode( $h, ":raw :encoding($name)" );
                };
            }
        }
        if ($@) {
            require Carp;
            Carp::croak($@);
        }
    }
    return 1;    # I doubt if we need it, though
}

sub unimport {
    no warnings;
    undef ${^ENCODING};
    undef ${^E_NCODING} if PERL_5_21_7;
    if (HAS_PERLIO) {
        binmode( STDIN,  ":raw" );
        binmode( STDOUT, ":raw" );
    }
    else {
        binmode(STDIN);
        binmode(STDOUT);
    }
    if ( $INC{"Filter/Util/Call.pm"} ) {
        eval { filter_del() };
    }
}

1;
__END__