[Summary view] [Print] [Text view]

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