Encode 原代码

#
# $Id: Encode.pm,v 2.8 2004/10/24 12:32:06 dankogai Exp $
#
package Encode;
use strict;
our $VERSION = do { my @r = (q$Revision: 2.8 $ =~ //d+/g); sprintf "%d."."%02d" x $#r, @r };
sub DEBUG () { 0 }
use XSLoader ();
XSLoader::load(__PACKAGE__, $VERSION);

require Exporter;
use base qw/Exporter/;

# Public, encouraged API is exported by default

our @EXPORT = qw(
  decode  decode_utf8  encode  encode_utf8
  encodings  find_encoding clone_encoding
);

our @FB_FLAGS  = qw(DIE_ON_ERR WARN_ON_ERR RETURN_ON_ERR LEAVE_SRC
      PERLQQ HTMLCREF XMLCREF);
our @FB_CONSTS = qw(FB_DEFAULT FB_CROAK FB_QUIET FB_WARN
      FB_PERLQQ FB_HTMLCREF FB_XMLCREF);

our @EXPORT_OK =
    (
     qw(
       _utf8_off _utf8_on define_encoding from_to is_16bit is_8bit
       is_utf8 perlio_ok resolve_alias utf8_downgrade utf8_upgrade
      ),
     @FB_FLAGS, @FB_CONSTS,
    );

our %EXPORT_TAGS =
    (
     all          =>  [ @EXPORT, @EXPORT_OK ],
     fallbacks    =>  [ @FB_CONSTS ],
     fallback_all =>  [ @FB_CONSTS, @FB_FLAGS ],
    );

# Documentation moved after __END__ for speed - NI-S

our $ON_EBCDIC = (ord("A") == 193);

use Encode::Alias;

# Make a %Encoding package variable to allow a certain amount of cheating
our %Encoding;
our %ExtModule;
require Encode::Config;
eval { require Encode::ConfigLocal };

sub encodings
{
    my $class = shift;
    my %enc;
    if (@_ and $_[0] eq ":all"){
 %enc = ( %Encoding, %ExtModule );
    }else{
 %enc = %Encoding;
 for my $mod (map {m/::/o ? $_ : "Encode::$_" } @_){
     DEBUG and warn $mod;
     for my $enc (keys %ExtModule){
  $ExtModule{$enc} eq $mod and $enc{$enc} = $mod;
     }
 }
    }
    return
 sort { lc $a cmp lc $b }
             grep {!/^(?:Internal|Unicode|Guess)$/o} keys %enc;
}

sub perlio_ok{
    my $obj = ref($_[0]) ? $_[0] : find_encoding($_[0]);
    $obj->can("perlio_ok") and return $obj->perlio_ok();
    return 0; # safety net
}

sub define_encoding
{
    my $obj  = shift;
    my $name = shift;
    $Encoding{$name} = $obj;
    my $lc = lc($name);
    define_alias($lc => $obj) unless $lc eq $name;
    while (@_){
 my $alias = shift;
 define_alias($alias, $obj);
    }
    return $obj;
}

sub getEncoding
{
    my ($class, $name, $skip_external) = @_;

    ref($name) && $name->can('renew') and return $name;
    exists $Encoding{$name} and return $Encoding{$name};
    my $lc = lc $name;
    exists $Encoding{$lc} and return $Encoding{$lc};

    my $oc = $class->find_alias($name);
    defined($oc) and return $oc;
    $lc ne $name and $oc = $class->find_alias($lc);
    defined($oc) and return $oc;

    unless ($skip_external)
    {
 if (my $mod = $ExtModule{$name} || $ExtModule{$lc}){
     $mod =~ s,::,/,g ; $mod .= '.pm';
     eval{ require $mod; };
     exists $Encoding{$name} and return $Encoding{$name};
 }
    }
    return;
}

sub find_encoding($;$)
{
    my ($name, $skip_external) = @_;
    return __PACKAGE__->getEncoding($name,$skip_external);
}

sub resolve_alias($){
    my $obj = find_encoding(shift);
    defined $obj and return $obj->name;
    return;
}

sub clone_encoding($){
    my $obj = find_encoding(shift);
    ref $obj or return;
    eval { require Storable };
    $@ and return;
    return Storable::dclone($obj);
}

sub encode($$;$)
{
    my ($name, $string, $check) = @_;
    return undef unless defined $string;
    return undef if ref $string;
    $check ||=0;
    my $enc = find_encoding($name);
    unless(defined $enc){
 require Carp;
 Carp::croak("Unknown encoding '$name'");
    }
    my $octets = $enc->encode($string,$check);
    $_[1] = $string if $check;
    return $octets;
}

sub decode($$;$)
{
    my ($name,$octets,$check) = @_;
    return undef unless defined $octets;
    return undef if ref $octets;
    $check ||=0;
    my $enc = find_encoding($name);
    unless(defined $enc){
 require Carp;
 Carp::croak("Unknown encoding '$name'");
    }
    my $string = $enc->decode($octets,$check);
    $_[1] = $octets if $check;
    return $string;
}

sub from_to($$$;$)
{
    my ($string,$from,$to,$check) = @_;
    return undef unless defined $string;
    $check ||=0;
    my $f = find_encoding($from);
    unless (defined $f){
 require Carp;
 Carp::croak("Unknown encoding '$from'");
    }
    my $t = find_encoding($to);
    unless (defined $t){
 require Carp;
 Carp::croak("Unknown encoding '$to'");
    }
    my $uni = $f->decode($string,$check);
    return undef if ($check && length($string));
    $string =  $t->encode($uni,$check);
    return undef if ($check && length($uni));
    return defined($_[0] = $string) ? length($string) : undef ;
}

sub encode_utf8($)
{
    my ($str) = @_;
    utf8::encode($str);
    return $str;
}

sub decode_utf8($;$)
{
    my ($str, $check) = @_;
    if ($check){
 return decode("utf8", $str, $check);
    }else{
 return undef unless utf8::decode($str);
 return $str;
    }
}

predefine_encodings(1);

#
# This is to restore %Encoding if really needed;
#

sub predefine_encodings{
    use Encode::Encoding;
    no warnings 'redefine';
    my $use_xs = shift;
    if ($ON_EBCDIC) {
 # was in Encode::UTF_EBCDIC
 package Encode::UTF_EBCDIC;
 push @Encode::UTF_EBCDIC::ISA, 'Encode::Encoding';
 *decode = sub{
     my ($obj,$str,$chk) = @_;
     my $res = '';
     for (my $i = 0; $i < length($str); $i++) {
  $res .=
      chr(utf8::unicode_to_native(ord(substr($str,$i,1))));
     }
     $_[1] = '' if $chk;
     return $res;
 };
 *encode = sub{
     my ($obj,$str,$chk) = @_;
     my $res = '';
     for (my $i = 0; $i < length($str); $i++) {
  $res .=
      chr(utf8::native_to_unicode(ord(substr($str,$i,1))));
     }
     $_[1] = '' if $chk;
     return $res;
 };
 $Encode::Encoding{Unicode} =
     bless {Name => "UTF_EBCDIC"} => "Encode::UTF_EBCDIC";
    } else {
 package Encode::Internal;
 push @Encode::Internal::ISA, 'Encode::Encoding';
 *decode = sub{
     my ($obj,$str,$chk) = @_;
     utf8::upgrade($str);
     $_[1] = '' if $chk;
     return $str;
 };
 *encode = /&decode;
 $Encode::Encoding{Unicode} =
     bless {Name => "Internal"} => "Encode::Internal";
    }

    {
 # was in Encode::utf8
 package Encode::utf8;
 push @Encode::utf8::ISA, 'Encode::Encoding';
 #
 if ($use_xs){
     Encode::DEBUG and warn __PACKAGE__, " XS on";
     *decode = /&decode_xs;
     *encode = /&encode_xs;
 }else{
     Encode::DEBUG and warn __PACKAGE__, " XS off";
     *decode = sub{
  my ($obj,$octets,$chk) = @_;
  my $str = Encode::decode_utf8($octets);
  if (defined $str) {
      $_[1] = '' if $chk;
      return $str;
  }
  return undef;
     };
     *encode = sub {
  my ($obj,$string,$chk) = @_;
  my $octets = Encode::encode_utf8($string);
  $_[1] = '' if $chk;
  return $octets;
     };
 }
 *cat_decode = sub{ # ($obj, $dst, $src, $pos, $trm, $chk)
     my ($obj, undef, undef, $pos, $trm) = @_; # currently ignores $chk
     my ($rdst, $rsrc, $rpos) = /@_[1,2,3];
     use bytes;
     if ((my $npos = index($$rsrc, $trm, $pos)) >= 0) {
  $$rdst .= substr($$rsrc, $pos, $npos - $pos + length($trm));
  $$rpos = $npos + length($trm);
  return 1;
     }
     $$rdst .= substr($$rsrc, $pos);
     $$rpos = length($$rsrc);
     return '';
 };
 $Encode::Encoding{utf8} =
     bless {Name => "utf8"} => "Encode::utf8";
    }
}

1;