latest switch/say/~~
[p5sagit/p5-mst-13.2.git] / lib / open.pm
CommitLineData
d1edabcf 1package open;
99ef548b 2use warnings;
9cfe5470 3$open::hint_bits = 0x20000; # HINT_LOCALIZE_HH
16fe6d59 4
9fe371da 5our $VERSION = '1.05';
b75c8c73 6
7c0e976d 7require 5.008001; # for PerlIO::get_layers()
58d53262 8
b4ebbc94 9my $locale_encoding;
a4157ebb 10
7c0e976d 11sub _get_encname {
b4ebbc94 12 return ($1, Encode::resolve_alias($1)) if $_[0] =~ /^:?encoding\((.+)\)$/;
7c0e976d 13 return;
14}
a4157ebb 15
8878f897 16sub croak {
17 require Carp; goto &Carp::croak;
18}
19
7c0e976d 20sub _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 &&
00243fce 40 $old[-1] eq 'utf8' &&
7c0e976d 41 $old[-2] =~ /^encoding\(.+\)$/;
b4ebbc94 42 require Encode;
7c0e976d 43 my ($loname, $lcname) = _get_encname($old[-2]);
44 unless (defined $lcname) { # Should we trust get_layers()?
8878f897 45 croak("open: Unknown encoding '$loname'");
7c0e976d 46 }
47 my ($voname, $vcname) = _get_encname($new[-1]);
48 unless (defined $vcname) {
8878f897 49 croak("open: Unknown encoding '$voname'");
7c0e976d 50 }
51 if ($lcname eq $vcname) {
52 binmode($h, ":pop"); # utf8 is part of the encoding layer
58d53262 53 }
54}
55
16fe6d59 56sub import {
dfebf958 57 my ($class,@args) = @_;
7c0e976d 58 croak("open: needs explicit list of PerlIO layers") unless @args;
b178108d 59 my $std;
16fe6d59 60 $^H |= $open::hint_bits;
ba6ce41c 61 my ($in,$out) = split(/\0/,(${^OPEN} || "\0"), -1);
dfebf958 62 while (@args) {
63 my $type = shift(@args);
1e616cf5 64 my $dscp;
65 if ($type =~ /^:?(utf8|locale|encoding\(.+\))$/) {
66 $type = 'IO';
67 $dscp = ":$1";
b178108d 68 } elsif ($type eq ':std') {
69 $std = 1;
70 next;
1e616cf5 71 } else {
725d232a 72 $dscp = shift(@args) || '';
1e616cf5 73 }
ac27b0f5 74 my @val;
1e616cf5 75 foreach my $layer (split(/\s+/,$dscp)) {
dfebf958 76 $layer =~ s/^://;
58d53262 77 if ($layer eq 'locale') {
54cfe943 78 require Encode;
b4ebbc94 79 require encoding;
80 $locale_encoding = encoding::_get_locale_encoding()
58d53262 81 unless defined $locale_encoding;
99ef548b 82 (warnings::warnif("layer", "Cannot figure out an encoding to use"), last)
58d53262 83 unless defined $locale_encoding;
11fc5dc3 84 if ($locale_encoding =~ /^utf-?8$/i) {
85 $layer = "utf8";
86 } else {
738b23dc 87 $layer = "encoding($locale_encoding)";
11fc5dc3 88 }
b178108d 89 $std = 1;
97ed432b 90 } else {
011f8d22 91 my $target = $layer; # the layer name itself
92 $target =~ s/^(\w+)\(.+\)$/$1/; # strip parameters
93
c7732655 94 unless(PerlIO::Layer::->find($target,1)) {
95 warnings::warnif("layer", "Unknown PerlIO layer '$target'");
97ed432b 96 }
ac27b0f5 97 }
98 push(@val,":$layer");
99 if ($layer =~ /^(crlf|raw)$/) {
100 $^H{"open_$type"} = $layer;
16fe6d59 101 }
ac27b0f5 102 }
103 if ($type eq 'IN') {
7c0e976d 104 _drop_oldenc(*STDIN, @val);
105 $in = join(' ', @val);
ac27b0f5 106 }
107 elsif ($type eq 'OUT') {
7c0e976d 108 _drop_oldenc(*STDOUT, @val);
109 $out = join(' ', @val);
16fe6d59 110 }
1e616cf5 111 elsif ($type eq 'IO') {
7c0e976d 112 _drop_oldenc(*STDIN, @val);
113 _drop_oldenc(*STDOUT, @val);
114 $in = $out = join(' ', @val);
f3b00462 115 }
16fe6d59 116 else {
e2d9456f 117 croak "Unknown PerlIO layer class '$type'";
16fe6d59 118 }
119 }
7c0e976d 120 ${^OPEN} = join("\0", $in, $out);
b178108d 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 }
16fe6d59 139}
140
1411;
142__END__
d1edabcf 143
144=head1 NAME
145
e2d9456f 146open - perl pragma to set default PerlIO layers for input and output
d1edabcf 147
148=head1 SYNOPSIS
149
d5563ed7 150 use open IN => ":crlf", OUT => ":bytes";
1e616cf5 151 use open OUT => ':utf8';
152 use open IO => ":encoding(iso-8859-7)";
153
154 use open IO => ':locale';
725d232a 155
1e616cf5 156 use open ':utf8';
157 use open ':locale';
158 use open ':encoding(iso-8859-7)';
d1edabcf 159
b178108d 160 use open ':std';
161
d1edabcf 162=head1 DESCRIPTION
163
e2d9456f 164Full-fledged support for I/O layers is now implemented provided
d151aa0e 165Perl is configured to use PerlIO as its IO system (which is now the
166default).
16fe6d59 167
7d3b96bb 168The C<open> pragma serves as one of the interfaces to declare default
16479489 169"layers" (also known as "disciplines") for all I/O. Any two-argument
170open(), readpipe() (aka qx//) and similar operators found within the
171lexical scope of this pragma will use the declared defaults.
172Three-argument opens are not affected by this pragma since there you
173(can) explicitly specify the layers and are supposed to know what you
174are doing.
7d3b96bb 175
1e616cf5 176With the C<IN> subpragma you can declare the default layers
d8d29d4f 177of input streams, and with the C<OUT> subpragma you can declare
1e616cf5 178the default layers of output streams. With the C<IO> subpragma
179you can control both input and output streams simultaneously.
180
181If you have a legacy encoding, you can use the C<:encoding(...)> tag.
182
e2d9456f 183if you want to set your encoding layers based on your
1e616cf5 184locale environment variables, you can use the C<:locale> tag.
185For example:
186
187 $ENV{LANG} = 'ru_RU.KOI8-R';
dbd62f41 188 # the :locale will probe the locale environment variables like LANG
189 use open OUT => ':locale';
1e616cf5 190 open(O, ">koi8");
23bcb45a 191 print O chr(0x430); # Unicode CYRILLIC SMALL LETTER A = KOI8-R 0xc1
1e616cf5 192 close O;
193 open(I, "<koi8");
23bcb45a 194 printf "%#x\n", ord(<I>), "\n"; # this should print 0xc1
1e616cf5 195 close I;
196
197These are equivalent
198
199 use open ':utf8';
200 use open IO => ':utf8';
201
202as are these
203
204 use open ':locale';
205 use open IO => ':locale';
206
207and these
208
209 use open ':encoding(iso-8859-7)';
210 use open IO => ':encoding(iso-8859-7)';
211
b5d8778e 212The matching of encoding names is loose: case does not matter, and
213many encodings have several aliases. See L<Encode::Supported> for
214details and the list of supported locales.
215
e2d9456f 216Note that C<:utf8> PerlIO layer must always be specified exactly like
b5d8778e 217that, it is not subject to the loose matching of encoding names.
218
9fe371da 219When open() is given an explicit list of layers (with the three-arg
220syntax), they override the list declared using this pragma.
7d3b96bb 221
b178108d 222The C<:std> subpragma on its own has no effect, but if combined with
223the C<:utf8> or C<:encoding> subpragmas, it converts the standard
224filehandles (STDIN, STDOUT, STDERR) to comply with encoding selected
225for input/output handles. For example, if both input and out are
226chosen to be C<:utf8>, a C<:std> will mean that STDIN, STDOUT, and
227STDERR are also in C<:utf8>. On the other hand, if only output is
fb80c70c 228chosen to be in C<< :encoding(koi8r) >>, a C<:std> will cause only the
b178108d 229STDOUT and STDERR to be in C<koi8r>. The C<:locale> subpragma
230implicitly turns on C<:std>.
231
9fe371da 232The logic of C<:locale> is described in full in L<encoding>,
7c0e976d 233but in short it is first trying nl_langinfo(CODESET) and then
234guessing from the LC_ALL and LANG locale environment variables.
b310b053 235
e2d9456f 236Directory handles may also support PerlIO layers in the future.
7d3b96bb 237
238=head1 NONPERLIO FUNCTIONALITY
239
d151aa0e 240If Perl is not built to use PerlIO as its IO system then only the two
e2d9456f 241pseudo-layers C<:bytes> and C<:crlf> are available.
16fe6d59 242
e2d9456f 243The C<:bytes> layer corresponds to "binary mode" and the C<:crlf>
244layer corresponds to "text mode" on platforms that distinguish
16fe6d59 245between the two modes when opening files (which is many DOS-like
e2d9456f 246platforms, including Windows). These two layers are no-ops on
d151aa0e 247platforms where binmode() is a no-op, but perform their functions
248everywhere if PerlIO is enabled.
7d3b96bb 249
250=head1 IMPLEMENTATION DETAILS
d1edabcf 251
f3b00462 252There is a class method in C<PerlIO::Layer> C<find> which is
253implemented as XS code. It is called by C<import> to validate the
254layers:
0c4f7ff0 255
256 PerlIO::Layer::->find("perlio")
257
f3b00462 258The return value (if defined) is a Perl object, of class
259C<PerlIO::Layer> which is created by the C code in F<perlio.c>. As
260yet there is nothing useful you can do with the object at the perl
261level.
16fe6d59 262
d1edabcf 263=head1 SEE ALSO
264
1768d7eb 265L<perlfunc/"binmode">, L<perlfunc/"open">, L<perlunicode>, L<PerlIO>,
266L<encoding>
d1edabcf 267
268=cut