This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
'Prototype after' and 'Illegal character' warnings should both pretty print the proto...
authorPeter Martini <PeterCMartini@GMail.com>
Tue, 9 Jul 2013 04:29:48 +0000 (00:29 -0400)
committerFather Chrysostomos <sprout@cpan.org>
Wed, 10 Jul 2013 04:27:45 +0000 (21:27 -0700)
For example, prior to this patch,
eval "sub foo (@\0) {}"
would give two warnings:

Prototype after '@' for main::foo : @ at (eval 1) line 1.
Illegal character in prototype for main::foo : @\0 at (eval 1) line 1.

In both cases, the representation which makes a NULL visible
is useful, and of course since we're printing the same warning twice,
it doesn't hurt to display it consistently.

t/lib/warnings/op
toke.c

index 5696ed4..c38bcde 100644 (file)
@@ -933,48 +933,54 @@ Prototype mismatch: sub main::frèd () vs ($) at - line 5.
 use utf8;
 use open qw( :utf8 :std );
 use warnings;
-eval "sub fòò (\$\0) {}";
+eval "sub fòò (@\$\0) {}";
 EXPECT
-Illegal character in prototype for main::fòò : $\0 at (eval 1) line 1.
+Prototype after '@' for main::fòò : @$\0 at (eval 1) line 1.
+Illegal character in prototype for main::fòò : @$\0 at (eval 1) line 1.
 ########
 # op.c
 use utf8;
 use open qw( :utf8 :std );
 use warnings;
-eval "sub foo (\0) {}";
+eval "sub foo (@\0) {}";
 EXPECT
-Illegal character in prototype for main::foo : \0 at (eval 1) line 1.
+Prototype after '@' for main::foo : @\0 at (eval 1) line 1.
+Illegal character in prototype for main::foo : @\0 at (eval 1) line 1.
 ########
 # op.c
 use utf8;
 use open qw( :utf8 :std );
 use warnings;
-BEGIN { $::{"foo"} = "\$\0L\351on" }
-BEGIN { eval "sub foo (\$\0L\x{c3}\x{a9}on) {}"; }
+BEGIN { $::{"foo"} = "\@\$\0L\351on" }
+BEGIN { eval "sub foo (@\$\0L\x{c3}\x{a9}on) {}"; }
 EXPECT
-Illegal character in prototype for main::foo : $\x{0}L... at (eval 1) line 1.
+Prototype after '@' for main::foo : @$\x{0}L... at (eval 1) line 1.
+Illegal character in prototype for main::foo : @$\x{0}L... at (eval 1) line 1.
 ########
 # op.c
 use utf8;
 use open qw( :utf8 :std );
 use warnings;
-BEGIN { eval "sub foo (\0) {}"; }
+BEGIN { eval "sub foo (@\0) {}"; }
 EXPECT
-Illegal character in prototype for main::foo : \0 at (eval 1) line 1.
+Prototype after '@' for main::foo : @\0 at (eval 1) line 1.
+Illegal character in prototype for main::foo : @\0 at (eval 1) line 1.
 ########
 # op.c
 use warnings;
-eval "sub foo (\xAB) {}";
+eval "sub foo (@\xAB) {}";
 EXPECT
-Illegal character in prototype for main::foo : \x{ab} at (eval 1) line 1.
+Prototype after '@' for main::foo : @\x{ab} at (eval 1) line 1.
+Illegal character in prototype for main::foo : @\x{ab} at (eval 1) line 1.
 ########
 # op.c
 use utf8;
 use open qw( :utf8 :std );
 use warnings;
-BEGIN { eval "sub foo (\x{30cb}) {}"; }
+BEGIN { eval "sub foo (@\x{30cb}) {}"; }
 EXPECT
-Illegal character in prototype for main::foo : \x{30cb} at (eval 1) line 1.
+Prototype after '@' for main::foo : @\x{30cb} at (eval 1) line 1.
+Illegal character in prototype for main::foo : @\x{30cb} at (eval 1) line 1.
 ########
 # op.c
 use utf8;
diff --git a/toke.c b/toke.c
index 878b084..11b235f 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -1651,25 +1651,21 @@ Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn)
     }
 
     if (warn) {
+       SV *tmpsv = newSVpvs_flags("", SVs_TEMP);
        p -= origlen;
+       p = SvUTF8(proto)
+           ? sv_uni_display(tmpsv, newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8),
+                            origlen, UNI_DISPLAY_ISPRINT)
+           : pv_pretty(tmpsv, p, origlen, 60, NULL, NULL, PERL_PV_ESCAPE_NONASCII);
+
        if (proto_after_greedy_proto)
            Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
                        "Prototype after '%c' for %"SVf" : %s",
                        greedy_proto, SVfARG(name), p);
-       if (bad_proto) {
-           SV *dsv = newSVpvs_flags("", SVs_TEMP);
+       if (bad_proto)
            Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
                        "Illegal character %sin prototype for %"SVf" : %s",
-                       seen_underscore ? "after '_' " : "",
-                       SVfARG(PL_subname),
-                       SvUTF8(PL_lex_stuff)
-                           ? sv_uni_display(dsv,
-                               newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8),
-                               origlen,
-                               UNI_DISPLAY_ISPRINT)
-                           : pv_pretty(dsv, p, origlen, 60, NULL, NULL,
-                               PERL_PV_ESCAPE_NONASCII));
-       }
+                       seen_underscore ? "after '_' " : "", SVfARG(name), p);
     }
 
     return (! (proto_after_greedy_proto || bad_proto) );