lib/open.pm

   1 package open;
   2 use warnings;
   3 use Carp;
   4 $open::hint_bits = 0x20000;
   5
   6 our $VERSION = '1.01';
   7
   8 my $locale_encoding;
   9
  10 sub in_locale { $^H & ($locale::hint_bits || 0)}
  11
  12 sub _get_locale_encoding {
  13     unless (defined $locale_encoding) {
  14         # I18N::Langinfo isn't available everywhere
  15         eval {
  16             require I18N::Langinfo;
  17             I18N::Langinfo->import(qw(langinfo CODESET));
  18             $locale_encoding = langinfo(CODESET());
  19         };
  20         my $country_language;
  21
  22         no warnings 'uninitialized';
  23
  24         if (not $locale_encoding && in_locale()) {
  25             if ($ENV{LC_ALL} =~ /^([^.]+)\.([^.]+)$/) {
  26                 ($country_language, $locale_encoding) = ($1, $2);
  27             } elsif ($ENV{LANG} =~ /^([^.]+)\.([^.]+)$/) {
  28                 ($country_language, $locale_encoding) = ($1, $2);
  29             }
  30         } elsif (not $locale_encoding) {
  31             if ($ENV{LC_ALL} =~ /\butf-?8\b/i ||
  32                 $ENV{LANG}   =~ /\butf-?8\b/i) {
  33                 $locale_encoding = 'utf8';
  34             }
  35             # Could do more heuristics based on the country and language
  36             # parts of LC_ALL and LANG (the parts before the dot (if any)),
  37             # since we have Locale::Country and Locale::Language available.
  38             # TODO: get a database of Language -> Encoding mappings
  39             # (the Estonian database at http://www.eki.ee/letter/
  40             # would be excellent!) --jhi
  41         }
  42         if (defined $locale_encoding &&
  43             $locale_encoding eq 'euc' &&
  44             defined $country_language) {
  45             if ($country_language =~ /^ja_JP|japan(?:ese)?$/i) {
  46                 $locale_encoding = 'euc-jp';
  47             } elsif ($country_language =~ /^ko_KR|korean?$/i) {
  48                 $locale_encoding = 'euc-kr';
  49             } elsif ($country_language =~ /^zh_CN|chin(?:a|ese)?$/i) {
  50                 $locale_encoding = 'euc-cn';
  51             } elsif ($country_language =~ /^zh_TW|taiwan(?:ese)?$/i) {
  52                 $locale_encoding = 'euc-tw';
  53             }
  54             croak "Locale encoding 'euc' too ambiguous"
  55                 if $locale_encoding eq 'euc';
  56         }
  57     }
  58 }
  59
  60 sub import {
  61     my ($class,@args) = @_;
  62     croak("`use open' needs explicit list of disciplines") unless @args;
  63     my $std;
  64     $^H |= $open::hint_bits;
  65     my ($in,$out) = split(/\0/,(${^OPEN} || "\0"), -1);
  66     while (@args) {
  67         my $type = shift(@args);
  68         my $dscp;
  69         if ($type =~ /^:?(utf8|locale|encoding\(.+\))$/) {
  70             $type = 'IO';
  71             $dscp = ":$1";
  72         } elsif ($type eq ':std') {
  73             $std = 1;
  74             next;
  75         } else {
  76             $dscp = shift(@args) || '';
  77         }
  78         my @val;
  79         foreach my $layer (split(/\s+/,$dscp)) {
  80             $layer =~ s/^://;
  81             if ($layer eq 'locale') {
  82                 use Encode;
  83                 _get_locale_encoding()
  84                     unless defined $locale_encoding;
  85                 (warnings::warnif("layer", "Cannot figure out an encoding to use"), last)
  86                     unless defined $locale_encoding;
  87                 if ($locale_encoding =~ /^utf-?8$/i) {
  88                     $layer = "utf8";
  89                 } else {
  90                     $layer = "encoding($locale_encoding)";
  91                 }
  92                 $std = 1;
  93             } else {
  94                 my $target = $layer;            # the layer name itself
  95                 $target =~ s/^(\w+)\(.+\)$/$1/; # strip parameters
  96
  97                 unless(PerlIO::Layer::->find($target)) {
  98                     warnings::warnif("layer", "Unknown discipline layer '$layer'");
  99                 }
 100             }
 101             push(@val,":$layer");
 102             if ($layer =~ /^(crlf|raw)$/) {
 103                 $^H{"open_$type"} = $layer;
 104             }
 105         }
 106         if ($type eq 'IN') {
 107             $in  = join(' ',@val);
 108         }
 109         elsif ($type eq 'OUT') {
 110             $out = join(' ',@val);
 111         }
 112         elsif ($type eq 'IO') {
 113             $in = $out = join(' ',@val);
 114         }
 115         else {
 116             croak "Unknown discipline class '$type'";
 117         }
 118     }
 119     ${^OPEN} = join("\0",$in,$out) if $in or $out;
 120     if ($std) {
 121         if ($in) {
 122             if ($in =~ /:utf8\b/) {
 123                     binmode(STDIN,  ":utf8");
 124                 } elsif ($in =~ /(\w+\(.+\))/) {
 125                     binmode(STDIN,  ":$1");
 126                 }
 127         }
 128         if ($out) {
 129             if ($out =~ /:utf8\b/) {
 130                 binmode(STDOUT,  ":utf8");
 131                 binmode(STDERR,  ":utf8");
 132             } elsif ($out =~ /(\w+\(.+\))/) {
 133                 binmode(STDOUT,  ":$1");
 134                 binmode(STDERR,  ":$1");
 135             }
 136         }
 137     }
 138 }
 139
 140 1;
 141 __END__
 142
 143 =head1 NAME
 144
 145 open - perl pragma to set default disciplines for input and output
 146
 147 =head1 SYNOPSIS
 148
 149     use open IN  => ":crlf", OUT => ":raw";
 150     use open OUT => ':utf8';
 151     use open IO  => ":encoding(iso-8859-7)";
 152
 153     use open IO  => ':locale';
 154
 155     use open ':utf8';
 156     use open ':locale';
 157     use open ':encoding(iso-8859-7)';
 158
 159     use open ':std';
 160
 161 =head1 DESCRIPTION
 162
 163 Full-fledged support for I/O disciplines is now implemented provided
 164 Perl is configured to use PerlIO as its IO system (which is now the
 165 default).
 166
 167 The C<open> pragma serves as one of the interfaces to declare default
 168 "layers" (aka disciplines) for all I/O.
 169
 170 The C<open> pragma is used to declare one or more default layers for
 171 I/O operations.  Any open(), readpipe() (aka qx//) and similar
 172 operators found within the lexical scope of this pragma will use the
 173 declared defaults.
 174
 175 With the C<IN> subpragma you can declare the default layers
 176 of input streams, and with the C<OUT> subpragma you can declare
 177 the default layers of output streams.  With the C<IO>  subpragma
 178 you can control both input and output streams simultaneously.
 179
 180 If you have a legacy encoding, you can use the C<:encoding(...)> tag.
 181
 182 if you want to set your encoding disciplines based on your
 183 locale environment variables, you can use the C<:locale> tag.
 184 For example:
 185
 186     $ENV{LANG} = 'ru_RU.KOI8-R';
 187     # the :locale will probe the locale environment variables like LANG
 188     use open OUT => ':locale';
 189     open(O, ">koi8");
 190     print O chr(0x430); # Unicode CYRILLIC SMALL LETTER A = KOI8-R 0xc1
 191     close O;
 192     open(I, "<koi8");
 193     printf "%#x\n", ord(<I>), "\n"; # this should print 0xc1
 194     close I;
 195
 196 These are equivalent
 197
 198     use open ':utf8';
 199     use open IO => ':utf8';
 200
 201 as are these
 202
 203     use open ':locale';
 204     use open IO => ':locale';
 205
 206 and these
 207
 208     use open ':encoding(iso-8859-7)';
 209     use open IO => ':encoding(iso-8859-7)';
 210
 211 When open() is given an explicit list of layers they are appended to
 212 the list declared using this pragma.
 213
 214 The C<:std> subpragma on its own has no effect, but if combined with
 215 the C<:utf8> or C<:encoding> subpragmas, it converts the standard
 216 filehandles (STDIN, STDOUT, STDERR) to comply with encoding selected
 217 for input/output handles.  For example, if both input and out are
 218 chosen to be C<:utf8>, a C<:std> will mean that STDIN, STDOUT, and
 219 STDERR are also in C<:utf8>.  On the other hand, if only output is
 220 chosen to be in C<< :encoding(koi8r) >>, a C<:std> will cause only the
 221 STDOUT and STDERR to be in C<koi8r>.  The C<:locale> subpragma
 222 implicitly turns on C<:std>.
 223
 224 The logic of C<:locale> is as follows:
 225
 226 =over 4
 227
 228 =item 1.
 229
 230 If the platform supports the langinfo(CODESET) interface, the codeset
 231 returned is used as the default encoding for the open pragma.
 232
 233 =item 2.
 234
 235 If 1. didn't work but we are under the locale pragma, the environment
 236 variables LC_ALL and LANG (in that order) are matched for encodings
 237 (the part after C<.>, if any), and if any found, that is used
 238 as the default encoding for the open pragma.
 239
 240 =item 3.
 241
 242 If 1. and 2. didn't work, the environment variables LC_ALL and LANG
 243 (in that order) are matched for anything looking like UTF-8, and if
 244 any found, C<:utf8> is used as the default encoding for the open
 245 pragma.
 246
 247 =back
 248
 249 If your locale environment variables (LANGUAGE, LC_ALL, LC_CTYPE, LANG)
 250 contain the strings 'UTF-8' or 'UTF8' (case-insensitive matching),
 251 the default encoding of your STDIN, STDOUT, and STDERR, and of
 252 B<any subsequent file open>, is UTF-8.
 253
 254 Directory handles may also support disciplines in future.
 255
 256 =head1 NONPERLIO FUNCTIONALITY
 257
 258 If Perl is not built to use PerlIO as its IO system then only the two
 259 pseudo-disciplines ":raw" and ":crlf" are available.
 260
 261 The ":raw" discipline corresponds to "binary mode" and the ":crlf"
 262 discipline corresponds to "text mode" on platforms that distinguish
 263 between the two modes when opening files (which is many DOS-like
 264 platforms, including Windows).  These two disciplines are no-ops on
 265 platforms where binmode() is a no-op, but perform their functions
 266 everywhere if PerlIO is enabled.
 267
 268 =head1 IMPLEMENTATION DETAILS
 269
 270 There is a class method in C<PerlIO::Layer> C<find> which is
 271 implemented as XS code.  It is called by C<import> to validate the
 272 layers:
 273
 274    PerlIO::Layer::->find("perlio")
 275
 276 The return value (if defined) is a Perl object, of class
 277 C<PerlIO::Layer> which is created by the C code in F<perlio.c>.  As
 278 yet there is nothing useful you can do with the object at the perl
 279 level.
 280
 281 =head1 SEE ALSO
 282
 283 L<perlfunc/"binmode">, L<perlfunc/"open">, L<perlunicode>, L<PerlIO>,
 284 L<encoding>
 285
 286 =cut