ext/Encode/lib/Encode/Guess.pm

   1 package Encode::Guess;
   2 use strict;
   3 use Carp;
   4
   5 use Encode qw(:fallbacks find_encoding);
   6 our $VERSION = do { my @r = (q$Revision: 1.2 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
   7
   8 my $Canon = 'Guess';
   9 our $DEBUG = 0;
  10 our %DEF_SUSPECTS = map { $_ => find_encoding($_) } qw(ascii utf8);
  11 $Encode::Encoding{$Canon} =
  12     bless {
  13            Name       => $Canon,
  14            Suspects => { %DEF_SUSPECTS },
  15           } => __PACKAGE__;
  16
  17 sub name { shift->{'Name'} }
  18 sub new_sequence { $_[0] }
  19 sub needs_lines { 1 }
  20 sub perlio_ok { 0 }
  21 sub DESTROY{}
  22
  23 our @EXPORT = qw(guess_encoding);
  24
  25 sub import { # Exporter not used so we do it on our own
  26     my $callpkg = caller;
  27     for my $item (@EXPORT){
  28         no strict 'refs';
  29         *{"$callpkg\::$item"} = \&{"$item"};
  30     }
  31     set_suspects(@_);
  32 }
  33
  34 sub set_suspects{
  35     my $class = shift;
  36     my $self = ref($class) ? $class : $Encode::Encoding{$Canon};
  37     $self->{Suspects} = { %DEF_SUSPECTS };
  38     $self->add_suspects(@_);
  39 }
  40
  41 sub add_suspects{
  42     my $class = shift;
  43     my $self = ref($class) ? $class : $Encode::Encoding{$Canon};
  44     for my $c (@_){
  45         my $e = find_encoding($c) or die "Unknown encoding: $c";
  46         $self->{Suspects}{$e->name} = $e;
  47         $DEBUG and warn "Added: ", $e->name;
  48     }
  49 }
  50
  51 sub decode($$;$){
  52     my ($obj, $octet, $chk) = @_;
  53     my $guessed = guess($obj, $octet);
  54     ref($guessed) or croak $guessed;
  55     my $utf8 = $guessed->decode($octet, $chk);
  56     $_[1] = $octet if $chk;
  57     return $utf8;
  58 }
  59
  60 sub encode{
  61     croak "Tsk, tsk, tsk.  You can't be too lazy here!";
  62 }
  63
  64 sub guess_encoding{
  65     guess($Encode::Encoding{$Canon}, @_);
  66 }
  67
  68 sub guess {
  69     my $class = shift;
  70     my $obj   = ref($class) ? $class : $Encode::Encoding{$Canon};
  71     my $octet = shift;
  72     # cheat 0: utf8 flag;
  73     Encode::is_utf8($octet) and return find_encoding('utf8');
  74     # cheat 1: BOM
  75     use Encode::Unicode;
  76     my $BOM = unpack('n', $octet);
  77     return find_encoding('UTF-16')
  78         if ($BOM == 0xFeFF or $BOM == 0xFFFe);
  79     $BOM = unpack('N', $octet);
  80     return find_encoding('UTF-32')
  81         if ($BOM == 0xFeFF or $BOM == 0xFFFe0000);
  82
  83     my %try =  %{$obj->{Suspects}};
  84     for my $c (@_){
  85         my $e = find_encoding($c) or die "Unknown encoding: $c";
  86         $try{$e->name} = $e;
  87         $DEBUG and warn "Added: ", $e->name;
  88     }
  89     my $nline = 1;
  90     for my $line (split /\r|\n|\r\n/, $octet){
  91         # cheat 2 -- \e in the string
  92         if ($line =~ /\e/o){
  93             my @keys = keys %try;
  94             delete @try{qw/utf8 ascii/};
  95             for my $k (@keys){
  96                 ref($try{$k}) eq 'Encode::XS' and delete $try{$k};
  97             }
  98         }
  99         my %ok = %try;
 100         # warn join(",", keys %try);
 101         for my $k (keys %try){
 102             my $scratch = $line;
 103             $try{$k}->decode($scratch, FB_QUIET);
 104             if ($scratch eq ''){
 105                 $DEBUG and warn sprintf("%4d:%-24s ok\n", $nline, $k);
 106             }else{
 107                 use bytes ();
 108                 $DEBUG and
 109                     warn sprintf("%4d:%-24s not ok; %d bytes left\n",
 110                                  $nline, $k, bytes::length($scratch));
 111                 delete $ok{$k};
 112
 113             }
 114         }
 115         %ok or return "No appropriate encodings found!";
 116         if (scalar(keys(%ok)) == 1){
 117             my ($retval) = values(%ok);
 118             return $retval;
 119         }
 120         %try = %ok; $nline++;
 121     }
 122     $try{ascii} or
 123         return  "Encodings too ambiguous: ", join(" or ", keys %try);
 124     return $try{ascii};
 125 }
 126
 127
 128
 129 1;
 130 __END__
 131
 132 =head1 NAME
 133
 134 Encode::Guess -- Guesses encoding from data
 135
 136 =head1 SYNOPSIS
 137
 138   # if you are sure $data won't contain anything bogus
 139
 140   use Encode::Guess qw/euc-jp shiftjis 7bit-jis/;
 141   my $utf8 = decode("Guess", $data);
 142   my $data = encode("Guess", $utf8);   # this doesn't work!
 143
 144   # more elaborate way
 145   use Encode::Guess,
 146   my $enc = guess_encoding($data, qw/euc-jp shiftjis 7bit-jis/);
 147   ref($enc) or die "Can't guess: $enc"; # trap error this way
 148   $utf8 = $enc->decode($data);
 149   # or
 150   $utf8 = decode($enc->name, $data)
 151
 152 =head1 ABSTRACT
 153
 154 Encode::Guess enables you to guess in what encoding a given data is
 155 encoded, or at least tries to.
 156
 157 =head1 DESCRIPTION
 158
 159 By default, it checks only ascii, utf8 and UTF-16/32 with BOM.
 160
 161   use Encode::Guess; # ascii/utf8/BOMed UTF
 162
 163 To use it more practically, you have to give the names of encodings to
 164 check (I<suspects> as follows).  The name of suspects can either be
 165 canonical names or aliases.
 166
 167  # tries all major Japanese Encodings as well
 168   use Encode::Guess qw/euc-jp shiftjis 7bit-jis/;
 169
 170 =over 4
 171
 172 =item Encode::Guess->set_suspects
 173
 174 You can also change the internal suspects list via C<set_suspects>
 175 method.
 176
 177   use Encode::Guess;
 178   Encode::Guess->set_suspects(qw/euc-jp shiftjis 7bit-jis/);
 179
 180 =item Encode::Guess->add_suspects
 181
 182 Or you can use C<add_suspects> method.  The difference is that
 183 C<set_suspects> flushes the current suspects list while
 184 C<add_suspects> adds.
 185
 186   use Encode::Guess;
 187   Encode::Guess->add_suspects(qw/euc-jp shiftjis 7bit-jis/);
 188   # now the suspects are euc-jp,shiftjis,7bit-jis, AND
 189   # euc-kr,euc-cn, and big5-eten
 190   Encode::Guess->add_suspects(qw/euc-kr euc-cn big5-eten/);
 191
 192 =item Encode::decode("Guess" ...)
 193
 194 When you are content with suspects list, you can now
 195
 196   my $utf8 = Encode::decode("Guess", $data);
 197
 198 =item Encode::Guess->guess($data)
 199
 200 But it will croak if Encode::Guess fails to eliminate all other
 201 suspects but the right one or no suspect was good.  So you should
 202 instead try this;
 203
 204   my $decoder = Encode::Guess->guess($data);
 205
 206 On success, $decoder is an object that is documented in
 207 L<Encode::Encoding>.  So you can now do this;
 208
 209   my $utf8 = $decoder->decode($data);
 210
 211 On failure, $decoder now contains an error message so the whole thing
 212 would be as follows;
 213
 214   my $decoder = Encode::Guess->guess($data);
 215   die $decoder unless ref($decoder);
 216   my $utf8 = $decoder->decode($data);
 217
 218 =item guess_encoding($data, [, I<list of suspects>])
 219
 220 You can also try C<guess_encoding> function which is exported by
 221 default.  It takes $data to check and it also takes the list of
 222 suspects by option.  The optional suspect list is I<not reflected> to
 223 the internal suspects list.
 224
 225   my $decoder = guess_encoding($data, qw/euc-jp euc-kr euc-cn/);
 226   die $decoder unless ref($decoder);
 227   my $utf8 = $decoder->decode($data);
 228   # check only ascii and utf8
 229   my $decoder = guess_encoding($data);
 230
 231 =back
 232
 233 =head1 CAVEATS
 234
 235 =over 4
 236
 237 =item *
 238
 239 Because of the algorithm used, ISO-8859 series and other single-byte
 240 encodings do not work well unless either one of ISO-8859 is the only
 241 one suspect (besides ascii and utf8).
 242
 243   use Encode::Guess;
 244   # perhaps ok
 245   my $decoder = guess_encoding($data, 'latin1');
 246   # definitely NOT ok
 247   my $decoder = guess_encoding($data, qw/latin1 greek/);
 248
 249 The reason is that Encode::Guess guesses encoding by trial and error.
 250 It first splits $data into lines and tries to decode the line for each
 251 suspect.  It keeps it going until all but one encoding was eliminated
 252 out of suspects list.  ISO-8859 series is just too successful for most
 253 cases (because it fills almost all code points in \x00-\xff).
 254
 255 =item *
 256
 257 Do not mix national standard encodings and the corresponding vendor
 258 encodings.
 259
 260   # a very bad idea
 261   my $decoder
 262      = guess_encoding($data, qw/shiftjis MacJapanese cp932/);
 263
 264 The reason is that vendor encoding is usually a superset of national
 265 standard so it becomes too ambiguous for most cases.
 266
 267 =item *
 268
 269 On the other hand, mixing various national standard encodings
 270 automagically works unless $data is too short to allow for guessing.
 271
 272  # This is ok if $data is long enough
 273  my $decoder =
 274   guess_encoding($data, qw/euc-cn
 275                            euc-jp shiftjis 7bit-jis
 276                            euc-kr
 277                            big5-eten/);
 278
 279 =item *
 280
 281 DO NOT PUT TOO MANY SUSPECTS!  Don't you try something like this!
 282
 283   my $decoder = guess_encoding($data,
 284                                Encode->encodings(":all"));
 285
 286 =back
 287
 288 It is, after all, just a guess.  You should alway be explicit when it
 289 comes to encodings.  But there are some, especially Japanese,
 290 environment that guess-coding is a must.  Use this module with care.
 291
 292 =head1 SEE ALSO
 293
 294 L<Encode>, L<Encode::Encoding>
 295
 296 =cut
 297