Mention the variable name in the new length warnings

diff --git a/embed.fnc b/embed.fnc
index 0857dd8..fb93b93 100644 (file)
--- 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 5771ad7..d8d2776 100644 (file)
--- 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 6d0736d..490af8a 100644 (file)
--- 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 bf18d53..55f4b3b 100644 (file)
--- 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 \
@@ -6781,6 +6778,11 @@ STATIC void      S_unreferenced_to_tmp_stack(pTHX_ AV *const 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);
 STATIC void    S_check_uni(pTHX);

diff --git a/sv.c b/sv.c
index 7cfa300..733df5d 100644 (file)
--- 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 b8bed27..f737bf9 100644 (file)
--- 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' ;