Commit | Line | Data |
---|---|---|
d1edabcf | 1 | package open; |
99ef548b | 2 | use warnings; |
9cfe5470 | 3 | $open::hint_bits = 0x20000; # HINT_LOCALIZE_HH |
16fe6d59 | 4 | |
8878f897 | 5 | our $VERSION = '1.04_01'; |
b75c8c73 | 6 | |
7c0e976d | 7 | require 5.008001; # for PerlIO::get_layers() |
58d53262 | 8 | |
b4ebbc94 | 9 | my $locale_encoding; |
a4157ebb | 10 | |
7c0e976d | 11 | sub _get_encname { |
b4ebbc94 | 12 | return ($1, Encode::resolve_alias($1)) if $_[0] =~ /^:?encoding\((.+)\)$/; |
7c0e976d JH |
13 | return; |
14 | } | |
a4157ebb | 15 | |
8878f897 T |
16 | sub croak { |
17 | require Carp; goto &Carp::croak; | |
18 | } | |
19 | ||
7c0e976d JH |
20 | sub _drop_oldenc { |
21 | # If by the time we arrive here there already is at the top of the | |
22 | # perlio layer stack an encoding identical to what we would like | |
23 | # to push via this open pragma, we will pop away the old encoding | |
24 | # (+utf8) so that we can push ourselves in place (this is easier | |
25 | # than ignoring pushing ourselves because of the way how ${^OPEN} | |
26 | # works). So we are looking for something like | |
27 | # | |
28 | # stdio encoding(xxx) utf8 | |
29 | # | |
30 | # in the existing layer stack, and in the new stack chunk for | |
31 | # | |
32 | # :encoding(xxx) | |
33 | # | |
34 | # If we find a match, we pop the old stack (once, since | |
35 | # the utf8 is just a flag on the encoding layer) | |
36 | my ($h, @new) = @_; | |
37 | return unless @new >= 1 && $new[-1] =~ /^:encoding\(.+\)$/; | |
38 | my @old = PerlIO::get_layers($h); | |
39 | return unless @old >= 3 && | |
00243fce | 40 | $old[-1] eq 'utf8' && |
7c0e976d | 41 | $old[-2] =~ /^encoding\(.+\)$/; |
b4ebbc94 | 42 | require Encode; |
7c0e976d JH |
43 | my ($loname, $lcname) = _get_encname($old[-2]); |
44 | unless (defined $lcname) { # Should we trust get_layers()? | |
8878f897 | 45 | croak("open: Unknown encoding '$loname'"); |
7c0e976d JH |
46 | } |
47 | my ($voname, $vcname) = _get_encname($new[-1]); | |
48 | unless (defined $vcname) { | |
8878f897 | 49 | croak("open: Unknown encoding '$voname'"); |
7c0e976d JH |
50 | } |
51 | if ($lcname eq $vcname) { | |
52 | binmode($h, ":pop"); # utf8 is part of the encoding layer | |
58d53262 JH |
53 | } |
54 | } | |
55 | ||
16fe6d59 | 56 | sub import { |
dfebf958 | 57 | my ($class,@args) = @_; |
7c0e976d | 58 | croak("open: needs explicit list of PerlIO layers") unless @args; |
b178108d | 59 | my $std; |
16fe6d59 | 60 | $^H |= $open::hint_bits; |
ba6ce41c | 61 | my ($in,$out) = split(/\0/,(${^OPEN} || "\0"), -1); |
dfebf958 NIS |
62 | while (@args) { |
63 | my $type = shift(@args); | |
1e616cf5 JH |
64 | my $dscp; |
65 | if ($type =~ /^:?(utf8|locale|encoding\(.+\))$/) { | |
66 | $type = 'IO'; | |
67 | $dscp = ":$1"; | |
b178108d JH |
68 | } elsif ($type eq ':std') { |
69 | $std = 1; | |
70 | next; | |
1e616cf5 | 71 | } else { |
725d232a | 72 | $dscp = shift(@args) || ''; |
1e616cf5 | 73 | } |
ac27b0f5 | 74 | my @val; |
1e616cf5 | 75 | foreach my $layer (split(/\s+/,$dscp)) { |
dfebf958 | 76 | $layer =~ s/^://; |
58d53262 | 77 | if ($layer eq 'locale') { |
54cfe943 | 78 | require Encode; |
b4ebbc94 NC |
79 | require encoding; |
80 | $locale_encoding = encoding::_get_locale_encoding() | |
58d53262 | 81 | unless defined $locale_encoding; |
99ef548b | 82 | (warnings::warnif("layer", "Cannot figure out an encoding to use"), last) |
58d53262 | 83 | unless defined $locale_encoding; |
11fc5dc3 JH |
84 | if ($locale_encoding =~ /^utf-?8$/i) { |
85 | $layer = "utf8"; | |
86 | } else { | |
738b23dc | 87 | $layer = "encoding($locale_encoding)"; |
11fc5dc3 | 88 | } |
b178108d | 89 | $std = 1; |
97ed432b | 90 | } else { |
011f8d22 JH |
91 | my $target = $layer; # the layer name itself |
92 | $target =~ s/^(\w+)\(.+\)$/$1/; # strip parameters | |
93 | ||
c7732655 NIS |
94 | unless(PerlIO::Layer::->find($target,1)) { |
95 | warnings::warnif("layer", "Unknown PerlIO layer '$target'"); | |
97ed432b | 96 | } |
ac27b0f5 NIS |
97 | } |
98 | push(@val,":$layer"); | |
99 | if ($layer =~ /^(crlf|raw)$/) { | |
100 | $^H{"open_$type"} = $layer; | |
16fe6d59 | 101 | } |
ac27b0f5 NIS |
102 | } |
103 | if ($type eq 'IN') { | |
7c0e976d JH |
104 | _drop_oldenc(*STDIN, @val); |
105 | $in = join(' ', @val); | |
ac27b0f5 NIS |
106 | } |
107 | elsif ($type eq 'OUT') { | |
7c0e976d JH |
108 | _drop_oldenc(*STDOUT, @val); |
109 | $out = join(' ', @val); | |
16fe6d59 | 110 | } |
1e616cf5 | 111 | elsif ($type eq 'IO') { |
7c0e976d JH |
112 | _drop_oldenc(*STDIN, @val); |
113 | _drop_oldenc(*STDOUT, @val); | |
114 | $in = $out = join(' ', @val); | |
f3b00462 | 115 | } |
16fe6d59 | 116 | else { |
e2d9456f | 117 | croak "Unknown PerlIO layer class '$type'"; |
16fe6d59 GS |
118 | } |
119 | } | |
7c0e976d | 120 | ${^OPEN} = join("\0", $in, $out); |
b178108d JH |
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 | } | |
16fe6d59 GS |
139 | } |
140 | ||
141 | 1; | |
142 | __END__ | |
d1edabcf GS |
143 | |
144 | =head1 NAME | |
145 | ||
e2d9456f | 146 | open - perl pragma to set default PerlIO layers for input and output |
d1edabcf GS |
147 | |
148 | =head1 SYNOPSIS | |
149 | ||
d5563ed7 | 150 | use open IN => ":crlf", OUT => ":bytes"; |
1e616cf5 JH |
151 | use open OUT => ':utf8'; |
152 | use open IO => ":encoding(iso-8859-7)"; | |
153 | ||
154 | use open IO => ':locale'; | |
725d232a | 155 | |
1e616cf5 JH |
156 | use open ':utf8'; |
157 | use open ':locale'; | |
158 | use open ':encoding(iso-8859-7)'; | |
d1edabcf | 159 | |
b178108d JH |
160 | use open ':std'; |
161 | ||
d1edabcf GS |
162 | =head1 DESCRIPTION |
163 | ||
e2d9456f | 164 | Full-fledged support for I/O layers is now implemented provided |
d151aa0e JH |
165 | Perl is configured to use PerlIO as its IO system (which is now the |
166 | default). | |
16fe6d59 | 167 | |
7d3b96bb | 168 | The C<open> pragma serves as one of the interfaces to declare default |
16479489 JH |
169 | "layers" (also known as "disciplines") for all I/O. Any two-argument |
170 | open(), readpipe() (aka qx//) and similar operators found within the | |
171 | lexical scope of this pragma will use the declared defaults. | |
172 | Three-argument opens are not affected by this pragma since there you | |
173 | (can) explicitly specify the layers and are supposed to know what you | |
174 | are doing. | |
7d3b96bb | 175 | |
1e616cf5 | 176 | With the C<IN> subpragma you can declare the default layers |
d8d29d4f | 177 | of input streams, and with the C<OUT> subpragma you can declare |
1e616cf5 JH |
178 | the default layers of output streams. With the C<IO> subpragma |
179 | you can control both input and output streams simultaneously. | |
180 | ||
181 | If you have a legacy encoding, you can use the C<:encoding(...)> tag. | |
182 | ||
e2d9456f | 183 | if you want to set your encoding layers based on your |
1e616cf5 JH |
184 | locale environment variables, you can use the C<:locale> tag. |
185 | For example: | |
186 | ||
187 | $ENV{LANG} = 'ru_RU.KOI8-R'; | |
dbd62f41 JH |
188 | # the :locale will probe the locale environment variables like LANG |
189 | use open OUT => ':locale'; | |
1e616cf5 | 190 | open(O, ">koi8"); |
23bcb45a | 191 | print O chr(0x430); # Unicode CYRILLIC SMALL LETTER A = KOI8-R 0xc1 |
1e616cf5 JH |
192 | close O; |
193 | open(I, "<koi8"); | |
23bcb45a | 194 | printf "%#x\n", ord(<I>), "\n"; # this should print 0xc1 |
1e616cf5 JH |
195 | close I; |
196 | ||
197 | These are equivalent | |
198 | ||
199 | use open ':utf8'; | |
200 | use open IO => ':utf8'; | |
201 | ||
202 | as are these | |
203 | ||
204 | use open ':locale'; | |
205 | use open IO => ':locale'; | |
206 | ||
207 | and these | |
208 | ||
209 | use open ':encoding(iso-8859-7)'; | |
210 | use open IO => ':encoding(iso-8859-7)'; | |
211 | ||
b5d8778e JH |
212 | The matching of encoding names is loose: case does not matter, and |
213 | many encodings have several aliases. See L<Encode::Supported> for | |
214 | details and the list of supported locales. | |
215 | ||
e2d9456f | 216 | Note that C<:utf8> PerlIO layer must always be specified exactly like |
b5d8778e JH |
217 | that, it is not subject to the loose matching of encoding names. |
218 | ||
d151aa0e JH |
219 | When open() is given an explicit list of layers they are appended to |
220 | the list declared using this pragma. | |
7d3b96bb | 221 | |
b178108d JH |
222 | The C<:std> subpragma on its own has no effect, but if combined with |
223 | the C<:utf8> or C<:encoding> subpragmas, it converts the standard | |
224 | filehandles (STDIN, STDOUT, STDERR) to comply with encoding selected | |
225 | for input/output handles. For example, if both input and out are | |
226 | chosen to be C<:utf8>, a C<:std> will mean that STDIN, STDOUT, and | |
227 | STDERR are also in C<:utf8>. On the other hand, if only output is | |
fb80c70c | 228 | chosen to be in C<< :encoding(koi8r) >>, a C<:std> will cause only the |
b178108d JH |
229 | STDOUT and STDERR to be in C<koi8r>. The C<:locale> subpragma |
230 | implicitly turns on C<:std>. | |
231 | ||
7c0e976d JH |
232 | The logic of C<:locale> is described in full in L</encoding>, |
233 | but in short it is first trying nl_langinfo(CODESET) and then | |
234 | guessing from the LC_ALL and LANG locale environment variables. | |
b310b053 | 235 | |
e2d9456f | 236 | Directory handles may also support PerlIO layers in the future. |
7d3b96bb NIS |
237 | |
238 | =head1 NONPERLIO FUNCTIONALITY | |
239 | ||
d151aa0e | 240 | If Perl is not built to use PerlIO as its IO system then only the two |
e2d9456f | 241 | pseudo-layers C<:bytes> and C<:crlf> are available. |
16fe6d59 | 242 | |
e2d9456f EM |
243 | The C<:bytes> layer corresponds to "binary mode" and the C<:crlf> |
244 | layer corresponds to "text mode" on platforms that distinguish | |
16fe6d59 | 245 | between the two modes when opening files (which is many DOS-like |
e2d9456f | 246 | platforms, including Windows). These two layers are no-ops on |
d151aa0e JH |
247 | platforms where binmode() is a no-op, but perform their functions |
248 | everywhere if PerlIO is enabled. | |
7d3b96bb NIS |
249 | |
250 | =head1 IMPLEMENTATION DETAILS | |
d1edabcf | 251 | |
f3b00462 JH |
252 | There is a class method in C<PerlIO::Layer> C<find> which is |
253 | implemented as XS code. It is called by C<import> to validate the | |
254 | layers: | |
0c4f7ff0 NIS |
255 | |
256 | PerlIO::Layer::->find("perlio") | |
257 | ||
f3b00462 JH |
258 | The return value (if defined) is a Perl object, of class |
259 | C<PerlIO::Layer> which is created by the C code in F<perlio.c>. As | |
260 | yet there is nothing useful you can do with the object at the perl | |
261 | level. | |
16fe6d59 | 262 | |
d1edabcf GS |
263 | =head1 SEE ALSO |
264 | ||
1768d7eb JH |
265 | L<perlfunc/"binmode">, L<perlfunc/"open">, L<perlunicode>, L<PerlIO>, |
266 | L<encoding> | |
d1edabcf GS |
267 | |
268 | =cut |