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