X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FRole%2FTiny.pm;h=e1397e2a7151028027c43c193c8442b5c5cf7b15;hb=56efcee2e1d28941148ead2612dec38a9d6cd82b;hp=751527d3f83531cf9bffb3fd9f0b03c18d1945ca;hpb=1ad34a6fe111e1d9539a126c1223240a2ec60049;p=gitmo%2FRole-Tiny.git

diff --git a/lib/Role/Tiny.pm b/lib/Role/Tiny.pm
index 751527d..e1397e2 100644
--- a/lib/Role/Tiny.pm
+++ b/lib/Role/Tiny.pm
@@ -6,7 +6,7 @@ sub _getstash { \%{"$_[0]::"} }
 use strict;
 use warnings FATAL => 'all';
 
-our $VERSION = '1.002005'; # 1.2.5
+our $VERSION = '1.003002'; # 1.3.2
 $VERSION = eval $VERSION;
 
 our %INFO;
@@ -43,7 +43,7 @@ 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);
@@ -83,7 +83,7 @@ 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 $INFO{$role};
+  die "${role} is not a Role::Tiny" unless $me->is_role($role);
 
   foreach my $step ($me->role_application_steps) {
     $me->$step($to, $role);
@@ -104,6 +104,21 @@ sub apply_roles_to_object {
   $object;
 }
 
+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 {
   my ($me, $superclass, @roles) = @_;
 
@@ -118,15 +133,13 @@ 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) {
@@ -135,8 +148,6 @@ sub create_class_with_roles {
     require MRO::Compat;
   }
 
-  my @composable = map $me->_composable_package_for($_), reverse @roles;
-
   my $composite_info = $me->_composite_info_for(@roles);
   my %conflicts = %{$composite_info->{conflicts}};
   if (keys %conflicts) {
@@ -150,6 +161,12 @@ sub create_class_with_roles {
     die $fail;
   }
 
+  my @composable = map $me->_composable_package_for($_), reverse @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},
@@ -181,7 +198,9 @@ 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 keys %{ $me->_concrete_methods_of($to) };
+  my @have = grep $to->can($_), keys %conflicts;
+  delete @conflicts{@have};
+
   if (keys %conflicts) {
     my $fail = 
       join "\n",
@@ -193,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()
@@ -250,7 +278,7 @@ 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
+  # 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
@@ -310,8 +338,8 @@ sub _concrete_methods_of {
 
 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 {
@@ -368,15 +396,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) = @_;
@@ -401,7 +430,7 @@ sub does_role {
 
 sub is_role {
   my ($me, $role) = @_;
-  return !!$INFO{$role};
+  return !!($INFO{$role} && $INFO{$role}{is_role});
 }
 
 1;