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