This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Subroutine reference assignment
authorFather Chrysostomos <sprout@cpan.org>
Thu, 2 Oct 2014 03:00:10 +0000 (20:00 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Sat, 11 Oct 2014 07:10:15 +0000 (00:10 -0700)
op.c
t/op/lvref.t

diff --git a/op.c b/op.c
index 9e4e8d9..5cafa05 100644 (file)
--- a/op.c
+++ b/op.c
@@ -2366,6 +2366,21 @@ S_lvref(pTHX_ OP *o)
        }
        o->op_private |= OPpLVREF_AV;
        goto checkgv;
+    case OP_RV2CV:
+       kid = cUNOPx(cUNOPx(cUNOPo->op_first)->op_first->op_sibling)
+               ->op_first;
+       o->op_private = OPpLVREF_CV;
+       if (kid->op_type == OP_GV)
+           o->op_flags |= OPf_STACKED;
+       else if (kid->op_type == OP_PADCV) {
+           o->op_targ = kid->op_targ;
+           kid->op_targ = 0;
+           op_free(cUNOPo->op_first);
+           cUNOPo->op_first = NULL;
+           o->op_flags &=~ OPf_KIDS;
+       }
+       else goto badref;
+       break;
     case OP_RV2HV:
        if (o->op_flags & OPf_PARENS) {
          parenhash:
@@ -10042,6 +10057,17 @@ Perl_ck_refassign(pTHX_ OP *o)
       checkgv:
        if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
        goto null_and_stack;
+    case OP_RV2CV: {
+       OP * const kid =
+           cUNOPx(cUNOPx(cUNOPx(varop)->op_first)->op_first->op_sibling)
+               ->op_first;
+       o->op_private = OPpLVREF_CV;
+       if (kid->op_type == OP_GV)      goto null_and_stack;
+       if (kid->op_type != OP_PADCV)   goto bad;
+       o->op_targ = kid->op_targ;
+       kid->op_targ = 0;
+       break;
+    }
     case OP_AELEM:
     case OP_HELEM:
        o->op_private = OPpLVREF_ELEM;
index 50268a5..bfdd737 100644 (file)
@@ -4,7 +4,7 @@ BEGIN {
     set_up_inc("../lib");
 }
 
-plan 111;
+plan 124;
 
 sub on { $::TODO = ' ' }
 sub off{ $::TODO = ''  }
@@ -232,7 +232,37 @@ package HashTest {
 
 # Subroutines
 
-# ...
+package CodeTest {
+  BEGIN { *is = *main::is; }
+  use feature 'lexical_subs', 'state';
+  no warnings 'experimental::lexical_subs';
+  sub expect_scalar_cx { wantarray ? 0 : \&ThatSub }
+  sub expect_list_cx   { wantarray ? (\&ThatSub)x2 : 0 }
+  \&a = expect_scalar_cx;
+  is \&a, \&ThatSub, '\&pkg';
+  my sub a;
+  \&a = expect_scalar_cx;
+  is \&a, \&ThatSub, '\&mysub';
+  state sub as;
+  \&as = expect_scalar_cx;
+  is \&as, \&ThatSub, '\&statesub';
+  (\&b) = expect_list_cx;
+  is \&b, \&ThatSub, '(\&pkg)';
+  my sub b;
+  (\&b) = expect_list_cx;
+  is \&b, \&ThatSub, '(\&mysub)';
+  my sub bs;
+  (\&bs) = expect_list_cx;
+  is \&bs, \&ThatSub, '(\&statesub)';
+  \(&c) = expect_list_cx;
+  is \&c, \&ThatSub, '\(&pkg)';
+  my sub b;
+  \(&c) = expect_list_cx;
+  is \&c, \&ThatSub, '\(&mysub)';
+  my sub bs;
+  \(&cs) = expect_list_cx;
+  is \&cs, \&ThatSub, '\(&statesub)';
+}
 
 # Mixed List Assignments
 
@@ -310,6 +340,14 @@ like $@, qr/^Assigned value is not a HASH reference at/,
 eval { \%::x = [] };
 like $@, qr/^Assigned value is not a HASH reference at/,
     'assigning non-hash ref to package hash ref';
+eval { use feature 'lexical_subs';
+       no warnings 'experimental::lexical_subs';
+       my sub x; \&x = [] };
+like $@, qr/^Assigned value is not a CODE reference at/,
+    'assigning non-code ref to lexical code ref';
+eval { \&::x = [] };
+like $@, qr/^Assigned value is not a CODE reference at/,
+    'assigning non-code ref to package code ref';
 
 eval { my $x; (\$x) = 3 };
 like $@, qr/^Assigned value is not a reference at/,
@@ -332,6 +370,14 @@ like $@, qr/^Assigned value is not a HASH reference at/,
 eval { (\%::x) = [] };
 like $@, qr/^Assigned value is not a HASH reference at/,
     'list-assigning non-hash ref to package hash ref';
+eval { use feature 'lexical_subs';
+       no warnings 'experimental::lexical_subs';
+       my sub x; (\&x) = [] };
+like $@, qr/^Assigned value is not a CODE reference at/,
+    'list-assigning non-code ref to lexical code ref';
+eval { (\&::x) = [] };
+like $@, qr/^Assigned value is not a CODE reference at/,
+    'list-assigning non-code ref to package code ref';
 
 eval '(\do{}) = 42';
 like $@, qr/^Can't modify reference to do block in list assignment at /,