In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/0c46edc2ed84a018c7aeb5f4ac8a662028bc8a9b?hp=71faf10a29dcbf55255bd39e6d95e5abbe97958b>
- Log ----------------------------------------------------------------- commit 0c46edc2ed84a018c7aeb5f4ac8a662028bc8a9b Author: Father Chrysostomos <[email protected]> Date: Tue Nov 25 05:35:55 2014 -0800 [perl #47363] \@ proto and parenthesised arrays The bug reported was that foo((@foo)) and foo+(@foo) pass a scalar reference to a subroutine with a \@ prototype. The scalar reference passed is the last element of @foo, or &PL_sv_undef if @foo has no elements. If the containing sub is called in list context, however, the entire array is flattened and the proto- typed sub gets a list of references longer that it is expecting. $ ./perl -Ilib -e 'sub f ($\@) { warn "@_"; warn ${$_[1]} if ref $_[1] eq SCALAR } @_ = a..z; f(1, @_); f(1, (@_))' 1 ARRAY(0x7fe1220061f0) at -e line 1. 1 SCALAR(0x7fe1220353e0) at -e line 1. z at -e line 1. $ ./perl -Ilib -e '() = sub {sub f ($\@) { warn "@_"; warn ${$_[1]} if ref $_[1] eq SCALAR } @_ = a..z; f(1, @_); f(1, (@_)) }->()' 1 ARRAY(0x7f914a8362a8) at -e line 1. 1 SCALAR(0x7f914a806430) SCALAR(0x7f914a82f678) SCALAR(0x7f914a82f690) SCALAR(0x7f914a82f6c0) SCALAR(0x7f914a82f6a8) SCALAR(0x7f914a82f750) SCALAR(0x7f914a82f768) SCALAR(0x7f914a82f7f8) SCALAR(0x7f914a82f810) SCALAR(0x7f914a82f7e0) SCALAR(0x7f914a835cf0) SCALAR(0x7f914a835d08) SCALAR(0x7f914a835d20) SCALAR(0x7f914a835d38) SCALAR(0x7f914a835d50) SCALAR(0x7f914a835d68) SCALAR(0x7f914a835d80) SCALAR(0x7f914a835d98) SCALAR(0x7f914a835db0) SCALAR(0x7f914a835dc8) SCALAR(0x7f914a835de0) SCALAR(0x7f914a835df8) SCALAR(0x7f914a835e10) SCALAR(0x7f914a835e28) SCALAR(0x7f914a835e40) SCALAR(0x7f914a835e58) at -e line 1. a at -e line 1. The problem here is that \ applied to an array usually checks whether the array was parenthesized. If it was, it gets flattened. The same code paths were used for the implicit \ added by the prototype. The reason for the erratic behaviour based on the context of the enclos- ing sub is that the refgen op had no context applied to it. Usually that means an op is at the end of a sub and should inherit the call- ing context. If we change the logic to remove the parentheses from the array before applying the implicit \ then it behaves as expected. Furthermore, we end up with a srefgen op, which doesnât care about context, so we donât need to bother setting it. M op.c M t/comp/proto.t commit 60f71a82f635e2a8a70b36c2a82b27b78602408f Author: Father Chrysostomos <[email protected]> Date: Mon Nov 24 22:28:34 2014 -0800 Allow \(&sub) for & proto I accidentally broke this in e41e9865. Prior to this commit, \&foo was becoming srefgen and \(&foo) was becoming refgen. Srefgen is a slightly faster version of refgen that only han- dles one item. The easiest fix was to change the logic in op.c:ck_spair so that \(&sub) with parens becomes srefgen. M op.c M t/comp/proto.t ----------------------------------------------------------------------- Summary of changes: op.c | 15 +++++++++++---- t/comp/proto.t | 18 +++++++++++++++++- 2 files changed, 28 insertions(+), 5 deletions(-) diff --git a/op.c b/op.c index 6489267..0d8463c 100644 --- a/op.c +++ b/op.c @@ -9358,10 +9358,11 @@ Perl_ck_spair(pTHX_ OP *o) const OPCODE type = newop->op_type; if (OP_HAS_SIBLING(newop)) return o; - if (o->op_type == OP_REFGEN && !(newop->op_flags & OPf_PARENS) - && (type == OP_RV2AV || type == OP_PADAV - || type == OP_RV2HV || type == OP_PADHV - || type == OP_RV2CV)) + if (o->op_type == OP_REFGEN + && ( type == OP_RV2CV + || ( !(newop->op_flags & OPf_PARENS) + && ( type == OP_RV2AV || type == OP_PADAV + || type == OP_RV2HV || type == OP_PADHV)))) NOOP; /* OK (allow srefgen for \@a and \%h) */ else if (!(PL_opargs[type] & OA_RETSCALAR)) return o; @@ -11254,14 +11255,20 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) case '@': if (o3->op_type == OP_RV2AV || o3->op_type == OP_PADAV) + { + o3->op_flags &=~ OPf_PARENS; goto wrapref; + } if (!contextclass) bad_type_gv(arg, "array", namegv, 0, o3); break; case '%': if (o3->op_type == OP_RV2HV || o3->op_type == OP_PADHV) + { + o3->op_flags &=~ OPf_PARENS; goto wrapref; + } if (!contextclass) bad_type_gv(arg, "hash", namegv, 0, o3); break; diff --git a/t/comp/proto.t b/t/comp/proto.t index 0858160..34c998e 100644 --- a/t/comp/proto.t +++ b/t/comp/proto.t @@ -18,7 +18,7 @@ BEGIN { # strict use strict; -print "1..206\n"; +print "1..211\n"; my $i = 1; @@ -285,6 +285,7 @@ sub tmp_sub_1 { printf "ok %d\n",$i++ } a_sub { printf "ok %d\n",$i++ }; a_sub \&tmp_sub_1; +a_sub \(&tmp_sub_1); @array = ( \&tmp_sub_1 ); eval 'a_sub @array'; @@ -395,6 +396,11 @@ a_hash_ref %hash; print "not " unless $hash{'b'} == 2; printf "ok %d\n",$i++; +%hash = ( a => 1); +a_hash_ref +(%hash); +print "not " unless $hash{'b'} == 2; +printf "ok %d\n",$i++; + ## ## ## @@ -414,6 +420,16 @@ sub array_ref_plus (\@@) { print "not " unless @array == 4; print @array; +@array = ('a'); +{ my @more = ('x'); + array_ref_plus +(@array), @more; } +print "not " unless @array == 4; +print @array; + +## +## +## + my $p; print "not " if defined prototype('CORE::print'); print "ok ", $i++, "\n"; -- Perl5 Master Repository
