Mention the variable name in the new length warnings

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	\
@@ -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 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' ;