X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fopen.pm;h=24488e6716fabb660eec949e93a88de65f8591a9;hb=3b7fbd4a8e0aec57c7898a1775b0a17a345883de;hp=007b66712d6ac112ca437a2f1f674450b6ee03dd;hpb=61de9fb5aad39c2904a43125c7c70031be6bc679;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/open.pm b/lib/open.pm index 007b667..24488e6 100644 --- a/lib/open.pm +++ b/lib/open.pm @@ -1,66 +1,61 @@ package open; use warnings; -use Carp; -$open::hint_bits = 0x20000; +$open::hint_bits = 0x20000; # HINT_LOCALIZE_HH -our $VERSION = '1.01'; +our $VERSION = '1.05'; + +require 5.008001; # for PerlIO::get_layers() my $locale_encoding; -sub in_locale { $^H & ($locale::hint_bits || 0)} - -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()); - }; - 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} =~ /^([^.]+)\.([^.]+)$/) { - ($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 && - $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'; - } - 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 } } sub import { my ($class,@args) = @_; - croak("`use open' needs explicit list of PerlIO layers") unless @args; + croak("open: needs explicit list of PerlIO layers") unless @args; my $std; $^H |= $open::hint_bits; my ($in,$out) = split(/\0/,(${^OPEN} || "\0"), -1); @@ -80,8 +75,9 @@ sub import { foreach my $layer (split(/\s+/,$dscp)) { $layer =~ s/^://; if ($layer eq 'locale') { - use Encode; - _get_locale_encoding() + require Encode; + require encoding; + $locale_encoding = encoding::_get_locale_encoding() unless defined $locale_encoding; (warnings::warnif("layer", "Cannot figure out an encoding to use"), last) unless defined $locale_encoding; @@ -95,8 +91,8 @@ sub import { my $target = $layer; # the layer name itself $target =~ s/^(\w+)\(.+\)$/$1/; # strip parameters - unless(PerlIO::Layer::->find($target)) { - warnings::warnif("layer", "Unknown PerlIO layer '$layer'"); + unless(PerlIO::Layer::->find($target,1)) { + warnings::warnif("layer", "Unknown PerlIO layer '$target'"); } } push(@val,":$layer"); @@ -105,19 +101,23 @@ sub import { } } if ($type eq 'IN') { - $in = join(' ',@val); + _drop_oldenc(*STDIN, @val); + $in = join(' ', @val); } elsif ($type eq 'OUT') { - $out = join(' ',@val); + _drop_oldenc(*STDOUT, @val); + $out = join(' ', @val); } elsif ($type eq 'IO') { - $in = $out = join(' ',@val); + _drop_oldenc(*STDIN, @val); + _drop_oldenc(*STDOUT, @val); + $in = $out = join(' ', @val); } else { croak "Unknown PerlIO layer class '$type'"; } } - ${^OPEN} = join("\0",$in,$out) if $in or $out; + ${^OPEN} = join("\0", $in, $out); if ($std) { if ($in) { if ($in =~ /:utf8\b/) { @@ -166,9 +166,12 @@ Perl is configured to use PerlIO as its IO system (which is now the default). The C pragma serves as one of the interfaces to declare default -"layers" (also known as "disciplines") for all I/O. Any open(), -readpipe() (aka qx//) and similar operators found within the lexical -scope of this pragma will use the declared defaults. +"layers" (also known as "disciplines") for all I/O. Any two-argument +open(), readpipe() (aka qx//) and similar operators found within the +lexical scope of this pragma will use the declared defaults. +Three-argument opens are not affected by this pragma since there you +(can) explicitly specify the layers and are supposed to know what you +are doing. With the C subpragma you can declare the default layers of input streams, and with the C subpragma you can declare @@ -213,8 +216,8 @@ details and the list of supported locales. Note that C<:utf8> PerlIO layer must always be specified exactly like that, it is not subject to the loose matching of encoding names. -When open() is given an explicit list of layers they are appended to -the list declared using this pragma. +When open() is given an explicit list of layers (with the three-arg +syntax), they override the list declared using this pragma. The C<:std> subpragma on its own has no effect, but if combined with the C<:utf8> or C<:encoding> subpragmas, it converts the standard @@ -226,35 +229,9 @@ chosen to be in C<< :encoding(koi8r) >>, a C<:std> will cause only the STDOUT and STDERR to be in C. The C<:locale> subpragma implicitly turns on C<:std>. -The logic of C<:locale> is as follows: - -=over 4 - -=item 1. - -If the platform supports the langinfo(CODESET) interface, the codeset -returned is used as the default encoding for the open pragma. - -=item 2. - -If 1. didn't work but we are under the locale pragma, the environment -variables LC_ALL and LANG (in that order) are matched for encodings -(the part after C<.>, if any), and if any found, that is used -as the default encoding for the open pragma. - -=item 3. - -If 1. and 2. didn't work, the environment variables LC_ALL and LANG -(in that order) are matched for anything looking like UTF-8, and if -any found, C<:utf8> is used as the default encoding for the open -pragma. - -=back - -If your locale environment variables (LC_ALL, LC_CTYPE, LANG) -contain the strings 'UTF-8' or 'UTF8' (case-insensitive matching), -the default encoding of your STDIN, STDOUT, and STDERR, and of -B, is UTF-8. +The logic of C<:locale> is described in full in L, +but in short it is first trying nl_langinfo(CODESET) and then +guessing from the LC_ALL and LANG locale environment variables. Directory handles may also support PerlIO layers in the future.