Warn for all uses of %hash{...} in scalar cx

and reword the warning slightly.

See <20131027204944.20489.qmail@lists-nntp.develooper.com>.

To avoid getting a warning about scalar context for ‘delete %a[1,2]’,
which dies anyway, I stopped scalar context from being applied to
delete’s argument.  Scalar context is not meaningful here anyway, and
the context is not really scalar.

This also means that ‘delete sort’ no longer produces a warning about
scalar context before dying, so I added a test for that.

9 files changed, 128 insertions, 81 deletions

diff --git a/dump.c b/dump.c
index 78e9aa93ab..a5061d3988 100644
--- a/dump.c
+++ b/dump.c
@@ -960,8 +960,7 @@ S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
                            (UV)(oppriv & OPpPADRANGE_COUNTMASK));       \
         if (  (o->op_type == OP_RV2HV || o->op_type == OP_RV2AV ||      \
                o->op_type == OP_PADAV || o->op_type == OP_PADHV ||      \
-               o->op_type == OP_ASLICE || o->op_type == OP_HSLICE ||    \
-               o->op_type == OP_KVHSLICE || o->op_type == OP_KVASLICE)  \
+               o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)      \
            && oppriv & OPpSLICEWARNING  )                               \
             sv_catpvs(tmpsv, ",SLICEWARNING");                          \
 	if (SvCUR(tmpsv)) {                                             \
diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm
index 632cc66678..01769facf1 100644
--- a/ext/B/B/Concise.pm
+++ b/ext/B/B/Concise.pm
@@ -621,7 +621,7 @@ $priv{$_}{8} = "LVSUB"
   for qw(rv2av rv2gv rv2hv padav padhv aelem helem aslice hslice
          av2arylen keys rkeys substr pos vec);
 $priv{$_}{4} = "SLICEWARN"
-  for qw(rv2hv rv2av kvhslice kvaslice padav padhv hslice aslice);
+  for qw(rv2hv rv2av padav padhv hslice aslice);
 @{$priv{$_}}{32,64} = qw(BOOL BOOL?) for qw(rv2hv padhv);
 $priv{substr}{16} = "REPL1ST";
 $priv{$_}{16} = "TARGMY"
diff --git a/op.c b/op.c
index dc0a4e3c42..5f7e875ae8 100644
--- a/op.c
+++ b/op.c
@@ -1145,15 +1145,31 @@ S_op_varname(pTHX_ const OP *o)
 }
 
 static void
+S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
+{ /* or not so pretty :-) */
+    const char *key = NULL;
+    if (o->op_type == OP_CONST) {
+	*retsv = cSVOPo_sv;
+	if (SvPOK(*retsv)) {
+	    SV *sv = *retsv;
+	    *retsv = sv_newmortal();
+	    pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
+		      PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
+	}
+	else if (!SvOK(*retsv))
+	    *retpv = "undef";
+    }
+    else *retpv = "...";
+}
+
+static void
 S_scalar_slice_warning(pTHX_ const OP *o)
 {
     OP *kid;
     const char lbrack =
-	o->op_type == OP_KVHSLICE || o->op_type == OP_HSLICE ? '{' : '[';
+	o->op_type == OP_HSLICE ? '{' : '[';
     const char rbrack =
-	o->op_type == OP_KVHSLICE || o->op_type == OP_HSLICE ? '}' : ']';
-    const char funny =
-	o->op_type == OP_ASLICE || o->op_type == OP_HSLICE ? '@' : '%';
+	o->op_type == OP_HSLICE ? '}' : ']';
     SV *name;
     SV *keysv = NULL; /* just to silence compiler warnings */
     const char *key = NULL;
@@ -1199,33 +1215,22 @@ S_scalar_slice_warning(pTHX_ const OP *o)
     name = S_op_varname(aTHX_ kid->op_sibling);
     if (!name) /* XS module fiddling with the op tree */
 	return;
-    if (kid->op_type == OP_CONST) {
-	keysv = kSVOP_sv;
-	if (SvPOK(kSVOP_sv)) {
-	    SV *sv = keysv;
-	    keysv = sv_newmortal();
-	    pv_pretty(keysv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
-		      PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
-	}
-	else if (!SvOK(keysv))
-	    key = "undef";
-    }
-    else key = "...";
+    S_op_pretty(aTHX_ kid, &keysv, &key);
     assert(SvPOK(name));
     sv_chop(name,SvPVX(name)+1);
     if (key)
-       /* diag_listed_as: Scalar value %%s[%s] better written as $%s[%s] */
+       /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
 	Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
-		   "Scalar value %c%"SVf"%c%s%c better written as $%"SVf
+		   "Scalar value @%"SVf"%c%s%c better written as $%"SVf
 		   "%c%s%c",
-		    funny, SVfARG(name), lbrack, key, rbrack, SVfARG(name),
+		    SVfARG(name), lbrack, key, rbrack, SVfARG(name),
 		    lbrack, key, rbrack);
     else
-       /* diag_listed_as: Scalar value %%s[%s] better written as $%s[%s] */
+       /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
 	Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
-		   "Scalar value %c%"SVf"%c%"SVf"%c better written as $%"
+		   "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
 		    SVf"%c%"SVf"%c",
-		    funny, SVfARG(name), lbrack, keysv, rbrack,
+		    SVfARG(name), lbrack, keysv, rbrack,
 		    SVfARG(name), lbrack, keysv, rbrack);
 }
 
@@ -1293,7 +1298,44 @@ Perl_scalar(pTHX_ OP *o)
 	break;
     case OP_KVHSLICE:
     case OP_KVASLICE:
-	S_scalar_slice_warning(aTHX_ o);
+    {
+	/* Warn about scalar context */
+	const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
+	const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
+	SV *name;
+	SV *keysv;
+	const char *key = NULL;
+
+	/* This warning can be nonsensical when there is a syntax error. */
+	if (PL_parser && PL_parser->error_count)
+	    break;
+
+	if (!ckWARN(WARN_SYNTAX)) break;
+
+	kid = cLISTOPo->op_first;
+	kid = kid->op_sibling; /* get past pushmark */
+	assert(kid->op_sibling);
+	name = S_op_varname(aTHX_ kid->op_sibling);
+	if (!name) /* XS module fiddling with the op tree */
+	    break;
+	S_op_pretty(aTHX_ kid, &keysv, &key);
+	assert(SvPOK(name));
+	sv_chop(name,SvPVX(name)+1);
+	if (key)
+  /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
+	    Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+		       "%%%"SVf"%c%s%c in scalar context better written "
+		       "as $%"SVf"%c%s%c",
+			SVfARG(name), lbrack, key, rbrack, SVfARG(name),
+			lbrack, key, rbrack);
+	else
+  /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
+	    Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+		       "%%%"SVf"%c%"SVf"%c in scalar context better "
+		       "written as $%"SVf"%c%"SVf"%c",
+			SVfARG(name), lbrack, keysv, rbrack,
+			SVfARG(name), lbrack, keysv, rbrack);
+    }
     }
     return o;
 }
@@ -9011,7 +9053,7 @@ Perl_ck_fun(pTHX_ OP *o)
 		{
 		    return too_many_arguments_pv(o,PL_op_desc[type], 0);
 		}
-		scalar(kid);
+		if (type != OP_DELETE) scalar(kid);
 		break;
 	    case OA_LIST:
 		if (oa < 16) {
diff --git a/op.h b/op.h
index 1c59ca8e44..8672e4bf0e 100644
--- a/op.h
+++ b/op.h
@@ -250,8 +250,8 @@ is no conversion of op type.
 #define OPpEARLY_CV		32	/* foo() called before sub foo was parsed */
   /* OP_?ELEM only */
 #define OPpLVAL_DEFER		16	/* Defer creation of array/hash elem */
-  /* OP_RV2[AH]V OP_KV[AH]SLICE OP_[AH]SLICE */
-#define OPpSLICEWARNING		4	/* warn about %hash{$scalar} */
+  /* OP_RV2[AH]V OP_[AH]SLICE */
+#define OPpSLICEWARNING		4	/* warn about @hash{$scalar} */
   /* OP_RV2[SAH]V, OP_GVSV, OP_ENTERITER only */
 #define OPpOUR_INTRO		16	/* Variable was in an our() */
   /* OP_RV2[AGH]V, OP_PAD[AH]V, OP_[AH]ELEM, OP_[AH]SLICE OP_AV2ARYLEN,
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index e88646a33d..81eef8e1bc 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -2348,6 +2348,28 @@ C<state ($a) = 42> as C<state $a = 42> to change from list to scalar
 context.  Constructions such as C<state (@a) = foo()> will be
 supported in a future perl release.
 
+=item %%s[%s] in scalar context better written as $%s[%s]
+
+(W syntax) In scalar context, you've used an array index/value slice
+(indicated by %) to select a single element of an array.  Generally
+it's better to ask for a scalar value (indicated by $).  The difference
+is that C<$foo[&bar]> always behaves like a scalar, both in the value it
+returns and when evaluating its argument, while C<%foo[&bar]> provides
+a list context to its subscript, which can do weird things if you're
+expecting only one subscript.  When called in list context, it also
+returns the index (what C<&bar> returns) in addition to the value.
+
+=item %%s{%s} in scalar context better written as $%s{%s}
+
+(W syntax) In scalar context, you've used a hash key/value slice
+(indicated by %) to select a single element of a hash.  Generally it's
+better to ask for a scalar value (indicated by $).  The difference
+is that C<$foo{&bar}> always behaves like a scalar, both in the value
+it returns and when evaluating its argument, while C<@foo{&bar}> and
+provides a list context to its subscript, which can do weird things
+if you're expecting only one subscript.  When called in list context,
+it also returns the key in addition to the value.
+
 =item Insecure dependency in %s
 
 (F) You tried to do something that the tainting mechanism didn't like.
@@ -4626,28 +4648,6 @@ as a list, you need to look into how references work, because Perl will
 not magically convert between scalars and lists for you.  See
 L<perlref>.
 
-=item Scalar value %%s[%s] better written as $%s[%s]
-
-(W syntax) In scalar context, you've used an array index/value slice
-(indicated by %) to select a single element of an array.  Generally
-it's better to ask for a scalar value (indicated by $).  The difference
-is that C<$foo[&bar]> always behaves like a scalar, both in the value it
-returns and when evaluating its argument, while C<%foo[&bar]> provides
-a list context to its subscript, which can do weird things if you're
-expecting only one subscript.  When called in list context, it also
-returns the index (what C<&bar> returns) in addition to the value.
-
-=item Scalar value %%s{%s} better written as $%s{%s}
-
-(W syntax) In scalar context, you've used a hash key/value slice
-(indicated by %) to select a single element of a hash.  Generally it's
-better to ask for a scalar value (indicated by $).  The difference
-is that C<$foo{&bar}> always behaves like a scalar, both in the value
-it returns and when evaluating its argument, while C<@foo{&bar}> and
-provides a list context to its subscript, which can do weird things
-if you're expecting only one subscript.  When called in list context,
-it also returns the key in addition to the value.
-
 =item Search pattern not terminated
 
 (F) The lexer couldn't find the final delimiter of a // or m{}
diff --git a/t/lib/croak/op b/t/lib/croak/op
index 31af174804..3ec418ffd4 100644
--- a/t/lib/croak/op
+++ b/t/lib/croak/op
@@ -48,6 +48,12 @@ delete $x;
 EXPECT
 delete argument is not a HASH or ARRAY element or slice at - line 1.
 ########
+# NAME delete sort
+use warnings;
+delete sort; # used to warn about scalar context, too
+EXPECT
+delete argument is not a HASH or ARRAY element or slice at - line 2.
+########
 # NAME exists BAD
 exists $x;
 EXPECT
diff --git a/t/op/kvaslice.t b/t/op/kvaslice.t
index a1d9388d04..0738a17a87 100644
--- a/t/op/kvaslice.t
+++ b/t/op/kvaslice.t
@@ -8,7 +8,7 @@ BEGIN {
 
 # use strict;
 
-plan tests => 39;
+plan tests => 40;
 
 # simple use cases
 {
@@ -41,17 +41,19 @@ plan tests => 39;
 
 # scalar context
 {
+    my @warn;
+    local $SIG{__WARN__} = sub {push @warn, "@_"};
+
     my @a = 'a'..'z';
-    is scalar %a[4,5,6], 'g', 'last element in scalar context';
+    is eval'scalar %a[4,5,6]', 'g', 'last element in scalar context';
 
-    {
-        my @warn;
-        local $SIG{__WARN__} = sub {push @warn, "@_"};
-        eval 'is( scalar %a[5], "f", "correct value");';
+    like ($warn[0],
+     qr/^\%a\[\.\.\.\] in scalar context better written as \$a\[\.\.\.\]/);
 
-        is (scalar @warn, 1);
-        like ($warn[0], qr/^Scalar value \%a\[5\] better written as \$a\[5\]/);
-    }
+    eval 'is( scalar %a[5], "f", "correct value");';
+
+    is (scalar @warn, 2);
+    like ($warn[1], qr/^\%a\[5\] in scalar context better written as \$a\[5\]/);
 }
 
 # autovivification
@@ -151,7 +153,8 @@ plan tests => 39;
         @warn = ();
         my $v = eval '%a[0]';
         is (scalar @warn, 1, 'warning in scalar context');
-        like $warn[0], qr{^Scalar value %a\[0\] better written as \$a\[0\]},
+        like $warn[0],
+             qr{^%a\[0\] in scalar context better written as \$a\[0\]},
             "correct warning text";
     }
     {
@@ -179,7 +182,8 @@ plan tests => 39;
 {
     my %h = 'a'..'b';
     my @i = \%h;
-    my ($k,$v) = each %i[(0)]; # parens suppress "Scalar better written as"
+    no warnings 'syntax';
+    my ($k,$v) = each %i[0];
     is $k, 'a', 'key returned by each %array[ix]';
     is $v, 'b', 'val returned by each %array[ix]';
     %h = 1..10;
diff --git a/t/op/kvhslice.t b/t/op/kvhslice.t
index bb0f3c16b9..8acd0ab81c 100644
--- a/t/op/kvhslice.t
+++ b/t/op/kvhslice.t
@@ -8,7 +8,7 @@ BEGIN {
 
 # use strict;
 
-plan tests => 43;
+plan tests => 44;
 
 # simple use cases
 {
@@ -41,18 +41,20 @@ plan tests => 43;
 
 # scalar context
 {
+    my @warn;
+    local $SIG{__WARN__} = sub {push @warn, "@_"};
+
     my %h = map { $_ => uc $_ } 'a'..'z';
-    is scalar %h{'c','d','e'}, 'E', 'last element in scalar context';
+    is scalar eval"%h{'c','d','e'}", 'E', 'last element in scalar context';
 
-    {
-        my @warn;
-        local $SIG{__WARN__} = sub {push @warn, "@_"};
-        eval 'is( scalar %h{i}, "I", "correct value");';
+    like ($warn[0],
+     qr/^\%h\{\.\.\.\} in scalar context better written as \$h\{\.\.\.\}/);
 
-        is (scalar @warn, 1);
-        like ($warn[0],
-              qr/^Scalar value \%h\{"i"\} better written as \$h\{"i"\}/);
-    }
+    eval 'is( scalar %h{i}, "I", "correct value");';
+
+    is (scalar @warn, 2);
+    like ($warn[1],
+          qr/^\%h\{"i"\} in scalar context better written as \$h\{"i"\}/);
 }
 
 # autovivification
@@ -149,7 +151,7 @@ plan tests => 43;
         my $v = eval '%h{a}';
         is (scalar @warn, 1, 'warning in scalar context');
         like $warn[0],
-             qr{^Scalar value %h{"a"} better written as \$h{"a"}},
+             qr{^%h{"a"} in scalar context better written as \$h{"a"}},
             "correct warning text";
     }
     {
@@ -193,7 +195,8 @@ plan tests => 43;
 {
     my %h = 'a'..'b';
     my %i = (foo => \%h);
-    my ($k,$v) = each %i{foo=>}; # => suppresses "Scalar better written as"
+    no warnings 'syntax';
+    my ($k,$v) = each %i{foo=>};
     is $k, 'a', 'key returned by each %hash{key}';
     is $v, 'b', 'val returned by each %hash{key}';
     %h = 1..10;
diff --git a/toke.c b/toke.c
index d871fc46e7..509aa8e3e7 100644
--- a/toke.c
+++ b/toke.c
@@ -5853,13 +5853,6 @@ Perl_yylex(pTHX)
 	if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
 	    if (*s == '[')
 		PL_tokenbuf[0] = '@';
-
-	    /* Warn about % where they meant $. */
-	    if (*s == '[' || *s == '{') {
-		if (ckWARN(WARN_SYNTAX)) {
-		    S_check_scalar_slice(aTHX_ s);
-		}
-	    }
 	}
 	PL_expect = XOPERATOR;
 	force_ident_maybe_lex('%');