lib/open.pm

   1 package open;
   2 use warnings;
   3
   4 our $VERSION = '1.05';
   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                 if ($locale_encoding =~ /^utf-?8$/i) {
  83                     $layer = "utf8";
  84                 } else {
  85                     $layer = "encoding($locale_encoding)";
  86                 }
  87                 $std = 1;
  88             } else {
  89                 my $target = $layer;            # the layer name itself
  90                 $target =~ s/^(\w+)\(.+\)$/$1/; # strip parameters
  91
  92                 unless(PerlIO::Layer::->find($target,1)) {
  93                     warnings::warnif("layer", "Unknown PerlIO layer '$target'");
  94                 }
  95             }
  96             push(@val,":$layer");
  97             if ($layer =~ /^(crlf|raw)$/) {
  98                 $^H{"open_$type"} = $layer;
  99             }
 100         }
 101         if ($type eq 'IN') {
 102             _drop_oldenc(*STDIN, @val);
 103             $in  = join(' ', @val);
 104         }
 105         elsif ($type eq 'OUT') {
 106             _drop_oldenc(*STDOUT, @val);
 107             $out = join(' ', @val);
 108         }
 109         elsif ($type eq 'IO') {
 110             _drop_oldenc(*STDIN,  @val);
 111             _drop_oldenc(*STDOUT, @val);
 112             $in = $out = join(' ', @val);
 113         }
 114         else {
 115             croak "Unknown PerlIO layer class '$type'";
 116         }
 117     }
 118     ${^OPEN} = join("\0", $in, $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 PerlIO layers for input and output
 145
 146 =head1 SYNOPSIS
 147
 148     use open IN  => ":crlf", OUT => ":bytes";
 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 layers 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" (also known as "disciplines") for all I/O. Any two-argument
 168 open(), readpipe() (aka qx//) and similar operators found within the
 169 lexical scope of this pragma will use the declared defaults.
 170 Even three-argument opens may be affected by this pragma
 171 when they don't specify IO layers in MODE.
 172
 173 With the C<IN> subpragma you can declare the default layers
 174 of input streams, and with the C<OUT> subpragma you can declare
 175 the default layers of output streams.  With the C<IO>  subpragma
 176 you can control both input and output streams simultaneously.
 177
 178 If you have a legacy encoding, you can use the C<:encoding(...)> tag.
 179
 180 If you want to set your encoding layers based on your
 181 locale environment variables, you can use the C<:locale> tag.
 182 For example:
 183
 184     $ENV{LANG} = 'ru_RU.KOI8-R';
 185     # the :locale will probe the locale environment variables like LANG
 186     use open OUT => ':locale';
 187     open(O, ">koi8");
 188     print O chr(0x430); # Unicode CYRILLIC SMALL LETTER A = KOI8-R 0xc1
 189     close O;
 190     open(I, "<koi8");
 191     printf "%#x\n", ord(<I>), "\n"; # this should print 0xc1
 192     close I;
 193
 194 These are equivalent
 195
 196     use open ':utf8';
 197     use open IO => ':utf8';
 198
 199 as are these
 200
 201     use open ':locale';
 202     use open IO => ':locale';
 203
 204 and these
 205
 206     use open ':encoding(iso-8859-7)';
 207     use open IO => ':encoding(iso-8859-7)';
 208
 209 The matching of encoding names is loose: case does not matter, and
 210 many encodings have several aliases.  See L<Encode::Supported> for
 211 details and the list of supported locales.
 212
 213 Note that C<:utf8> PerlIO layer must always be specified exactly like
 214 that, it is not subject to the loose matching of encoding names.
 215
 216 When open() is given an explicit list of layers (with the three-arg
 217 syntax), they override the list declared using this pragma.
 218
 219 The C<:std> subpragma on its own has no effect, but if combined with
 220 the C<:utf8> or C<:encoding> subpragmas, it converts the standard
 221 filehandles (STDIN, STDOUT, STDERR) to comply with encoding selected
 222 for input/output handles.  For example, if both input and out are
 223 chosen to be C<:utf8>, a C<:std> will mean that STDIN, STDOUT, and
 224 STDERR are also in C<:utf8>.  On the other hand, if only output is
 225 chosen to be in C<< :encoding(koi8r) >>, a C<:std> will cause only the
 226 STDOUT and STDERR to be in C<koi8r>.  The C<:locale> subpragma
 227 implicitly turns on C<:std>.
 228
 229 The logic of C<:locale> is described in full in L<encoding>,
 230 but in short it is first trying nl_langinfo(CODESET) and then
 231 guessing from the LC_ALL and LANG locale environment variables.
 232
 233 Directory handles may also support PerlIO layers in the future.
 234
 235 =head1 NONPERLIO FUNCTIONALITY
 236
 237 If Perl is not built to use PerlIO as its IO system then only the two
 238 pseudo-layers C<:bytes> and C<:crlf> are available.
 239
 240 The C<:bytes> layer corresponds to "binary mode" and the C<:crlf>
 241 layer corresponds to "text mode" on platforms that distinguish
 242 between the two modes when opening files (which is many DOS-like
 243 platforms, including Windows).  These two layers are no-ops on
 244 platforms where binmode() is a no-op, but perform their functions
 245 everywhere if PerlIO is enabled.
 246
 247 =head1 IMPLEMENTATION DETAILS
 248
 249 There is a class method in C<PerlIO::Layer> C<find> which is
 250 implemented as XS code.  It is called by C<import> to validate the
 251 layers:
 252
 253    PerlIO::Layer::->find("perlio")
 254
 255 The return value (if defined) is a Perl object, of class
 256 C<PerlIO::Layer> which is created by the C code in F<perlio.c>.  As
 257 yet there is nothing useful you can do with the object at the perl
 258 level.
 259
 260 =head1 SEE ALSO
 261
 262 L<perlfunc/"binmode">, L<perlfunc/"open">, L<perlunicode>, L<PerlIO>,
 263 L<encoding>
 264
 265 =cut