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 The matching of encoding names is loose: case does not matter, and
 212 many encodings have several aliases.  See L<Encode::Supported> for
 213 details and the list of supported locales.
 214
 215 Note that C<:utf8> discipline must always be specified exactly like
 216 that, it is not subject to the loose matching of encoding names.
 217
 218 When open() is given an explicit list of layers they are appended to
 219 the list declared using this pragma.
 220
 221 The C<:std> subpragma on its own has no effect, but if combined with
 222 the C<:utf8> or C<:encoding> subpragmas, it converts the standard
 223 filehandles (STDIN, STDOUT, STDERR) to comply with encoding selected
 224 for input/output handles.  For example, if both input and out are
 225 chosen to be C<:utf8>, a C<:std> will mean that STDIN, STDOUT, and
 226 STDERR are also in C<:utf8>.  On the other hand, if only output is
 227 chosen to be in C<< :encoding(koi8r) >>, a C<:std> will cause only the
 228 STDOUT and STDERR to be in C<koi8r>.  The C<:locale> subpragma
 229 implicitly turns on C<:std>.
 230
 231 The logic of C<:locale> is as follows:
 232
 233 =over 4
 234
 235 =item 1.
 236
 237 If the platform supports the langinfo(CODESET) interface, the codeset
 238 returned is used as the default encoding for the open pragma.
 239
 240 =item 2.
 241
 242 If 1. didn't work but we are under the locale pragma, the environment
 243 variables LC_ALL and LANG (in that order) are matched for encodings
 244 (the part after C<.>, if any), and if any found, that is used
 245 as the default encoding for the open pragma.
 246
 247 =item 3.
 248
 249 If 1. and 2. didn't work, the environment variables LC_ALL and LANG
 250 (in that order) are matched for anything looking like UTF-8, and if
 251 any found, C<:utf8> is used as the default encoding for the open
 252 pragma.
 253
 254 =back
 255
 256 If your locale environment variables (LANGUAGE, LC_ALL, LC_CTYPE, LANG)
 257 contain the strings 'UTF-8' or 'UTF8' (case-insensitive matching),
 258 the default encoding of your STDIN, STDOUT, and STDERR, and of
 259 B<any subsequent file open>, is UTF-8.
 260
 261 Directory handles may also support disciplines in future.
 262
 263 =head1 NONPERLIO FUNCTIONALITY
 264
 265 If Perl is not built to use PerlIO as its IO system then only the two
 266 pseudo-disciplines ":raw" and ":crlf" are available.
 267
 268 The ":raw" discipline corresponds to "binary mode" and the ":crlf"
 269 discipline corresponds to "text mode" on platforms that distinguish
 270 between the two modes when opening files (which is many DOS-like
 271 platforms, including Windows).  These two disciplines are no-ops on
 272 platforms where binmode() is a no-op, but perform their functions
 273 everywhere if PerlIO is enabled.
 274
 275 =head1 IMPLEMENTATION DETAILS
 276
 277 There is a class method in C<PerlIO::Layer> C<find> which is
 278 implemented as XS code.  It is called by C<import> to validate the
 279 layers:
 280
 281    PerlIO::Layer::->find("perlio")
 282
 283 The return value (if defined) is a Perl object, of class
 284 C<PerlIO::Layer> which is created by the C code in F<perlio.c>.  As
 285 yet there is nothing useful you can do with the object at the perl
 286 level.
 287
 288 =head1 SEE ALSO
 289
 290 L<perlfunc/"binmode">, L<perlfunc/"open">, L<perlunicode>, L<PerlIO>,
 291 L<encoding>
 292
 293 =cut