Optimize reversing an array in-place
[p5sagit/p5-mst-13.2.git] / lib / open.pm
1 package open;
2 use warnings;
3
4 our $VERSION = '1.07';
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