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         # I18N::Langinfo isn't available everywhere
  14         eval "use I18N::Langinfo qw(langinfo CODESET)";
  15         unless ($@) {
  16             $locale_encoding = langinfo(CODESET());
  17         }
  18         my $country_language;
  19         if (not $locale_encoding && in_locale()) {
  20             if ($ENV{LC_ALL} =~ /^([^.]+)\.([^.]+)$/) {
  21                 ($country_language, $locale_encoding) = ($1, $2);
  22             } elsif ($ENV{LANG} =~ /^([^.]+)\.([^.]+)$/) {
  23                 ($country_language, $locale_encoding) = ($1, $2);
  24             }
  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
  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
  34             # (the Estonian database at http://www.eki.ee/letter/
  35             # would be excellent!) --jhi
  36         }
  37         if (defined $locale_encoding &&
  38             $locale_encoding eq 'euc' &&
  39             defined $country_language) {
  40             if ($country_language =~ /^ja_JP|japan(?:ese)?$/i) {
  41                 $locale_encoding = 'euc-jp';
  42             } elsif ($country_language =~ /^ko_KR|korean?$/i) {
  43                 $locale_encoding = 'euc-kr';
  44             } elsif ($country_language =~ /^zh_TW|taiwan(?:ese)?$/i) {
  45                 $locale_encoding = 'euc-tw';
  46             }
  47             croak "Locale encoding 'euc' too ambiguous"
  48                 if $locale_encoding eq 'euc';
  49         }
  50     }
  51 }
  52
  53 sub import {
  54     my ($class,@args) = @_;
  55     croak("`use open' needs explicit list of disciplines") unless @args;
  56     $^H |= $open::hint_bits;
  57     my ($in,$out) = split(/\0/,(${^OPEN} || "\0"), -1);
  58     while (@args) {
  59         my $type = shift(@args);
  60         my $dscp;
  61         if ($type =~ /^:?(utf8|locale|encoding\(.+\))$/) {
  62             $type = 'IO';
  63             $dscp = ":$1";
  64         } else {
  65             $dscp = shift(@args);
  66         }
  67         my @val;
  68         foreach my $layer (split(/\s+/,$dscp)) {
  69             $layer =~ s/^://;
  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;
  76                 if ($locale_encoding =~ /^utf-?8$/i) {
  77                     $layer = "utf8";
  78                 } else {
  79                     $layer = "encoding($locale_encoding)";
  80                 }
  81             } else {
  82                 unless(PerlIO::Layer::->find($layer)) {
  83                     carp("Unknown discipline layer '$layer'");
  84                 }
  85             }
  86             push(@val,":$layer");
  87             if ($layer =~ /^(crlf|raw)$/) {
  88                 $^H{"open_$type"} = $layer;
  89             }
  90         }
  91         # print "# type = $type, val = @val\n";
  92         if ($type eq 'IN') {
  93             $in  = join(' ',@val);
  94         }
  95         elsif ($type eq 'OUT') {
  96             $out = join(' ',@val);
  97         }
  98         elsif ($type eq 'IO') {
  99             $in = $out = join(' ',@val);
 100         }
 101         else {
 102             croak "Unknown discipline class '$type'";
 103         }
 104     }
 105     ${^OPEN} = join("\0",$in,$out);
 106 }
 107
 108 1;
 109 __END__
 110
 111 =head1 NAME
 112
 113 open - perl pragma to set default disciplines for input and output
 114
 115 =head1 SYNOPSIS
 116
 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)';
 126
 127 =head1 DESCRIPTION
 128
 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).
 132
 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
 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.
 140
 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';
 153     # the :locale will probe the locale environment variables like LANG
 154     use open OUT => ':locale';
 155     open(O, ">koi8");
 156     print O chr(0x430); # Unicode CYRILLIC SMALL LETTER A = KOI8-R 0xc1
 157     close O;
 158     open(I, "<koi8");
 159     printf "%#x\n", ord(<I>), "\n"; # this should print 0xc1
 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
 177 When open() is given an explicit list of layers they are appended to
 178 the list declared using this pragma.
 179
 180 Directory handles may also support disciplines in future.
 181
 182 =head1 NONPERLIO FUNCTIONALITY
 183
 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.
 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
 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.
 193
 194 =head1 IMPLEMENTATION DETAILS
 195
 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:
 199
 200    PerlIO::Layer::->find("perlio")
 201
 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.
 206
 207 =head1 SEE ALSO
 208
 209 L<perlfunc/"binmode">, L<perlfunc/"open">, L<perlunicode>, L<PerlIO>,
 210 L<encoding>
 211
 212 =cut