From e1f8bc2f46c1c230327938e585862ff65fd8c91a Mon Sep 17 00:00:00 2001 From: Pali Date: Thu, 25 May 2017 19:32:33 +0200 Subject: [PATCH 1/2] Do not assign directly to hash $Encode::Encoding but rather use Encode::define_encoding() This unify code for registering new encodings. --- Encode.pm | 16 +++++++--------- Unicode/Unicode.pm | 3 ++- lib/Encode/Guess.pm | 3 ++- lib/Encode/JP/JIS7.pm | 3 ++- lib/Encode/MIME/Header.pm | 10 +++++++--- lib/Encode/MIME/Header/ISO_2022_JP.pm | 3 ++- 6 files changed, 22 insertions(+), 16 deletions(-) diff --git a/Encode.pm b/Encode.pm index c6bca2a..f684334 100644 --- a/Encode.pm +++ b/Encode.pm @@ -333,8 +333,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 +347,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 +400,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'); } } diff --git a/Unicode/Unicode.pm b/Unicode/Unicode.pm index 7dec3e3..c857894 100644 --- a/Unicode/Unicode.pm +++ b/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); diff --git a/lib/Encode/Guess.pm b/lib/Encode/Guess.pm index b44daf5..302ec0e 100644 --- a/lib/Encode/Guess.pm +++ b/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 } diff --git a/lib/Encode/JP/JIS7.pm b/lib/Encode/JP/JIS7.pm index 13aa51b..493a534 100644 --- a/lib/Encode/JP/JIS7.pm +++ b/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); diff --git a/lib/Encode/MIME/Header.pm b/lib/Encode/MIME/Header.pm index 09c591e..f67a84c 100644 --- a/lib/Encode/MIME/Header.pm +++ b/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 } diff --git a/lib/Encode/MIME/Header/ISO_2022_JP.pm b/lib/Encode/MIME/Header/ISO_2022_JP.pm index c36535a..041883a 100644 --- a/lib/Encode/MIME/Header/ISO_2022_JP.pm +++ b/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 => '?='; From 3c860475aee454495bde40a360b720185052162a Mon Sep 17 00:00:00 2001 From: Pali Date: Thu, 25 May 2017 19:32:42 +0200 Subject: [PATCH 2/2] Correctly propagate carp() and croak() messages from Encode modules back to caller Normally caller use Encode::encode() or Encode::decode() function and when Encode module throw carp() or croak() message, then Carp show information that it was called in Encode.pm instead real caller of Encode. This patch properly fill CARP_NOT for skipping Encode, Encode::Encoder, Encode::Encoding and Encode modules so correct caller of Encode will be shown in carp() and croak() messages. This patch also remove localization of $Carp::CarpLevel as it is not needed by this change anymore. --- Encode.pm | 5 +++++ lib/Encode/Encoding.pm | 2 ++ lib/Encode/MIME/Header.pm | 7 +------ 3 files changed, 8 insertions(+), 6 deletions(-) diff --git a/Encode.pm b/Encode.pm index f684334..868f7f2 100644 --- a/Encode.pm +++ b/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; } diff --git a/lib/Encode/Encoding.pm b/lib/Encode/Encoding.pm index 39d2e0a..6b7aae1 100644 --- a/lib/Encode/Encoding.pm +++ b/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 } diff --git a/lib/Encode/MIME/Header.pm b/lib/Encode/MIME/Header.pm index f67a84c..f124a38 100644 --- a/lib/Encode/MIME/Header.pm +++ b/lib/Encode/MIME/Header.pm @@ -199,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; @@ -243,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;