latest switch/say/~~
[p5sagit/p5-mst-13.2.git] / lib / open.pm
1 package open;
2 use warnings;
3 $open::hint_bits = 0x20000; # HINT_LOCALIZE_HH
4
5 our $VERSION = '1.05';
6
7 require 5.008001; # for PerlIO::get_layers()
8
9 my $locale_encoding;
10
11 sub _get_encname {
12     return ($1, Encode::resolve_alias($1)) if $_[0] =~ /^:?encoding\((.+)\)$/;
13     return;
14 }
15
16 sub croak {
17     require Carp; goto &Carp::croak;
18 }
19
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 &&
40                   $old[-1] eq 'utf8' &&
41                   $old[-2] =~ /^encoding\(.+\)$/;
42     require Encode;
43     my ($loname, $lcname) = _get_encname($old[-2]);
44     unless (defined $lcname) { # Should we trust get_layers()?
45         croak("open: Unknown encoding '$loname'");
46     }
47     my ($voname, $vcname) = _get_encname($new[-1]);
48     unless (defined $vcname) {
49         croak("open: Unknown encoding '$voname'");
50     }
51     if ($lcname eq $vcname) {
52         binmode($h, ":pop"); # utf8 is part of the encoding layer
53     }
54 }
55
56 sub import {
57     my ($class,@args) = @_;
58     croak("open: needs explicit list of PerlIO layers") unless @args;
59     my $std;
60     $^H |= $open::hint_bits;
61     my ($in,$out) = split(/\0/,(${^OPEN} || "\0"), -1);
62     while (@args) {
63         my $type = shift(@args);
64         my $dscp;
65         if ($type =~ /^:?(utf8|locale|encoding\(.+\))$/) {
66             $type = 'IO';
67             $dscp = ":$1";
68         } elsif ($type eq ':std') {
69             $std = 1;
70             next;
71         } else {
72             $dscp = shift(@args) || '';
73         }
74         my @val;
75         foreach my $layer (split(/\s+/,$dscp)) {
76             $layer =~ s/^://;
77             if ($layer eq 'locale') {
78                 require Encode;
79                 require encoding;
80                 $locale_encoding = encoding::_get_locale_encoding()
81                     unless defined $locale_encoding;
82                 (warnings::warnif("layer", "Cannot figure out an encoding to use"), last)
83                     unless defined $locale_encoding;
84                 if ($locale_encoding =~ /^utf-?8$/i) {
85                     $layer = "utf8";
86                 } else {
87                     $layer = "encoding($locale_encoding)";
88                 }
89                 $std = 1;
90             } else {
91                 my $target = $layer;            # the layer name itself
92                 $target =~ s/^(\w+)\(.+\)$/$1/; # strip parameters
93
94                 unless(PerlIO::Layer::->find($target,1)) {
95                     warnings::warnif("layer", "Unknown PerlIO layer '$target'");
96                 }
97             }
98             push(@val,":$layer");
99             if ($layer =~ /^(crlf|raw)$/) {
100                 $^H{"open_$type"} = $layer;
101             }
102         }
103         if ($type eq 'IN') {
104             _drop_oldenc(*STDIN, @val);
105             $in  = join(' ', @val);
106         }
107         elsif ($type eq 'OUT') {
108             _drop_oldenc(*STDOUT, @val);
109             $out = join(' ', @val);
110         }
111         elsif ($type eq 'IO') {
112             _drop_oldenc(*STDIN,  @val);
113             _drop_oldenc(*STDOUT, @val);
114             $in = $out = join(' ', @val);
115         }
116         else {
117             croak "Unknown PerlIO layer class '$type'";
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
141 1;
142 __END__
143
144 =head1 NAME
145
146 open - 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 ':utf8';
157     use open ':locale';
158     use open ':encoding(iso-8859-7)';
159
160     use open ':std';
161
162 =head1 DESCRIPTION
163
164 Full-fledged support for I/O layers is now implemented provided
165 Perl is configured to use PerlIO as its IO system (which is now the
166 default).
167
168 The 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
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.
175
176 With the C<IN> subpragma you can declare the default layers
177 of input streams, and with the C<OUT> subpragma you can declare
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
183 if you want to set your encoding layers based on your
184 locale environment variables, you can use the C<:locale> tag.
185 For example:
186
187     $ENV{LANG} = 'ru_RU.KOI8-R';
188     # the :locale will probe the locale environment variables like LANG
189     use open OUT => ':locale';
190     open(O, ">koi8");
191     print O chr(0x430); # Unicode CYRILLIC SMALL LETTER A = KOI8-R 0xc1
192     close O;
193     open(I, "<koi8");
194     printf "%#x\n", ord(<I>), "\n"; # this should print 0xc1
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
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
216 Note that C<:utf8> PerlIO layer must always be specified exactly like
217 that, it is not subject to the loose matching of encoding names.
218
219 When open() is given an explicit list of layers (with the three-arg
220 syntax), they override the list declared using this pragma.
221
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
228 chosen to be in C<< :encoding(koi8r) >>, a C<:std> will cause only the
229 STDOUT and STDERR to be in C<koi8r>.  The C<:locale> subpragma
230 implicitly turns on C<:std>.
231
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.
235
236 Directory handles may also support PerlIO layers in the future.
237
238 =head1 NONPERLIO FUNCTIONALITY
239
240 If Perl is not built to use PerlIO as its IO system then only the two
241 pseudo-layers C<:bytes> and C<:crlf> are available.
242
243 The C<:bytes> layer corresponds to "binary mode" and the C<:crlf>
244 layer corresponds to "text mode" on platforms that distinguish
245 between the two modes when opening files (which is many DOS-like
246 platforms, including Windows).  These two layers are no-ops on
247 platforms where binmode() is a no-op, but perform their functions
248 everywhere if PerlIO is enabled.
249
250 =head1 IMPLEMENTATION DETAILS
251
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:
255
256    PerlIO::Layer::->find("perlio")
257
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.
262
263 =head1 SEE ALSO
264
265 L<perlfunc/"binmode">, L<perlfunc/"open">, L<perlunicode>, L<PerlIO>,
266 L<encoding>
267
268 =cut