[libencode-perl] 04/08: Catch and re-issue utf8 warnings at a higher level

[Anuradha Weeraman]

This is an automated email from the git hooks/post-receive script.

anuradha-guest pushed a commit to tag 2.64
in repository libencode-perl.

commit a6c2ba385875c2c03bd42350e23aef0188fb23b0
Author: David Golden <dagolden at cpan.org>
Date:   Fri Oct 24 22:26:31 2014 -0400

    Catch and re-issue utf8 warnings at a higher level
    
    This catches Encode::Unicode warnings and re-issues them from Encode, so
    that callers can disable warnings lexically with `no warnings 'utf8'`.
    
    Fixes https://rt.cpan.org/Ticket/Display.html?id=88592
---
 Encode.pm        | 30 ++++++++++++++++++++++++++--
 t/utf8warnings.t | 60 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 88 insertions(+), 2 deletions(-)

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'");
+};
+

-- 
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libencode-perl.git