X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FRole.pm;h=4f19eb865704260571a2a05f75e78fc6376f7eb1;hb=fb175631f4f6e2449cbd0c84c95fdd136e9256a9;hp=547dabb964965f365a1a05bd3546dd31f000d2bd;hpb=eaa35e6e0f9132abf6ed0cec60515dd7259ce704;p=gitmo%2FMoose.git

diff --git a/lib/Moose/Meta/Role.pm b/lib/Moose/Meta/Role.pm
index 547dabb..4f19eb8 100644
--- a/lib/Moose/Meta/Role.pm
+++ b/lib/Moose/Meta/Role.pm
@@ -8,7 +8,7 @@ use metaclass;
 use Carp         'confess';
 use Scalar::Util 'blessed';
 
-our $VERSION   = '0.50';
+our $VERSION   = '0.56';
 our $AUTHORITY = 'cpan:STEVAN';
 
 use Moose::Meta::Class;
@@ -240,6 +240,14 @@ sub get_method_modifier_list {
     keys %{$self->$accessor};
 }
 
+sub reset_package_cache_flag  { (shift)->{'_package_cache_flag'} = undef }
+sub update_package_cache_flag {
+    my $self = shift;
+    $self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name);
+}
+
+
+
 ## ------------------------------------------------------------------
 ## subroles
 
@@ -285,7 +293,16 @@ sub method_metaclass { 'Moose::Meta::Role::Method' }
 
 sub get_method_map {
     my $self = shift;
-    my $map  = {};
+
+    my $current = Class::MOP::check_package_cache_flag($self->name);
+
+    if (defined $self->{'_package_cache_flag'} && $self->{'_package_cache_flag'} == $current) {
+        return $self->{'methods'} ||= {};
+    }
+
+    $self->{_package_cache_flag} = $current;
+
+    my $map  = $self->{'methods'} ||= {};
 
     my $role_name        = $self->name;
     my $method_metaclass = $self->method_metaclass;
@@ -295,6 +312,10 @@ sub get_method_map {
     foreach my $symbol (keys %all_code) {
         my $code = $all_code{$symbol};
 
+        next if exists  $map->{$symbol} &&
+                defined $map->{$symbol} &&
+                        $map->{$symbol}->body == $code;
+
         my ($pkg, $name) = Class::MOP::get_code_info($code);
 
         if ($pkg->can('meta')
@@ -305,7 +326,7 @@ sub get_method_map {
             # loudly (in the case of Curses.pm) so we
             # just be a little overly cautious here.
             # - SL
-            && eval { no warnings; blessed($pkg->meta) }
+            && eval { no warnings; blessed($pkg->meta) } # FIXME calls meta
             && $pkg->meta->isa('Moose::Meta::Role')) {
             my $role = $pkg->meta->name;
             next unless $self->does_role($role);
@@ -344,6 +365,59 @@ sub has_method {
     exists $self->get_method_map->{$name} ? 1 : 0
 }
 
+# FIXME this is copypasated from Class::MOP::Class
+# refactor to inherit from some common base
+sub wrap_method_body {
+    my ( $self, %args ) = @_;
+
+    my $body = delete $args{body}; # delete is for compat
+
+    ('CODE' eq ref($body))
+        || confess "Your code block must be a CODE reference";
+
+    $self->method_metaclass->wrap( $body => (
+        package_name => $self->name,
+        %args,
+    ));
+}
+
+sub add_method {
+    my ($self, $method_name, $method) = @_;
+    (defined $method_name && $method_name)
+    || confess "You must define a method name";
+
+    my $body;
+    if (blessed($method)) {
+        $body = $method->body;
+        if ($method->package_name ne $self->name &&
+            $method->name         ne $method_name) {
+            warn "Hello there, got something for you."
+            . " Method says " . $method->package_name . " " . $method->name
+            . " Class says " . $self->name . " " . $method_name;
+            $method = $method->clone(
+                package_name => $self->name,
+                name         => $method_name
+            ) if $method->can('clone');
+        }
+    }
+    else {
+        $body = $method;
+        $method = $self->wrap_method_body( body => $body, name => $method_name );
+    }
+
+    $method->attach_to_class($self);
+
+    $self->get_method_map->{$method_name} = $method;
+
+    my $full_method_name = ($self->name . '::' . $method_name);
+    $self->add_package_symbol(
+        { sigil => '&', type => 'CODE', name => $method_name },
+        Class::MOP::subname($full_method_name => $body)
+    );
+
+    $self->update_package_cache_flag; # still valid, since we just added the method to the map, and if it was invalid before that then get_method_map updated it
+}
+
 sub find_method_by_name { (shift)->get_method(@_) }
 
 sub get_method_list {
@@ -390,6 +464,16 @@ sub apply {
     }  
 }
 
+sub apply_to_metaclass_instance {
+    my ($self, $meta, @args) = @_;
+
+    $meta->isa('Moose::Meta::Class') || $meta->isa('Moose::Meta::Role')
+        || confess "You must pass in a Moose::Meta::Class or Moose::Meta::Role instance";
+
+    require Moose::Meta::Role::Application::ToMetaclassInstance;
+    return Moose::Meta::Role::Application::ToMetaclassInstance->new(@args)->apply($self, $meta);
+}
+
 sub combine {
     my ($class, @role_specs) = @_;
     
@@ -560,6 +644,8 @@ probably not that much really).
 
 =item B<apply>
 
+=item B<apply_to_metaclass_instance>
+
 =item B<combine>
 
 =back
@@ -608,6 +694,10 @@ probably not that much really).
 
 =item B<has_method>
 
+=item B<add_method>
+
+=item B<wrap_method_body>
+
 =item B<alias_method>
 
 =item B<get_method_list>