basic role composition support

diff --git a/lib/Role/Tiny.pm b/lib/Role/Tiny.pm
index 4962d1c..fce2018 100644 (file)
--- a/lib/Role/Tiny.pm
+++ b/lib/Role/Tiny.pm
@@ -56,8 +56,7 @@ sub import {
     push @{$INFO{$target}{requires}||=[]}, @_;
   };
   *{_getglob "${target}::with"} = sub {
-    die "Only one role supported at a time by with" if @_ > 1;
-    $me->apply_role_to_package($target, $_[0]);
+    $me->apply_union_of_roles_to_package($target, @_);
   };
   # grab all *non-constant* (stash slot is not a scalarref) subs present
   # in the symbol table and store their refaddrs (no need to forcibly
@@ -144,6 +143,29 @@ sub create_class_with_roles {
   return $new_name;
 }
 
+sub apply_union_of_roles_to_package {
+  my ($me, $to, @roles) = @_;
+
+  return $me->apply_role_to_package($to, $roles[0]) if @roles == 1;
+
+  _load_module($_) for @roles;
+  my %methods;
+  foreach my $role (@roles) {
+    my $this_methods = $me->_concrete_methods_of($role);
+    $methods{$_}{$this_methods->{$_}} = $role for keys %$this_methods;
+  }
+  delete $methods{$_} for grep keys(%{$methods{$_}}) == 1, keys %methods;
+  delete $methods{$_} for $me->_concrete_methods_of($to);
+  if (keys %methods) {
+    my $fail = 
+      join "\n",
+        map "$_ is provided by: ".join(', ', values %{$methods{$_}}),
+          keys %methods;
+    die "Conflict combining ".join(', ', @roles);
+  }
+  $me->apply_role_to_package($to, $_) for @roles;
+}
+
 sub _composable_package_for {
   my ($me, $role) = @_;
   my $composed_name = 'Role::Tiny::_COMPOSABLE::'.$role;
@@ -185,18 +207,16 @@ sub _check_requires {
 sub _concrete_methods_of {
   my ($me, $role) = @_;
   my $info = $INFO{$role};
-  $info->{methods} ||= do {
-    # grab role symbol table
-    my $stash = do { no strict 'refs'; \%{"${role}::"}};
-    my $not_methods = $info->{not_methods};
-    +{
-      # grab all code entries that aren't in the not_methods list
-      map {
-        my $code = *{$stash->{$_}}{CODE};
-        # rely on the '' key we added in import for "no code here"
-        exists $not_methods->{$code||''} ? () : ($_ => $code)
-      } grep !ref($stash->{$_}), keys %$stash
-    };
+  # grab role symbol table
+  my $stash = do { no strict 'refs'; \%{"${role}::"}};
+  my $not_methods = $info->{not_methods};
+  +{
+    # grab all code entries that aren't in the not_methods list
+    map {
+      my $code = *{$stash->{$_}}{CODE};
+      # rely on the '' key we added in import for "no code here"
+      exists $not_methods->{$code||''} ? () : ($_ => $code)
+    } grep !ref($stash->{$_}), keys %$stash
   };
 }
 

diff --git a/lib/Role/Tiny/With.pm b/lib/Role/Tiny/With.pm
index 5296486..0633de8 100644 (file)
--- a/lib/Role/Tiny/With.pm
+++ b/lib/Role/Tiny/With.pm
@@ -9,7 +9,7 @@ our @EXPORT = qw( with );
 
 sub with {
     my $target = caller;
-    Role::Tiny->apply_role_to_package($target, @_)
+    Role::Tiny->apply_union_of_roles_to_package($target, @_)
 }
 
 1;

diff --git a/t/role-basic/composition.t b/t/role-basic/composition.t
new file mode 100644 (file)
index 0000000..9b94a3c
--- /dev/null
+++ b/t/role-basic/composition.t
@@ -0,0 +1,126 @@
+#!/usr/bin/env perl
+
+use lib 'lib', 't/role-basic/lib';
+use MyTests;
+require Role::Tiny::Restricted;
+
+{
+
+    package My::Does::Basic1;
+    use Role::Tiny::Restricted;
+    requires 'turbo_charger';
+
+    sub method {
+        return __PACKAGE__ . " method";
+    }
+}
+{
+
+    package My::Does::Basic2;
+    use Role::Tiny::Restricted;
+    requires 'turbo_charger';
+
+    sub method2 {
+        return __PACKAGE__ . " method2";
+    }
+}
+
+eval <<'END_PACKAGE';
+package My::Class1;
+use Role::Tiny::Restricted 'with';
+with qw(
+    My::Does::Basic1
+    My::Does::Basic2
+);
+sub turbo_charger {}
+END_PACKAGE
+ok !$@, 'We should be able to use two roles with the same requirements'
+    or die $@;
+
+{
+
+    package My::Does::Basic3;
+    use Role::Tiny::Restricted;
+    with 'My::Does::Basic2';
+
+    sub method3 {
+        return __PACKAGE__ . " method3";
+    }
+}
+
+eval <<'END_PACKAGE';
+package My::Class2;
+use Role::Tiny::Restricted 'with';
+with qw(
+    My::Does::Basic3
+);
+sub new { bless {} => shift }
+sub turbo_charger {}
+END_PACKAGE
+ok !$@, 'We should be able to use roles which consume roles'
+    or die $@;
+can_ok 'My::Class2', 'method2';
+is My::Class2->method2, 'My::Does::Basic2 method2',
+  '... and it should be the correct method';
+can_ok 'My::Class2', 'method3';
+is My::Class2->method3, 'My::Does::Basic3 method3',
+  '... and it should be the correct method';
+
+ok My::Class2->Role::Tiny::does_role('My::Does::Basic3'), 'A class DOES roles which it consumes';
+ok My::Class2->Role::Tiny::does_role('My::Does::Basic2'),
+  '... and should do roles which its roles consumes';
+ok !My::Class2->Role::Tiny::does_role('My::Does::Basic1'),
+  '... but not roles which it never consumed';
+
+my $object = My::Class2->new;
+ok $object->Role::Tiny::does_role('My::Does::Basic3'), 'An instance DOES roles which its class consumes';
+ok $object->Role::Tiny::does_role('My::Does::Basic2'),
+  '... and should do roles which its roles consumes';
+ok !$object->Role::Tiny::does_role('My::Does::Basic1'),
+  '... but not roles which it never consumed';
+
+{
+    {
+        package Role::Which::Imports;
+        use Role::Tiny::Restricted allow => 'TestMethods';
+        use TestMethods qw(this that);
+    }
+    {
+       package Class::With::ImportingRole;
+       use Role::Tiny::Restricted 'with';
+       with 'Role::Which::Imports';
+       sub new { bless {} => shift }
+    }
+    my $o = Class::With::ImportingRole->new;
+
+    foreach my $method (qw/this that/) {
+        can_ok $o, $method;
+        ok $o->$method($method), '... and calling "allow"ed methods should succeed';
+        is $o->$method, $method, '... and it should function correctly';
+    }
+}
+
+{
+    {
+        package Role::WithImportsOnceRemoved;
+        use Role::Tiny::Restricted;
+        with 'Role::Which::Imports';
+    }
+    {
+        package Class::With::ImportingRole2;
+        use Role::Tiny::Restricted 'with';
+$ENV{DEBUG} = 1;
+        with 'Role::WithImportsOnceRemoved';
+        sub new { bless {} => shift }
+    }
+    ok my $o = Class::With::ImportingRole2->new,
+        'We should be able to use roles which compose roles which import';
+
+    foreach my $method (qw/this that/) {
+        can_ok $o, $method;
+        ok $o->$method($method), '... and calling "allow"ed methods should succeed';
+        is $o->$method, $method, '... and it should function correctly';
+    }
+}
+
+done_testing;