diff -urN Role-Tiny-1.001005/Changes Role-Tiny-dev/Changes --- Role-Tiny-1.001005/Changes 2012-07-18 12:32:37.000000000 +0100 +++ Role-Tiny-dev/Changes 2012-10-04 00:41:28.098074807 +0100 @@ -1,3 +1,7 @@ +1.001006 - 2012-??-?? + - when classes consume roles, override their DOES method + - method modifiers can be used for 'does' and 'DOES' + 1.001005 - 2012-07-18 - localize UNIVERSAL::can change to avoid confusing TB2 - properly report roles consumed by superclasses diff -urN Role-Tiny-1.001005/lib/Role/Tiny.pm Role-Tiny-dev/lib/Role/Tiny.pm --- Role-Tiny-1.001005/lib/Role/Tiny.pm 2012-07-18 12:28:30.000000000 +0100 +++ Role-Tiny-dev/lib/Role/Tiny.pm 2012-10-04 00:39:06.275832518 +0100 @@ -13,6 +13,7 @@ our %APPLIED_TO; our %COMPOSED; our %COMPOSITE_INFO; +our %I_MADE_THIS_SUB; # Module state workaround totally stolen from Zefram's Module::Runtime. @@ -86,11 +87,6 @@ $me->_install_modifiers($to, $info->{modifiers}); - # only add does() method to classes and only if they don't have one - if (not $INFO{$to} and not $to->can('does')) { - *{_getglob "${to}::does"} = \&does_role; - } - # copy our role list into the target's @{$APPLIED_TO{$to}||={}}{keys %{$APPLIED_TO{$role}}} = (); } @@ -156,8 +152,6 @@ do { my %h; @h{map @{$_->{requires}||[]}, @info} = (); keys %h } ); - *{_getglob "${new_name}::does"} = \&does_role unless $new_name->can('does'); - @{$APPLIED_TO{$new_name}||={}}{ map keys %{$APPLIED_TO{$_}}, @roles } = (); @@ -297,6 +291,8 @@ no warnings 'once'; *{_getglob "${to}::${i}"} = $methods->{$i}; } + + $me->_install_does($to); } sub _install_modifiers { @@ -315,6 +311,30 @@ Class::Method::Modifiers::install_modifier(@args); } +sub _install_does { + my ($me, $to) = @_; + + # only add does() method to classes + return if $INFO{$to}; + + # add does() only if they don't have one + *{_getglob "${to}::does"} = \&does_role unless $to->can('does'); + + # if the class already has a DOES method that was manufactured by + # Role::Tiny, then it can remain in place + my $existing = $to->can('DOES') || $to->can('isa') || UNIVERSAL->can('isa'); + return if $I_MADE_THIS_SUB{ "$existing" }; + + my $new_sub = sub { + my ($proto, $role) = @_; + Role::Tiny::does_role($proto, $role) or $proto->$existing($role); + }; + $I_MADE_THIS_SUB{ "$new_sub" }++; + + no warnings 'redefine'; + *{_getglob "${to}::DOES"} = $new_sub; +} + sub does_role { my ($proto, $role) = @_; if ($] >= 5.010) { @@ -473,7 +493,11 @@ ... } -will work for classes but to test a role, one must use ::does_role directly +will work for classes but to test a role, one must use ::does_role directly. + +Additionally, Role::Tiny will override the standard Perl C method +for your class. If your class provides its own C method, this will +be I with Role::Tiny's C. =head1 METHODS @@ -539,6 +563,8 @@ ilmari - Dagfinn Ilmari Mannsåker (cpan:ILMARI) +tobyink - Toby Inkster (cpan:TOBYINK) + =head1 COPYRIGHT Copyright (c) 2010-2012 the Role::Tiny L and L diff -urN Role-Tiny-1.001005/t/around-does.t Role-Tiny-dev/t/around-does.t --- Role-Tiny-1.001005/t/around-does.t 1970-01-01 01:00:00.000000000 +0100 +++ Role-Tiny-dev/t/around-does.t 2012-10-04 00:40:03.870073528 +0100 @@ -0,0 +1,31 @@ +use Test::More; + +my $pass; +my $pass2; + +BEGIN { + package Local::Role; + use Role::Tiny; + around does => sub { + my ($orig, $self, @args) = @_; + $pass++; + return $self->$orig(@args); + }; + around DOES => sub { + my ($orig, $self, @args) = @_; + $pass2++; + return $self->$orig(@args); + }; +} + +BEGIN { + package Local::Class; + use Role::Tiny::With; + with 'Local::Role'; +} + +ok(Local::Class->does('Local::Role')); +ok($pass); +ok(Local::Class->DOES('Local::Role')); +ok($pass2); +done_testing(); \ No newline at end of file diff -urN Role-Tiny-1.001005/t/does.t Role-Tiny-dev/t/does.t --- Role-Tiny-1.001005/t/does.t 1970-01-01 01:00:00.000000000 +0100 +++ Role-Tiny-dev/t/does.t 2012-10-03 21:54:53.207071823 +0100 @@ -0,0 +1,75 @@ +use Test::More tests => 16; + +BEGIN { + package Local::Role1; + use Role::Tiny; +} + +BEGIN { + package Local::Role2; + use Role::Tiny; +} + +BEGIN { + package Local::Class1; + use Role::Tiny::With; + with qw( + Local::Role1 + Local::Role2 + ); +} + +BEGIN { + package Local::Class2; + use Role::Tiny::With; + with qw( Local::Role1 ); + with qw( Local::Role2 ); +} + +BEGIN { + package Local::Class3; + use Role::Tiny::With; + with qw( Local::Role1 ); + with qw( Local::Role2 ); + sub DOES { + my ($proto, $role) = @_; + return 1 if $role eq 'Local::Role3'; + return $self->SUPER::DOES($role); + } +} + +for my $c (1 .. 3) { + my $class = "Local::Class$c"; + for my $r (1 .. 2) { + my $role = "Local::Role$r"; + ok($class->does($role), "$class\->does($role)"); + ok($class->DOES($role), "$class\->DOES($role)"); + } +} + +{ + my $class = "Local::Class3"; + my $role = "Local::Role3"; + ok( ! $class->does($role), "$class\->does($role)"); + ok( $class->DOES($role), "$class\->DOES($role)"); +} + +my @refs; +{ + package Local::Class4; + use Role::Tiny::With; + push @refs, __PACKAGE__->can('DOES'); + with qw( Local::Role1 ); + push @refs, __PACKAGE__->can('DOES'); + with qw( Local::Role2 ); + push @refs, __PACKAGE__->can('DOES'); + sub DOES { + my ($proto, $role) = @_; + return 1 if $role eq 'Local::Role3'; + return $self->SUPER::DOES($role); + } +} + +isnt($refs[0], $refs[1], "with installs a DOES method"); +is($refs[1], $refs[2], "with skips installing DOES method if it would be unnecessary"); +