Change 23326 by rgs@no-spam on 2004/09/20 08:10:47
Subject: [PATCH] encoding and open pragmas
From: Jarkko Hietaniemi <jhi@no-spam>
Date: Mon, 16 Aug 2004 22:27:00 +0300
Message-ID: <41210A84.6060506@no-spam>
Subject: Re: [PATCH] encoding and open pragmas
From: Jarkko Hietaniemi <jhi@no-spam>
Date: Tue, 17 Aug 2004 11:22:58 +0300 (EEST)
Message-Id: <200408170822.i7H8MwUU016793@no-spam>
Affected files ...
... //depot/perl/ext/Encode/encoding.pm#32 edit
... //depot/perl/lib/open.pm#47 edit
... //depot/perl/lib/open.t#24 edit
... //depot/perl/t/io/layers.t#18 edit
Differences ...
==== //depot/perl/ext/Encode/encoding.pm#32 (text) ====
Index: perl/ext/Encode/encoding.pm
--- perl/ext/Encode/encoding.pm#31~22835~ Thu May 20 06:30:25 2004
+++ perl/ext/Encode/encoding.pm Mon Sep 20 01:10:47 2004
@@no-spam -1,15 +1,16 @@no-spam
-# $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 @no-spam = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @no-spam };
+our $VERSION = do { my @no-spam = (q$Revision: 2.01 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @no-spam };
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");
}
}
@@no-spam -30,15 +31,79 @@no-spam
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 = @no-spam
- $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}) {
@@no-spam -62,13 +127,14 @@no-spam
$status ;
});
};
- } DEBUG and warn "Filter installed";
+ $@no-spam == '' 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{
@@no-spam -133,6 +199,14 @@no-spam
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
@@no-spam -510,10 +584,44 @@no-spam
=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<any subsequent file open>, 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
==== //depot/perl/lib/open.pm#47 (text) ====
Index: perl/lib/open.pm
--- perl/lib/open.pm#46~22538~ Fri Mar 19 04:15:23 2004
+++ perl/lib/open.pm Mon Sep 20 01:10:47 2004
@@no-spam -3,64 +3,60 @@no-spam
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;
-
- 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 {
- croak "Locale encoding 'euc' too ambiguous";
- }
- }
+use encoding ':_get_locale_encoding';
+my $locale_encoding = _get_locale_encoding();
+
+sub _get_encname {
+ return ($1, resolve_alias($1)) if $_[0] =~ /^:?encoding\((.+)\)$/;
+ return;
+}
+
+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, @no-spam = @no-spam
+ return unless @no-spam >= 1 && $new[-1] =~ /^:encoding\(.+\)$/;
+ my @no-spam = PerlIO::get_layers($h);
+ return unless @no-spam >= 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,@no-spam = @no-spam
- croak("`use open' needs explicit list of PerlIO layers") unless @no-spam
+ croak("open: needs explicit list of PerlIO layers") unless @no-spam
my $std;
$^H |= $open::hint_bits;
my ($in,$out) = split(/\0/,(${^OPEN} || "\0"), -1);
@@no-spam -81,7 +77,7 @@no-spam
$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;
@@no-spam -105,19 +101,23 @@no-spam
}
}
if ($type eq 'IN') {
- $in = join(' ',@no-spam
+ _drop_oldenc(*STDIN, @no-spam
+ $in = join(' ', @no-spam
}
elsif ($type eq 'OUT') {
- $out = join(' ',@no-spam
+ _drop_oldenc(*STDOUT, @no-spam
+ $out = join(' ', @no-spam
}
elsif ($type eq 'IO') {
- $in = $out = join(' ',@no-spam
+ _drop_oldenc(*STDIN, @no-spam
+ _drop_oldenc(*STDOUT, @no-spam
+ $in = $out = join(' ', @no-spam
}
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/) {
@@no-spam -229,35 +229,9 @@no-spam
STDOUT and STDERR to be in C<koi8r>. 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<any subsequent file open>, is UTF-8.
+The logic of C<:locale> is described in full in L</encoding>,
+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.
==== //depot/perl/lib/open.t#24 (text) ====
Index: perl/lib/open.t
--- perl/lib/open.t#23~19600~ Fri May 23 09:55:09 2003
+++ perl/lib/open.t Mon Sep 20 01:10:47 2004
@@no-spam -7,7 +7,7 @@no-spam
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 {
@@no-spam -43,17 +43,10 @@no-spam
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' );
==== //depot/perl/t/io/layers.t#18 (text) ====
Index: perl/t/io/layers.t
--- perl/t/io/layers.t#17~22423~ Tue Mar 2 14:02:36 2004
+++ perl/t/io/layers.t Mon Sep 20 01:10:47 2004
@@no-spam -34,6 +34,8 @@no-spam
my $NTEST = 43 - (($DOSISH || !$FASTSTDIO) ? 7 : 0) - ($DOSISH ? 5 : 0);
+sub PerlIO::F_UTF8 () { 0x00008000 } # from perliol.h
+
plan tests => $NTEST;
print <<__EOH__;
End of Patch.