summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/encoding.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/encoding.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/encoding.pm156
1 files changed, 84 insertions, 72 deletions
diff --git a/Master/tlpkg/tlperl/lib/encoding.pm b/Master/tlpkg/tlperl/lib/encoding.pm
index fde410dc890..8450f9ca127 100644
--- a/Master/tlpkg/tlperl/lib/encoding.pm
+++ b/Master/tlpkg/tlperl/lib/encoding.pm
@@ -1,25 +1,16 @@
-# $Id: encoding.pm,v 2.14 2015/03/14 02:44:39 dankogai Exp dankogai $
+# $Id: encoding.pm,v 2.17 2015/09/15 13:53:27 dankogai Exp dankogai $
package encoding;
-our $VERSION = sprintf "%d.%02d", q$Revision: 2.14 $ =~ /(\d+)/g;
+our $VERSION = sprintf "%d.%02d", q$Revision: 2.17 $ =~ /(\d+)/g;
use Encode;
use strict;
use warnings;
-use constant DEBUG => !!$ENV{PERL_ENCODE_DEBUG};
-
-BEGIN {
- if ( ord("A") == 193 ) {
- require Carp;
- Carp::croak("encoding: pragma does not support EBCDIC platforms");
- }
-}
-
-our $HAS_PERLIO = 0;
-eval { require PerlIO::encoding };
-unless ($@) {
- $HAS_PERLIO = ( PerlIO::encoding->VERSION >= 0.02 );
-}
+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,
+};
sub _exception {
my $name = shift;
@@ -39,69 +30,90 @@ 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
- eval {
+ $locale_encoding = eval {
require I18N::Langinfo;
- I18N::Langinfo->import(qw(langinfo CODESET));
- $locale_encoding = langinfo( CODESET() );
+ find_encoding(
+ I18N::Langinfo::langinfo( I18N::Langinfo::CODESET() )
+ )->name
};
+ return $locale_encoding if defined $locale_encoding;
- my $country_language;
-
- no warnings 'uninitialized';
-
- if ( (not $locale_encoding) && in_locale() ) {
- if ( $ENV{LC_ALL} =~ /^([^.]+)\.([^.@]+)(@.*)?$/ ) {
- ( $country_language, $locale_encoding ) = ( $1, $2 );
- }
- elsif ( $ENV{LANG} =~ /^([^.]+)\.([^.@]+)(@.*)?$/ ) {
+ 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 );
- }
-
- # LANGUAGE affects only LC_MESSAGES only on glibc
- }
- elsif ( not $locale_encoding ) {
- if ( $ENV{LC_ALL} =~ /\butf-?8\b/i
- || $ENV{LANG} =~ /\butf-?8\b/i )
- {
- $locale_encoding = 'utf8';
- }
- # Could do more heuristics based on the country and language
- # parts of LC_ALL and LANG (the parts before the dot (if any)),
- # 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 ( defined $locale_encoding
- && lc($locale_encoding) eq 'euc'
- && defined $country_language )
- {
- 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"
- );
+ # 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");
+ }
+
if ($] >= 5.017) {
warnings::warnif("deprecated",
"Use of the encoding pragma is deprecated")
@@ -132,7 +144,7 @@ sub import {
unless ( $arg{Filter} ) {
DEBUG and warn "_exception($name) = ", _exception($name);
if (! _exception($name)) {
- if (!$^V || $^V lt v5.21.7) {
+ if (!PERL_5_21_7) {
${^ENCODING} = $enc;
}
else {
@@ -143,11 +155,11 @@ sub import {
${^E_NCODING} = $enc;
}
}
- $HAS_PERLIO or return 1;
+ HAS_PERLIO or return 1;
}
else {
defined( ${^ENCODING} ) and undef ${^ENCODING};
- undef ${^E_NCODING} if $^V && $^V ge v5.21.7;
+ undef ${^E_NCODING} if PERL_5_21_7;
# implicitly 'use utf8'
require utf8; # to fetch $utf8::hint_bits;
@@ -197,8 +209,8 @@ sub import {
sub unimport {
no warnings;
undef ${^ENCODING};
- undef ${^E_NCODING} if $^V && $^V ge v5.21.7;
- if ($HAS_PERLIO) {
+ undef ${^E_NCODING} if PERL_5_21_7;
+ if (HAS_PERLIO) {
binmode( STDIN, ":raw" );
binmode( STDOUT, ":raw" );
}