lib/open.pm

   1 package open;
   2 use warnings;
   3
   4 our $VERSION = '1.07';
   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