X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fopen.pm;h=3d7782fc8b5b41dc4131978d57f9f038ff78a1ac;hb=149e698571d538389632b17001d47e502cc5be50;hp=a845459da6b119aa0e122653ffbe57886b57e647;hpb=642f9debcae19ee23c984c3fbe5fa65e96398ea0;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/open.pm b/lib/open.pm index a845459..3d7782f 100644 --- a/lib/open.pm +++ b/lib/open.pm @@ -1,23 +1,101 @@ package open; +use Carp; $open::hint_bits = 0x20000; +our $VERSION = '1.01'; + +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); + } + } else { + # Could do 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 = 'eucjp'; + } elsif ($country_language =~ /^ko_KR|korean?$/i) { + $locale_encoding = 'euckr'; + } elsif ($country_language =~ /^zh_TW|taiwan(?:ese)?$/i) { + $locale_encoding = 'euctw'; + } + croak "Locale encoding 'euc' too ambiguous" + if $locale_encoding eq 'euc'; + } + } +} + sub import { - shift; - die "`use open' needs explicit list of disciplines" unless @_; + my ($class,@args) = @_; + croak("`use open' needs explicit list of disciplines") unless @args; $^H |= $open::hint_bits; - while (@_) { - my $type = shift; - if ($type =~ /^(IN|OUT)\z/s) { - my $discp = shift; - unless ($discp =~ /^\s*:(raw|crlf)\s*\z/s) { - die "Unknown discipline '$discp'"; + my ($in,$out) = split(/\0/,(${^OPEN} || "\0"), -1); + while (@args) { + my $type = shift(@args); + my $discp = shift(@args); + my @val; + foreach my $layer (split(/\s+/,$discp)) { + $layer =~ s/^://; + 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'"); + } } - $^H{"open_$type"} = $discp; + 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 'INOUT') { + $in = $out = join(' ',@val); } else { - die "Unknown discipline class '$type'"; + croak "Unknown discipline class '$type'"; } } + ${^OPEN} = join('\0',$in,$out); } 1; @@ -30,47 +108,54 @@ open - perl pragma to set default disciplines for input and output =head1 SYNOPSIS use open IN => ":crlf", OUT => ":raw"; + use open INOUT => ":utf8"; =head1 DESCRIPTION -The open pragma is used to declare one or more default disciplines for -I/O operations. Any open() and readpipe() (aka qx//) operators found -within the lexical scope of this pragma will use the declared defaults. -Neither open() with an explicit set of disciplines, nor sysopen() are -influenced by this pragma. +Full-fledged support for I/O disciplines 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. -Only the two pseudo-disciplines ":raw" and ":crlf" are currently -available. +When open() is given an explicit list of layers they are appended to +the list declared using this pragma. + +Directory handles may also support disciplines in 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. The ":raw" discipline corresponds to "binary mode" and the ":crlf" discipline 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 currently -no-ops on platforms where binmode() is a no-op, but will be -supported everywhere in future. - -=head1 UNIMPLEMENTED FUNCTIONALITY - -Full-fledged support for I/O disciplines is currently unimplemented. -When they are eventually supported, this pragma will serve as one of -the interfaces to declare default disciplines for all I/O. +platforms, including Windows). These two disciplines are no-ops on +platforms where binmode() is a no-op, but perform their functions +everywhere if PerlIO is enabled. -In future, any default disciplines declared by this pragma will be -available by the special discipline name ":def", and could be used -within handle constructors that allow disciplines to be specified. -This would make it possible to stack new disciplines over the default -ones. +=head1 IMPLEMENTATION DETAILS - open FH, "<:para :def", $file or die "can't open $file: $!"; +There is a class method in C C which is +implemented as XS code. It is called by C to validate the +layers: -Socket and directory handles will also support disciplines in -future. + PerlIO::Layer::->find("perlio") -Full support for I/O disciplines will enable all of the supported -disciplines to work on all platforms. +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 =cut