Make push/shift $scalar accept only unblessed aryrefs

See ticket #80626.

9 files changed, 66 insertions, 69 deletions

diff --git a/embed.h b/embed.h
index a9d7ad6d60..89c4fa81be 100644
--- a/embed.h
+++ b/embed.h
@@ -969,7 +969,6 @@
 #define ck_method(a)		Perl_ck_method(aTHX_ a)
 #define ck_null(a)		Perl_ck_null(aTHX_ a)
 #define ck_open(a)		Perl_ck_open(aTHX_ a)
-#define ck_push(a)		Perl_ck_push(aTHX_ a)
 #define ck_readline(a)		Perl_ck_readline(aTHX_ a)
 #define ck_repeat(a)		Perl_ck_repeat(aTHX_ a)
 #define ck_require(a)		Perl_ck_require(aTHX_ a)
diff --git a/op.c b/op.c
index e917d434ac..41bb59fdb1 100644
--- a/op.c
+++ b/op.c
@@ -7434,9 +7434,15 @@ Perl_ck_fun(pTHX_ OP *o)
 		    kid->op_sibling = sibl;
 		    *tokid = kid;
 		}
-		else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
+		else if (kid->op_type == OP_CONST
+		      && (  !SvROK(cSVOPx_sv(kid)) 
+		         || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
+		        )
 		    bad_type(numargs, "array", PL_op_desc[type], kid);
-		op_lvalue(kid, type);
+		/* Defer checks to run-time if we have a scalar arg */
+		if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
+		    op_lvalue(kid, type);
+		else scalar(kid);
 		break;
 	    case OA_HVREF:
 		if (kid->op_type == OP_CONST &&
@@ -8277,7 +8283,7 @@ Perl_ck_shift(pTHX_ OP *o)
 	return newUNOP(type, 0, scalar(argop));
 #endif
     }
-    return scalar(modkids(ck_push(o), type));
+    return scalar(ck_fun(o));
 }
 
 OP *
@@ -9143,48 +9149,6 @@ Perl_ck_substr(pTHX_ OP *o)
 }
 
 OP *
-Perl_ck_push(pTHX_ OP *o)
-{
-    dVAR;
-    OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
-    OP *cursor = NULL;
-    OP *proxy = NULL;
-
-    PERL_ARGS_ASSERT_CK_PUSH;
-
-    /* If 1st kid is pushmark (e.g. push, unshift, splice), we need 2nd kid */
-    if (kid) {
-	cursor = kid->op_type == OP_PUSHMARK ? kid->op_sibling : kid;
-    }
-
-    /* If not array or array deref, wrap it with an array deref.
-     * For OP_CONST, we only wrap arrayrefs */
-    if (cursor) {
-	if ( (    cursor->op_type != OP_PADAV
-	       && cursor->op_type != OP_RV2AV
-	       && cursor->op_type != OP_CONST
-	     )
-	     ||
-	     (    cursor->op_type == OP_CONST
-	       && SvROK(cSVOPx_sv(cursor))
-	       && SvTYPE(SvRV(cSVOPx_sv(cursor))) == SVt_PVAV
-	     )
-	) {
-	    proxy = newAVREF(cursor);
-	    if ( cursor == kid ) {
-		cLISTOPx(o)->op_first = proxy;
-	    }
-	    else {
-		cLISTOPx(kid)->op_sibling = proxy;
-	    }
-	    cLISTOPx(proxy)->op_sibling = cLISTOPx(cursor)->op_sibling;
-	    cLISTOPx(cursor)->op_sibling = NULL;
-	}
-    }
-    return ck_fun(o);
-}
-
-OP *
 Perl_ck_each(pTHX_ OP *o)
 {
     dVAR;
diff --git a/opcode.h b/opcode.h
index 0dbd2701ca..4f0e1c658a 100644
--- a/opcode.h
+++ b/opcode.h
@@ -1451,11 +1451,11 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */
 	Perl_ck_null,		/* lslice */
 	Perl_ck_fun,		/* anonlist */
 	Perl_ck_fun,		/* anonhash */
-	Perl_ck_push,		/* splice */
-	Perl_ck_push,		/* push */
+	Perl_ck_fun,		/* splice */
+	Perl_ck_fun,		/* push */
 	Perl_ck_shift,		/* pop */
 	Perl_ck_shift,		/* shift */
-	Perl_ck_push,		/* unshift */
+	Perl_ck_fun,		/* unshift */
 	Perl_ck_sort,		/* sort */
 	Perl_ck_fun,		/* reverse */
 	Perl_ck_grep,		/* grepstart */
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 88c55a8e68..cc1931138d 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -3050,6 +3050,12 @@ find out what kind of ref it really was.  See L<perlref>.
 a reference to something else instead.  You can use the ref() function
 to find out what kind of ref it really was.  See L<perlref>.
 
+=item Not an unblessed ARRAY reference
+
+(F) You passed a reference to a blessed array to C<push>, C<shift> or
+another array function.  These only accept unblessed array references
+or arrays beginning explicitly with C<@>.
+
 =item Not a SCALAR reference
 
 (F) Perl was trying to evaluate a reference to a scalar value, but found
diff --git a/pp.c b/pp.c
index 8b15b6ec5f..40f6ed80d7 100644
--- a/pp.c
+++ b/pp.c
@@ -5424,10 +5424,39 @@ PP(pp_anonhash)
     RETURN;
 }
 
+static AV *
+S_deref_plain_array(pTHX_ AV *ary)
+{
+    if (SvTYPE(ary) == SVt_PVAV) return ary;
+    if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
+	Perl_die(aTHX_ "Not an ARRAY reference");
+    else if (SvOBJECT(SvRV(ary)))
+	Perl_die(aTHX_ "Not an unblessed ARRAY reference");
+    return (AV *)SvRV(ary);
+}
+
+#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
+# define DEREF_PLAIN_ARRAY(ary)       \
+   ({                                  \
+     AV *aRrRay = ary;                  \
+     SvTYPE(aRrRay) == SVt_PVAV          \
+      ? aRrRay                            \
+      : S_deref_plain_array(aTHX_ aRrRay); \
+   })
+#else
+# define DEREF_PLAIN_ARRAY(ary)            \
+   (                                        \
+     PL_Sv = (SV *)(ary);                    \
+     SvTYPE(PL_Sv) == SVt_PVAV                \
+      ? (AV *)PL_Sv                            \
+      : S_deref_plain_array(aTHX_ (AV *)PL_Sv); \
+   )
+#endif
+
 PP(pp_splice)
 {
     dVAR; dSP; dMARK; dORIGMARK;
-    register AV *ary = MUTABLE_AV(*++MARK);
+    register AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
     register SV **src;
     register SV **dst;
     register I32 i;
@@ -5630,7 +5659,7 @@ PP(pp_splice)
 PP(pp_push)
 {
     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
-    register AV * const ary = MUTABLE_AV(*++MARK);
+    register AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
 
     if (mg) {
@@ -5667,7 +5696,7 @@ PP(pp_shift)
     dVAR;
     dSP;
     AV * const av = PL_op->op_flags & OPf_SPECIAL
-	? MUTABLE_AV(GvAV(PL_defgv)) : MUTABLE_AV(POPs);
+	? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
     EXTEND(SP, 1);
     assert (sv);
@@ -5680,7 +5709,7 @@ PP(pp_shift)
 PP(pp_unshift)
 {
     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
-    register AV *ary = MUTABLE_AV(*++MARK);
+    register AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
 
     if (mg) {
diff --git a/proto.h b/proto.h
index 69ffaa74bc..a8c066a554 100644
--- a/proto.h
+++ b/proto.h
@@ -443,12 +443,6 @@ PERL_CALLCONV OP *	Perl_ck_open(pTHX_ OP *o)
 #define PERL_ARGS_ASSERT_CK_OPEN	\
 	assert(o)
 
-PERL_CALLCONV OP *	Perl_ck_push(pTHX_ OP *o)
-			__attribute__warn_unused_result__
-			__attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_CK_PUSH	\
-	assert(o)
-
 PERL_CALLCONV OP *	Perl_ck_readline(pTHX_ OP *o)
 			__attribute__warn_unused_result__
 			__attribute__nonnull__(pTHX_1);
diff --git a/regen/opcodes b/regen/opcodes
index 5f8b88b93d..20087d1ef3 100644
--- a/regen/opcodes
+++ b/regen/opcodes
@@ -245,11 +245,11 @@ lslice		list slice		ck_null		2	H L L
 anonlist	anonymous list ([])	ck_fun		ms@	L
 anonhash	anonymous hash ({})	ck_fun		ms@	L
 
-splice		splice			ck_push		m@	A S? S? L
-push		push			ck_push		imsT@	A L
+splice		splice			ck_fun		m@	A S? S? L
+push		push			ck_fun		imsT@	A L
 pop		pop			ck_shift	s%	A?
 shift		shift			ck_shift	s%	A?
-unshift		unshift			ck_push		imsT@	A L
+unshift		unshift			ck_fun		imsT@	A L
 sort		sort			ck_sort		dm@	C? L
 reverse		reverse			ck_fun		mt@	L
 
diff --git a/t/op/push.t b/t/op/push.t
index 2804d5be66..813898e669 100644
--- a/t/op/push.t
+++ b/t/op/push.t
@@ -14,7 +14,7 @@
 -4,			4 5 6 7,	0 1 2 3
 EOF
 
-print "1..", 13 + 2*@tests, "\n";
+print "1..", 14 + 2*@tests, "\n";
 die "blech" unless @tests;
 
 @x = (1,2,3);
@@ -44,8 +44,10 @@ if (join(':',@x) eq '1:2:3:1:2:3:4') {print "ok 6\n";} else {print "not ok 6\n";
 # test autovivification
 push @$undef1, 1, 2, 3;
 if (join(':',@$undef1) eq '1:2:3') {print "ok 7\n";} else {print "not ok 7\n";}
-push $undef2, 1, 2, 3;
-if (join(':',@$undef2) eq '1:2:3') {print "ok 8\n";} else {print "not ok 8\n";}
+
+# test push on undef (error)
+eval { push $undef2, 1, 2, 3 };
+if ($@ =~ /Not an ARRAY/) {print "ok 8\n";} else {print "not ok 8\n";}
 
 # test constant
 use constant CONST_ARRAYREF => [qw/a b c/];
@@ -60,7 +62,10 @@ $hashref = { };
 eval { push $hashref, 0, 1, 2, 3 };
 if ( $@ && $@ =~ /Not an ARRAY reference/ ) {print "ok 11\n"} else {print "not ok 11 # \$\@ = $@\n"}
 
-$test = 12;
+eval { push bless([]), 0, 1, 2, 3 };
+if ( $@ && $@ =~ /Not an unblessed ARRAY reference/ ) {print "ok 12\n"} else {print "not ok 12 # \$\@ = $@\n"}
+
+$test = 13;
 
 # test context
 {
diff --git a/t/op/splice.t b/t/op/splice.t
index 07a3e6723c..bc6fb40272 100644
--- a/t/op/splice.t
+++ b/t/op/splice.t
@@ -93,7 +93,7 @@ splice @Foo::ISA, 0, 0, 'Bar';
 print "not " if !Foo->isa('Bar');
 print "ok 20\n";
 
-# Test vivification
-splice( $new_arrayref, 0, 0, 1, 2, 3 );
-print "not " unless j(@$new_arrayref) eq j(1,2,3);
+# Test undef first arg
+eval { splice( $new_arrayref, 0, 0, 1, 2, 3 ) };
+print "not " unless $@ && $@ =~ /Not an ARRAY/;
 print "ok 21\n";