X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FRole%2FTiny.pm;h=07fb3d44cbde003db625eb13f2434ae3d8a7b972;hb=cca4fd3e2b7ba5b6b6bd615d4f46ae2aefffd27b;hp=b076c8e5398c3a8d8c5d645e70c5d7d280eab062;hpb=f656cac92a3274607aa97844ad90522110395e30;p=gitmo%2FRole-Tiny.git diff --git a/lib/Role/Tiny.pm b/lib/Role/Tiny.pm index b076c8e..07fb3d4 100644 --- a/lib/Role/Tiny.pm +++ b/lib/Role/Tiny.pm @@ -6,18 +6,20 @@ sub _getstash { \%{"$_[0]::"} } use strict; use warnings FATAL => 'all'; -our $VERSION = '1.002005'; # 1.2.5 +our $VERSION = '1.003002'; $VERSION = eval $VERSION; our %INFO; our %APPLIED_TO; our %COMPOSED; our %COMPOSITE_INFO; +our @ON_ROLE_CREATE; # Module state workaround totally stolen from Zefram's Module::Runtime. BEGIN { *_WORK_AROUND_BROKEN_MODULE_STATE = "$]" < 5.009 ? sub(){1} : sub(){0}; + *_MRO_MODULE = "$]" < 5.010 ? sub(){"MRO/Compat.pm"} : sub(){"mro.pm"}; } sub Role::Tiny::__GUARD__::DESTROY { @@ -43,7 +45,8 @@ sub import { my $me = shift; strict->import; warnings->import(FATAL => 'all'); - return if $INFO{$target}; # already exported into this package + return if $me->is_role($target); # already exported into this package + $INFO{$target}{is_role} = 1; # get symbol table reference my $stash = _getstash($target); # install before/after/around subs @@ -64,12 +67,17 @@ sub import { }; # grab all *non-constant* (stash slot is not a scalarref) subs present # in the symbol table and store their refaddrs (no need to forcibly - # inflate constant subs into real subs) - also add '' to here (this - # is used later) with a map to the coderefs in case of copying or re-use - my @not_methods = ('', map { *$_{CODE}||() } grep !ref($_), values %$stash); + # inflate constant subs into real subs) with a map to the coderefs in + # case of copying or re-use + my @not_methods = (map { *$_{CODE}||() } grep !ref($_), values %$stash); @{$INFO{$target}{not_methods}={}}{@not_methods} = @not_methods; # a role does itself $APPLIED_TO{$target} = { $target => undef }; + $_->($target) for @ON_ROLE_CREATE; +} + +sub role_application_steps { + qw(_install_methods _check_requires _install_modifiers _copy_applied_list); } sub apply_single_role_to_package { @@ -78,14 +86,15 @@ sub apply_single_role_to_package { _load_module($role); die "This is apply_role_to_package" if ref($to); - die "${role} is not a Role::Tiny" unless my $info = $INFO{$role}; - - $me->_check_requires($to, $role, @{$info->{requires}||[]}); - - $me->_install_methods($to, $role); + die "${role} is not a Role::Tiny" unless $me->is_role($role); - $me->_install_modifiers($to, $info->{modifiers}); + foreach my $step ($me->role_application_steps) { + $me->$step($to, $role); + } +} +sub _copy_applied_list { + my ($me, $to, $role) = @_; # copy our role list into the target's @{$APPLIED_TO{$to}||={}}{keys %{$APPLIED_TO{$role}}} = (); } @@ -94,8 +103,24 @@ sub apply_roles_to_object { my ($me, $object, @roles) = @_; die "No roles supplied!" unless @roles; my $class = ref($object); - bless($object, $me->create_class_with_roles($class, @roles)); - $object; + # on perl < 5.8.9, magic isn't copied to all ref copies. bless the parameter + # directly, so at least the variable passed to us will get any magic applied + bless($_[1], $me->create_class_with_roles($class, @roles)); +} + +my $role_suffix = 'A000'; +sub _composite_name { + my ($me, $superclass, @roles) = @_; + + my $new_name = join( + '__WITH__', $superclass, my $compose_name = join '__AND__', @roles + ); + + if (length($new_name) > 252) { + $new_name = $COMPOSED{abbrev}{$new_name} + ||= substr($new_name, 0, 250 - length $role_suffix).'__'.$role_suffix++; + } + return wantarray ? ($new_name, $compose_name) : $new_name; } sub create_class_with_roles { @@ -112,26 +137,21 @@ sub create_class_with_roles { } } - my $new_name = join( - '__WITH__', $superclass, my $compose_name = join '__AND__', @roles - ); + my ($new_name, $compose_name) = $me->_composite_name($superclass, @roles); return $new_name if $COMPOSED{class}{$new_name}; foreach my $role (@roles) { _load_module($role); - die "${role} is not a Role::Tiny" unless $INFO{$role}; + die "${role} is not a Role::Tiny" unless $me->is_role($role); } - if ($] >= 5.010) { - require mro; - } else { - require MRO::Compat; - } + require(_MRO_MODULE); - my %conflicts = %{$me->_composite_info_for(@roles)->{conflicts}}; + my $composite_info = $me->_composite_info_for(@roles); + my %conflicts = %{$composite_info->{conflicts}}; if (keys %conflicts) { - my $fail = + my $fail = join "\n", map { "Method name conflict for '$_' between roles " @@ -143,15 +163,22 @@ sub create_class_with_roles { my @composable = map $me->_composable_package_for($_), reverse @roles; - *{_getglob("${new_name}::ISA")} = [ @composable, $superclass ]; - - my @info = map $INFO{$_}, @roles; + # some methods may not exist in the role, but get generated by + # _composable_package_for (Moose accessors via Moo). filter out anything + # provided by the composable packages, excluding the subs we generated to + # make modifiers work. + my @requires = grep { + my $method = $_; + !grep $_->can($method) && !$COMPOSED{role}{$_}{modifiers_only}{$method}, + @composable + } @{$composite_info->{requires}}; $me->_check_requires( - $new_name, $compose_name, - do { my %h; @h{map @{$_->{requires}||[]}, @info} = (); keys %h } + $superclass, $compose_name, \@requires ); + *{_getglob("${new_name}::ISA")} = [ @composable, $superclass ]; + @{$APPLIED_TO{$new_name}||={}}{ map keys %{$APPLIED_TO{$_}}, @roles } = (); @@ -171,9 +198,11 @@ sub apply_roles_to_package { return $me->apply_role_to_package($to, $roles[0]) if @roles == 1; my %conflicts = %{$me->_composite_info_for(@roles)->{conflicts}}; - delete $conflicts{$_} for $me->_concrete_methods_of($to); + my @have = grep $to->can($_), keys %conflicts; + delete @conflicts{@have}; + if (keys %conflicts) { - my $fail = + my $fail = join "\n", map { "Due to a method name conflict between roles " @@ -183,6 +212,15 @@ sub apply_roles_to_package { die $fail; } + # conflicting methods are supposed to be treated as required by the + # composed role. we don't have an actual composed role, but because + # we know the target class already provides them, we can instead + # pretend that the roles don't do for the duration of application. + my @role_methods = map $me->_concrete_methods_of($_), @roles; + # separate loops, since local ..., delete ... for ...; creates a scope + local @{$_}{@have} for @role_methods; + delete @{$_}{@have} for @role_methods; + # the if guard here is essential since otherwise we accidentally create # a $INFO for something that isn't a Role::Tiny (or Moo::Role) because # autovivification hates us and wants us to die() @@ -190,8 +228,27 @@ sub apply_roles_to_package { delete $INFO{$to}{methods}; # reset since we're about to add methods } - foreach my $role (@roles) { - $me->apply_single_role_to_package($to, $role); + # backcompat: allow subclasses to use apply_single_role_to_package + # to apply changes. set a local var so ours does nothing. + our %BACKCOMPAT_HACK; + if($me ne __PACKAGE__ + and exists $BACKCOMPAT_HACK{$me} ? $BACKCOMPAT_HACK{$me} : + $BACKCOMPAT_HACK{$me} = + $me->can('role_application_steps') + == \&role_application_steps + && $me->can('apply_single_role_to_package') + != \&apply_single_role_to_package + ) { + foreach my $role (@roles) { + $me->apply_single_role_to_package($to, $role); + } + } + else { + foreach my $step ($me->role_application_steps) { + foreach my $role (@roles) { + $me->$step($to, $role); + } + } } $APPLIED_TO{$to}{join('|',@roles)} = 1; } @@ -207,8 +264,11 @@ sub _composite_info_for { my $this_methods = $me->_concrete_methods_of($role); $methods{$_}{$this_methods->{$_}} = $role for keys %$this_methods; } + my %requires; + @requires{map @{$INFO{$_}{requires}||[]}, @roles} = (); + delete $requires{$_} for keys %methods; delete $methods{$_} for grep keys(%{$methods{$_}}) == 1, keys %methods; - +{ conflicts => \%methods } + +{ conflicts => \%methods, requires => [keys %requires] } }; } @@ -218,6 +278,8 @@ sub _composable_package_for { return $composed_name if $COMPOSED{role}{$composed_name}; $me->_install_methods($composed_name, $role); my $base_name = $composed_name.'::_BASE'; + # force stash to exist so ->can doesn't complain + _getstash($base_name); # Not using _getglob, since setting @ISA via the typeglob breaks # inheritance on 5.10.0 if the stash has previously been accessed an # then a method called on the class (in that order!), which @@ -225,9 +287,9 @@ sub _composable_package_for { { no strict 'refs'; @{"${composed_name}::ISA"} = ( $base_name ); } my $modifiers = $INFO{$role}{modifiers}||[]; my @mod_base; - foreach my $modified ( - do { my %h; @h{map $_->[1], @$modifiers} = (); keys %h } - ) { + my @modifiers = grep !$composed_name->can($_), + do { my %h; @h{map @{$_}[1..$#$_-1], @$modifiers} = (); keys %h }; + foreach my $modified (@modifiers) { push @mod_base, "sub ${modified} { shift->next::method(\@_) }"; } my $e; @@ -237,13 +299,16 @@ sub _composable_package_for { $e = "Evaling failed: $@\nTrying to eval:\n${code}" if $@; } die $e if $e; - $me->_install_modifiers($composed_name, $modifiers); - $COMPOSED{role}{$composed_name} = 1; + $me->_install_modifiers($composed_name, $role); + $COMPOSED{role}{$composed_name} = { + modifiers_only => { map { $_ => 1 } @modifiers }, + }; return $composed_name; } sub _check_requires { - my ($me, $to, $name, @requires) = @_; + my ($me, $to, $name, $requires) = @_; + return unless my @requires = @{$requires||$INFO{$name}{requires}||[]}; if (my @requires_fail = grep !$to->can($_), @requires) { # role -> role, add to requires, role -> class, error out if (my $to_info = $INFO{$to}) { @@ -266,16 +331,15 @@ sub _concrete_methods_of { # 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" - ( ! $code or exists $not_methods->{$code||''} ) ? () : ($_ => $code) + ( ! $code or exists $not_methods->{$code} ) ? () : ($_ => $code) } grep !ref($stash->{$_}), keys %$stash }; } sub methods_provided_by { my ($me, $role) = @_; - die "${role} is not a Role::Tiny" unless my $info = $INFO{$role}; - (keys %{$me->_concrete_methods_of($role)}, @{$info->{requires}||[]}); + die "${role} is not a Role::Tiny" unless $me->is_role($role); + (keys %{$me->_concrete_methods_of($role)}, @{$INFO{$role}->{requires}||[]}); } sub _install_methods { @@ -297,14 +361,29 @@ sub _install_methods { foreach my $i (grep !exists $has_methods{$_}, keys %$methods) { no warnings 'once'; - *{_getglob "${to}::${i}"} = $methods->{$i}; + my $glob = _getglob "${to}::${i}"; + *$glob = $methods->{$i}; + + # overloads using method names have the method stored in the scalar slot + # and &overload::nil in the code slot. + next + unless $i =~ /^\(/ + && defined &overload::nil + && $methods->{$i} == \&overload::nil; + + my $overload = ${ *{_getglob "${role}::${i}"}{SCALAR} }; + next + unless defined $overload; + + *$glob = \$overload; } - + $me->_install_does($to); } sub _install_modifiers { - my ($me, $to, $modifiers) = @_; + my ($me, $to, $name) = @_; + return unless my $modifiers = $INFO{$name}{modifiers}; if (my $info = $INFO{$to}) { push @{$info->{modifiers}}, @{$modifiers||[]}; } else { @@ -331,15 +410,16 @@ sub _install_single_modifier { my $FALLBACK = sub { 0 }; sub _install_does { my ($me, $to) = @_; - + # only add does() method to classes - return if $INFO{$to}; - + return if $me->is_role($to); + # add does() only if they don't have one *{_getglob "${to}::does"} = \&does_role unless $to->can('does'); - - return if ($to->can('DOES') and $to->can('DOES') != (UNIVERSAL->can('DOES') || 0)); - + + return + if $to->can('DOES') and $to->can('DOES') != (UNIVERSAL->can('DOES') || 0); + my $existing = $to->can('DOES') || $to->can('isa') || $FALLBACK; my $new_sub = sub { my ($proto, $role) = @_; @@ -351,18 +431,20 @@ sub _install_does { sub does_role { my ($proto, $role) = @_; - if ($] >= 5.010) { - require mro; - } else { - require MRO::Compat; - } + require(_MRO_MODULE); foreach my $class (@{mro::get_linear_isa(ref($proto)||$proto)}) { return 1 if exists $APPLIED_TO{$class}{$role}; } return 0; } +sub is_role { + my ($me, $role) = @_; + return !!($INFO{$role} && $INFO{$role}{is_role}); +} + 1; +__END__ =encoding utf-8 @@ -448,7 +530,7 @@ Declares a list of methods that must be defined to compose role. Composes another role into the current role (or class via L). If you have conflicts and want to resolve them in favour of Some::Role1 you -can instead write: +can instead write: with 'Some::Role1'; with 'Some::Role2'; @@ -492,6 +574,15 @@ L is lazily loaded and we do not declare it as a dependency. If your L role uses modifiers you must depend on both L and L. +=head2 Strict and Warnings + +In addition to importing subroutines, using C applies L and +L to the caller. It's possible to +disable these if desired: + + use Role::Tiny; + use warnings NONFATAL => 'all'; + =head1 SUBROUTINES =head2 does_role @@ -513,7 +604,7 @@ 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. However, if C class in your class' inheritance -heirarchy provides C, then Role::Tiny will not override it. +hierarchy provides C, then Role::Tiny will not override it. =head1 METHODS @@ -539,17 +630,28 @@ resulting class. Creates a new class based on base, with the roles composed into it in order. New class is returned. +=head2 is_role + + Role::Tiny->is_role('Some::Role1') + +Returns true if the given package is a role. + +=head1 CAVEATS + +=over 4 + +=item * On perl 5.8.8 and earlier, applying a role to an object won't apply any +overloads from the role to all copies of the object. + +=back + =head1 SEE ALSO L is the attribute-less subset of L; L is a meta-protocol-less subset of the king of role systems, L. -If you don't want method modifiers and do want to be forcibly restricted -to a single role application per class, Ovid's L exists. But -Stevan Little (the L author) and I don't find the additional -restrictions to be amazingly helpful in most cases; L's choices -are more a guide to what you should prefer doing, to our mind, rather than -something that needs to be enforced. +Ovid's L provides roles with a similar scope, but without method +modifiers, and having some extra usage restrictions. =head1 AUTHOR @@ -581,6 +683,8 @@ ilmari - Dagfinn Ilmari Mannsåker (cpan:ILMARI) tobyink - Toby Inkster (cpan:TOBYINK) +haarg - Graham Knop (cpan:HAARG) + =head1 COPYRIGHT Copyright (c) 2010-2012 the Role::Tiny L and L