(perl #126162) improve stat @array handling

- warn on lexical arrays too

- limit the warning to under C<use warnings 'syntax';>

- test the warnings

- include the (correct) variable name where possible

3 files changed, 40 insertions, 6 deletions

diff --git a/op.c b/op.c
index 9bbe4f31cc..fcb1bc6a40 100644
--- a/op.c
+++ b/op.c
@@ -109,6 +109,8 @@ recursive, but it's recursive on basic blocks, not on tree nodes.
 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
 
+static char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
+
 /* Used to avoid recursion through the op tree in scalarvoid() and
    op_free()
 */
@@ -1548,7 +1550,7 @@ S_scalarboolean(pTHX_ OP *o)
 }
 
 static SV *
-S_op_varname(pTHX_ const OP *o)
+S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
 {
     assert(o);
     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
@@ -1561,13 +1563,19 @@ S_op_varname(pTHX_ const OP *o)
 	    if (cUNOPo->op_first->op_type != OP_GV
 	     || !(gv = cGVOPx_gv(cUNOPo->op_first)))
 		return NULL;
-	    return varname(gv, funny, 0, NULL, 0, 1);
+	    return varname(gv, funny, 0, NULL, 0, subscript_type);
 	}
 	return
-	    varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
+	    varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
     }
 }
 
+static SV *
+S_op_varname(pTHX_ const OP *o)
+{
+    return S_op_varname_subscript(aTHX_ o, 1);
+}
+
 static void
 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
 { /* or not so pretty :-) */
@@ -9734,8 +9742,17 @@ Perl_ck_ftst(pTHX_ OP *o)
 	    return newop;
 	}
 
-       if (kidtype == OP_RV2AV) {
-           Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Array passed to stat will be coerced to a scalar (did you want stat $_[0]?)");
+        if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
+            SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
+            if (name) {
+                /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
+                Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
+                            array_passed_to_stat, name);
+            }
+            else {
+                /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
+                Perl_warner(aTHX_ packWARN(WARN_SYNTAX), array_passed_to_stat);
+            }
        }
 	scalar((OP *) kid);
 	if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 941a108ae5..78aeb164e3 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -216,7 +216,7 @@ operator which expects either a number or a string matching
 C</^[a-zA-Z]*[0-9]*\z/>.  See L<perlop/Auto-increment and
 Auto-decrement> for details.
 
-=item Array passed to stat will be coerced to a scalar (did you want stat $_[0]?)
+=item Array passed to stat will be coerced to a scalar%s
 
 (W syntax) You called stat() on an array, but the array will be
 coerced to a scalar - the number of elements in the array.
diff --git a/t/lib/warnings/op b/t/lib/warnings/op
index 8256c23c54..528639e5a9 100644
--- a/t/lib/warnings/op
+++ b/t/lib/warnings/op
@@ -2040,3 +2040,20 @@ EXPECT
 Non-finite repeat count does nothing at - line 5.
 Non-finite repeat count does nothing at - line 6.
 Non-finite repeat count does nothing at - line 7.
+########
+# NAME warn on stat @array
+@foo = ("op/stat.t");
+stat @foo;
+my @bar = @foo;
+stat @bar;
+my $ref = \@foo;
+stat @$ref;
+use warnings 'syntax';
+stat @foo;
+stat @bar;
+stat @$ref;
+EXPECT
+Array passed to stat will be coerced to a scalar (did you want stat $foo[0]?) at - line 8.
+Array passed to stat will be coerced to a scalar (did you want stat $bar[0]?) at - line 9.
+Array passed to stat will be coerced to a scalar at - line 10.
+