lib/open.pm

   1 package open;
   2 use warnings;
   3 $open::hint_bits = 0x20000; # HINT_LOCALIZE_HH
   4
   5 our $VERSION = '1.05';
   6
   7 require 5.008001; # for PerlIO::get_layers()
   8
   9 my $locale_encoding;
  10
  11 sub _get_encname {
  12     return ($1, Encode::resolve_alias($1)) if $_[0] =~ /^:?encoding\((.+)\)$/;
  13     return;
  14 }
  15
  16 sub croak {
  17     require Carp; goto &Carp::croak;
  18 }
  19
  20 sub _drop_oldenc {
  21     # If by the time we arrive here there already is at the top of the
  22     # perlio layer stack an encoding identical to what we would like
  23     # to push via this open pragma, we will pop away the old encoding
  24     # (+utf8) so that we can push ourselves in place (this is easier
  25     # than ignoring pushing ourselves because of the way how ${^OPEN}
  26     # works).  So we are looking for something like
  27     #
  28     #   stdio encoding(xxx) utf8
  29     #
  30     # in the existing layer stack, and in the new stack chunk for
  31     #
  32     #   :encoding(xxx)
  33     #
  34     # If we find a match, we pop the old stack (once, since
  35     # the utf8 is just a flag on the encoding layer)
  36     my ($h, @new) = @_;
  37     return unless @new >= 1 && $new[-1] =~ /^:encoding\(.+\)$/;
  38     my @old = PerlIO::get_layers($h);
  39     return unless @old >= 3 &&
  40                   $old[-1] eq 'utf8' &&
  41                   $old[-2] =~ /^encoding\(.+\)$/;
  42     require Encode;
  43     my ($loname, $lcname) = _get_encname($old[-2]);
  44     unless (defined $lcname) { # Should we trust get_layers()?
  45         croak("open: Unknown encoding '$loname'");
  46     }
  47     my ($voname, $vcname) = _get_encname($new[-1]);
  48     unless (defined $vcname) {
  49         croak("open: Unknown encoding '$voname'");
  50     }
  51     if ($lcname eq $vcname) {
  52         binmode($h, ":pop"); # utf8 is part of the encoding layer
  53     }
  54 }
  55
  56 sub import {
  57     my ($class,@args) = @_;
  58     croak("open: needs explicit list of PerlIO layers") unless @args;
  59     my $std;
  60     $^H |= $open::hint_bits;
  61     my ($in,$out) = split(/\0/,(${^OPEN} || "\0"), -1);
  62     while (@args) {
  63         my $type = shift(@args);
  64         my $dscp;
  65         if ($type =~ /^:?(utf8|locale|encoding\(.+\))$/) {
  66             $type = 'IO';
  67             $dscp = ":$1";
  68         } elsif ($type eq ':std') {
  69             $std = 1;
  70             next;
  71         } else {
  72             $dscp = shift(@args) || '';
  73         }
  74         my @val;
  75         foreach my $layer (split(/\s+/,$dscp)) {
  76             $layer =~ s/^://;
  77             if ($layer eq 'locale') {
  78                 require Encode;
  79                 require encoding;
  80                 $locale_encoding = encoding::_get_locale_encoding()
  81                     unless defined $locale_encoding;
  82                 (warnings::warnif("layer", "Cannot figure out an encoding to use"), last)
  83                     unless defined $locale_encoding;
  84                 if ($locale_encoding =~ /^utf-?8$/i) {
  85                     $layer = "utf8";
  86                 } else {
  87                     $layer = "encoding($locale_encoding)";
  88                 }
  89                 $std = 1;
  90             } else {
  91                 my $target = $layer;            # the layer name itself
  92                 $target =~ s/^(\w+)\(.+\)$/$1/; # strip parameters
  93
  94                 unless(PerlIO::Layer::->find($target,1)) {
  95                     warnings::warnif("layer", "Unknown PerlIO layer '$target'");
  96                 }
  97             }
  98             push(@val,":$layer");
  99             if ($layer =~ /^(crlf|raw)$/) {
 100                 $^H{"open_$type"} = $layer;
 101             }
 102         }
 103         if ($type eq 'IN') {
 104             _drop_oldenc(*STDIN, @val);
 105             $in  = join(' ', @val);
 106         }
 107         elsif ($type eq 'OUT') {
 108             _drop_oldenc(*STDOUT, @val);
 109             $out = join(' ', @val);
 110         }
 111         elsif ($type eq 'IO') {
 112             _drop_oldenc(*STDIN,  @val);
 113             _drop_oldenc(*STDOUT, @val);
 114             $in = $out = join(' ', @val);
 115         }
 116         else {
 117             croak "Unknown PerlIO layer class '$type'";
 118         }
 119     }
 120     ${^OPEN} = join("\0", $in, $out);
 121     if ($std) {
 122         if ($in) {
 123             if ($in =~ /:utf8\b/) {
 124                     binmode(STDIN,  ":utf8");
 125                 } elsif ($in =~ /(\w+\(.+\))/) {
 126                     binmode(STDIN,  ":$1");
 127                 }
 128         }
 129         if ($out) {
 130             if ($out =~ /:utf8\b/) {
 131                 binmode(STDOUT,  ":utf8");
 132                 binmode(STDERR,  ":utf8");
 133             } elsif ($out =~ /(\w+\(.+\))/) {
 134                 binmode(STDOUT,  ":$1");
 135                 binmode(STDERR,  ":$1");
 136             }
 137         }
 138     }
 139 }
 140
 141 1;
 142 __END__
 143
 144 =head1 NAME
 145
 146 open - perl pragma to set default PerlIO layers for input and output
 147
 148 =head1 SYNOPSIS
 149
 150     use open IN  => ":crlf", OUT => ":bytes";
 151     use open OUT => ':utf8';
 152     use open IO  => ":encoding(iso-8859-7)";
 153
 154     use open IO  => ':locale';
 155
 156     use open ':utf8';
 157     use open ':locale';
 158     use open ':encoding(iso-8859-7)';
 159
 160     use open ':std';
 161
 162 =head1 DESCRIPTION
 163
 164 Full-fledged support for I/O layers is now implemented provided
 165 Perl is configured to use PerlIO as its IO system (which is now the
 166 default).
 167
 168 The C<open> pragma serves as one of the interfaces to declare default
 169 "layers" (also known as "disciplines") for all I/O. Any two-argument
 170 open(), readpipe() (aka qx//) and similar operators found within the
 171 lexical scope of this pragma will use the declared defaults.
 172 Three-argument opens are not affected by this pragma since there you
 173 (can) explicitly specify the layers and are supposed to know what you
 174 are doing.
 175
 176 With the C<IN> subpragma you can declare the default layers
 177 of input streams, and with the C<OUT> subpragma you can declare
 178 the default layers of output streams.  With the C<IO>  subpragma
 179 you can control both input and output streams simultaneously.
 180
 181 If you have a legacy encoding, you can use the C<:encoding(...)> tag.
 182
 183 if you want to set your encoding layers based on your
 184 locale environment variables, you can use the C<:locale> tag.
 185 For example:
 186
 187     $ENV{LANG} = 'ru_RU.KOI8-R';
 188     # the :locale will probe the locale environment variables like LANG
 189     use open OUT => ':locale';
 190     open(O, ">koi8");
 191     print O chr(0x430); # Unicode CYRILLIC SMALL LETTER A = KOI8-R 0xc1
 192     close O;
 193     open(I, "<koi8");
 194     printf "%#x\n", ord(<I>), "\n"; # this should print 0xc1
 195     close I;
 196
 197 These are equivalent
 198
 199     use open ':utf8';
 200     use open IO => ':utf8';
 201
 202 as are these
 203
 204     use open ':locale';
 205     use open IO => ':locale';
 206
 207 and these
 208
 209     use open ':encoding(iso-8859-7)';
 210     use open IO => ':encoding(iso-8859-7)';
 211
 212 The matching of encoding names is loose: case does not matter, and
 213 many encodings have several aliases.  See L<Encode::Supported> for
 214 details and the list of supported locales.
 215
 216 Note that C<:utf8> PerlIO layer must always be specified exactly like
 217 that, it is not subject to the loose matching of encoding names.
 218
 219 When open() is given an explicit list of layers (with the three-arg
 220 syntax), they override the list declared using this pragma.
 221
 222 The C<:std> subpragma on its own has no effect, but if combined with
 223 the C<:utf8> or C<:encoding> subpragmas, it converts the standard
 224 filehandles (STDIN, STDOUT, STDERR) to comply with encoding selected
 225 for input/output handles.  For example, if both input and out are
 226 chosen to be C<:utf8>, a C<:std> will mean that STDIN, STDOUT, and
 227 STDERR are also in C<:utf8>.  On the other hand, if only output is
 228 chosen to be in C<< :encoding(koi8r) >>, a C<:std> will cause only the
 229 STDOUT and STDERR to be in C<koi8r>.  The C<:locale> subpragma
 230 implicitly turns on C<:std>.
 231
 232 The logic of C<:locale> is described in full in L<encoding>,
 233 but in short it is first trying nl_langinfo(CODESET) and then
 234 guessing from the LC_ALL and LANG locale environment variables.
 235
 236 Directory handles may also support PerlIO layers in the future.
 237
 238 =head1 NONPERLIO FUNCTIONALITY
 239
 240 If Perl is not built to use PerlIO as its IO system then only the two
 241 pseudo-layers C<:bytes> and C<:crlf> are available.
 242
 243 The C<:bytes> layer corresponds to "binary mode" and the C<:crlf>
 244 layer corresponds to "text mode" on platforms that distinguish
 245 between the two modes when opening files (which is many DOS-like
 246 platforms, including Windows).  These two layers are no-ops on
 247 platforms where binmode() is a no-op, but perform their functions
 248 everywhere if PerlIO is enabled.
 249
 250 =head1 IMPLEMENTATION DETAILS
 251
 252 There is a class method in C<PerlIO::Layer> C<find> which is
 253 implemented as XS code.  It is called by C<import> to validate the
 254 layers:
 255
 256    PerlIO::Layer::->find("perlio")
 257
 258 The return value (if defined) is a Perl object, of class
 259 C<PerlIO::Layer> which is created by the C code in F<perlio.c>.  As
 260 yet there is nothing useful you can do with the object at the perl
 261 level.
 262
 263 =head1 SEE ALSO
 264
 265 L<perlfunc/"binmode">, L<perlfunc/"open">, L<perlunicode>, L<PerlIO>,
 266 L<encoding>
 267
 268 =cut