In perl.git, the branch sprout/lvref has been updated <http://perl5.git.perl.org/perl.git/commitdiff/e6ae93c9cb0667b2f26de8fa96fbf1343aee7af4?hp=0a9766e8a6f9373260d64d378260e354f4557aeb>
- Log ----------------------------------------------------------------- commit e6ae93c9cb0667b2f26de8fa96fbf1343aee7af4 Author: Father Chrysostomos <[email protected]> Date: Sun Sep 28 22:17:27 2014 -0700 Assignment to \local @array and \local %hash Doesnât work with lhs parentheses yet. M pp.c M t/op/lvref.t commit ac81778aa4ab19d329688d1a6974f7c8eac8ef39 Author: Father Chrysostomos <[email protected]> Date: Sun Sep 28 11:45:57 2014 -0700 lvref.t: Tests for localised arrays and hashes M t/op/lvref.t commit cd6db18d0dc323bbc34eb2dff7bbebfe53745248 Author: Father Chrysostomos <[email protected]> Date: Sun Sep 28 00:53:19 2014 -0700 lvref.t: Test assigning non-array to array Same with hashes. M t/op/lvref.t commit 327fe1a7701006379baea7bac2280843271e0bce Author: Father Chrysostomos <[email protected]> Date: Sun Sep 28 00:52:45 2014 -0700 Simple \@array and \%hash assignment Parentheses do not work yet. Neither does local. M op.c M pp.c M t/op/lvref.t commit 2a22ba42a61aad5d908603a78adac7625b6d2786 Author: Father Chrysostomos <[email protected]> Date: Sun Sep 28 00:42:09 2014 -0700 lvref.t: To-do tests for hashes Concerning the error message tests, âparenthesized hashâ would be more helpful than âhash dereferenceâ or âprivate hashâ (as would be provided by OP_DESC), as %foo doesnât look like a hash dereference and âprivate hashâ suggests that \%foo= wonât work, whereas it will. M t/op/lvref.t ----------------------------------------------------------------------- Summary of changes: op.c | 21 +++++++++++-- pp.c | 41 +++++++++++++++++++++--- t/op/lvref.t | 101 +++++++++++++++++++++++++++++++++++++++++++++++++++++++---- 3 files changed, 150 insertions(+), 13 deletions(-) diff --git a/op.c b/op.c index 4738a7d..4841bcf 100644 --- a/op.c +++ b/op.c @@ -5648,9 +5648,14 @@ S_assignment_type(pTHX_ const OP *o) if (type == OP_SREFGEN) { + OP * const kid = cUNOPx(cUNOPo->op_first)->op_first; + type = kid->op_type; + flags |= kid->op_flags; + if (!(flags & OPf_PARENS) + && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV || + kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV )) + return ASSIGN_REF; ret = ASSIGN_REF; - type = cUNOPx(cUNOPo->op_first)->op_first->op_type; - flags |= cUNOPx(cUNOPo->op_first)->op_first->op_flags; } else ret = 0; @@ -9759,11 +9764,23 @@ Perl_ck_sbind(pTHX_ OP *o) assert (left->op_type == OP_SREFGEN); switch (varop->op_type) { + case OP_PADAV: + o->op_private = OPpLVREF_AV; + goto settarg; + case OP_PADHV: + o->op_private = OPpLVREF_HV; case OP_PADSV: + settarg: o->op_targ = varop->op_targ; varop->op_targ = 0; break; + case OP_RV2AV: + o->op_private = OPpLVREF_AV; + goto checkgv; + case OP_RV2HV: + o->op_private = OPpLVREF_HV; case OP_RV2SV: + checkgv: if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad; goto null_and_stack; case OP_AELEM: diff --git a/pp.c b/pp.c index 9df9eb9..cba31b9 100644 --- a/pp.c +++ b/pp.c @@ -6188,10 +6188,29 @@ PP(pp_sbind) SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL; SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL; dTOPss; + const char *bad = NULL; + const U8 type = PL_op->op_private & OPpLVREF_TYPE; if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference"); - if (SvTYPE(SvRV(sv)) > SVt_PVLV) + switch (type) { + case OPpLVREF_SV: + if (SvTYPE(SvRV(sv)) > SVt_PVLV) + bad = " SCALAR"; + break; + case OPpLVREF_AV: + if (SvTYPE(SvRV(sv)) != SVt_PVAV) + bad = "n ARRAY"; + break; + case OPpLVREF_HV: + if (SvTYPE(SvRV(sv)) != SVt_PVHV) + bad = " HASH"; + break; + case OPpLVREF_CV: + if (SvTYPE(SvRV(sv)) != SVt_PVCV) + bad = " CODE"; + } + if (bad) /* diag_listed_as: Assigned value is not %s reference */ - DIE(aTHX_ "Assigned value is not a SCALAR reference"); + DIE(aTHX_ "Assigned value is not a%s reference", bad); switch (left ? SvTYPE(left) : 0) { MAGIC *mg; HV *stash; @@ -6206,9 +6225,21 @@ PP(pp_sbind) } case SVt_PVGV: if (PL_op->op_private & OPpLVAL_INTRO) { - save_pushptrptr((GV *)left, SvREFCNT_inc_simple(GvSV(left)), - SAVEt_GVSV); - GvSV(left) = 0; + if (type == OPpLVREF_SV) { + save_pushptrptr((GV *)left, + SvREFCNT_inc_simple(GvSV(left)), + SAVEt_GVSV); + GvSV(left) = 0; + } + else if (type == OPpLVREF_AV) + /* XXX Inefficient, as it creates a new AV, which we are + about to clobber. */ + save_ary((GV *)left); + else { + assert(type == OPpLVREF_HV); + /* XXX Likewise inefficient. */ + save_hash((GV *)left); + } } gv_setref(left, sv); SvSETMAGIC(left); diff --git a/t/op/lvref.t b/t/op/lvref.t index ff01717..0a10921 100644 --- a/t/op/lvref.t +++ b/t/op/lvref.t @@ -4,7 +4,7 @@ BEGIN { set_up_inc("../lib"); } -plan 78; +plan 102; sub on { $::TODO = ' ' } sub off{ $::TODO = '' } @@ -154,7 +154,6 @@ is \$h{b}, \$_, '\($hash{a})'; # Arrays -on; package ArrayTest { BEGIN { *is = *main::is } sub expect_scalar_cx { wantarray ? 0 : \@ThatArray } @@ -163,15 +162,18 @@ package ArrayTest { eval '\@a = expect_scalar_cx'; is \@a, \@ThatArray, '\@pkg'; my @a; - eval '\@a = expect_scalar_cx'; + \@a = expect_scalar_cx; is \@a, \@ThatArray, '\@lexical'; +::on; eval '(\@b) = expect_list_cx_a'; is \@b, \@ThatArray, '(\@pkg)'; my @b; eval '(\@b) = expect_list_cx_a'; is \@b, \@ThatArray, '(\@lexical)'; - eval '\my @c = expect_scalar_cx'; +::off; + \my @c = expect_scalar_cx; is \@c, \@ThatArray, '\my @lexical'; +::on; eval '(\my @d) = expect_list_cx_a'; is \@d, \@ThatArray, '(\my @lexical)'; eval '\(@e) = expect_list_cx'; @@ -183,12 +185,58 @@ package ArrayTest { is \$f[0].$f[1], \$_.\$_, '\(my @lexical)'; eval '\my(@g) = expect_list_cx'; is \$g[0].$g[1], \$_.\$_, '\my(@lexical)'; + my $old = \@h; +::off; + { + \local @h = \@ThatArray; + is \@h, \@ThatArray, '\local @a'; + } + is \@h, $old, '\local @a unwound'; + $old = \@i; + eval q{ + (\local @i) = \@ThatArray; + is \@i, \@ThatArray, '(\local @a)'; + } or do { SKIP: { ::skip 'unimplemented' } }; + is \@i, $old, '(\local @a) unwound'; } -off; # Hashes -# ... +package HashTest { + BEGIN { *is = *main::is } + sub expect_scalar_cx { wantarray ? 0 : \%ThatHash } + sub expect_list_cx { wantarray ? (\%ThatHash)x2 : 0 } + \%a = expect_scalar_cx; + is \%a, \%ThatHash, '\%pkg'; + my %a; + \%a = expect_scalar_cx; + is \%a, \%ThatHash, '\%lexical'; +::on; + eval '(\%b) = expect_list_cx'; + is \%b, \%ThatArray, '(\%pkg)'; + my %b; + eval '(\%b) = expect_list_cx'; + is \%b, \%ThatHash, '(\%lexical)'; +::off; + \my %c = expect_scalar_cx; + is \%c, \%ThatHash, '\my %lexical'; +::on; + eval '(\my %d) = expect_list_cx'; + is \%d, \%ThatHash, '(\my %lexical)'; + my $old = \%h; +::off; + { + \local %h = \%ThatHash; + is \%h, \%ThatHash, '\local %a'; + } + is \%h, $old, '\local %a unwound'; + $old = \%i; + eval q{ + (\local %i) = \%ThatHash; + is \%i, \%ThatHash, '(\local %a)'; + } or do { SKIP: { ::skip 'unimplemented' } }; + is \%i, $old, '(\local %a) unwound'; +} # Subroutines @@ -256,6 +304,18 @@ like $@, qr/^Assigned value is not a SCALAR reference at/, eval { \$::x = [] }; like $@, qr/^Assigned value is not a SCALAR reference at/, 'assigning non-scalar ref to package scalar ref'; +eval { my @x; \@x = {} }; +like $@, qr/^Assigned value is not an ARRAY reference at/, + 'assigning non-array ref to array ref'; +eval { \@::x = {} }; +like $@, qr/^Assigned value is not an ARRAY reference at/, + 'assigning non-array ref to package array ref'; +eval { my %x; \%x = [] }; +like $@, qr/^Assigned value is not a HASH reference at/, + 'assigning non-hash ref to hash ref'; +eval { \%::x = [] }; +like $@, qr/^Assigned value is not a HASH reference at/, + 'assigning non-hash ref to package hash ref'; on; eval '(\do{}) = 42'; @@ -275,6 +335,35 @@ like $@, qr/^Can't modify reference to match position in scalar assignment at /, "Can't modify ref to some scalar-returning op in scalar assignment"; on; +eval '\(local @b) = 42'; +like $@, + qr/^Can't modify reference to parenthesized localized array in list(?x: + ) assignment at /, + q"Can't modify \(local @array) in list assignment"; +eval '\local(@b) = 42'; +like $@, + qr/^Can't modify reference to parenthesized localized array in list(?x: + ) assignment at /, + q"Can't modify \local(@array) in list assignment"; +eval '\(%b) = 42'; +like $@, + qr/^Can't modify reference to parenthesized hash in list assignment a/, + "Can't modify ref to parenthesized package hash in scalar assignment"; +eval '\(my %b) = 42'; +like $@, + qr/^Can't modify reference to parenthesized hash in list assignment a/, + "Can't modify ref to parenthesized hash (\(my %b)) in list assignment"; +eval '\my(%b) = 42'; +like $@, + qr/^Can't modify reference to parenthesized hash in list assignment a/, + "Can't modify ref to parenthesized hash (\my(%b)) in list assignment"; +off; +eval '\%{"42"} = 42'; +like $@, + qr/^Can't modify reference to hash dereference in scalar assignment a/, + "Can't modify reference to hash dereference in scalar assignment"; +on; + # Miscellaneous -- Perl5 Master Repository
