This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix my typo in change 32137.
[perl5.git] / 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