ext/Encode/lib/Encode/Guess.pm

   1 package Encode::Guess;
   2 use strict;
   3 use Carp;
   4 use Encode qw(:fallbacks find_encoding);
   5 our $VERSION = do { my @r = (q$Revision: 1.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
   6
   7 my $Canon = 'Guess';
   8 $Encode::Encoding{$Canon} = bless { Name => $Canon } => __PACKAGE__;
   9 our $DEBUG = 0;
  10 our %DEF_CANDIDATES =
  11     map { $_ => find_encoding($_) } qw(ascii utf8);
  12 our %CANDIDATES;
  13
  14
  15 sub import{
  16     my $class = shift;
  17     %CANDIDATES = %DEF_CANDIDATES;
  18     for my $c (@_){
  19         my $e = find_encoding($c) or die "Unknown encoding: $c";
  20         $CANDIDATES{$e->name} = $e;
  21         $DEBUG and warn "Added: ", $e->name;
  22     }
  23 }
  24
  25 sub name { shift->{'Name'} }
  26 sub new_sequence { $_[0] }
  27 sub needs_lines { 1 }
  28 sub perlio_ok { 0 }
  29
  30 sub decode($$;$){
  31     my ($obj, $octet, $chk) = @_;
  32     my $utf8 = $obj->guess($octet)->decode($octet, $chk);
  33     $_[1] = $octet if $chk;
  34     return $utf8;
  35 }
  36
  37 sub encode{
  38     croak "Tsk, tsk, tsk.  You can't be too lazy here here!";
  39 }
  40
  41 sub guess {
  42     my ($obj, $octet) = @_;
  43     # cheat 1: utf8 flag;
  44     Encode::is_utf8($octet) and return find_encoding('utf8');
  45     my %try = %CANDIDATES;
  46     my $nline = 1;
  47     for my $line (split /\r|\n|\r\n/, $octet){
  48         # cheat 2 -- escape
  49         if ($line =~ /\e/o){
  50             my @keys = keys %try;
  51             delete @try{qw/utf8 ascii/};
  52             for my $k (@keys){
  53                 ref($try{$k}) eq 'Encode::XS' and delete $try{$k};
  54             }
  55         }
  56         my %ok = %try;
  57         # warn join(",", keys %try);
  58         for my $k (keys %try){
  59             my $scratch = $line;
  60             $try{$k}->decode($scratch, FB_QUIET);
  61             if ($scratch eq ''){
  62                 $DEBUG and warn sprintf("%4d:%-24s ok\n", $nline, $k);
  63             }else{
  64                 use bytes ();
  65                 $DEBUG and
  66                     warn sprintf("%4d:%-24s not ok; %d bytes left\n",
  67                                  $nline, $k, bytes::length($scratch));
  68                 delete $ok{$k};
  69
  70             }
  71         }
  72         %ok or croak "No appropriate encodings found!";
  73         if (scalar(keys(%ok)) == 1){
  74             my ($retval) = values(%ok);
  75             return $retval;
  76         }
  77         %try = %ok; $nline++;
  78     }
  79     unless ($try{ascii}){
  80         croak "Encodings too ambiguous: ",
  81             join(" or ", keys %try);
  82     }
  83     return $try{ascii};
  84 }
  85
  86
  87 1;
  88 __END__
  89
  90 =head1 NAME
  91
  92 Encode::Guess -- guesscoding!
  93
  94 =cut
  95