See ticket #80626.
#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)
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 &&
return newUNOP(type, 0, scalar(argop));
#endif
}
- return scalar(modkids(ck_push(o), type));
+ return scalar(ck_fun(o));
}
OP *
}
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;
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 */
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
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;
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) {
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);
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) {
#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);
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
-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);
# 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/];
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
{
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";