X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fopen.pm;h=b535d88239a75507a773fb5db1e6546441ffc3f6;hb=9c1370fb202eb56860da11d7695c846c33542694;hp=c90181bb1b6afae9f76abda93cf416823b3e2726;hpb=d151aa0ec14d76b1fc090f7a4c70252742dc3539;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/open.pm b/lib/open.pm index c90181b..b535d88 100644 --- a/lib/open.pm +++ b/lib/open.pm @@ -2,48 +2,111 @@ package open; use Carp; $open::hint_bits = 0x20000; -# layers array and hash mainly manipulated by C code in perlio.c -use vars qw(%layers @layers); - -# Populate hash in non-PerlIO case -%layers = (crlf => 1, raw => 0) unless (@layers); - -# warn join(',',keys %layers); - -our $VERSION = '1.00'; +our $VERSION = '1.01'; + +my $locale_encoding; + +sub in_locale { $^H & $locale::hint_bits } + +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()); + }; + unless ($@) { + print "# locale_encoding = $locale_encoding\n"; + } + 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 import { my ($class,@args) = @_; croak("`use open' needs explicit list of disciplines") unless @args; $^H |= $open::hint_bits; - my ($in,$out) = split(/\0/,(${^OPEN} || '\0')); - my @in = split(/\s+/,$in); - my @out = split(/\s+/,$out); + my ($in,$out) = split(/\0/,(${^OPEN} || "\0"), -1); while (@args) { my $type = shift(@args); - my $discp = shift(@args); + my $dscp; + if ($type =~ /^:?(utf8|locale|encoding\(.+\))$/) { + $type = 'IO'; + $dscp = ":$1"; + } else { + $dscp = shift(@args) || ''; + } my @val; - foreach my $layer (split(/\s+/,$discp)) { + foreach my $layer (split(/\s+/,$dscp)) { $layer =~ s/^://; - unless(exists $layers{$layer}) { - carp("Unknown discipline layer '$layer'"); + if ($layer eq 'locale') { + use Encode; + _get_locale_encoding() + unless defined $locale_encoding; + croak "Cannot figure out an encoding to use" + unless defined $locale_encoding; + if ($locale_encoding =~ /^utf-?8$/i) { + $layer = "utf8"; + } else { + $layer = "encoding($locale_encoding)"; + } + } else { + unless(PerlIO::Layer::->find($layer)) { + carp("Unknown discipline layer '$layer'"); + } } push(@val,":$layer"); if ($layer =~ /^(crlf|raw)$/) { $^H{"open_$type"} = $layer; } } + # print "# type = $type, val = @val\n"; if ($type eq 'IN') { $in = join(' ',@val); } elsif ($type eq 'OUT') { $out = join(' ',@val); } + elsif ($type eq 'IO') { + $in = $out = join(' ',@val); + } else { croak "Unknown discipline class '$type'"; } } - ${^OPEN} = join('\0',$in,$out); + ${^OPEN} = join("\0",$in,$out); } 1; @@ -55,7 +118,15 @@ open - perl pragma to set default disciplines for input and output =head1 SYNOPSIS - use open IN => ":crlf", OUT => ":raw"; + use open IN => ":crlf", OUT => ":raw"; + use open OUT => ':utf8'; + use open IO => ":encoding(iso-8859-7)"; + + use open IO => ':locale'; + + use open ':utf8'; + use open ':locale'; + use open ':encoding(iso-8859-7)'; =head1 DESCRIPTION @@ -71,6 +142,42 @@ I/O operations. Any open(), readpipe() (aka qx//) and similar operators found within the lexical scope of this pragma will use the declared defaults. +With the C subpragma you can declare the default layers +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 +locale environment variables, you can use the C<:locale> tag. +For example: + + $ENV{LANG} = 'ru_RU.KOI8-R'; + # 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 + close O; + open(I, "), "\n"; # this should print 0xc1 + close I; + +These are equivalent + + use open ':utf8'; + use open IO => ':utf8'; + +as are these + + use open ':locale'; + use open IO => ':locale'; + +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. @@ -90,36 +197,20 @@ everywhere if PerlIO is enabled. =head1 IMPLEMENTATION DETAILS -There are two package variables C<%layers> and C<@layers> which are -mainly manipulated by C code in F, but are visible to the -nosy: - - print "Have ",join(',',keys %open::layers),"\n"; - print "Using ",join(',',@open::layers),"\n"; - -The C<%open::layers> hash is a record of the available "layers" that -may be pushed onto a C stream. The values of the hash are Perl -objects, of class C which are created by the C code in -F. As yet there is nothing useful you can do with the -objects at the perl level. - -The C<@open::layers> array is the current set of layers and their -arguments. The array consists of layer => argument pairs and I -always have even number of entries and the even entries I be -C objects or Perl will "die" when it attempts to open a -filehandle. In most cases the odd entry will be C, but in the -case of (say) ":encoding(iso-8859-1)" it will be 'iso-8859-1'. These -argument entries are currently restricted to being strings. +There is a class method in C C which is +implemented as XS code. It is called by C to validate the +layers: -When a new C stream is opened, the C code looks at the array -to determine the default layers to be pushed. So with care it is -possible to manipulate the default layer "stack": + PerlIO::Layer::->find("perlio") - splice(@PerlIO::layers,-2,2); - push(@PerlIO::layers,$PerlIO::layers{'stdio'} => undef); +The return value (if defined) is a Perl object, of class +C which is created by the C code in F. As +yet there is nothing useful you can do with the object at the perl +level. =head1 SEE ALSO -L, L, L, L +L, L, L, L, +L =cut