I don't think trying to bracket the hires time with lores
[p5sagit/p5-mst-13.2.git] / lib / open.pm
1 package open;
2 use Carp;
3 $open::hint_bits = 0x20000;
4
5 our $VERSION = '1.01';
6
7 my $locale_encoding;
8
9 sub in_locale { $^H & $locale::hint_bits }
10
11 sub _get_locale_encoding {
12     unless (defined $locale_encoding) {
13         eval {
14             # I18N::Langinfo isn't available everywhere
15             require I18N::Langinfo;
16             I18N::Langinfo->import('langinfo', 'CODESET');
17         };
18         unless ($@) {
19             $locale_encoding = langinfo(CODESET());
20         }
21         my $country_language;
22         if (not $locale_encoding && in_locale()) {
23             if ($ENV{LC_ALL} =~ /^([^.]+)\.([^.]+)$/) {
24                 ($country_language, $locale_encoding) = ($1, $2);
25             } elsif ($ENV{LANG} =~ /^([^.]+)\.([^.]+)$/) {
26                 ($country_language, $locale_encoding) = ($1, $2);
27             }
28         } elsif (not $locale_encoding) {
29             if ($ENV{LC_ALL} =~ /\butf-?8\b/i ||
30                 $ENV{LANG}   =~ /\butf-?8\b/i) {
31                 $locale_encoding = 'utf8';
32             }
33             # Could do more heuristics based on the country and language
34             # parts of LC_ALL and LANG (the parts before the dot (if any)),
35             # since we have Locale::Country and Locale::Language available.
36             # TODO: get a database of Language -> Encoding mappings
37             # (the Estonian database at http://www.eki.ee/letter/
38             # would be excellent!) --jhi
39         }
40         if (defined $locale_encoding &&
41             $locale_encoding eq 'euc' &&
42             defined $country_language) {
43             if ($country_language =~ /^ja_JP|japan(?:ese)?$/i) {
44                 $locale_encoding = 'euc-jp';
45             } elsif ($country_language =~ /^ko_KR|korean?$/i) {
46                 $locale_encoding = 'euc-kr';
47             } elsif ($country_language =~ /^zh_TW|taiwan(?:ese)?$/i) {
48                 $locale_encoding = 'euc-tw';
49             }
50             croak "Locale encoding 'euc' too ambiguous"
51                 if $locale_encoding eq 'euc';
52         }
53     }
54 }
55
56 sub import {
57     my ($class,@args) = @_;
58     croak("`use open' needs explicit list of disciplines") unless @args;
59     $^H |= $open::hint_bits;
60     my ($in,$out) = split(/\0/,(${^OPEN} || "\0"), -1);
61     while (@args) {
62         my $type = shift(@args);
63         my $dscp;
64         if ($type =~ /^:?(utf8|locale|encoding\(.+\))$/) {
65             $type = 'IO';
66             $dscp = ":$1";
67         } else {
68             $dscp = shift(@args);
69         }
70         my @val;
71         foreach my $layer (split(/\s+/,$dscp)) {
72             $layer =~ s/^://;
73             if ($layer eq 'locale') {
74                 use Encode;
75                 _get_locale_encoding()
76                     unless defined $locale_encoding;
77                 croak "Cannot figure out an encoding to use"
78                     unless defined $locale_encoding;
79                 if ($locale_encoding =~ /^utf-?8$/i) {
80                     $layer = "utf8";
81                 } else {
82                     $layer = "encoding($locale_encoding)";
83                 }
84             } else {
85                 unless(PerlIO::Layer::->find($layer)) {
86                     carp("Unknown discipline layer '$layer'");
87                 }
88             }
89             push(@val,":$layer");
90             if ($layer =~ /^(crlf|raw)$/) {
91                 $^H{"open_$type"} = $layer;
92             }
93         }
94         # print "# type = $type, val = @val\n";
95         if ($type eq 'IN') {
96             $in  = join(' ',@val);
97         }
98         elsif ($type eq 'OUT') {
99             $out = join(' ',@val);
100         }
101         elsif ($type eq 'IO') {
102             $in = $out = join(' ',@val);
103         }
104         else {
105             croak "Unknown discipline class '$type'";
106         }
107     }
108     ${^OPEN} = join("\0",$in,$out);
109 }
110
111 1;
112 __END__
113
114 =head1 NAME
115
116 open - perl pragma to set default disciplines for input and output
117
118 =head1 SYNOPSIS
119
120     use open IN  => ":crlf", OUT => ":raw";
121     use open OUT => ':utf8';
122     use open IO  => ":encoding(iso-8859-7)";
123
124     use open IO  => ':locale';
125   
126     use open ':utf8';
127     use open ':locale';
128     use open ':encoding(iso-8859-7)';
129
130 =head1 DESCRIPTION
131
132 Full-fledged support for I/O disciplines is now implemented provided
133 Perl is configured to use PerlIO as its IO system (which is now the
134 default).
135
136 The C<open> pragma serves as one of the interfaces to declare default
137 "layers" (aka disciplines) for all I/O.
138
139 The C<open> pragma is used to declare one or more default layers for
140 I/O operations.  Any open(), readpipe() (aka qx//) and similar
141 operators found within the lexical scope of this pragma will use the
142 declared defaults.
143
144 With the C<IN> subpragma you can declare the default layers
145 of input sterams, and with the C<OUT> subpragma you can declare
146 the default layers of output streams.  With the C<IO>  subpragma
147 you can control both input and output streams simultaneously.
148
149 If you have a legacy encoding, you can use the C<:encoding(...)> tag.
150
151 if you want to set your encoding disciplines based on your
152 locale environment variables, you can use the C<:locale> tag.
153 For example:
154
155     $ENV{LANG} = 'ru_RU.KOI8-R';
156     # the :locale will probe the locale environment variables like LANG
157     use open OUT => ':locale';
158     open(O, ">koi8");
159     print O chr(0x430); # Unicode CYRILLIC SMALL LETTER A = KOI8-R 0xc1
160     close O;
161     open(I, "<koi8");
162     printf "%#x\n", ord(<I>), "\n"; # this should print 0xc1
163     close I;
164
165 These are equivalent
166
167     use open ':utf8';
168     use open IO => ':utf8';
169
170 as are these
171
172     use open ':locale';
173     use open IO => ':locale';
174
175 and these
176
177     use open ':encoding(iso-8859-7)';
178     use open IO => ':encoding(iso-8859-7)';
179
180 When open() is given an explicit list of layers they are appended to
181 the list declared using this pragma.
182
183 Directory handles may also support disciplines in future.
184
185 =head1 NONPERLIO FUNCTIONALITY
186
187 If Perl is not built to use PerlIO as its IO system then only the two
188 pseudo-disciplines ":raw" and ":crlf" are available.
189
190 The ":raw" discipline corresponds to "binary mode" and the ":crlf"
191 discipline corresponds to "text mode" on platforms that distinguish
192 between the two modes when opening files (which is many DOS-like
193 platforms, including Windows).  These two disciplines are no-ops on
194 platforms where binmode() is a no-op, but perform their functions
195 everywhere if PerlIO is enabled.
196
197 =head1 IMPLEMENTATION DETAILS
198
199 There is a class method in C<PerlIO::Layer> C<find> which is
200 implemented as XS code.  It is called by C<import> to validate the
201 layers:
202
203    PerlIO::Layer::->find("perlio")
204
205 The return value (if defined) is a Perl object, of class
206 C<PerlIO::Layer> which is created by the C code in F<perlio.c>.  As
207 yet there is nothing useful you can do with the object at the perl
208 level.
209
210 =head1 SEE ALSO
211
212 L<perlfunc/"binmode">, L<perlfunc/"open">, L<perlunicode>, L<PerlIO>,
213 L<encoding>
214
215 =cut