This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Assignment to \(@array)
authorFather Chrysostomos <sprout@cpan.org>
Tue, 30 Sep 2014 05:21:21 +0000 (22:21 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Sat, 11 Oct 2014 07:10:13 +0000 (00:10 -0700)
This is a slurpy lvalue that gobbles up all the rhs elements, which
are expected to be references.  So \(@a)=\(@b) makes @a share the
same elements as @b.

We implement this by pushing a null on to the stack as a special
marker that pp_aassign will recognise.

I decided to change the wording for the \local(@a)=... error
slightly, from what my to-do tests had.

Some of the other to-do tests were badly written and had to be
fixed up a bit.

op.c
pp.c
pp_hot.c
t/op/lvref.t

diff --git a/op.c b/op.c
index 1e1799a..dfe09dc 100644 (file)
--- a/op.c
+++ b/op.c
@@ -2641,8 +2641,22 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
         kid_2lvref:
          switch (kid->op_type) {
          case OP_RV2AV:
+           if (kUNOP->op_first->op_type != OP_GV) goto badref;
+           kid->op_flags |= OPf_STACKED;
            if (kid->op_flags & OPf_PARENS) {
-               goto badref; /* XXX temporary */
+               if (kid->op_private & OPpLVAL_INTRO) {
+                    /* diag_listed_as: Can't modify %s in %s */
+                    yyerror(Perl_form(aTHX_ "Can't modify reference to "
+                                            "localized parenthesized "
+                                            "array in list assignment"));
+                   return o;
+               }
+             slurpy:
+               kid->op_type = OP_LVAVREF;
+               kid->op_ppaddr = PL_ppaddr[OP_LVAVREF];
+               kid->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
+               kid->op_flags |= OPf_MOD|OPf_REF;
+               continue;
            }
            kid->op_private |= OPpLVREF_AV;
            goto checkgv;
@@ -2662,6 +2676,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
          case OP_PADSV:
            break;
          case OP_PADAV:
+           if (kid->op_flags & OPf_PARENS) goto slurpy;
            kid->op_private |= OPpLVREF_AV;
            break;
          case OP_PADHV:
diff --git a/pp.c b/pp.c
index 04e372c..3ca98cc 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -62,6 +62,7 @@ PP(pp_stub)
 
 /* Pushy stuff. */
 
+/* This is also called directly by pp_lvavref.  */
 PP(pp_padav)
 {
     dSP; dTARGET;
@@ -6349,7 +6350,17 @@ PP(pp_lvrefslice)
 
 PP(pp_lvavref)
 {
-    DIE(aTHX_ "Unimplemented");
+    if (PL_op->op_flags & OPf_STACKED)
+       Perl_pp_rv2av(aTHX);
+    else
+       Perl_pp_padav(aTHX);
+    {
+       dSP;
+       dTOPss;
+       SETs(0); /* special alias marker that aassign recognises */
+       XPUSHs(sv);
+       RETURN;
+    }
 }
 
 /*
index 1d67379..84e934e 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -886,6 +886,7 @@ PP(pp_print)
 
 
 /* also used for: pp_rv2hv() */
+/* also called directly by pp_lvavref */
 
 PP(pp_rv2av)
 {
@@ -893,7 +894,8 @@ PP(pp_rv2av)
     const I32 gimme = GIMME_V;
     static const char an_array[] = "an ARRAY";
     static const char a_hash[] = "a HASH";
-    const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
+    const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV
+                         || PL_op->op_type == OP_LVAVREF;
     const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
 
     SvGETMAGIC(sv);
@@ -1071,8 +1073,14 @@ PP(pp_aassign)
     hash = NULL;
 
     while (LIKELY(lelem <= lastlelem)) {
+       bool alias = FALSE;
        TAINT_NOT;              /* Each item stands on its own, taintwise. */
        sv = *lelem++;
+       if (UNLIKELY(!sv)) {
+           alias = TRUE;
+           sv = *lelem++;
+           ASSUME(SvTYPE(sv) == SVt_PVAV);
+       }
        switch (SvTYPE(sv)) {
        case SVt_PVAV:
            ary = MUTABLE_AV(sv);
@@ -1086,9 +1094,24 @@ PP(pp_aassign)
                SV **didstore;
                if (LIKELY(*relem))
                    SvGETMAGIC(*relem); /* before newSV, in case it dies */
-               sv = newSV(0);
-               sv_setsv_nomg(sv, *relem);
-               *(relem++) = sv;
+               if (LIKELY(!alias)) {
+                   sv = newSV(0);
+                   sv_setsv_nomg(sv, *relem);
+                   *relem = sv;
+               }
+               else {
+                   if (!SvROK(*relem))
+                       DIE(aTHX_ "Assigned value is not a reference");
+                   if (SvTYPE(SvRV(*relem)) > SVt_PVLV)
+                  /* diag_listed_as: Assigned value is not %s reference */
+                       DIE(aTHX_
+                          "Assigned value is not a SCALAR reference");
+                   if (lval)
+                       *relem = sv_mortalcopy(*relem);
+                   /* XXX else check for weak refs?  */
+                   sv = SvREFCNT_inc_simple_NN(SvRV(*relem));
+               }
+               relem++;
                didstore = av_store(ary,i++,sv);
                if (magic) {
                    if (!didstore)
index dc49edd..0e4a25d 100644 (file)
@@ -4,7 +4,7 @@ BEGIN {
     set_up_inc("../lib");
 }
 
-plan 102;
+plan 103;
 
 sub on { $::TODO = ' ' }
 sub off{ $::TODO = ''  }
@@ -171,20 +171,18 @@ package ArrayTest {
   is \@b, \@ThatArray, '(\@lexical)';
   \my @c = expect_scalar_cx;
   is \@c, \@ThatArray, '\my @lexical';
-::on;
-  eval '(\my @d) = expect_list_cx_a';
+  (\my @d) = expect_list_cx_a;
   is \@d, \@ThatArray, '(\my @lexical)';
-  eval '\(@e) = expect_list_cx';
-  is \$e[0].$e[1], \$_.\$_, '\(@pkg)';
+  \(@e) = expect_list_cx;
+  is \$e[0].\$e[1], \$_.\$_, '\(@pkg)';
   my @e;
-  eval '\(@e) = expect_list_cx';
-  is \$e[0].$e[1], \$_.\$_, '\(@lexical)';
-  eval '\(my @f) = expect_list_cx';
-  is \$f[0].$f[1], \$_.\$_, '\(my @lexical)';
-  eval '\my(@g) = expect_list_cx';
-  is \$g[0].$g[1], \$_.\$_, '\my(@lexical)';
+  \(@e) = expect_list_cx;
+  is \$e[0].\$e[1], \$_.\$_, '\(@lexical)';
+  \(my @f) = expect_list_cx;
+  is \$f[0].\$f[1], \$_.\$_, '\(my @lexical)';
+  \my(@g) = expect_list_cx;
+  is \$g[0].\$g[1], \$_.\$_, '\my(@lexical)';
   my $old = \@h;
-::off;
   {
     \local @h = \@ThatArray;
     is \@h, \@ThatArray, '\local @a';
@@ -328,18 +326,20 @@ eval '\pos = 42';
 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:
+    qr/^Can't modify reference to localized parenthesized 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:
+    qr/^Can't modify reference to localized parenthesized array in list(?x:
       ) assignment at /,
    q"Can't modify \local(@array) in list assignment";
-off;
+eval '\local(@{foo()}) = 42';
+like $@,
+    qr/^Can't modify reference to array dereference in list assignment at/,
+   q"'Array deref' error takes prec. over 'local paren' error";
 eval '\(%b) = 42';
 like $@,
     qr/^Can't modify reference to parenthesized hash in list assignment a/,