Merge pull request #102 from pali/master

Use Encode::define_encoding and propagate carp/croak messages

Encode.pm

@@ -11,6 +11,8 @@ XSLoader::load( __PACKAGE__, $VERSION );
 
 use Exporter 5.57 'import';
 
+our @CARP_NOT = qw(Encode::Encoder);
+
 # Public, encouraged API is exported by default
 
 our @EXPORT = qw(
@@ -96,6 +98,9 @@ sub define_encoding {
         my $alias = shift;
         define_alias( $alias, $obj );
     }
+    my $class = ref($obj);
+    push @Encode::CARP_NOT, $class unless grep { $_ eq $class } @Encode::CARP_NOT;
+    push @Encode::Encoding::CARP_NOT, $class unless grep { $_ eq $class } @Encode::Encoding::CARP_NOT;
     return $obj;
 }
 
@@ -333,8 +338,8 @@ sub predefine_encodings {
             $_[1] = '' if $chk;
             return $res;
         };
-        $Encode::Encoding{Unicode} =
-          bless { Name => "UTF_EBCDIC" } => "Encode::UTF_EBCDIC";
+        my $obj = bless { Name => "UTF_EBCDIC" } => "Encode::UTF_EBCDIC";
+        Encode::define_encoding($obj, 'Unicode');
     }
     else {
 
@@ -347,8 +352,8 @@ sub predefine_encodings {
             return $str;
         };
         *encode = \&decode;
-        $Encode::Encoding{Unicode} =
-          bless { Name => "Internal" } => "Encode::Internal";
+        my $obj = bless { Name => "Internal" } => "Encode::Internal";
+        Encode::define_encoding($obj, 'Unicode');
     }
     {
         # https://rt.cpan.org/Public/Bug/Display.html?id=103253
@@ -400,11 +405,9 @@ sub predefine_encodings {
             $$rpos = length($$rsrc);
             return '';
         };
-        $Encode::Encoding{utf8} =
-          bless { Name => "utf8" } => "Encode::utf8";
-        $Encode::Encoding{"utf-8-strict"} =
-          bless { Name => "utf-8-strict", strict_utf8 => 1 } 
-            => "Encode::utf8";
+        __PACKAGE__->Define('utf8');
+        my $strict_obj = bless { Name => "utf-8-strict", strict_utf8 => 1 } => "Encode::utf8";
+        Encode::define_encoding($strict_obj, 'utf-8-strict');
     }
 }
 

Unicode/Unicode.pm

@@ -34,12 +34,13 @@ for my $name (
     $endian = ( $3 eq 'BE' ) ? 'n' : ( $3 eq 'LE' ) ? 'v' : '';
     $size == 4 and $endian = uc($endian);
 
-    $Encode::Encoding{$name} = bless {
+    my $obj = bless {
         Name   => $name,
         size   => $size,
         endian => $endian,
         ucs2   => $ucs2,
     } => __PACKAGE__;
+    Encode::define_encoding($obj, $name);
 }
 
 use parent qw(Encode::Encoding);

lib/Encode/Encoding.pm

@@ -5,6 +5,8 @@ use strict;
 use warnings;
 our $VERSION = do { my @r = ( q$Revision: 2.7 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r };
 
+our @CARP_NOT = qw(Encode Encode::Encoder);
+
 require Encode;
 
 sub DEBUG { 0 }

lib/Encode/Guess.pm

@@ -7,10 +7,11 @@ our $VERSION = do { my @r = ( q$Revision: 2.6 $ =~ /\d+/g ); sprintf "%d." . "%0
 my $Canon = 'Guess';
 use constant DEBUG => !!$ENV{PERL_ENCODE_DEBUG};
 our %DEF_SUSPECTS = map { $_ => find_encoding($_) } qw(ascii utf8);
-$Encode::Encoding{$Canon} = bless {
+my $obj = bless {
     Name     => $Canon,
     Suspects => {%DEF_SUSPECTS},
 } => __PACKAGE__;
+Encode::define_encoding($obj, $Canon);
 
 use parent qw(Encode::Encoding);
 sub needs_lines { 1 }

lib/Encode/JP/JIS7.pm

@@ -9,11 +9,12 @@ for my $name ( '7bit-jis', 'iso-2022-jp', 'iso-2022-jp-1' ) {
     my $h2z     = ( $name eq '7bit-jis' )    ? 0 : 1;
     my $jis0212 = ( $name eq 'iso-2022-jp' ) ? 0 : 1;
 
-    $Encode::Encoding{$name} = bless {
+    my $obj = bless {
         Name    => $name,
         h2z     => $h2z,
         jis0212 => $jis0212,
     } => __PACKAGE__;
+    Encode::define_encoding($obj, $name);
 }
 
 use parent qw(Encode::Encoding);

lib/Encode/MIME/Header.pm

@@ -16,24 +16,28 @@ my %seed = (
     bpl      => 75,      # bytes per line
 );
 
-$Encode::Encoding{'MIME-Header'} = bless {
+my @objs;
+
+push @objs, bless {
     %seed,
     Name     => 'MIME-Header',
 } => __PACKAGE__;
 
-$Encode::Encoding{'MIME-B'} = bless {
+push @objs, bless {
     %seed,
     decode_q => 0,
     Name     => 'MIME-B',
 } => __PACKAGE__;
 
-$Encode::Encoding{'MIME-Q'} = bless {
+push @objs, bless {
     %seed,
     decode_b => 0,
     encode   => 'Q',
     Name     => 'MIME-Q',
 } => __PACKAGE__;
 
+Encode::define_encoding($_, $_->{Name}) foreach @objs;
+
 use parent qw(Encode::Encoding);
 
 sub needs_lines { 1 }
@@ -195,7 +199,6 @@ sub _decode_q {
 sub _decode_octets {
     my ($enc, $octets, $chk) = @_;
     $chk &= ~Encode::LEAVE_SRC if not ref $chk and $chk;
-    local $Carp::CarpLevel = $Carp::CarpLevel + 1; # propagate Carp messages back to caller
     my $output = $enc->decode($octets, $chk);
     return undef if not ref $chk and $chk and $octets ne '';
     return $output;
@@ -239,11 +242,7 @@ sub _encode_string {
     my @result = ();
     my $octets = '';
     while ( length( my $chr = substr($str, 0, 1, '') ) ) {
-        my $seq;
-        {
-            local $Carp::CarpLevel = $Carp::CarpLevel + 1; # propagate Carp messages back to caller
-            $seq = $enc->encode($chr, $enc_chk);
-        }
+        my $seq = $enc->encode($chr, $enc_chk);
         if ( not length($seq) ) {
             substr($str, 0, 0, $chr);
             last;

lib/Encode/MIME/Header/ISO_2022_JP.pm

@@ -5,9 +5,10 @@ use warnings;
 
 use parent qw(Encode::MIME::Header);
 
-$Encode::Encoding{'MIME-Header-ISO_2022_JP'} =
+my $obj =
   bless { decode_b => '1', decode_q => '1', encode => 'B', bpl => 76, Name => 'MIME-Header-ISO_2022_JP' } =>
   __PACKAGE__;
+Encode::define_encoding($obj, 'MIME-Header-ISO_2022_JP');
 
 use constant HEAD => '=?ISO-2022-JP?B?';
 use constant TAIL => '?=';