From: Jarkko Hietaniemi Date: Mon, 16 Aug 2004 22:27:00 +0000 (+0300) Subject: [PATCH] encoding and open pragmas X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7c0e976d40017a166598b7de52585069637d2764;p=p5sagit%2Fp5-mst-13.2.git [PATCH] encoding and open pragmas Date: Mon, 16 Aug 2004 22:27:00 +0300 Message-ID: <41210A84.6060506@iki.fi> Subject: Re: [PATCH] encoding and open pragmas From: Jarkko Hietaniemi Date: Tue, 17 Aug 2004 11:22:58 +0300 (EEST) Message-Id: <200408170822.i7H8MwUU016793@vipunen.hut.fi> p4raw-id: //depot/perl@23326 --- diff --git a/ext/Encode/encoding.pm b/ext/Encode/encoding.pm index d1181ff..b398301 100644 --- a/ext/Encode/encoding.pm +++ b/ext/Encode/encoding.pm @@ -1,15 +1,16 @@ -# $Id: encoding.pm,v 2.0 2004/05/16 20:55:16 dankogai Exp $ +# $Id: encoding.pm,v 2.01 2004/05/16 20:55:16 dankogai Exp $ package encoding; -our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; +our $VERSION = do { my @r = (q$Revision: 2.01 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; use Encode; use strict; + sub DEBUG () { 0 } BEGIN { if (ord("A") == 193) { require Carp; - Carp::croak("encoding pragma does not support EBCDIC platforms"); + Carp::croak("encoding: pragma does not support EBCDIC platforms"); } } @@ -30,15 +31,79 @@ sub _exception{ return $Config{perl_patchlevel} ? 0 : 1 # maintperl then no } +sub in_locale { $^H & ($locale::hint_bits || 0)} + +sub _get_locale_encoding { + my $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 && + 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"); + } + } + + return $locale_encoding; +} + sub import { my $class = shift; my $name = shift; + 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'; my %arg = @_; - $name ||= $ENV{PERL_ENCODING}; + $name = $ENV{PERL_ENCODING} unless defined $name; my $enc = find_encoding($name); unless (defined $enc) { require Carp; - Carp::croak("Unknown encoding '$name'"); + Carp::croak("encoding: Unknown encoding '$name'"); } $name = $enc->name; # canonize unless ($arg{Filter}) { @@ -62,13 +127,14 @@ sub import { $status ; }); }; - } DEBUG and warn "Filter installed"; + $@ == '' 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("Unknown encoding for $h, '$arg{$h}'"); + Carp::croak("encoding: Unknown encoding for $h, '$arg{$h}'"); } eval { binmode($h, ":raw :encoding($arg{$h})") }; }else{ @@ -133,6 +199,14 @@ encoding - allows you to write your script in non-ascii or non-utf8 use encoding "euc-jp", Filter=>1; # now you can use kanji identifiers -- in euc-jp! + # switch on locale - + # note that this probably means that unless you have a complete control + # over the environments the application is ever going to be run, you should + # NOT use the feature of encoding pragma allowing you to write your script + # in any recognized encoding because changing locale settings will wreck + # the script; you can of course still use the other features of the pragma. + use encoding ':locale'; + =head1 ABSTRACT Let's start with a bit of history: Perl 5.6.0 introduced Unicode @@ -510,11 +584,45 @@ Arabic and Hebrew). =back +=head2 The Logic of :locale + +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. + =head1 HISTORY This pragma first appeared in Perl 5.8.0. For features that require 5.8.1 and better, see above. +The C<:locale> subpragma was implemented in 2.01, or Perl 5.8.6. + =head1 SEE ALSO L, L, L, L, diff --git a/lib/open.pm b/lib/open.pm index 32c5118..35d33dd 100644 --- a/lib/open.pm +++ b/lib/open.pm @@ -3,64 +3,60 @@ use warnings; use Carp; $open::hint_bits = 0x20000; # HINT_LOCALIZE_HH -our $VERSION = '1.03'; +our $VERSION = '1.04'; -my $locale_encoding; +require 5.008001; # for PerlIO::get_layers() -sub in_locale { $^H & ($locale::hint_bits || 0)} +use Encode qw(resolve_alias); -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; +use encoding ':_get_locale_encoding'; +my $locale_encoding = _get_locale_encoding(); - no warnings 'uninitialized'; +sub _get_encname { + return ($1, resolve_alias($1)) if $_[0] =~ /^:?encoding\((.+)\)$/; + return; +} - 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 && - 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 { - croak "Locale encoding 'euc' too ambiguous"; - } - } +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\(.+\)$/; + my ($loname, $lcname) = _get_encname($old[-2]); + unless (defined $lcname) { # Should we trust get_layers()? + require Carp; + Carp::croak("open: Unknown encoding '$loname'"); + } + my ($voname, $vcname) = _get_encname($new[-1]); + unless (defined $vcname) { + require Carp; + Carp::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); @@ -81,7 +77,7 @@ sub import { $layer =~ s/^://; if ($layer eq 'locale') { require Encode; - _get_locale_encoding() + $locale_encoding = _get_locale_encoding() unless defined $locale_encoding; (warnings::warnif("layer", "Cannot figure out an encoding to use"), last) unless defined $locale_encoding; @@ -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/) { @@ -229,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. diff --git a/lib/open.t b/lib/open.t index 55b955b..554798b 100644 --- a/lib/open.t +++ b/lib/open.t @@ -7,7 +7,7 @@ BEGIN { require Config; import Config; } -use Test::More tests => 17; +use Test::More tests => 16; # open::import expects 'open' as its first argument, but it clashes with open() sub import { @@ -43,17 +43,10 @@ eval q{ use warnings 'layer'; use open IN => ':macguffin' ; }; like( $warn, qr/Unknown PerlIO layer/, 'should warn about unknown layer with bad layer provided' ); -SKIP: { - skip("no perlio, no :utf8", 1) unless (find PerlIO::Layer 'perlio'); - skip("no Encode for locale layer", 1) unless eval { require Encode }; - # now load a real-looking locale - $ENV{LC_ALL} = ' .utf8'; - import( 'IN', 'locale' ); - like( ${^OPEN}, qr/^(:utf8)?:utf8\0/, - 'should set a valid locale layer' ); -} +# open :locale logic changed since open 1.04, new logic +# difficult to test portably. -# and see if it sets the magic variables appropriately +# see if it sets the magic variables appropriately import( 'IN', ':crlf' ); ok( $^H & $open::hint_bits, 'hint bits should be set in $^H after open import' ); diff --git a/t/io/layers.t b/t/io/layers.t index d0e37a3..e2c63a9 100644 --- a/t/io/layers.t +++ b/t/io/layers.t @@ -34,6 +34,8 @@ my $FASTSTDIO = $Config{d_faststdio} && $Config{usefaststdio} ? 1 : 0; my $NTEST = 43 - (($DOSISH || !$FASTSTDIO) ? 7 : 0) - ($DOSISH ? 5 : 0); +sub PerlIO::F_UTF8 () { 0x00008000 } # from perliol.h + plan tests => $NTEST; print <<__EOH__;