Catch and re-issue utf8 warnings at a higher level

xdg · xdg · commit a6c2ba385875 · 2014-10-24T22:26:31.000-04:00
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
diff --git 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
@@ -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'");
+};
+
