diff --git a/Encode.pm b/Encode.pm index 03eded6..09c44b1 100644 --- a/Encode.pm +++ b/Encode.pm @@ -156,7 +156,20 @@ sub encode($$;$) { require Carp; Carp::croak("Unknown encoding '$name'"); } - my $octets = $enc->encode( $string, $check ); + # For Unicode, warnings need to be caught and re-issued at this level + # so that callers can disable utf8 warnings lexically. + my $octets; + if ( ref($enc) eq 'Encode::Unicode' ) { + my $warn = ''; + { + local $SIG{__WARN__} = sub { $warn = shift }; + $octets = $enc->encode( $string, $check ); + } + warnings::warnif('utf8', $warn) if length $warn; + } + else { + $octets = $enc->encode( $string, $check ); + } $_[1] = $string if $check and !ref $check and !( $check & LEAVE_SRC() ); return $octets; } @@ -172,7 +185,20 @@ sub decode($$;$) { require Carp; Carp::croak("Unknown encoding '$name'"); } - my $string = $enc->decode( $octets, $check ); + # For Unicode, warnings need to be caught and re-issued at this level + # so that callers can disable utf8 warnings lexically. + my $string; + if ( ref($enc) eq 'Encode::Unicode' ) { + my $warn = ''; + { + local $SIG{__WARN__} = sub { $warn = shift }; + $string = $enc->decode( $octets, $check ); + } + warnings::warnif('utf8', $warn) if length $warn; + } + else { + $string = $enc->decode( $octets, $check ); + } $_[1] = $octets if $check and !ref $check and !( $check & LEAVE_SRC() ); return $string; } diff --git a/t/utf8warnings.t b/t/utf8warnings.t new file mode 100644 index 0000000..24af470 --- /dev/null +++ b/t/utf8warnings.t @@ -0,0 +1,60 @@ +use strict; +use warnings; + +use Encode; +use Test::More tests => 7; + +my $valid = "\x61\x00\x00\x00"; +my $invalid = "\x78\x56\x34\x12"; + +my @warnings; +$SIG{__WARN__} = sub {push @warnings, "@_"}; + +my $enc = find_encoding("UTF32-LE"); + +{ + @warnings = (); + my $ret = Encode::Unicode::decode( $enc, $valid ); + is("@warnings", "", "Calling decode in Encode::Unicode on valid string produces no warnings"); +} + +{ + @warnings = (); + my $ret = Encode::Unicode::decode( $enc, $invalid ); + like("@warnings", qr/is not Unicode/, "Calling decode in Encode::Unicode on invalid string warns"); +} + +{ + no warnings 'utf8'; + @warnings = (); + my $ret = Encode::Unicode::decode( $enc, $invalid ); + is("@warnings", "", "Warning from decode in Encode::Unicode can be silenced via no warnings 'utf8'"); +} + +{ + no warnings; + @warnings = (); + my $ret = Encode::Unicode::decode( $enc, $invalid ); + is("@warnings", "", "Warning from decode in Encode::Unicode can be silenced via no warnings"); +} + +{ + @warnings = (); + my $ret = Encode::decode( $enc, $invalid ); + like("@warnings", qr/is not Unicode/, "Calling decode in Encode on invalid string warns"); +} + +{ + no warnings 'utf8'; + @warnings = (); + my $ret = Encode::decode( $enc, $invalid ); + is("@warnings", "", "Warning from decode in Encode can be silenced via no warnings 'utf8'"); +}; + +{ + no warnings; + @warnings = (); + my $ret = Encode::decode( $enc, $invalid ); + is("@warnings", "", "Warning from decode in Encode can be silenced via no warnings 'utf8'"); +}; +