-sub in_locale { $^H & $locale::hint_bits }
-
-sub _get_locale_encoding {
- unless (defined $locale_encoding) {
- # I18N::Langinfo isn't available everywhere
- eval {
- require I18N::Langinfo;
- I18N::Langinfo->import(qw(langinfo CODESET));
- $locale_encoding = langinfo(CODESET());
- };
- unless ($@) {
- print "# locale_encoding = $locale_encoding\n";
- }
- my $country_language;
- if (not $locale_encoding && in_locale()) {
- if ($ENV{LC_ALL} =~ /^([^.]+)\.([^.]+)$/) {
- ($country_language, $locale_encoding) = ($1, $2);
- } elsif ($ENV{LANG} =~ /^([^.]+)\.([^.]+)$/) {
- ($country_language, $locale_encoding) = ($1, $2);
- }
- } 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 &&
- $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_TW|taiwan(?:ese)?$/i) {
- $locale_encoding = 'euc-tw';
- }
- croak "Locale encoding 'euc' too ambiguous"
- if $locale_encoding eq 'euc';
- }
+sub _get_encname {
+ return ($1, Encode::resolve_alias($1)) if $_[0] =~ /^:?encoding\((.+)\)$/;
+ return;
+}
+
+sub croak {
+ require Carp; goto &Carp::croak;
+}
+
+sub _drop_oldenc {
+ # If by the time we arrive here there already is at the top of the
+ # perlio layer stack an encoding identical to what we would like
+ # to push via this open pragma, we will pop away the old encoding
+ # (+utf8) so that we can push ourselves in place (this is easier
+ # than ignoring pushing ourselves because of the way how ${^OPEN}
+ # works). So we are looking for something like
+ #
+ # stdio encoding(xxx) utf8
+ #
+ # in the existing layer stack, and in the new stack chunk for
+ #
+ # :encoding(xxx)
+ #
+ # If we find a match, we pop the old stack (once, since
+ # the utf8 is just a flag on the encoding layer)
+ my ($h, @new) = @_;
+ return unless @new >= 1 && $new[-1] =~ /^:encoding\(.+\)$/;
+ my @old = PerlIO::get_layers($h);
+ return unless @old >= 3 &&
+ $old[-1] eq 'utf8' &&
+ $old[-2] =~ /^encoding\(.+\)$/;
+ require Encode;
+ my ($loname, $lcname) = _get_encname($old[-2]);
+ unless (defined $lcname) { # Should we trust get_layers()?
+ croak("open: Unknown encoding '$loname'");
+ }
+ my ($voname, $vcname) = _get_encname($new[-1]);
+ unless (defined $vcname) {
+ croak("open: Unknown encoding '$voname'");
+ }
+ if ($lcname eq $vcname) {
+ binmode($h, ":pop"); # utf8 is part of the encoding layer