lib/open.pm

   1 package open;
   2 use warnings;
   3
   4 our $VERSION = '1.12';
   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) if $std;
  99             $in  = join(' ', @val);
 100         }
 101         elsif ($type eq 'OUT') {
 102             if ($std) {
 103                 _drop_oldenc(*STDOUT, @val);
 104                 _drop_oldenc(*STDERR, @val);
 105             }
 106             $out = join(' ', @val);
 107         }
 108         elsif ($type eq 'IO') {
 109             if ($std) {
 110                 _drop_oldenc(*STDIN, @val);
 111                 _drop_oldenc(*STDOUT, @val);
 112                 _drop_oldenc(*STDERR, @val);
 113             }
 114             $in = $out = join(' ', @val);
 115         }
 116         else {
 117             croak "Unknown PerlIO layer class '$type' (need IN, OUT or IO)";
 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 => ':raw';
 151     open my $in, '<', 'foo.txt' or die "open failed: $!";
 152     my $line = <$in>; # CRLF translated
 153     close $in;
 154     open my $out, '>', 'bar.txt' or die "open failed: $!";
 155     print $out $line; # no translation of bytes
 156     close $out;
 157
 158     use open OUT => ':encoding(UTF-8)';
 159     use open IN  => ':encoding(iso-8859-7)';
 160
 161     use open IO  => ':locale';
 162
 163     # IO implicit only for :utf8, :encoding, :locale
 164     use open ':encoding(UTF-8)';
 165     use open ':encoding(iso-8859-7)';
 166     use open ':locale';
 167
 168     # with :std, also affect global standard handles
 169     use open ':std', ':encoding(UTF-8)';
 170     use open ':std', OUT => ':encoding(cp1252)';
 171     use open ':std', IO => ':raw :encoding(UTF-16LE)';
 172
 173 =head1 DESCRIPTION
 174
 175 Full-fledged support for I/O layers is now implemented provided
 176 Perl is configured to use PerlIO as its IO system (which has been the
 177 default since 5.8, and the only supported configuration since 5.16).
 178
 179 The C<open> pragma serves as one of the interfaces to declare default
 180 "layers" (previously known as "disciplines") for all I/O. Any open(),
 181 readpipe() (aka qx//) and similar operators found within the
 182 lexical scope of this pragma will use the declared defaults via the
 183 L<C<${^OPEN}>|perlvar/${^OPEN}> variable.
 184
 185 Layers are specified with a leading colon by convention. You can
 186 specify a stack of multiple layers as a space-separated string.
 187 See L<PerlIO> for more information on the available layers.
 188
 189 With the C<IN> subpragma you can declare the default layers
 190 of input streams, and with the C<OUT> subpragma you can declare
 191 the default layers of output streams.  With the C<IO> subpragma
 192 (may be omitted for C<:utf8>, C<:locale>, or C<:encoding>) you
 193 can control both input and output streams simultaneously.
 194
 195 When open() is given an explicit list of layers (with the three-arg
 196 syntax), they override the list declared using this pragma.  open() can
 197 also be given a single colon (:) for a layer name, to override this pragma
 198 and use the default as detailed in
 199 L<PerlIO/Defaults and how to override them>.
 200
 201 To translate from and to an arbitrary text encoding, use the C<:encoding>
 202 layer.  The matching of encoding names in C<:encoding> is loose: case does
 203 not matter, and many encodings have several aliases.  See
 204 L<Encode::Supported> for details and the list of supported locales.
 205
 206 If you want to set your encoding layers based on your
 207 locale environment variables, you can use the C<:locale> pseudo-layer.
 208 For example:
 209
 210     $ENV{LANG} = 'ru_RU.KOI8-R';
 211     # the :locale will probe the locale environment variables like LANG
 212     use open OUT => ':locale';
 213     open(my $out, '>', 'koi8') or die "open failed: $!";
 214     print $out chr(0x430); # CYRILLIC SMALL LETTER A = KOI8-R 0xc1
 215     close $out;
 216     open(my $in, '<', 'koi8') or die "open failed: $!";
 217     printf "%#x\n", ord(<$in>); # this should print 0xc1
 218     close $in;
 219
 220 The logic of C<:locale> is described in full in
 221 L<encoding/The C<:locale> sub-pragma>,
 222 but in short it is first trying nl_langinfo(CODESET) and then
 223 guessing from the LC_ALL and LANG locale environment variables.
 224 C<:locale> also implicitly turns on C<:std>.
 225
 226 C<:std> is not a layer but an additional subpragma.  When specified in the
 227 import list, it activates an additional functionality of pushing the
 228 layers selected for input/output handles to the standard filehandles
 229 (STDIN, STDOUT, STDERR).  If the new layers and existing layer stack both
 230 end with an C<:encoding> layer, the existing C<:encoding> layer will also
 231 be removed.
 232
 233 For example, if both input and out are chosen to be C<:encoding(UTF-8)>, a
 234 C<:std> will mean that STDIN, STDOUT, and STDERR will also have
 235 C<:encoding(UTF-8)> set.  On the other hand, if only output is chosen to
 236 be in C<:encoding(koi8r)>, a C<:std> will cause only the STDOUT and STDERR
 237 to be in C<koi8r>.
 238
 239 The effect of C<:std> is not lexical as it modifies the layer stack of the
 240 global handles.  If you wish to apply only this global effect and not the
 241 effect on handles that are opened in that scope, you can isolate the call
 242 to this pragma in its own lexical scope.
 243
 244     { use open ':std', IO => ':encoding(UTF-8)' }
 245
 246 =head1 IMPLEMENTATION DETAILS
 247
 248 There is a class method in C<PerlIO::Layer> C<find> which is
 249 implemented as XS code.  It is called by C<import> to validate the
 250 layers:
 251
 252    PerlIO::Layer::->find("perlio")
 253
 254 The return value (if defined) is a Perl object, of class
 255 C<PerlIO::Layer> which is created by the C code in F<perlio.c>.  As
 256 yet there is nothing useful you can do with the object at the perl
 257 level.
 258
 259 =head1 SEE ALSO
 260
 261 L<perlfunc/"binmode">, L<perlfunc/"open">, L<perlunicode>, L<PerlIO>,
 262 L<encoding>
 263
 264 =cut