This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
warnings for perlio + others
[perl5.git] / lib / open.pm
1 package open;
2 use warnings;
3 use Carp;
4 $open::hint_bits = 0x20000;
5
6 our $VERSION = '1.01';
7
8 my $locale_encoding;
9
10 sub in_locale { $^H & ($locale::hint_bits || 0)}
11
12 sub _get_locale_encoding {
13     unless (defined $locale_encoding) {
14         # I18N::Langinfo isn't available everywhere
15         eval {
16             require I18N::Langinfo;
17             I18N::Langinfo->import(qw(langinfo CODESET));
18             $locale_encoding = langinfo(CODESET());
19         };
20         my $country_language;
21
22         no warnings 'uninitialized';
23
24         if (not $locale_encoding && in_locale()) {
25             if ($ENV{LC_ALL} =~ /^([^.]+)\.([^.]+)$/) {
26                 ($country_language, $locale_encoding) = ($1, $2);
27             } elsif ($ENV{LANG} =~ /^([^.]+)\.([^.]+)$/) {
28                 ($country_language, $locale_encoding) = ($1, $2);
29             }
30         } elsif (not $locale_encoding) {
31             if ($ENV{LC_ALL} =~ /\butf-?8\b/i ||
32                 $ENV{LANG}   =~ /\butf-?8\b/i) {
33                 $locale_encoding = 'utf8';
34             }
35             # Could do more heuristics based on the country and language
36             # parts of LC_ALL and LANG (the parts before the dot (if any)),
37             # since we have Locale::Country and Locale::Language available.
38             # TODO: get a database of Language -> Encoding mappings
39             # (the Estonian database at http://www.eki.ee/letter/
40             # would be excellent!) --jhi
41         }
42         if (defined $locale_encoding &&
43             $locale_encoding eq 'euc' &&
44             defined $country_language) {
45             if ($country_language =~ /^ja_JP|japan(?:ese)?$/i) {
46                 $locale_encoding = 'euc-jp';
47             } elsif ($country_language =~ /^ko_KR|korean?$/i) {
48                 $locale_encoding = 'euc-kr';
49             } elsif ($country_language =~ /^zh_CN|chin(?:a|ese)?$/i) {
50                 $locale_encoding = 'euc-cn';
51             } elsif ($country_language =~ /^zh_TW|taiwan(?:ese)?$/i) {
52                 $locale_encoding = 'euc-tw';
53             }
54             croak "Locale encoding 'euc' too ambiguous"
55                 if $locale_encoding eq 'euc';
56         }
57     }
58 }
59
60 sub import {
61     my ($class,@args) = @_;
62     croak("`use open' needs explicit list of disciplines") unless @args;
63     my $std;
64     $^H |= $open::hint_bits;
65     my ($in,$out) = split(/\0/,(${^OPEN} || "\0"), -1);
66     while (@args) {
67         my $type = shift(@args);
68         my $dscp;
69         if ($type =~ /^:?(utf8|locale|encoding\(.+\))$/) {
70             $type = 'IO';
71             $dscp = ":$1";
72         } elsif ($type eq ':std') {
73             $std = 1;
74             next;
75         } else {
76             $dscp = shift(@args) || '';
77         }
78         my @val;
79         foreach my $layer (split(/\s+/,$dscp)) {
80             $layer =~ s/^://;
81             if ($layer eq 'locale') {
82                 use Encode;
83                 _get_locale_encoding()
84                     unless defined $locale_encoding;
85                 (warnings::warnif("layer", "Cannot figure out an encoding to use"), last)
86                     unless defined $locale_encoding;
87                 if ($locale_encoding =~ /^utf-?8$/i) {
88                     $layer = "utf8";
89                 } else {
90                     $layer = "encoding($locale_encoding)";
91                 }
92                 $std = 1;
93             } else {
94                 my $target = $layer;            # the layer name itself
95                 $target =~ s/^(\w+)\(.+\)$/$1/; # strip parameters
96
97                 unless(PerlIO::Layer::->find($target)) {
98                     warnings::warnif("layer", "Unknown discipline layer '$layer'");
99                 }
100             }
101             push(@val,":$layer");
102             if ($layer =~ /^(crlf|raw)$/) {
103                 $^H{"open_$type"} = $layer;
104             }
105         }
106         if ($type eq 'IN') {
107             $in  = join(' ',@val);
108         }
109         elsif ($type eq 'OUT') {
110             $out = join(' ',@val);
111         }
112         elsif ($type eq 'IO') {
113             $in = $out = join(' ',@val);
114         }
115         else {
116             croak "Unknown discipline class '$type'";
117         }
118     }
119     ${^OPEN} = join("\0",$in,$out) if $in or $out;
120     if ($std) {
121         if ($in) {
122             if ($in =~ /:utf8\b/) {
123                     binmode(STDIN,  ":utf8");
124                 } elsif ($in =~ /(\w+\(.+\))/) {
125                     binmode(STDIN,  ":$1");
126                 }
127         }
128         if ($out) {
129             if ($out =~ /:utf8\b/) {
130                 binmode(STDOUT,  ":utf8");
131                 binmode(STDERR,  ":utf8");
132             } elsif ($out =~ /(\w+\(.+\))/) {
133                 binmode(STDOUT,  ":$1");
134                 binmode(STDERR,  ":$1");
135             }
136         }
137     }
138 }
139
140 1;
141 __END__
142
143 =head1 NAME
144
145 open - perl pragma to set default disciplines for input and output
146
147 =head1 SYNOPSIS
148
149     use open IN  => ":crlf", OUT => ":raw";
150     use open OUT => ':utf8';
151     use open IO  => ":encoding(iso-8859-7)";
152
153     use open IO  => ':locale';
154
155     use open ':utf8';
156     use open ':locale';
157     use open ':encoding(iso-8859-7)';
158
159     use open ':std';
160
161 =head1 DESCRIPTION
162
163 Full-fledged support for I/O disciplines is now implemented provided
164 Perl is configured to use PerlIO as its IO system (which is now the
165 default).
166
167 The C<open> pragma serves as one of the interfaces to declare default
168 "layers" (aka disciplines) for all I/O.
169
170 The C<open> pragma is used to declare one or more default layers for
171 I/O operations.  Any open(), readpipe() (aka qx//) and similar
172 operators found within the lexical scope of this pragma will use the
173 declared defaults.
174
175 With the C<IN> subpragma you can declare the default layers
176 of input streams, and with the C<OUT> subpragma you can declare
177 the default layers of output streams.  With the C<IO>  subpragma
178 you can control both input and output streams simultaneously.
179
180 If you have a legacy encoding, you can use the C<:encoding(...)> tag.
181
182 if you want to set your encoding disciplines based on your
183 locale environment variables, you can use the C<:locale> tag.
184 For example:
185
186     $ENV{LANG} = 'ru_RU.KOI8-R';
187     # the :locale will probe the locale environment variables like LANG
188     use open OUT => ':locale';
189     open(O, ">koi8");
190     print O chr(0x430); # Unicode CYRILLIC SMALL LETTER A = KOI8-R 0xc1
191     close O;
192     open(I, "<koi8");
193     printf "%#x\n", ord(<I>), "\n"; # this should print 0xc1
194     close I;
195
196 These are equivalent
197
198     use open ':utf8';
199     use open IO => ':utf8';
200
201 as are these
202
203     use open ':locale';
204     use open IO => ':locale';
205
206 and these
207
208     use open ':encoding(iso-8859-7)';
209     use open IO => ':encoding(iso-8859-7)';
210
211 When open() is given an explicit list of layers they are appended to
212 the list declared using this pragma.
213
214 The C<:std> subpragma on its own has no effect, but if combined with
215 the C<:utf8> or C<:encoding> subpragmas, it converts the standard
216 filehandles (STDIN, STDOUT, STDERR) to comply with encoding selected
217 for input/output handles.  For example, if both input and out are
218 chosen to be C<:utf8>, a C<:std> will mean that STDIN, STDOUT, and
219 STDERR are also in C<:utf8>.  On the other hand, if only output is
220 chosen to be in C<< :encoding(koi8r) >>, a C<:std> will cause only the
221 STDOUT and STDERR to be in C<koi8r>.  The C<:locale> subpragma
222 implicitly turns on C<:std>.
223
224 The logic of C<:locale> is as follows:
225
226 =over 4
227
228 =item 1.
229
230 If the platform supports the langinfo(CODESET) interface, the codeset
231 returned is used as the default encoding for the open pragma.
232
233 =item 2.
234
235 If 1. didn't work but we are under the locale pragma, the environment
236 variables LC_ALL and LANG (in that order) are matched for encodings
237 (the part after C<.>, if any), and if any found, that is used 
238 as the default encoding for the open pragma.
239
240 =item 3.
241
242 If 1. and 2. didn't work, the environment variables LC_ALL and LANG
243 (in that order) are matched for anything looking like UTF-8, and if
244 any found, C<:utf8> is used as the default encoding for the open
245 pragma.
246
247 =back
248
249 If your locale environment variables (LANGUAGE, LC_ALL, LC_CTYPE, LANG)
250 contain the strings 'UTF-8' or 'UTF8' (case-insensitive matching),
251 the default encoding of your STDIN, STDOUT, and STDERR, and of
252 B<any subsequent file open>, is UTF-8.
253
254 Directory handles may also support disciplines in future.
255
256 =head1 NONPERLIO FUNCTIONALITY
257
258 If Perl is not built to use PerlIO as its IO system then only the two
259 pseudo-disciplines ":raw" and ":crlf" are available.
260
261 The ":raw" discipline corresponds to "binary mode" and the ":crlf"
262 discipline corresponds to "text mode" on platforms that distinguish
263 between the two modes when opening files (which is many DOS-like
264 platforms, including Windows).  These two disciplines are no-ops on
265 platforms where binmode() is a no-op, but perform their functions
266 everywhere if PerlIO is enabled.
267
268 =head1 IMPLEMENTATION DETAILS
269
270 There is a class method in C<PerlIO::Layer> C<find> which is
271 implemented as XS code.  It is called by C<import> to validate the
272 layers:
273
274    PerlIO::Layer::->find("perlio")
275
276 The return value (if defined) is a Perl object, of class
277 C<PerlIO::Layer> which is created by the C code in F<perlio.c>.  As
278 yet there is nothing useful you can do with the object at the perl
279 level.
280
281 =head1 SEE ALSO
282
283 L<perlfunc/"binmode">, L<perlfunc/"open">, L<perlunicode>, L<PerlIO>,
284 L<encoding>
285
286 =cut