[ Index ] |
PHP Cross Reference of Unnamed Project |
[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
title
Description
Body
title
Description
Body
title
Description
Body
title
Body
Generated: Tue Mar 17 22:47:18 2015 | Cross-referenced by PHPXref 0.7.1 |