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