Make keys/value/each $scalar accept only unblessed refs

See ticket #80626.

4 files changed, 112 insertions, 95 deletions

diff --git a/op.c b/op.c
index 41bb59fdb1..f22f888008 100644
--- a/op.c
+++ b/op.c
@@ -9171,11 +9171,16 @@ Perl_ck_each(pTHX_ OP *o)
 		CHANGE_TYPE(o, array_type);
 		break;
 	    case OP_CONST:
-		if (kid->op_private == OPpCONST_BARE)
-		    /* we let ck_fun treat as hash */
+		if (kid->op_private == OPpCONST_BARE
+		 || !SvROK(cSVOPx_sv(kid))
+		 || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
+		    && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
+		   )
+		    /* we let ck_fun handle it */
 		    break;
 	    default:
 		CHANGE_TYPE(o, ref_type);
+		scalar(kid);
 	}
     }
     /* if treating as a reference, defer additional checks to runtime */
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index cc1931138d..56e840807f 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -4660,10 +4660,10 @@ certain type.  Arrays must be @NAME or C<@{EXPR}>.  Hashes must be
 %NAME or C<%{EXPR}>.  No implicit dereferencing is allowed--use the
 {EXPR} forms as an explicit dereference.  See L<perlref>.
 
-=item Type of argument to %s must be hashref or arrayref
+=item Type of argument to %s must be unblessed hashref or arrayref
 
-(F) You called C<keys>, C<values> or C<each> with an argument that was
-expected to be a reference to a hash or a reference to an array.
+(F) You called C<keys>, C<values> or C<each> with a scalar argument that
+was not a reference to an unblessed hash or array.
 
 =item umask not implemented
 
diff --git a/pp.c b/pp.c
index 058a068483..5b32daf78e 100644
--- a/pp.c
+++ b/pp.c
@@ -4836,51 +4836,17 @@ PP(pp_rkeys)
     dSP;
     dPOPss;
 
-    if (!SvOK(sv))
-	RETURN;
-
-    if (SvROK(sv)) {
-	SvGETMAGIC(sv);
-	if (SvAMAGIC(sv)) {
-	    /* N.B.: AMG macros return sv if no overloading is found */
-	    SV *maybe_hv = AMG_CALLunary(sv, to_hv_amg);
-	    SV *maybe_av = AMG_CALLunary(sv, to_av_amg);
-	    if ( maybe_hv != sv && maybe_av != sv ) {
-		Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s",
-		    Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as %%{}",
-			PL_op_desc[PL_op->op_type]
-		    )
-		);
-		sv = maybe_hv;
-	    }
-	    else if ( maybe_av != sv ) {
-		if ( SvTYPE(SvRV(sv)) == SVt_PVHV ) {
-		    /* @{} overload, but underlying reftype is HV */
-		    Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s",
-			Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as @{}",
-			    PL_op_desc[PL_op->op_type]
-			)
-		    );
-		}
-		sv = maybe_av;
-	    }
-	    else if ( maybe_hv != sv ) {
-		if ( SvTYPE(SvRV(sv)) == SVt_PVAV ) {
-		    /* %{} overload, but underlying reftype is AV */
-		    Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s",
-			Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as %%{}",
-			    PL_op_desc[PL_op->op_type]
-			)
-		    );
-		}
-		sv = maybe_hv;
-	    }
-	}
-	sv = SvRV(sv);
-    }
-
-    if ( SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV ) {
-	DIE(aTHX_ "Type of argument to %s must be hashref or arrayref",
+    SvGETMAGIC(sv);
+
+    if (
+         !SvROK(sv)
+      || (sv = SvRV(sv),
+            (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
+          || SvOBJECT(sv)
+         )
+    ) {
+	DIE(aTHX_
+	   "Type of argument to %s must be unblessed hashref or arrayref",
 	    PL_op_desc[PL_op->op_type] );
     }
 
diff --git a/t/op/smartkve.t b/t/op/smartkve.t
index 4cb19f5452..7c57e7bba4 100644
--- a/t/op/smartkve.t
+++ b/t/op/smartkve.t
@@ -8,7 +8,7 @@ BEGIN {
 use strict;
 use warnings;
 no warnings 'deprecated';
-use vars qw($data $array $values $hash);
+use vars qw($data $array $values $hash $errpat);
 
 plan 'no_plan';
 
@@ -124,26 +124,39 @@ is(j(keys array_sub)            ,$a_expect, 'List: keys array_sub');
 is(j(keys array_sub())          ,$a_expect, 'List: keys array_sub()');
 is(j(keys $obj->array)          ,$a_expect, 'List: keys $obj->array');
 
-# Keys -- undef
-
-undef $empty;
-is(j(keys undef),     '',     'Undef: keys undef is empty list');
-is(j(keys $empty),    '',     'Undef: keys $empty is empty list');
-is($empty,            undef,  'Undef: $empty is not vivified');
-
 # Keys -- vivification
-is(j(keys $empty->{hash}),    '',   'Vivify: keys $empty->{hash}');
-ok(defined $empty               ,   'Vivify: $empty is HASHREF');
+undef $empty;
+eval { keys $empty->{hash} };
+ok(defined $empty,
+  'Vivify: $empty (after keys $empty->{hash}) is HASHREF');
 ok(!defined $empty->{hash}      ,   'Vivify: $empty->{hash} is undef');
 
 # Keys -- errors
+$errpat = qr/
+ (?-x:Type of argument to keys on reference must be unblessed hashref or)
+ (?-x: arrayref)
+/x;
+
+eval "keys undef";
+ok($@ =~ $errpat,
+  'Errors: keys undef throws error'
+);
+
+undef $empty;
+eval q"keys $empty";
+ok($@ =~ $errpat,
+  'Errors: keys $undef throws error'
+);
+
+is($empty, undef, 'keys $undef does not vivify $undef');
+
 eval "keys 3";
-ok($@ =~ qr/Type of argument to keys on reference must be hashref or arrayref/,
+ok($@ =~ qr/Type of arg 1 to keys must be hash/,
   'Errors: keys CONSTANT throws error'
 );
 
 eval "keys qr/foo/";
-ok($@ =~ qr/Type of argument to keys on reference must be hashref or arrayref/,
+ok($@ =~ $errpat,
   'Errors: keys qr/foo/ throws error'
 );
 
@@ -206,26 +219,39 @@ is(j(values array_sub)            ,$a_expect, 'List: values array_sub');
 is(j(values array_sub())          ,$a_expect, 'List: values array_sub()');
 is(j(values $obj->array)          ,$a_expect, 'List: values $obj->array');
 
-# Values -- undef
-
-undef $empty;
-is(j(values undef),     '',     'Undef: values undef is empty list');
-is(j(values $empty),    '',     'Undef: values $empty is empty list');
-is($empty,            undef,  'Undef: $empty is not vivified');
-
 # Values -- vivification
-is(j(values $empty->{hash}),    '',   'Vivify: values $empty->{hash}');
-ok(defined $empty               ,   'Vivify: $empty is HASHREF');
+undef $empty;
+eval { values $empty->{hash} };
+ok(defined $empty,
+  'Vivify: $empty (after values $empty->{hash}) is HASHREF');
 ok(!defined $empty->{hash}      ,   'Vivify: $empty->{hash} is undef');
 
 # Values -- errors
+$errpat = qr/
+ (?-x:Type of argument to values on reference must be unblessed hashref or)
+ (?-x: arrayref)
+/x;
+
+eval "values undef";
+ok($@ =~ $errpat,
+  'Errors: values undef throws error'
+);
+
+undef $empty;
+eval q"values $empty";
+ok($@ =~ $errpat,
+  'Errors: values $undef throws error'
+);
+
+is($empty, undef, 'values $undef does not vivify $undef');
+
 eval "values 3";
-ok($@ =~ qr/Type of argument to values on reference must be hashref or arrayref/,
+ok($@ =~ qr/Type of arg 1 to values must be hash/,
   'Errors: values CONSTANT throws error'
 );
 
 eval "values qr/foo/";
-ok($@ =~ qr/Type of argument to values on reference must be hashref or arrayref/,
+ok($@ =~ $errpat,
   'Errors: values qr/foo/ throws error'
 );
 
@@ -302,26 +328,39 @@ keys $obj->array;
 @tmp=@tmp2=(); while(($k,$v) = each array_sub()){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys array_sub(), values array_sub()), 'List: each array_sub()');
 @tmp=@tmp2=(); while(($k,$v) = each $obj->array){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys $obj->array, values $obj->array), 'List: each $obj->array');
 
-# Each -- undef
+# Each -- vivification
+undef $empty;
+eval { each $empty->{hash} };
+ok(defined $empty,
+  'Vivify: $empty (after each $empty->{hash}) is HASHREF');
+ok(!defined $empty->{hash}      ,   'Vivify: $empty->{hash} is undef');
+
+# Each -- errors
+$errpat = qr/
+ (?-x:Type of argument to each on reference must be unblessed hashref or)
+ (?-x: arrayref)
+/x;
+
+eval "each undef";
+ok($@ =~ $errpat,
+  'Errors: each undef throws error'
+);
 
 undef $empty;
-is(j(@{[each undef]}),     '',     'Undef: each undef is empty list');
-is(j(@{[each $empty]}),     '',    'Undef: each $empty is empty list');
-is($empty,            undef,  'Undef: $empty is not vivified');
+eval q"each $empty";
+ok($@ =~ $errpat,
+  'Errors: each $undef throws error'
+);
 
-# Values -- vivification
-is(j(@{[each $empty->{hash}]}),     '',     'Vivify: each $empty->{hash} is empty list');
-ok(defined $empty               ,   'Vivify: $empty is HASHREF');
-ok(!defined $empty->{hash}      ,   'Vivify: $empty->{hash} is undef');
+is($empty, undef, 'each $undef does not vivify $undef');
 
-# Values -- errors
 eval "each 3";
-ok($@ =~ qr/Type of argument to each on reference must be hashref or arrayref/,
+ok($@ =~ qr/Type of arg 1 to each must be hash/,
   'Errors: each CONSTANT throws error'
 );
 
 eval "each qr/foo/";
-ok($@ =~ qr/Type of argument to each on reference must be hashref or arrayref/,
+ok($@ =~ $errpat,
   'Errors: each qr/foo/ throws error'
 );
 
@@ -337,25 +376,32 @@ my $over_b = Foo::Overload::Both->new;
 my $over_h_a = Foo::Overload::HashOnArray->new;
 my $over_a_h = Foo::Overload::ArrayOnHash->new;
 
-my $re_warn_array = qr/Ambiguous overloaded argument to keys on reference resolved as \@\{\}/;
-my $re_warn_hash = qr/Ambiguous overloaded argument to keys on reference resolved as \%\{\}/;
-
 {
   my $warn = '';
   local $SIG{__WARN__} = sub { $warn = shift };
 
-  is(j(keys $over_a), j(keys @$array), "Overload: array dereference");
+  $errpat = qr/
+   (?-x:Type of argument to keys on reference must be unblessed hashref or)
+   (?-x: arrayref)
+  /x;
+
+  eval { keys $over_a };
+  like($@, $errpat, "Overload: array dereference");
   is($warn, '', "no warning issued"); $warn = '';
 
-  is(j(keys $over_h), j(keys %$hash), "Overload: hash dereference");
+  eval { keys $over_h };
+  like($@, $errpat, "Overload: hash dereference");
   is($warn, '', "no warning issued"); $warn = '';
 
-  is(j(keys $over_b), j(keys %$hash), "Overload: ambiguous dereference (both) resolves to hash");
-  like($warn, $re_warn_hash, "warning correct"); $warn = '';
+  eval { keys $over_b };
+  like($@, $errpat, "Overload: ambiguous dereference (both)");
+  is($warn, '', "no warning issued"); $warn = '';
 
-  is(j(keys $over_h_a), j(keys %$hash), "Overload: ambiguous dereference resolves to hash");
-  like($warn, $re_warn_hash, "warning correct"); $warn = '';
+  eval { keys $over_h_a };
+  like($@, $errpat, "Overload: ambiguous dereference");
+  is($warn, '', "no warning issued"); $warn = '';
 
-  is(j(keys $over_a_h), j(keys @$array), "Overload: ambiguous dereference resolves to array");
-  like($warn, $re_warn_array, "warning correct"); $warn = '';
+  eval { keys $over_a_h };
+  like($@, $errpat, "Overload: ambiguous dereference");
+  is($warn, '', "no warning issued"); $warn = '';
 }