From 579333ee9e3b92774e120d958ee92fbc9a9fb009 Mon Sep 17 00:00:00 2001 From: Father Chrysostomos Date: Fri, 18 Nov 2011 22:03:04 -0800 Subject: Mention the variable name in the new length warnings --- embed.fnc | 9 ++++++--- embed.h | 4 +++- op.c | 36 +++++++++++++++++++++++++++--------- proto.h | 8 +++++--- sv.c | 4 ++-- t/lib/warnings/op | 16 ++++++++-------- 6 files changed, 51 insertions(+), 26 deletions(-) diff --git a/embed.fnc b/embed.fnc index 0857dd8e92..fb93b939c7 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1975,15 +1975,18 @@ po |void |sv_add_backref |NN SV *const tsv|NN SV *const sv poM |void |sv_kill_backrefs |NN SV *const sv|NULLOK AV *const av #endif +#if defined(PERL_IN_SV_C) || defined (PERL_IN_OP_C) +pR |SV * |varname |NULLOK const GV *const gv|const char gvtype \ + |PADOFFSET targ|NULLOK const SV *const keyname \ + |I32 aindex|int subscript_type +#endif + pX |void |sv_del_backref |NN SV *const tsv|NN SV *const sv #if defined(PERL_IN_SV_C) nsR |char * |uiv_2buf |NN char *const buf|const IV iv|UV uv|const int is_uv|NN char **const peob s |void |sv_unglob |NN SV *const sv s |void |not_a_number |NN SV *const sv s |I32 |visit |NN SVFUNC_t f|const U32 flags|const U32 mask -sR |SV * |varname |NULLOK const GV *const gv|const char gvtype \ - |PADOFFSET targ|NULLOK const SV *const keyname \ - |I32 aindex|int subscript_type # ifdef DEBUGGING s |void |del_sv |NN SV *p # endif diff --git a/embed.h b/embed.h index 5771ad7b0b..d8d27769ea 100644 --- a/embed.h +++ b/embed.h @@ -1511,7 +1511,6 @@ #define uiv_2buf S_uiv_2buf #define utf8_mg_len_cache_update(a,b,c) S_utf8_mg_len_cache_update(aTHX_ a,b,c) #define utf8_mg_pos_cache_update(a,b,c,d,e) S_utf8_mg_pos_cache_update(aTHX_ a,b,c,d,e) -#define varname(a,b,c,d,e,f) S_varname(aTHX_ a,b,c,d,e,f) #define visit(a,b,c) S_visit(aTHX_ a,b,c) # if defined(PERL_OLD_COPY_ON_WRITE) #define sv_release_COW(a,b,c) S_sv_release_COW(aTHX_ a,b,c) @@ -1522,6 +1521,9 @@ #define unreferenced_to_tmp_stack(a) S_unreferenced_to_tmp_stack(aTHX_ a) # endif # endif +# if defined(PERL_IN_SV_C) || defined (PERL_IN_OP_C) +#define varname(a,b,c,d,e,f) Perl_varname(aTHX_ a,b,c,d,e,f) +# endif # if defined(PERL_IN_TOKE_C) #define ao(a) S_ao(aTHX_ a) #define check_uni() S_check_uni(aTHX) diff --git a/op.c b/op.c index 6d0736da00..490af8a89a 100644 --- a/op.c +++ b/op.c @@ -9675,22 +9675,40 @@ Perl_ck_length(pTHX_ OP *o) const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL; if (kid) { + SV *name = NULL; + const bool hash = kid->op_type == OP_PADHV + || kid->op_type == OP_RV2HV; switch (kid->op_type) { case OP_PADHV: - case OP_RV2HV: - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)"); - break; - case OP_PADAV: + name = varname( + NULL, hash ? '%' : '@', kid->op_targ, NULL, 0, 1 + ); + break; + case OP_RV2HV: case OP_RV2AV: - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "length() used on @array (did you mean \"scalar(@array)\"?)"); + if (cUNOPx(kid)->op_first->op_type != OP_GV) break; + { + GV *gv = cGVOPx_gv(cUNOPx(kid)->op_first); + if (!gv) break; + name = varname(gv, hash?'%':'@', 0, NULL, 0, 1); + } break; - default: - break; + return o; } + if (name) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "length() used on %"SVf" (did you mean \"scalar(%s%"SVf + ")\"?)", + name, hash ? "keys " : "", name + ); + else if (hash) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)"); + else + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "length() used on @array (did you mean \"scalar(@array)\"?)"); } } diff --git a/proto.h b/proto.h index bf18d5366d..55f4b3b09f 100644 --- a/proto.h +++ b/proto.h @@ -6742,9 +6742,6 @@ STATIC void S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, co #define PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE \ assert(sv); assert(mgp) -STATIC SV * S_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ, const SV *const keyname, I32 aindex, int subscript_type) - __attribute__warn_unused_result__; - STATIC I32 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_VISIT \ @@ -6780,6 +6777,11 @@ STATIC void S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced) assert(unreferenced) # endif +#endif +#if defined(PERL_IN_SV_C) || defined (PERL_IN_OP_C) +PERL_CALLCONV SV * Perl_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ, const SV *const keyname, I32 aindex, int subscript_type) + __attribute__warn_unused_result__; + #endif #if defined(PERL_IN_TOKE_C) STATIC int S_ao(pTHX_ int toketype); diff --git a/sv.c b/sv.c index 7cfa3009fb..733df5d594 100644 --- a/sv.c +++ b/sv.c @@ -13774,8 +13774,8 @@ S_find_array_subscript(pTHX_ const AV *const av, const SV *const val) #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */ #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */ -STATIC SV* -S_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ, +SV* +Perl_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ, const SV *const keyname, I32 aindex, int subscript_type) { diff --git a/t/lib/warnings/op b/t/lib/warnings/op index b8bed271d6..f737bf9c98 100644 --- a/t/lib/warnings/op +++ b/t/lib/warnings/op @@ -926,19 +926,19 @@ $[ used in numeric ge (>=) (did you mean $] ?) at - line 20. # op.c [Perl_ck_length] use warnings 'syntax' ; length(@a); -length(%a); -length(@$a); -length(%$a); +length(%b); +length(@$c); +length(%$d); length($a); length(my %h); -length(my @a); +length(my @g); EXPECT -length() used on @array (did you mean "scalar(@array)"?) at - line 3. -length() used on %hash (did you mean "scalar(keys %hash)"?) at - line 4. +length() used on @a (did you mean "scalar(@a)"?) at - line 3. +length() used on %b (did you mean "scalar(keys %b)"?) at - line 4. length() used on @array (did you mean "scalar(@array)"?) at - line 5. length() used on %hash (did you mean "scalar(keys %hash)"?) at - line 6. -length() used on %hash (did you mean "scalar(keys %hash)"?) at - line 8. -length() used on @array (did you mean "scalar(@array)"?) at - line 9. +length() used on %h (did you mean "scalar(keys %h)"?) at - line 8. +length() used on @g (did you mean "scalar(@g)"?) at - line 9. ######## # op.c use warnings 'syntax' ; -- cgit v1.2.1