X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fopen.pm;h=a6b4250e325d1813c4105bc970d5e543c0443b9e;hb=0508fb16c6a57ba6d246b3ddb11c79c68d302f62;hp=1c42b8aee93f4ad103a466e15ce42d82722fe0ef;hpb=1e616cf5bffcf11a1df72838e96be99b97cfab72;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/open.pm b/lib/open.pm index 1c42b8a..a6b4250 100644 --- a/lib/open.pm +++ b/lib/open.pm @@ -1,62 +1,61 @@ package open; -use Carp; -$open::hint_bits = 0x20000; +use warnings; -our $VERSION = '1.01'; +our $VERSION = '1.07'; + +require 5.008001; # for PerlIO::get_layers() my $locale_encoding; -sub in_locale { $^H & $locale::hint_bits } - -sub _get_locale_encoding { - unless (defined $locale_encoding) { - eval { - # I18N::Langinfo isn't available everywhere - require I18N::Langinfo; - I18N::Langinfo->import('langinfo', 'CODESET'); - }; - unless ($@) { - $locale_encoding = langinfo(CODESET()); - } - 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 } } sub import { my ($class,@args) = @_; - croak("`use open' needs explicit list of disciplines") unless @args; - $^H |= $open::hint_bits; + croak("open: needs explicit list of PerlIO layers") unless @args; + my $std; my ($in,$out) = split(/\0/,(${^OPEN} || "\0"), -1); while (@args) { my $type = shift(@args); @@ -64,26 +63,30 @@ sub import { if ($type =~ /^:?(utf8|locale|encoding\(.+\))$/) { $type = 'IO'; $dscp = ":$1"; + } elsif ($type eq ':std') { + $std = 1; + next; } else { - $dscp = shift(@args); + $dscp = shift(@args) || ''; } my @val; 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; - croak "Cannot figure out an encoding to use" + (warnings::warnif("layer", "Cannot figure out an encoding to use"), last) unless defined $locale_encoding; - if ($locale_encoding =~ /^utf-?8$/i) { - $layer = "utf8"; - } else { - $layer = "encoding($locale_encoding)"; - } + $layer = "encoding($locale_encoding)"; + $std = 1; } else { - unless(PerlIO::Layer::->find($layer)) { - carp("Unknown discipline layer '$layer'"); + my $target = $layer; # the layer name itself + $target =~ s/^(\w+)\(.+\)$/$1/; # strip parameters + + unless(PerlIO::Layer::->find($target,1)) { + warnings::warnif("layer", "Unknown PerlIO layer '$target'"); } } push(@val,":$layer"); @@ -91,21 +94,42 @@ sub import { $^H{"open_$type"} = $layer; } } - # print "# type = $type, val = @val\n"; 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 discipline class '$type'"; + croak "Unknown PerlIO layer class '$type'"; + } + } + ${^OPEN} = join("\0", $in, $out); + if ($std) { + if ($in) { + if ($in =~ /:utf8\b/) { + binmode(STDIN, ":utf8"); + } elsif ($in =~ /(\w+\(.+\))/) { + binmode(STDIN, ":$1"); + } + } + if ($out) { + if ($out =~ /:utf8\b/) { + binmode(STDOUT, ":utf8"); + binmode(STDERR, ":utf8"); + } elsif ($out =~ /(\w+\(.+\))/) { + binmode(STDOUT, ":$1"); + binmode(STDERR, ":$1"); + } } } - ${^OPEN} = join("\0",$in,$out); } 1; @@ -113,58 +137,60 @@ __END__ =head1 NAME -open - perl pragma to set default disciplines for input and output +open - perl pragma to set default PerlIO layers for input and output =head1 SYNOPSIS - use open IN => ":crlf", OUT => ":raw"; + use open IN => ":crlf", OUT => ":bytes"; use open OUT => ':utf8'; use open IO => ":encoding(iso-8859-7)"; use open IO => ':locale'; - - use open ':utf8'; + + use open ':encoding(utf8)'; use open ':locale'; use open ':encoding(iso-8859-7)'; + use open ':std'; + =head1 DESCRIPTION -Full-fledged support for I/O disciplines is now implemented provided +Full-fledged support for I/O layers is now implemented provided 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" (aka disciplines) for all I/O. - -The C pragma is used to declare one or more default layers for -I/O operations. 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. +Even three-argument opens may be affected by this pragma +when they don't specify IO layers in MODE. With the C subpragma you can declare the default layers -of input sterams, and with the C subpragma you can declare +of input streams, and with the C subpragma you can declare the default layers of output streams. With the C subpragma you can control both input and output streams simultaneously. If you have a legacy encoding, you can use the C<:encoding(...)> tag. -if you want to set your encoding disciplines based on your +If you want to set your encoding layers based on your locale environment variables, you can use the C<:locale> tag. For example: $ENV{LANG} = 'ru_RU.KOI8-R'; - use open ':locale'; + # the :locale will probe the locale environment variables like LANG + use open OUT => ':locale'; open(O, ">koi8"); - print O chr(0x430); # Unicode CYRILLIC SMALL LETTER A = KOI8-R 0xC1 + print O chr(0x430); # Unicode CYRILLIC SMALL LETTER A = KOI8-R 0xc1 close O; open(I, "), "\n"; # this should print 0xC1 + printf "%#x\n", ord(), "\n"; # this should print 0xc1 close I; These are equivalent - use open ':utf8'; - use open IO => ':utf8'; + use open ':encoding(utf8)'; + use open IO => ':encoding(utf8)'; as are these @@ -176,20 +202,38 @@ and these use open ':encoding(iso-8859-7)'; use open IO => ':encoding(iso-8859-7)'; -When open() is given an explicit list of layers they are appended to -the list declared using this pragma. +The matching of encoding names is loose: case does not matter, and +many encodings have several aliases. See L for +details and the list of supported locales. + +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 +filehandles (STDIN, STDOUT, STDERR) to comply with encoding selected +for input/output handles. For example, if both input and out are +chosen to be C<:encoding(utf8)>, a C<:std> will mean that STDIN, STDOUT, +and STDERR are also in C<:encoding(utf8)>. On the other hand, if only +output is 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 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 disciplines in future. +Directory handles may also support PerlIO layers in the future. =head1 NONPERLIO FUNCTIONALITY If Perl is not built to use PerlIO as its IO system then only the two -pseudo-disciplines ":raw" and ":crlf" are available. +pseudo-layers C<:bytes> and C<:crlf> are available. -The ":raw" discipline corresponds to "binary mode" and the ":crlf" -discipline corresponds to "text mode" on platforms that distinguish +The C<:bytes> layer corresponds to "binary mode" and the C<:crlf> +layer corresponds to "text mode" on platforms that distinguish between the two modes when opening files (which is many DOS-like -platforms, including Windows). These two disciplines are no-ops on +platforms, including Windows). These two layers are no-ops on platforms where binmode() is a no-op, but perform their functions everywhere if PerlIO is enabled.