Teach splain about %X

diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm
index a40da9e..78e2c15 100644 (file)
--- a/lib/diagnostics.pm
+++ b/lib/diagnostics.pm
@@ -416,7 +416,7 @@ my %msg;
        # Since we strip "\.\n" when we search a warning, strip it here as well
        $header =~ s/\.?$//;
 
-        my @toks = split( /(%l?[dx]|%u|%c|%(?:\.\d+)?[fs])/, $header );
+        my @toks = split( /(%l?[dxX]|%u|%c|%(?:\.\d+)?[fs])/, $header );
        if (@toks > 1) {
             my $conlen = 0;
             for my $i (0..$#toks){
@@ -429,8 +429,8 @@ my %msg;
                         $toks[$i] = $i == $#toks ? '.*' : '.*?';
                     } elsif( $toks[$i] =~ '%.(\d+)s' ){
                         $toks[$i] = ".{$1}";
-                    } elsif( $toks[$i] =~ '^%l*x$' ){
-                        $toks[$i] = '[\da-f]+';
+                    } elsif( $toks[$i] =~ '^%l*([xX])$' ){
+                        $toks[$i] = $1 eq 'x' ? '[\da-f]+' : '[\dA-F]+';
                     }
                 } elsif( length( $toks[$i] ) ){
                     $toks[$i] = quotemeta $toks[$i];

diff --git a/lib/diagnostics.t b/lib/diagnostics.t
index 4e5ab82..d0d4364 100644 (file)
--- a/lib/diagnostics.t
+++ b/lib/diagnostics.t
@@ -5,7 +5,7 @@ BEGIN {
     @INC = 'lib';
 }
 
-use Test::More tests => 10;
+use Test::More tests => 11;
 
 BEGIN {
     my $w;
@@ -45,7 +45,7 @@ like $warning, qr/using lex_stuff_pvn or similar/, 'L<foo|bar/baz>';
 # Multiple messages with the same description
 seek STDERR, 0,0;
 $warning = '';
-warn 'Code point 0x%X is not Unicode, may not be portable';
+warn 'Code point 0xBEE5 is not Unicode, may not be portable';
 like $warning, qr/W utf8/,
    'Message sharing its description with the following message';
 
@@ -61,6 +61,12 @@ $warning = '';
 warn "Bad arg length for us, is 4, should be 42";
 like $warning, qr/In C parlance/, '%u works';
 
+# Test for %X
+seek STDERR, 0,0;
+$warning = '';
+warn "Unicode surrogate U+C0FFEE is illegal in UTF-8";
+like $warning, qr/You had a UTF-16 surrogate/, '%X';
+
 # Strip S<>
 seek STDERR, 0,0;
 $warning = '';