[libmoo-perl] 19/43: make has +attr in roles consistent with classes

[gregor herrmann]

This is an automated email from the git hooks/post-receive script.

gregoa pushed a commit to branch master
in repository libmoo-perl.

commit c57ed0008cc7a3f22ceb7120166697171b4a8794
Author: Graham Knop <haarg at haarg.org>
Date:   Sun Nov 27 14:33:24 2016 -0500

    make has +attr in roles consistent with classes
    
    has '+attr' should be prohibited if the attribute doesn't exist, and it
    should properly merge with the existing attribute spec.
---
 lib/Moo/Role.pm    | 18 +++++++++++++++---
 t/accessor-roles.t |  2 +-
 t/has-plus.t       | 25 +++++++++++++++++++++++++
 3 files changed, 41 insertions(+), 4 deletions(-)

diff --git a/lib/Moo/Role.pm b/lib/Moo/Role.pm
index 5859956..bbc1d37 100644
--- a/lib/Moo/Role.pm
+++ b/lib/Moo/Role.pm
@@ -71,11 +71,23 @@ sub _install_subs {
     my %spec = @_;
     foreach my $name (@name_proto) {
       my $spec_ref = @name_proto > 1 ? +{%spec} : \%spec;
-      ($INFO{$target}{accessor_maker} ||= do {
+      my $ag = $INFO{$target}{accessor_maker} ||= do {
         require Method::Generate::Accessor;
         Method::Generate::Accessor->new
-      })->generate_method($target, $name, $spec_ref);
-      push @{$INFO{$target}{attributes}||=[]}, $name, $spec_ref;
+      };
+      my $attrs = $INFO{$target}{attributes}||=[];
+      if ($name =~ /^\+(.*)/) {
+        my $attr_name = $1;
+        my ($old_spec) =
+          map $attrs->[$_+1],
+          grep $attrs->[$_] eq $attr_name,
+          0 .. @$attrs/2 - 1;
+        croak "has '${name}' given but no ${attr_name} attribute already exists"
+          unless $old_spec;
+        $ag->merge_specs($spec_ref, $old_spec);
+      }
+      $ag->generate_method($target, $name, $spec_ref);
+      push @$attrs, $name, $spec_ref;
       $me->_maybe_reset_handlemoose($target);
     }
   };
diff --git a/t/accessor-roles.t b/t/accessor-roles.t
index 51ffb31..1546ebf 100644
--- a/t/accessor-roles.t
+++ b/t/accessor-roles.t
@@ -15,7 +15,7 @@ use Sub::Quote;
   has four => (is => 'ro', lazy => 1, default => sub { 'four' }, predicate => 1);
 
   package One::P3; use Moo::Role;
-  has '+three' => (is => 'ro', default => sub { 'three' });
+  has 'three' => (is => 'ro', default => sub { 'three' });
 }
 
 my $combined = Moo::Role->create_class_with_roles('One', qw(One::P1 One::P2));
diff --git a/t/has-plus.t b/t/has-plus.t
index 1287a20..27c65cf 100644
--- a/t/has-plus.t
+++ b/t/has-plus.t
@@ -48,6 +48,22 @@ use Test::Fatal;
 }
 
 {
+  package RoleWithTheRole;
+  use Moo::Role;
+
+  with 'RollyRole';
+
+  has '+f' => (default => sub { 4 });
+}
+
+{
+  package UsesTheOtherRole;
+  use Moo;
+
+  with 'RoleWithTheRole';
+}
+
+{
   package BlowsUp;
 
   use Moo;
@@ -56,6 +72,14 @@ use Test::Fatal;
 }
 
 {
+  package RoleBlowsUp;
+
+  use Moo::Role;
+
+  ::like(::exception { has '+f' => () }, qr/\Qhas '+f'/, 'Kaboom');
+}
+
+{
   package ClassyClass2;
   use Moo;
   has d => (is => 'ro', default => sub { 4 });
@@ -78,5 +102,6 @@ is(UsesTheRole->new->f, 0, 'role attr');
 is(ClassyClass->new->f, 1, 'class attr');
 is(UsesTheRole2->new->f, 2, 'role attr with +');
 is(ExtendsTheClass->new->f, 3, 'class attr with +');
+is(UsesTheOtherRole->new->f, 4, 'role attr with + in role');
 
 done_testing;

-- 
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libmoo-perl.git