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) { |
13 | eval { use I18N::Langinfo qw(langinfo CODESET) }; |
14 | unless ($@) { |
15 | $locale_encoding = langinfo(CODESET); |
16 | } |
11fc5dc3 |
17 | my $country_language; |
58d53262 |
18 | if (not $locale_encoding && in_locale()) { |
11fc5dc3 |
19 | if ($ENV{LC_ALL} =~ /^([^.]+)\.([^.]+)$/) { |
20 | ($country_language, $locale_encoding) = ($1, $2); |
21 | } elsif ($ENV{LANG} =~ /^([^.]+)\.([^.]+)$/) { |
22 | ($country_language, $locale_encoding) = ($1, $2); |
58d53262 |
23 | } |
24 | } else { |
25 | # Could do heuristics based on the country and language |
26 | # parts of LC_ALL and LANG (the parts before the dot (if any)), |
27 | # since we have Locale::Country and Locale::Language available. |
28 | # TODO: get a database of Language -> Encoding mappings |
29 | # (the Estonian database would be excellent!) |
30 | # --jhi |
31 | } |
11fc5dc3 |
32 | if (defined $locale_encoding && |
33 | $locale_encoding eq 'euc' && |
34 | defined $country_language) { |
35 | if ($country_language =~ /^ja_JP|japan(?:ese)$/i) { |
36 | $locale_encoding = 'eucjp'; |
37 | } elsif ($country_language =~ /^ko_KR|korea(?:n)$/i) { |
38 | $locale_encoding = 'euckr'; |
39 | } elsif ($country_language =~ /^zh_TW|taiwan(?:ese)$/i) { |
40 | $locale_encoding = 'euctw'; |
41 | } |
42 | croak "Locale encoding 'euc' too ambiguous" |
43 | if $locale_encoding eq 'euc'; |
44 | } |
58d53262 |
45 | } |
46 | } |
47 | |
16fe6d59 |
48 | sub import { |
dfebf958 |
49 | my ($class,@args) = @_; |
50 | croak("`use open' needs explicit list of disciplines") unless @args; |
16fe6d59 |
51 | $^H |= $open::hint_bits; |
ac27b0f5 |
52 | my ($in,$out) = split(/\0/,(${^OPEN} || '\0')); |
53 | my @in = split(/\s+/,$in); |
54 | my @out = split(/\s+/,$out); |
dfebf958 |
55 | while (@args) { |
56 | my $type = shift(@args); |
57 | my $discp = shift(@args); |
ac27b0f5 |
58 | my @val; |
dfebf958 |
59 | foreach my $layer (split(/\s+/,$discp)) { |
60 | $layer =~ s/^://; |
58d53262 |
61 | if ($layer eq 'locale') { |
62 | use Encode; |
63 | _get_locale_encoding() |
64 | unless defined $locale_encoding; |
65 | croak "Cannot figure out an encoding to use" |
66 | unless defined $locale_encoding; |
11fc5dc3 |
67 | if ($locale_encoding =~ /^utf-?8$/i) { |
68 | $layer = "utf8"; |
69 | } else { |
70 | $layer = "encoding($locale_encoding)"; |
71 | } |
58d53262 |
72 | } |
0c4f7ff0 |
73 | unless(PerlIO::Layer::->find($layer)) { |
dfebf958 |
74 | carp("Unknown discipline layer '$layer'"); |
ac27b0f5 |
75 | } |
76 | push(@val,":$layer"); |
77 | if ($layer =~ /^(crlf|raw)$/) { |
78 | $^H{"open_$type"} = $layer; |
16fe6d59 |
79 | } |
ac27b0f5 |
80 | } |
81 | if ($type eq 'IN') { |
82 | $in = join(' ',@val); |
83 | } |
84 | elsif ($type eq 'OUT') { |
85 | $out = join(' ',@val); |
16fe6d59 |
86 | } |
87 | else { |
ac27b0f5 |
88 | croak "Unknown discipline class '$type'"; |
16fe6d59 |
89 | } |
90 | } |
ac27b0f5 |
91 | ${^OPEN} = join('\0',$in,$out); |
16fe6d59 |
92 | } |
93 | |
94 | 1; |
95 | __END__ |
d1edabcf |
96 | |
97 | =head1 NAME |
98 | |
99 | open - perl pragma to set default disciplines for input and output |
100 | |
101 | =head1 SYNOPSIS |
102 | |
16fe6d59 |
103 | use open IN => ":crlf", OUT => ":raw"; |
d1edabcf |
104 | |
105 | =head1 DESCRIPTION |
106 | |
d151aa0e |
107 | Full-fledged support for I/O disciplines is now implemented provided |
108 | Perl is configured to use PerlIO as its IO system (which is now the |
109 | default). |
16fe6d59 |
110 | |
7d3b96bb |
111 | The C<open> pragma serves as one of the interfaces to declare default |
112 | "layers" (aka disciplines) for all I/O. |
113 | |
114 | The C<open> pragma is used to declare one or more default layers for |
d151aa0e |
115 | I/O operations. Any open(), readpipe() (aka qx//) and similar |
116 | operators found within the lexical scope of this pragma will use the |
117 | declared defaults. |
7d3b96bb |
118 | |
d151aa0e |
119 | When open() is given an explicit list of layers they are appended to |
120 | the list declared using this pragma. |
7d3b96bb |
121 | |
122 | Directory handles may also support disciplines in future. |
123 | |
124 | =head1 NONPERLIO FUNCTIONALITY |
125 | |
d151aa0e |
126 | If Perl is not built to use PerlIO as its IO system then only the two |
127 | pseudo-disciplines ":raw" and ":crlf" are available. |
16fe6d59 |
128 | |
129 | The ":raw" discipline corresponds to "binary mode" and the ":crlf" |
130 | discipline corresponds to "text mode" on platforms that distinguish |
131 | between the two modes when opening files (which is many DOS-like |
d151aa0e |
132 | platforms, including Windows). These two disciplines are no-ops on |
133 | platforms where binmode() is a no-op, but perform their functions |
134 | everywhere if PerlIO is enabled. |
7d3b96bb |
135 | |
136 | =head1 IMPLEMENTATION DETAILS |
d1edabcf |
137 | |
0c4f7ff0 |
138 | There is a class method in C<PerlIO::Layer> C<find> which is implemented as XS code. |
139 | It is called by C<import> to validate the layers: |
140 | |
141 | PerlIO::Layer::->find("perlio") |
142 | |
143 | The return value (if defined) is a Perl object, of class C<PerlIO::Layer> which is |
144 | created by the C code in F<perlio.c>. As yet there is nothing useful you can do with the |
145 | object at the perl level. |
16fe6d59 |
146 | |
d1edabcf |
147 | =head1 SEE ALSO |
148 | |
7d3b96bb |
149 | L<perlfunc/"binmode">, L<perlfunc/"open">, L<perlunicode>, L<PerlIO> |
d1edabcf |
150 | |
151 | =cut |