[ PATCH ] mymalloc on HP-UX
[p5sagit/p5-mst-13.2.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 The matching of encoding names is loose: case does not matter, and
212 many encodings have several aliases.  See L<Encode::Supported> for
213 details and the list of supported locales.
214
215 Note that C<:utf8> discipline must always be specified exactly like
216 that, it is not subject to the loose matching of encoding names.
217
218 When open() is given an explicit list of layers they are appended to
219 the list declared using this pragma.
220
221 The C<:std> subpragma on its own has no effect, but if combined with
222 the C<:utf8> or C<:encoding> subpragmas, it converts the standard
223 filehandles (STDIN, STDOUT, STDERR) to comply with encoding selected
224 for input/output handles.  For example, if both input and out are
225 chosen to be C<:utf8>, a C<:std> will mean that STDIN, STDOUT, and
226 STDERR are also in C<:utf8>.  On the other hand, if only output is
227 chosen to be in C<< :encoding(koi8r) >>, a C<:std> will cause only the
228 STDOUT and STDERR to be in C<koi8r>.  The C<:locale> subpragma
229 implicitly turns on C<:std>.
230
231 The logic of C<:locale> is as follows:
232
233 =over 4
234
235 =item 1.
236
237 If the platform supports the langinfo(CODESET) interface, the codeset
238 returned is used as the default encoding for the open pragma.
239
240 =item 2.
241
242 If 1. didn't work but we are under the locale pragma, the environment
243 variables LC_ALL and LANG (in that order) are matched for encodings
244 (the part after C<.>, if any), and if any found, that is used 
245 as the default encoding for the open pragma.
246
247 =item 3.
248
249 If 1. and 2. didn't work, the environment variables LC_ALL and LANG
250 (in that order) are matched for anything looking like UTF-8, and if
251 any found, C<:utf8> is used as the default encoding for the open
252 pragma.
253
254 =back
255
256 If your locale environment variables (LANGUAGE, LC_ALL, LC_CTYPE, LANG)
257 contain the strings 'UTF-8' or 'UTF8' (case-insensitive matching),
258 the default encoding of your STDIN, STDOUT, and STDERR, and of
259 B<any subsequent file open>, is UTF-8.
260
261 Directory handles may also support disciplines in future.
262
263 =head1 NONPERLIO FUNCTIONALITY
264
265 If Perl is not built to use PerlIO as its IO system then only the two
266 pseudo-disciplines ":raw" and ":crlf" are available.
267
268 The ":raw" discipline corresponds to "binary mode" and the ":crlf"
269 discipline corresponds to "text mode" on platforms that distinguish
270 between the two modes when opening files (which is many DOS-like
271 platforms, including Windows).  These two disciplines are no-ops on
272 platforms where binmode() is a no-op, but perform their functions
273 everywhere if PerlIO is enabled.
274
275 =head1 IMPLEMENTATION DETAILS
276
277 There is a class method in C<PerlIO::Layer> C<find> which is
278 implemented as XS code.  It is called by C<import> to validate the
279 layers:
280
281    PerlIO::Layer::->find("perlio")
282
283 The return value (if defined) is a Perl object, of class
284 C<PerlIO::Layer> which is created by the C code in F<perlio.c>.  As
285 yet there is nothing useful you can do with the object at the perl
286 level.
287
288 =head1 SEE ALSO
289
290 L<perlfunc/"binmode">, L<perlfunc/"open">, L<perlunicode>, L<PerlIO>,
291 L<encoding>
292
293 =cut