1package open; 2use warnings; 3 4our $VERSION = '1.11'; 5 6require 5.008001; # for PerlIO::get_layers() 7 8my $locale_encoding; 9 10sub _get_encname { 11 return ($1, Encode::resolve_alias($1)) if $_[0] =~ /^:?encoding\((.+)\)$/; 12 return; 13} 14 15sub croak { 16 require Carp; goto &Carp::croak; 17} 18 19sub _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 55sub 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 1411; 142__END__ 143 144=head1 NAME 145 146open - 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 ':encoding(UTF-8)'; 157 use open ':locale'; 158 use open ':encoding(iso-8859-7)'; 159 160 use open ':std'; 161 162=head1 DESCRIPTION 163 164Full-fledged support for I/O layers is now implemented provided 165Perl is configured to use PerlIO as its IO system (which is now the 166default). 167 168The 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 170open(), readpipe() (aka qx//) and similar operators found within the 171lexical scope of this pragma will use the declared defaults. 172Even three-argument opens may be affected by this pragma 173when they don't specify IO layers in MODE. 174 175With the C<IN> subpragma you can declare the default layers 176of input streams, and with the C<OUT> subpragma you can declare 177the default layers of output streams. With the C<IO> subpragma 178you can control both input and output streams simultaneously. 179 180If you have a legacy encoding, you can use the C<:encoding(...)> tag. 181 182If you want to set your encoding layers based on your 183locale environment variables, you can use the C<:locale> tag. 184For example: 185 186 $ENV{LANG} = 'ru_RU.KOI8-R'; 187 # the :locale will probe the locale environment variables like LANG 188 use open OUT => ':locale'; 189 open(O, ">koi8"); 190 print O chr(0x430); # Unicode CYRILLIC SMALL LETTER A = KOI8-R 0xc1 191 close O; 192 open(I, "<koi8"); 193 printf "%#x\n", ord(<I>), "\n"; # this should print 0xc1 194 close I; 195 196These are equivalent 197 198 use open ':encoding(UTF-8)'; 199 use open IO => ':encoding(UTF-8)'; 200 201as are these 202 203 use open ':locale'; 204 use open IO => ':locale'; 205 206and these 207 208 use open ':encoding(iso-8859-7)'; 209 use open IO => ':encoding(iso-8859-7)'; 210 211The matching of encoding names is loose: case does not matter, and 212many encodings have several aliases. See L<Encode::Supported> for 213details and the list of supported locales. 214 215When open() is given an explicit list of layers (with the three-arg 216syntax), they override the list declared using this pragma. open() can 217also be given a single colon (:) for a layer name, to override this pragma 218and use the default (C<:raw> on Unix, C<:crlf> on Windows). 219 220The C<:std> subpragma on its own has no effect, but if combined with 221the C<:utf8> or C<:encoding> subpragmas, it converts the standard 222filehandles (STDIN, STDOUT, STDERR) to comply with encoding selected 223for input/output handles. For example, if both input and out are 224chosen to be C<:encoding(UTF-8)>, a C<:std> will mean that STDIN, STDOUT, 225and STDERR are also in C<:encoding(UTF-8)>. On the other hand, if only 226output is chosen to be in C<< :encoding(koi8r) >>, a C<:std> will cause 227only the STDOUT and STDERR to be in C<koi8r>. The C<:locale> subpragma 228implicitly turns on C<:std>. 229 230The logic of C<:locale> is described in full in L<encoding>, 231but in short it is first trying nl_langinfo(CODESET) and then 232guessing from the LC_ALL and LANG locale environment variables. 233 234Directory handles may also support PerlIO layers in the future. 235 236=head1 NONPERLIO FUNCTIONALITY 237 238If Perl is not built to use PerlIO as its IO system then only the two 239pseudo-layers C<:bytes> and C<:crlf> are available. 240 241The C<:bytes> layer corresponds to "binary mode" and the C<:crlf> 242layer corresponds to "text mode" on platforms that distinguish 243between the two modes when opening files (which is many DOS-like 244platforms, including Windows). These two layers are no-ops on 245platforms where binmode() is a no-op, but perform their functions 246everywhere if PerlIO is enabled. 247 248=head1 IMPLEMENTATION DETAILS 249 250There is a class method in C<PerlIO::Layer> C<find> which is 251implemented as XS code. It is called by C<import> to validate the 252layers: 253 254 PerlIO::Layer::->find("perlio") 255 256The return value (if defined) is a Perl object, of class 257C<PerlIO::Layer> which is created by the C code in F<perlio.c>. As 258yet there is nothing useful you can do with the object at the perl 259level. 260 261=head1 SEE ALSO 262 263L<perlfunc/"binmode">, L<perlfunc/"open">, L<perlunicode>, L<PerlIO>, 264L<encoding> 265 266=cut 267