In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/cbf837914d6724cb703a328dab484c8c9995ca3a?hp=365cfd8eaaec7a682ba41eb6274ce70b09eb9430>
- Log -----------------------------------------------------------------
commit cbf837914d6724cb703a328dab484c8c9995ca3a
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Aug 27 22:19:24 2017 -0700
[perl #131883] Include pkg in :prototype warnings
The subref-in-stash optimisation was causing the package name to be
dropped in prototype warnings triggered by the :prototype() attribute
syntax, since the GV containing the stash name and the sub name did
not exist because of the optimisation.
Commit 2eaf799e, which introduced said optimisation, simply did not
include the package name in validate_protoâs ânameâ parameter, but
just the sub name. This commit makes it tell validate_proto to use
the current stash name.
M embed.fnc
M embed.h
M op.c
M proto.h
M t/lib/warnings/toke
M toke.c
commit 5783dc5192c36d5487bd5408fd7138e9ea36d70c
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Aug 27 21:48:42 2017 -0700
Add another param to validate_proto
I need this in order to fix bug #131883. Since it has a bit of
churn, Iâm putting it in a separate commit.
M embed.fnc
M embed.h
M ext/attributes/attributes.pm
M ext/attributes/attributes.xs
M op.c
M proto.h
M toke.c
commit bc63756f96fd2f5f6bc046ab634053b983799876
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Aug 27 11:42:50 2017 -0700
Test âMissing ']' in prototypeâ warning
M t/lib/warnings/toke
-----------------------------------------------------------------------
Summary of changes:
embed.fnc | 6 ++++--
embed.h | 4 ++--
ext/attributes/attributes.pm | 2 +-
ext/attributes/attributes.xs | 2 +-
op.c | 12 +++++++-----
proto.h | 4 ++--
t/lib/warnings/toke | 13 ++++++++++++-
toke.c | 12 ++++++++++--
8 files changed, 39 insertions(+), 16 deletions(-)
diff --git a/embed.fnc b/embed.fnc
index aa3a623ab5..b0a362b294 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1047,7 +1047,8 @@ poX |OP* |op_lvalue_flags|NULLOK OP* o|I32
type|U32 flags
p |void |finalize_optree |NN OP* o
#if defined(PERL_IN_OP_C)
s |void |finalize_op |NN OP* o
-s |void |move_proto_attr|NN OP **proto|NN OP **attrs|NN const GV *name
+s |void |move_proto_attr|NN OP **proto|NN OP **attrs \
+ |NN const GV *name|bool curstash
#endif
: Used in op.c and pp_sys.c
p |int |mode_from_discipline|NULLOK const char* s|STRLEN len
@@ -2708,7 +2709,8 @@ s |int |tokereport |I32 rv|NN const YYSTYPE* lvalp
sf |void |printbuf |NN const char *const fmt|NN const char *const s
# endif
#endif
-EXMp |bool |validate_proto |NN SV *name|NULLOK SV *proto|bool warn
+EXMp |bool |validate_proto |NN SV *name|NULLOK SV *proto|bool warn \
+ |bool curstash
#if defined(PERL_IN_UNIVERSAL_C)
s |bool |isa_lookup |NN HV *stash|NN const char * const name \
diff --git a/embed.h b/embed.h
index 31a9852e16..a28d1c849a 100644
--- a/embed.h
+++ b/embed.h
@@ -948,7 +948,7 @@
#define sv_only_taint_gmagic S_sv_only_taint_gmagic
#define swash_fetch(a,b,c) Perl_swash_fetch(aTHX_ a,b,c)
#define swash_init(a,b,c,d,e) Perl_swash_init(aTHX_ a,b,c,d,e)
-#define validate_proto(a,b,c) Perl_validate_proto(aTHX_ a,b,c)
+#define validate_proto(a,b,c,d) Perl_validate_proto(aTHX_ a,b,c,d)
#define vivify_defelem(a) Perl_vivify_defelem(aTHX_ a)
#define yylex() Perl_yylex(aTHX)
# if !defined(PERL_EXT_RE_BUILD)
@@ -1634,7 +1634,7 @@
#define listkids(a) S_listkids(aTHX_ a)
#define looks_like_bool(a) S_looks_like_bool(aTHX_ a)
#define modkids(a,b) S_modkids(aTHX_ a,b)
-#define move_proto_attr(a,b,c) S_move_proto_attr(aTHX_ a,b,c)
+#define move_proto_attr(a,b,c,d) S_move_proto_attr(aTHX_ a,b,c,d)
#define my_kid(a,b,c) S_my_kid(aTHX_ a,b,c)
#define newGIVWHENOP(a,b,c,d,e) S_newGIVWHENOP(aTHX_ a,b,c,d,e)
#define newMETHOP_internal(a,b,c,d) S_newMETHOP_internal(aTHX_ a,b,c,d)
diff --git a/ext/attributes/attributes.pm b/ext/attributes/attributes.pm
index 3a3a43ea5b..82e970ad6e 100644
--- a/ext/attributes/attributes.pm
+++ b/ext/attributes/attributes.pm
@@ -1,6 +1,6 @@
package attributes;
-our $VERSION = 0.30;
+our $VERSION = 0.31;
@EXPORT_OK = qw(get reftype);
@EXPORT = ();
diff --git a/ext/attributes/attributes.xs b/ext/attributes/attributes.xs
index 287ac347d9..605749a010 100644
--- a/ext/attributes/attributes.xs
+++ b/ext/attributes/attributes.xs
@@ -96,7 +96,7 @@ modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV
**attrlist, int numattrs)
else
subname=(SV *)CvGV((const CV *)sv);
if (ckWARN(WARN_ILLEGALPROTO))
- Perl_validate_proto(aTHX_ subname, proto, TRUE);
+ Perl_validate_proto(aTHX_ subname, proto, TRUE, 0);
Perl_cv_ckproto_len_flags(aTHX_ (const CV *)sv,
(const GV *)subname,
name+10,
diff --git a/op.c b/op.c
index f37da2c164..06ec00b1e9 100644
--- a/op.c
+++ b/op.c
@@ -3687,7 +3687,8 @@ Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
}
STATIC void
-S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
+S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
+ bool curstash)
{
OP *new_proto = NULL;
STRLEN pvlen;
@@ -3761,7 +3762,8 @@ S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV
* name)
else
svname = (SV *)name;
if (ckWARN(WARN_ILLEGALPROTO))
- (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
+ (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
+ curstash);
if (*proto && ckWARN(WARN_PROTOTYPE)) {
STRLEN old_len, new_len;
const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
@@ -8227,7 +8229,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs, OP *block)
spot = (CV **)svspot;
if (!(PL_parser && PL_parser->error_count))
- move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name));
+ move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
if (proto) {
assert(proto->op_type == OP_CONST);
@@ -8604,10 +8606,10 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs,
if (!ec) {
if (isGV(gv)) {
- move_proto_attr(&proto, &attrs, gv);
+ move_proto_attr(&proto, &attrs, gv, 0);
} else {
assert(cSVOPo);
- move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv);
+ move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
}
}
diff --git a/proto.h b/proto.h
index a7bd967bab..9822512fe4 100644
--- a/proto.h
+++ b/proto.h
@@ -3668,7 +3668,7 @@ PERL_CALLCONV UV Perl_valid_utf8_to_uvuni(pTHX_ const U8
*s, STRLEN *retlen)
#define PERL_ARGS_ASSERT_VALID_UTF8_TO_UVUNI \
assert(s)
-PERL_CALLCONV bool Perl_validate_proto(pTHX_ SV *name, SV *proto, bool
warn);
+PERL_CALLCONV bool Perl_validate_proto(pTHX_ SV *name, SV *proto, bool
warn, bool curstash);
#define PERL_ARGS_ASSERT_VALIDATE_PROTO \
assert(name)
PERL_CALLCONV int Perl_vcmp(pTHX_ SV *lhv, SV *rhv);
@@ -4699,7 +4699,7 @@ STATIC bool S_looks_like_bool(pTHX_ const OP* o);
#define PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL \
assert(o)
STATIC OP* S_modkids(pTHX_ OP *o, I32 type);
-STATIC void S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV *name);
+STATIC void S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV *name,
bool curstash);
#define PERL_ARGS_ASSERT_MOVE_PROTO_ATTR \
assert(proto); assert(attrs); assert(name)
STATIC OP * S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp);
diff --git a/t/lib/warnings/toke b/t/lib/warnings/toke
index 0833a0ff7b..cf1d632cc6 100644
--- a/t/lib/warnings/toke
+++ b/t/lib/warnings/toke
@@ -138,9 +138,12 @@ use utf8;
use open qw( :utf8 :std );
use warnings;
eval "sub foo (@\0) {}";
+eval "sub foo2 :prototype(@\0) {}";
EXPECT
Prototype after '@' for main::foo : @\0 at (eval 1) line 1.
Illegal character in prototype for main::foo : @\0 at (eval 1) line 1.
+Prototype after '@' for main::foo2 : @\x{0} at (eval 2) line 1.
+Illegal character in prototype for main::foo2 : @\x{0} at (eval 2) line 1.
########
BEGIN {
if (ord('A') == 193) {
@@ -179,6 +182,13 @@ EXPECT
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.
########
+use warnings;
+sub f ([);
+sub f :prototype([)
+EXPECT
+Missing ']' in prototype for main::f : [ at - line 2.
+Missing ']' in prototype for main::f : [ at - line 3.
+########
# toke.c
$a =~ m/$foo/eq;
$a =~ s/$foo/fool/seq;
@@ -1298,7 +1308,7 @@ sub proto_after_hashref(\%$);
sub proto_after_hashref2(\[%$]);
sub underscore_last_pos($_);
sub underscore2($_;$);
-sub underscore_fail($_$);
+sub underscore_fail($_$); sub underscore_fail2 : prototype($_$);
sub underscore_after_at(@_);
our sub hour (@$);
my sub migh (@$);
@@ -1316,6 +1326,7 @@ EXPECT
Prototype after '@' for main::proto_after_array : @$ at - line 3.
Prototype after '%' for main::proto_after_hash : %$ at - line 7.
Illegal character after '_' in prototype for main::underscore_fail : $_$ at -
line 12.
+Illegal character after '_' in prototype for main::underscore_fail2 : $_$ at -
line 12.
Prototype after '@' for main::underscore_after_at : @_ at - line 13.
Prototype after '@' for hour : @$ at - line 14.
Prototype after '@' for migh : @$ at - line 15.
diff --git a/toke.c b/toke.c
index 591b169b10..35940be787 100644
--- a/toke.c
+++ b/toke.c
@@ -1623,7 +1623,7 @@ Note that C<NULL> is a valid C<proto> and will always
return C<true>.
*/
bool
-Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn)
+Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn, bool curstash)
{
STRLEN len, origlen;
char *p;
@@ -1685,6 +1685,13 @@ Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn)
origlen, UNI_DISPLAY_ISPRINT)
: pv_pretty(tmpsv, p, origlen, 60, NULL, NULL,
PERL_PV_ESCAPE_NONASCII);
+ if (curstash && !memchr(SvPVX(name), ':', SvCUR(name))) {
+ SV *name2 = sv_2mortal(newSVsv(PL_curstname));
+ sv_catpvs(name2, "::");
+ sv_catsv(name2, (SV *)name);
+ name = name2;
+ }
+
if (proto_after_greedy_proto)
Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
"Prototype after '%c' for %" SVf " : %s",
@@ -8636,7 +8643,8 @@ Perl_yylex(pTHX)
COPLINE_SET_FROM_MULTI_END;
if (!s)
Perl_croak(aTHX_ "Prototype not terminated");
- (void)validate_proto(PL_subname, PL_lex_stuff,
ckWARN(WARN_ILLEGALPROTO));
+ (void)validate_proto(PL_subname, PL_lex_stuff,
+ ckWARN(WARN_ILLEGALPROTO), 0);
have_proto = TRUE;
s = skipspace(s);
--
Perl5 Master Repository
