From d4fc4415aac96132fac5b1e43e73bcba33a41b79 Mon Sep 17 00:00:00 2001 From: Father Chrysostomos Date: Mon, 18 Apr 2011 06:34:01 -0700 Subject: [PATCH] Make push/shift $scalar accept only unblessed aryrefs See ticket #80626. --- embed.h | 1 - op.c | 54 +++++++++--------------------------------------------- opcode.h | 6 +++--- pod/perldiag.pod | 6 ++++++ pp.c | 37 +++++++++++++++++++++++++++++++++---- proto.h | 6 ------ regen/opcodes | 6 +++--- t/op/push.t | 13 +++++++++---- t/op/splice.t | 6 +++--- 9 files changed, 66 insertions(+), 69 deletions(-) diff --git a/embed.h b/embed.h index a9d7ad6..89c4fa8 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 e917d43..41bb59f 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 0dbd270..4f0e1c6 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 88c55a8..cc19311 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -3050,6 +3050,12 @@ find out what kind of ref it really was. See L. a reference to something else instead. You can use the ref() function to find out what kind of ref it really was. See L. +=item Not an unblessed ARRAY reference + +(F) You passed a reference to a blessed array to C, C 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 --- 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 --- 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 --- 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 --- 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 --- 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"; -- 2.7.4