lib/open.pm

   1 package open;
   2 use Carp;
   3 $open::hint_bits = 0x20000;
   4
   5 our $VERSION = '1.01';
   6
   7 my $locale_encoding;
   8
   9 sub in_locale { $^H & $locale::hint_bits }
  10
  11 sub _get_locale_encoding {
  12     unless (defined $locale_encoding) {
  13         eval {
  14             # I18N::Langinfo isn't available everywhere
  15             require I18N::Langinfo;
  16             I18N::Langinfo->import('langinfo', 'CODESET');
  17         };
  18         unless ($@) {
  19             $locale_encoding = langinfo(CODESET());
  20         }
  21         my $country_language;
  22         if (not $locale_encoding && in_locale()) {
  23             if ($ENV{LC_ALL} =~ /^([^.]+)\.([^.]+)$/) {
  24                 ($country_language, $locale_encoding) = ($1, $2);
  25             } elsif ($ENV{LANG} =~ /^([^.]+)\.([^.]+)$/) {
  26                 ($country_language, $locale_encoding) = ($1, $2);
  27             }
  28         } elsif (not $locale_encoding) {
  29             if ($ENV{LC_ALL} =~ /\butf-?8\b/i ||
  30                 $ENV{LANG}   =~ /\butf-?8\b/i) {
  31                 $locale_encoding = 'utf8';
  32             }
  33             # Could do more heuristics based on the country and language
  34             # parts of LC_ALL and LANG (the parts before the dot (if any)),
  35             # since we have Locale::Country and Locale::Language available.
  36             # TODO: get a database of Language -> Encoding mappings
  37             # (the Estonian database at http://www.eki.ee/letter/
  38             # would be excellent!) --jhi
  39         }
  40         if (defined $locale_encoding &&
  41             $locale_encoding eq 'euc' &&
  42             defined $country_language) {
  43             if ($country_language =~ /^ja_JP|japan(?:ese)?$/i) {
  44                 $locale_encoding = 'euc-jp';
  45             } elsif ($country_language =~ /^ko_KR|korean?$/i) {
  46                 $locale_encoding = 'euc-kr';
  47             } elsif ($country_language =~ /^zh_TW|taiwan(?:ese)?$/i) {
  48                 $locale_encoding = 'euc-tw';
  49             }
  50             croak "Locale encoding 'euc' too ambiguous"
  51                 if $locale_encoding eq 'euc';
  52         }
  53     }
  54 }
  55
  56 sub import {
  57     my ($class,@args) = @_;
  58     croak("`use open' needs explicit list of disciplines") unless @args;
  59     $^H |= $open::hint_bits;
  60     my ($in,$out) = split(/\0/,(${^OPEN} || "\0"), -1);
  61     while (@args) {
  62         my $type = shift(@args);
  63         my $dscp;
  64         if ($type =~ /^:?(utf8|locale|encoding\(.+\))$/) {
  65             $type = 'IO';
  66             $dscp = ":$1";
  67         } else {
  68             $dscp = shift(@args);
  69         }
  70         my @val;
  71         foreach my $layer (split(/\s+/,$dscp)) {
  72             $layer =~ s/^://;
  73             if ($layer eq 'locale') {
  74                 use Encode;
  75                 _get_locale_encoding()
  76                     unless defined $locale_encoding;
  77                 croak "Cannot figure out an encoding to use"
  78                     unless defined $locale_encoding;
  79                 if ($locale_encoding =~ /^utf-?8$/i) {
  80                     $layer = "utf8";
  81                 } else {
  82                     $layer = "encoding($locale_encoding)";
  83                 }
  84             } else {
  85                 unless(PerlIO::Layer::->find($layer)) {
  86                     carp("Unknown discipline layer '$layer'");
  87                 }
  88             }
  89             push(@val,":$layer");
  90             if ($layer =~ /^(crlf|raw)$/) {
  91                 $^H{"open_$type"} = $layer;
  92             }
  93         }
  94         # print "# type = $type, val = @val\n";
  95         if ($type eq 'IN') {
  96             $in  = join(' ',@val);
  97         }
  98         elsif ($type eq 'OUT') {
  99             $out = join(' ',@val);
 100         }
 101         elsif ($type eq 'IO') {
 102             $in = $out = join(' ',@val);
 103         }
 104         else {
 105             croak "Unknown discipline class '$type'";
 106         }
 107     }
 108     ${^OPEN} = join("\0",$in,$out);
 109 }
 110
 111 1;
 112 __END__
 113
 114 =head1 NAME
 115
 116 open - perl pragma to set default disciplines for input and output
 117
 118 =head1 SYNOPSIS
 119
 120     use open IN  => ":crlf", OUT => ":raw";
 121     use open OUT => ':utf8';
 122     use open IO  => ":encoding(iso-8859-7)";
 123
 124     use open IO  => ':locale';
 125
 126     use open ':utf8';
 127     use open ':locale';
 128     use open ':encoding(iso-8859-7)';
 129
 130 =head1 DESCRIPTION
 131
 132 Full-fledged support for I/O disciplines is now implemented provided
 133 Perl is configured to use PerlIO as its IO system (which is now the
 134 default).
 135
 136 The C<open> pragma serves as one of the interfaces to declare default
 137 "layers" (aka disciplines) for all I/O.
 138
 139 The C<open> pragma is used to declare one or more default layers for
 140 I/O operations.  Any open(), readpipe() (aka qx//) and similar
 141 operators found within the lexical scope of this pragma will use the
 142 declared defaults.
 143
 144 With the C<IN> subpragma you can declare the default layers
 145 of input sterams, and with the C<OUT> subpragma you can declare
 146 the default layers of output streams.  With the C<IO>  subpragma
 147 you can control both input and output streams simultaneously.
 148
 149 If you have a legacy encoding, you can use the C<:encoding(...)> tag.
 150
 151 if you want to set your encoding disciplines based on your
 152 locale environment variables, you can use the C<:locale> tag.
 153 For example:
 154
 155     $ENV{LANG} = 'ru_RU.KOI8-R';
 156     use open ':locale';
 157     open(O, ">koi8");
 158     print O chr(0x430); # Unicode CYRILLIC SMALL LETTER A = KOI8-R 0xC1
 159     close O;
 160     open(I, "<koi8");
 161     printf "%#x\n", ord(<I>), "\n"; # this should print 0xC1
 162     close I;
 163
 164 These are equivalent
 165
 166     use open ':utf8';
 167     use open IO => ':utf8';
 168
 169 as are these
 170
 171     use open ':locale';
 172     use open IO => ':locale';
 173
 174 and these
 175
 176     use open ':encoding(iso-8859-7)';
 177     use open IO => ':encoding(iso-8859-7)';
 178
 179 When open() is given an explicit list of layers they are appended to
 180 the list declared using this pragma.
 181
 182 Directory handles may also support disciplines in future.
 183
 184 =head1 NONPERLIO FUNCTIONALITY
 185
 186 If Perl is not built to use PerlIO as its IO system then only the two
 187 pseudo-disciplines ":raw" and ":crlf" are available.
 188
 189 The ":raw" discipline corresponds to "binary mode" and the ":crlf"
 190 discipline corresponds to "text mode" on platforms that distinguish
 191 between the two modes when opening files (which is many DOS-like
 192 platforms, including Windows).  These two disciplines are no-ops on
 193 platforms where binmode() is a no-op, but perform their functions
 194 everywhere if PerlIO is enabled.
 195
 196 =head1 IMPLEMENTATION DETAILS
 197
 198 There is a class method in C<PerlIO::Layer> C<find> which is
 199 implemented as XS code.  It is called by C<import> to validate the
 200 layers:
 201
 202    PerlIO::Layer::->find("perlio")
 203
 204 The return value (if defined) is a Perl object, of class
 205 C<PerlIO::Layer> which is created by the C code in F<perlio.c>.  As
 206 yet there is nothing useful you can do with the object at the perl
 207 level.
 208
 209 =head1 SEE ALSO
 210
 211 L<perlfunc/"binmode">, L<perlfunc/"open">, L<perlunicode>, L<PerlIO>,
 212 L<encoding>
 213
 214 =cut