From: Matt S Trout Date: Sun, 8 Apr 2012 19:13:54 +0000 (+0000) Subject: basic role composition support X-Git-Tag: v1.000_900~13 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=60dfe768e64a52bf2245361c2da546c45567553b;p=gitmo%2FRole-Tiny.git basic role composition support --- diff --git a/lib/Role/Tiny.pm b/lib/Role/Tiny.pm index 4962d1c..fce2018 100644 --- 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 --- 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 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;