Make push/shift $scalar accept only unblessed aryrefs

See ticket #80626.

diff --git a/embed.h b/embed.h
index a9d7ad6..89c4fa8 100644 (file)
--- 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 e917d43..41bb59f 100644 (file)
--- 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 0dbd270..4f0e1c6 100644 (file)
--- 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 88c55a8..cc19311 100644 (file)
--- 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 8b15b6e..40f6ed8 100644 (file)
--- 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 69ffaa7..a8c066a 100644 (file)
--- 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 5f8b88b..20087d1 100644 (file)
--- 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 2804d5b..813898e 100644 (file)
--- 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 07a3e67..bc6fb40 100644 (file)
--- 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";