-# $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");
}
}
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}) {
$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{
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
=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
L<perlunicode>, L<Encode>, L<open>, L<Filter::Util::Call>,
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);
$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;
}
}
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/) {
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.
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 {
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' );
my $NTEST = 43 - (($DOSISH || !$FASTSTDIO) ? 7 : 0) - ($DOSISH ? 5 : 0);
+sub PerlIO::F_UTF8 () { 0x00008000 } # from perliol.h
+
plan tests => $NTEST;
print <<__EOH__;
projects / p5sagit/p5-mst-13.2.git / commitdiff