diff options
| -rw-r--r-- | t/lib/warnings/toke | 23 | ||||
| -rw-r--r-- | toke.c | 41 |
2 files changed, 62 insertions, 2 deletions
diff --git a/t/lib/warnings/toke b/t/lib/warnings/toke index f4842a7d0c..b82268de16 100644 --- a/t/lib/warnings/toke +++ b/t/lib/warnings/toke @@ -852,3 +852,26 @@ use warnings 'deprecated'; our $bar :unique; EXPECT Use of :unique is deprecated at - line 4. +######## +# toke.c +use warnings "syntax"; +sub proto_after_array(@$); +sub proto_after_arref(\@$); +sub proto_after_arref2(\[@$]); +sub proto_after_arref3(\[@$]_); +sub proto_after_hash(%$); +sub proto_after_hashref(\%$); +sub proto_after_hashref2(\[%$]); +sub underscore_last_pos($_); +sub underscore2($_;$); +sub underscore_fail($_$); +sub underscore_after_at(@_); +no warnings "syntax"; +sub proto_after_array(@$); +sub proto_after_hash(%$); +sub underscore_fail($_$); +EXPECT +Prototype after '@' for main::proto_after_array : @$ at - line 3. +Prototype after '%' for main::proto_after_hash : %$ at - line 7. +Illegal character in prototype for main::underscore_fail : $_$ at - line 12. +Prototype after '@' for main::underscore_after_at : @_ at - line 13. @@ -6744,6 +6744,11 @@ Perl_yylex(pTHX) if (*s == '(') { char *p; bool bad_proto = FALSE; + bool in_brackets = FALSE; + char greedy_proto = ' '; + bool proto_after_greedy_proto = FALSE; + bool must_be_last = FALSE; + bool underscore = FALSE; const bool warnsyntax = ckWARN(WARN_SYNTAX); s = scan_str(s,!!PL_madskills,FALSE); @@ -6755,11 +6760,43 @@ Perl_yylex(pTHX) for (p = d; *p; ++p) { if (!isSPACE(*p)) { d[tmp++] = *p; - if (warnsyntax && !strchr("$@%*;[]&\\_", *p)) - bad_proto = TRUE; + + if (warnsyntax) { + if (must_be_last) + proto_after_greedy_proto = TRUE; + if (!strchr("$@%*;[]&\\_", *p)) { + bad_proto = TRUE; + } + else { + if ( underscore ) { + if ( *p != ';' ) + bad_proto = TRUE; + underscore = FALSE; + } + if ( *p == '[' ) { + in_brackets = TRUE; + } + else if ( *p == ']' ) { + in_brackets = FALSE; + } + else if ( (*p == '@' || *p == '%') && + ( tmp < 2 || d[tmp-2] != '\\' ) && + !in_brackets ) { + must_be_last = TRUE; + greedy_proto = *p; + } + else if ( *p == '_' ) { + underscore = TRUE; + } + } + } } } d[tmp] = '\0'; + if (proto_after_greedy_proto) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "Prototype after '%c' for %"SVf" : %s", + greedy_proto, SVfARG(PL_subname), d); if (bad_proto) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Illegal character in prototype for %"SVf" : %s", |