perl/lib/open.pm

package open;
use warnings;
use Carp;
$open::hint_bits = 0x20000; # HINT_LOCALIZE_HH

our $VERSION = '1.04';

require 5.008001; # for PerlIO::get_layers()

my $locale_encoding;

sub _get_encname {
    return ($1, Encode::resolve_alias($1)) if $_[0] =~ /^:?encoding\((.+)\)$/;
    return;
}

sub _drop_oldenc {
    # If by the time we arrive here there already is at the top of the
    # perlio layer stack an encoding identical to what we would like
    # to push via this open pragma, we will pop away the old encoding
    # (+utf8) so that we can push ourselves in place (this is easier
    # than ignoring pushing ourselves because of the way how ${^OPEN}
    # works).  So we are looking for something like
    #
    #   stdio encoding(xxx) utf8
    #
    # in the existing layer stack, and in the new stack chunk for
    #
    #   :encoding(xxx)
    #
    # If we find a match, we pop the old stack (once, since
    # the utf8 is just a flag on the encoding layer)
    my ($h, @new) = @_;
    return unless @new >= 1 && $new[-1] =~ /^:encoding\(.+\)$/;
    my @old = PerlIO::get_layers($h);
    return unless @old >= 3 &&
                  $old[-1] eq 'utf8' &&
                  $old[-2] =~ /^encoding\(.+\)$/;
    require Encode;
    my ($loname, $lcname) = _get_encname($old[-2]);
    unless (defined $lcname) { # Should we trust get_layers()?
        require Carp;
        Carp::croak("open: Unknown encoding '$loname'");
    }
    my ($voname, $vcname) = _get_encname($new[-1]);
    unless (defined $vcname) {
        require Carp;
        Carp::croak("open: Unknown encoding '$voname'");
    }
    if ($lcname eq $vcname) {
        binmode($h, ":pop"); # utf8 is part of the encoding layer
    }
}

sub import {
    my ($class,@args) = @_;
    croak("open: needs explicit list of PerlIO layers") unless @args;
    my $std;
    $^H |= $open::hint_bits;
    my ($in,$out) = split(/\0/,(${^OPEN} || "\0"), -1);
    while (@args) {
        my $type = shift(@args);
        my $dscp;
        if ($type =~ /^:?(utf8|locale|encoding\(.+\))$/) {
            $type = 'IO';
            $dscp = ":$1";
        } elsif ($type eq ':std') {
            $std = 1;
            next;
        } else {
            $dscp = shift(@args) || '';
        }
        my @val;
        foreach my $layer (split(/\s+/,$dscp)) {
            $layer =~ s/^://;
            if ($layer eq 'locale') {
                require Encode;
                require encoding;
                $locale_encoding = encoding::_get_locale_encoding()
                    unless defined $locale_encoding;
                (warnings::warnif("layer", "Cannot figure out an encoding to use"), last)
                    unless defined $locale_encoding;
                if ($locale_encoding =~ /^utf-?8$/i) {
                    $layer = "utf8";
                } else {
                    $layer = "encoding($locale_encoding)";
                }
                $std = 1;
            } else {
                my $target = $layer;            # the layer name itself
                $target =~ s/^(\w+)\(.+\)$/$1/; # strip parameters

                unless(PerlIO::Layer::->find($target,1)) {
                    warnings::warnif("layer", "Unknown PerlIO layer '$target'");
                }
            }
            push(@val,":$layer");
            if ($layer =~ /^(crlf|raw)$/) {
                $^H{"open_$type"} = $layer;
            }
        }
        if ($type eq 'IN') {
            _drop_oldenc(*STDIN, @val);
            $in  = join(' ', @val);
        }
        elsif ($type eq 'OUT') {
            _drop_oldenc(*STDOUT, @val);
            $out = join(' ', @val);
        }
        elsif ($type eq 'IO') {
            _drop_oldenc(*STDIN,  @val);
            _drop_oldenc(*STDOUT, @val);
            $in = $out = join(' ', @val);
        }
        else {
            croak "Unknown PerlIO layer class '$type'";
        }
    }
    ${^OPEN} = join("\0", $in, $out);
    if ($std) {
        if ($in) {
            if ($in =~ /:utf8\b/) {
                    binmode(STDIN,  ":utf8");
                } elsif ($in =~ /(\w+\(.+\))/) {
                    binmode(STDIN,  ":$1");
                }
        }
        if ($out) {
            if ($out =~ /:utf8\b/) {
                binmode(STDOUT,  ":utf8");
                binmode(STDERR,  ":utf8");
            } elsif ($out =~ /(\w+\(.+\))/) {
                binmode(STDOUT,  ":$1");
                binmode(STDERR,  ":$1");
            }
        }
    }
}

1;
__END__

=head1 NAME

open - perl pragma to set default PerlIO layers for input and output

=head1 SYNOPSIS

    use open IN  => ":crlf", OUT => ":bytes";
    use open OUT => ':utf8';
    use open IO  => ":encoding(iso-8859-7)";

    use open IO  => ':locale';

    use open ':utf8';
    use open ':locale';
    use open ':encoding(iso-8859-7)';

    use open ':std';

=head1 DESCRIPTION

Full-fledged support for I/O layers is now implemented provided
Perl is configured to use PerlIO as its IO system (which is now the
default).

The C<open> pragma serves as one of the interfaces to declare default
"layers" (also known as "disciplines") for all I/O. Any two-argument
open(), readpipe() (aka qx//) and similar operators found within the
lexical scope of this pragma will use the declared defaults.
Three-argument opens are not affected by this pragma since there you
(can) explicitly specify the layers and are supposed to know what you
are doing.

With the C<IN> subpragma you can declare the default layers
of input streams, and with the C<OUT> subpragma you can declare
the default layers of output streams.  With the C<IO>  subpragma
you can control both input and output streams simultaneously.

If you have a legacy encoding, you can use the C<:encoding(...)> tag.

if you want to set your encoding layers based on your
locale environment variables, you can use the C<:locale> tag.
For example:

    $ENV{LANG} = 'ru_RU.KOI8-R';
    # the :locale will probe the locale environment variables like LANG
    use open OUT => ':locale';
    open(O, ">koi8");
    print O chr(0x430); # Unicode CYRILLIC SMALL LETTER A = KOI8-R 0xc1
    close O;
    open(I, "<koi8");
    printf "%#x\n", ord(<I>), "\n"; # this should print 0xc1
    close I;

These are equivalent

    use open ':utf8';
    use open IO => ':utf8';

as are these

    use open ':locale';
    use open IO => ':locale';

and these

    use open ':encoding(iso-8859-7)';
    use open IO => ':encoding(iso-8859-7)';

The matching of encoding names is loose: case does not matter, and
many encodings have several aliases.  See L<Encode::Supported> for
details and the list of supported locales.

Note that C<:utf8> PerlIO layer must always be specified exactly like
that, it is not subject to the loose matching of encoding names.

When open() is given an explicit list of layers they are appended to
the list declared using this pragma.

The C<:std> subpragma on its own has no effect, but if combined with
the C<:utf8> or C<:encoding> subpragmas, it converts the standard
filehandles (STDIN, STDOUT, STDERR) to comply with encoding selected
for input/output handles.  For example, if both input and out are
chosen to be C<:utf8>, a C<:std> will mean that STDIN, STDOUT, and
STDERR are also in C<:utf8>.  On the other hand, if only output is
chosen to be in C<< :encoding(koi8r) >>, a C<:std> will cause only the
STDOUT and STDERR to be in C<koi8r>.  The C<:locale> subpragma
implicitly turns on C<:std>.

The logic of C<:locale> is described in full in L</encoding>,
but in short it is first trying nl_langinfo(CODESET) and then
guessing from the LC_ALL and LANG locale environment variables.

Directory handles may also support PerlIO layers in the future.

=head1 NONPERLIO FUNCTIONALITY

If Perl is not built to use PerlIO as its IO system then only the two
pseudo-layers C<:bytes> and C<:crlf> are available.

The C<:bytes> layer corresponds to "binary mode" and the C<:crlf>
layer corresponds to "text mode" on platforms that distinguish
between the two modes when opening files (which is many DOS-like
platforms, including Windows).  These two layers are no-ops on
platforms where binmode() is a no-op, but perform their functions
everywhere if PerlIO is enabled.

=head1 IMPLEMENTATION DETAILS

There is a class method in C<PerlIO::Layer> C<find> which is
implemented as XS code.  It is called by C<import> to validate the
layers:

   PerlIO::Layer::->find("perlio")

The return value (if defined) is a Perl object, of class
C<PerlIO::Layer> which is created by the C code in F<perlio.c>.  As
yet there is nothing useful you can do with the object at the perl
level.

=head1 SEE ALSO

L<perlfunc/"binmode">, L<perlfunc/"open">, L<perlunicode>, L<PerlIO>,
L<encoding>

=cut
Revision:	1.1
Committed:	Thu Jun 30 14:27:09 2005 UTC (21 years, 3 months ago) by root
Branch:	MAIN
CVS Tags:	PERL-5-8-7, HEAD
Branch point for:	PERL
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	package open;
2			use warnings;
3			use Carp;
4			$open::hint_bits = 0x20000; # HINT_LOCALIZE_HH
5
6			our $VERSION = '1.04';
7
8			require 5.008001; # for PerlIO::get_layers()
9
10			my $locale_encoding;
11
12			sub _get_encname {
13			return ($1, Encode::resolve_alias($1)) if $_[0] =~ /^:?encoding\((.+)\)$/;
14			return;
15			}
16
17			sub _drop_oldenc {
18			# If by the time we arrive here there already is at the top of the
19			# perlio layer stack an encoding identical to what we would like
20			# to push via this open pragma, we will pop away the old encoding
21			# (+utf8) so that we can push ourselves in place (this is easier
22			# than ignoring pushing ourselves because of the way how ${^OPEN}
23			# works). So we are looking for something like
24			#
25			# stdio encoding(xxx) utf8
26			#
27			# in the existing layer stack, and in the new stack chunk for
28			#
29			# :encoding(xxx)
30			#
31			# If we find a match, we pop the old stack (once, since
32			# the utf8 is just a flag on the encoding layer)
33			my ($h, @new) = @_;
34			return unless @new >= 1 && $new[-1] =~ /^:encoding\(.+\)$/;
35			my @old = PerlIO::get_layers($h);
36			return unless @old >= 3 &&
37			$old[-1] eq 'utf8' &&
38			$old[-2] =~ /^encoding\(.+\)$/;
39			require Encode;
40			my ($loname, $lcname) = _get_encname($old[-2]);
41			unless (defined $lcname) { # Should we trust get_layers()?
42			require Carp;
43			Carp::croak("open: Unknown encoding '$loname'");
44			}
45			my ($voname, $vcname) = _get_encname($new[-1]);
46			unless (defined $vcname) {
47			require Carp;
48			Carp::croak("open: Unknown encoding '$voname'");
49			}
50			if ($lcname eq $vcname) {
51			binmode($h, ":pop"); # utf8 is part of the encoding layer
52			}
53			}
54
55			sub import {
56			my ($class,@args) = @_;
57			croak("open: needs explicit list of PerlIO layers") unless @args;
58			my $std;
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			} elsif ($type eq ':std') {
68			$std = 1;
69			next;
70			} else {
71			$dscp = shift(@args) \|\| '';
72			}
73			my @val;
74			foreach my $layer (split(/\s+/,$dscp)) {
75			$layer =~ s/^://;
76			if ($layer eq 'locale') {
77			require Encode;
78			require encoding;
79			$locale_encoding = encoding::_get_locale_encoding()
80			unless defined $locale_encoding;
81			(warnings::warnif("layer", "Cannot figure out an encoding to use"), last)
82			unless defined $locale_encoding;
83			if ($locale_encoding =~ /^utf-?8$/i) {
84			$layer = "utf8";
85			} else {
86			$layer = "encoding($locale_encoding)";
87			}
88			$std = 1;
89			} else {
90			my $target = $layer; # the layer name itself
91			$target =~ s/^(\w+)\(.+\)$/$1/; # strip parameters
92
93			unless(PerlIO::Layer::->find($target,1)) {
94			warnings::warnif("layer", "Unknown PerlIO layer '$target'");
95			}
96			}
97			push(@val,":$layer");
98			if ($layer =~ /^(crlf\|raw)$/) {
99			$^H{"open_$type"} = $layer;
100			}
101			}
102			if ($type eq 'IN') {
103			_drop_oldenc(*STDIN, @val);
104			$in = join(' ', @val);
105			}
106			elsif ($type eq 'OUT') {
107			_drop_oldenc(*STDOUT, @val);
108			$out = join(' ', @val);
109			}
110			elsif ($type eq 'IO') {
111			_drop_oldenc(*STDIN, @val);
112			_drop_oldenc(*STDOUT, @val);
113			$in = $out = join(' ', @val);
114			}
115			else {
116			croak "Unknown PerlIO layer class '$type'";
117			}
118			}
119			${^OPEN} = join("\0", $in, $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 PerlIO layers for input and output
146
147			=head1 SYNOPSIS
148
149			use open IN => ":crlf", OUT => ":bytes";
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 layers 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" (also known as "disciplines") for all I/O. Any two-argument
169			open(), readpipe() (aka qx//) and similar operators found within the
170			lexical scope of this pragma will use the declared defaults.
171			Three-argument opens are not affected by this pragma since there you
172			(can) explicitly specify the layers and are supposed to know what you
173			are doing.
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 layers 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> PerlIO layer 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 described in full in L</encoding>,
232			but in short it is first trying nl_langinfo(CODESET) and then
233			guessing from the LC_ALL and LANG locale environment variables.
234
235			Directory handles may also support PerlIO layers in the future.
236
237			=head1 NONPERLIO FUNCTIONALITY
238
239			If Perl is not built to use PerlIO as its IO system then only the two
240			pseudo-layers C<:bytes> and C<:crlf> are available.
241
242			The C<:bytes> layer corresponds to "binary mode" and the C<:crlf>
243			layer corresponds to "text mode" on platforms that distinguish
244			between the two modes when opening files (which is many DOS-like
245			platforms, including Windows). These two layers are no-ops on
246			platforms where binmode() is a no-op, but perform their functions
247			everywhere if PerlIO is enabled.
248
249			=head1 IMPLEMENTATION DETAILS
250
251			There is a class method in C<PerlIO::Layer> C<find> which is
252			implemented as XS code. It is called by C<import> to validate the
253			layers:
254
255			PerlIO::Layer::->find("perlio")
256
257			The return value (if defined) is a Perl object, of class
258			C<PerlIO::Layer> which is created by the C code in F<perlio.c>. As
259			yet there is nothing useful you can do with the object at the perl
260			level.
261
262			=head1 SEE ALSO
263
264			L<perlfunc/"binmode">, L<perlfunc/"open">, L<perlunicode>, L<PerlIO>,
265			L<encoding>
266
267			=cut