From: Stevan Little <stevan.little@iinteractive.com>
Date: Wed, 25 Jan 2006 22:25:27 +0000 (+0000)
Subject: Class::MOP - all the method methods and tests
X-Git-Tag: 0_02~21
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a5eca69502089a63153a77e2c0c0b5f1c9c2504f;p=gitmo%2FClass-MOP.git

Class::MOP - all the method methods and tests
---

diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm
index cadef21..2b86f1a 100644
--- a/lib/Class/MOP.pm
+++ b/lib/Class/MOP.pm
@@ -280,6 +280,11 @@ with the following information; method name (which will always be the
 same as C<$method_name>), the name of the class in which the method 
 lives and a CODE reference for the actual method.
 
+The list of methods produced is a distinct list, meaning there are no 
+duplicates in it. This is especially useful for things like object 
+initialization and destruction where you only want the method called 
+once, and in the correct order.
+
 =back
 
 =head3 Attributes
diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 79b267c..2f600dc 100644
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -92,6 +92,7 @@ sub add_method {
     my ($self, $method_name, $method) = @_;
     (defined $method_name && $method_name)
         || confess "You must define a method name";
+    # use reftype here to allow for blessed subs ...
     (reftype($method) && reftype($method) eq 'CODE')
         || confess "Your code block must be a CODE reference";
     my $full_method_name = ($self->name . '::' . $method_name);    
@@ -151,9 +152,82 @@ sub remove_method {
 sub get_method_list {
     my $self = shift;
     no strict 'refs';
-    grep { 
-        defined &{$self->name . '::' . $_} && $self->has_method($_) 
-    } %{$self->name . '::'};
+    grep { $self->has_method($_) } %{$self->name . '::'};
+}
+
+sub compute_all_applicable_methods {
+    my $self = shift;
+    my @methods;
+    # keep a record of what we have seen
+    # here, this will handle all the 
+    # inheritence issues because we are 
+    # using the &class_precedence_list
+    my (%seen_class, %seen_method);
+    foreach my $class ($self->class_precedence_list()) {
+        next if $seen_class{$class};
+        $seen_class{$class}++;
+        # fetch the meta-class ...
+        my $meta = $self->initialize($class);
+        foreach my $method_name ($meta->get_method_list()) { 
+            next if exists $seen_method{$method_name};
+            $seen_method{$method_name}++;
+            push @methods => {
+                name  => $method_name, 
+                class => $class,
+                code  => $meta->get_method($method_name)
+            };
+        }
+    }
+    return @methods;
+}
+
+## Recursive Version of compute_all_applicable_methods
+# sub compute_all_applicable_methods {
+#     my ($self, $seen) = @_;
+#     $seen ||= {};
+#     (
+#         (map { 
+#             if (exists $seen->{$_}) { 
+#                 ();
+#             }
+#             else {
+#                 $seen->{$_}++;
+#                 {
+#                     name  => $_, 
+#                     class => $self->name,
+#                     code  => $self->get_method($_)
+#                 };
+#             }
+#         } $self->get_method_list()),
+#         map { 
+#             $self->initialize($_)->compute_all_applicable_methods($seen)
+#         } $self->superclasses()
+#     );
+# }
+
+sub find_all_methods_by_name {
+    my ($self, $method_name) = @_;
+    (defined $method_name && $method_name)
+        || confess "You must define a method name to find";    
+    my @methods;
+    # keep a record of what we have seen
+    # here, this will handle all the 
+    # inheritence issues because we are 
+    # using the &class_precedence_list
+    my %seen_class;
+    foreach my $class ($self->class_precedence_list()) {
+        next if $seen_class{$class};
+        $seen_class{$class}++;
+        # fetch the meta-class ...
+        my $meta = $self->initialize($class);
+        push @methods => {
+            name  => $method_name, 
+            class => $class,
+            code  => $meta->get_method($method_name)
+        } if $meta->has_method($method_name);
+    }
+    return @methods;
+
 }
 
 1;
diff --git a/t/003_methods.t b/t/003_methods.t
index 24dde7a..0bfe252 100644
--- a/t/003_methods.t
+++ b/t/003_methods.t
@@ -5,7 +5,6 @@ use warnings;
 
 use Test::More no_plan => 1;
 use Test::Exception;
-use Test::Deep;
 
 BEGIN {
     use_ok('Class::MOP');   
@@ -83,6 +82,29 @@ is_deeply(
     [ qw(FOO_CONSTANT bang bar baz blah bling evaled_foo floob foo) ],
     '... got the right method list for Foo');
 
+is_deeply(
+    [ sort { $a->{name} cmp $b->{name} } $Foo->compute_all_applicable_methods() ],
+    [
+        map {
+            {
+            name  => $_,
+            class => 'Foo',
+            code  => $Foo->get_method($_) 
+            }
+        } qw(
+            FOO_CONSTANT
+            bang 
+            bar 
+            baz 
+            blah 
+            bling 
+            evaled_foo 
+            floob 
+            foo
+        )
+    ],
+    '... got the right list of applicable methods for Foo');
+
 is($Foo->remove_method('foo'), $foo, '... removed the foo method');
 ok(!$Foo->has_method('foo'), '... !Foo->has_method(foo) we just removed it');
 dies_ok { Foo->foo } '... cannot call Foo->foo because it is not there';
@@ -129,4 +151,40 @@ is(Bar->foo, 'Bar::foo v2', '... Bar->foo == "Bar::foo v2"');
 is_deeply(
     [ sort $Bar->get_method_list ],
     [ qw(bar foo) ],
-    '... got the right method list for Bar');
+    '... got the right method list for Bar');  
+    
+is_deeply(
+    [ sort { $a->{name} cmp $b->{name} } $Bar->compute_all_applicable_methods() ],
+    [
+        {
+            name  => 'bang',
+            class => 'Foo',
+            code  => $Foo->get_method('bang') 
+        },
+        {
+            name  => 'bar',
+            class => 'Bar',
+            code  => $Bar->get_method('bar')            
+        },
+        (map {
+            {
+                name  => $_,
+                class => 'Foo',
+                code  => $Foo->get_method($_) 
+            }
+        } qw(        
+            baz 
+            blah 
+            bling 
+            evaled_foo 
+            floob 
+        )),
+        {
+            name  => 'foo',
+            class => 'Bar',
+            code  => $Bar->get_method('foo')            
+        },        
+    ],
+    '... got the right list of applicable methods for Bar');
+
+
diff --git a/t/004_advanced_methods.t b/t/004_advanced_methods.t
new file mode 100644
index 0000000..f3a3d49
--- /dev/null
+++ b/t/004_advanced_methods.t
@@ -0,0 +1,225 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More no_plan => 1;
+use Test::Exception;
+
+BEGIN {
+    use_ok('Class::MOP');   
+    use_ok('Class::MOP::Class');        
+}
+
+=pod
+
+The following class hierarhcy is very contrived 
+and totally horrid (it won't work under C3 even),
+but it tests a number of aspect of this module.
+
+A more real-world example would be a nice addition :)
+
+=cut
+
+{
+    package Foo;
+    
+    sub BUILD { 'Foo::BUILD' }    
+    sub foo { 'Foo::foo' }
+    
+    package Bar;
+    our @ISA = ('Foo');
+    
+    sub BUILD { 'Bar::BUILD' }    
+    sub bar { 'Bar::bar' }     
+    
+    package Baz;
+    our @ISA = ('Bar');
+    
+    sub BUILD { 'Baz::BUILD' }    
+    sub baz { 'Baz::baz' }
+    sub foo { 'Baz::foo' }           
+    
+    package Foo::Bar;
+    our @ISA = ('Foo', 'Bar');
+    
+    sub BUILD { 'Foo::Bar::BUILD' }    
+    sub foobar { 'Foo::Bar::foobar' }    
+    
+    package Foo::Bar::Baz;
+    our @ISA = ('Foo', 'Bar', 'Baz');
+    
+    sub BUILD { 'Foo::Bar::Baz::BUILD' }    
+    sub bar { 'Foo::Bar::Baz::bar' }    
+    sub foobarbaz { 'Foo::Bar::Baz::foobarbaz' }    
+}
+
+is_deeply(
+    [ sort { $a->{name} cmp $b->{name} } Class::MOP::Class->initialize('Foo')->compute_all_applicable_methods() ],
+    [
+        {
+            name  => 'BUILD',
+            class => 'Foo',
+            code  => \&Foo::BUILD 
+        },    
+        {
+            name  => 'foo',
+            class => 'Foo',
+            code  => \&Foo::foo 
+        },       
+    ],
+    '... got the right list of applicable methods for Foo');
+    
+is_deeply(
+    [ sort { $a->{name} cmp $b->{name} } Class::MOP::Class->initialize('Bar')->compute_all_applicable_methods() ],
+    [
+        {
+            name  => 'BUILD',
+            class => 'Bar',
+            code  => \&Bar::BUILD 
+        },    
+        {
+            name  => 'bar',
+            class => 'Bar',
+            code  => \&Bar::bar  
+        },
+        {
+            name  => 'foo',
+            class => 'Foo',
+            code  => \&Foo::foo  
+        },       
+    ],
+    '... got the right list of applicable methods for Bar');
+    
+
+is_deeply(
+    [ sort { $a->{name} cmp $b->{name} } Class::MOP::Class->initialize('Baz')->compute_all_applicable_methods() ],
+    [
+        {
+            name  => 'BUILD',
+            class => 'Baz',
+            code  => \&Baz::BUILD 
+        },    
+        {
+            name  => 'bar',
+            class => 'Bar',
+            code  => \&Bar::bar  
+        },
+        {
+            name  => 'baz',
+            class => 'Baz',
+            code  => \&Baz::baz  
+        },        
+        {
+            name  => 'foo',
+            class => 'Baz',
+            code  => \&Baz::foo  
+        },       
+    ],
+    '... got the right list of applicable methods for Baz');
+
+is_deeply(
+    [ sort { $a->{name} cmp $b->{name} } Class::MOP::Class->initialize('Foo::Bar')->compute_all_applicable_methods() ],
+    [
+        {
+            name  => 'BUILD',
+            class => 'Foo::Bar',
+            code  => \&Foo::Bar::BUILD 
+        },    
+        {
+            name  => 'bar',
+            class => 'Bar',
+            code  => \&Bar::bar  
+        },
+        {
+            name  => 'foo',
+            class => 'Foo',
+            code  => \&Foo::foo  
+        },       
+        {
+            name  => 'foobar',
+            class => 'Foo::Bar',
+            code  => \&Foo::Bar::foobar  
+        },        
+    ],
+    '... got the right list of applicable methods for Foo::Bar');
+
+is_deeply(
+    [ sort { $a->{name} cmp $b->{name} } Class::MOP::Class->initialize('Foo::Bar::Baz')->compute_all_applicable_methods() ],
+    [
+        {
+            name  => 'BUILD',
+            class => 'Foo::Bar::Baz',
+            code  => \&Foo::Bar::Baz::BUILD 
+        },    
+        {
+            name  => 'bar',
+            class => 'Foo::Bar::Baz',
+            code  => \&Foo::Bar::Baz::bar  
+        },
+        {
+            name  => 'baz',
+            class => 'Baz',
+            code  => \&Baz::baz  
+        },        
+        {
+            name  => 'foo',
+            class => 'Foo',
+            code  => \&Foo::foo  
+        },   
+        {
+            name  => 'foobarbaz',
+            class => 'Foo::Bar::Baz',
+            code  => \&Foo::Bar::Baz::foobarbaz  
+        },            
+    ],
+    '... got the right list of applicable methods for Foo::Bar::Baz');
+
+## find_all_methods_by_name
+
+is_deeply(
+    [ Class::MOP::Class->initialize('Foo::Bar')->find_all_methods_by_name('BUILD') ],
+    [
+        {
+            name  => 'BUILD',
+            class => 'Foo::Bar',
+            code  => \&Foo::Bar::BUILD 
+        },    
+        {
+            name  => 'BUILD',
+            class => 'Foo',
+            code  => \&Foo::BUILD 
+        },    
+        {
+            name  => 'BUILD',
+            class => 'Bar',
+            code  => \&Bar::BUILD 
+        }
+    ],
+    '... got the right list of BUILD methods for Foo::Bar');
+
+is_deeply(
+    [ Class::MOP::Class->initialize('Foo::Bar::Baz')->find_all_methods_by_name('BUILD') ],
+    [
+        {
+            name  => 'BUILD',
+            class => 'Foo::Bar::Baz',
+            code  => \&Foo::Bar::Baz::BUILD 
+        },    
+        {
+            name  => 'BUILD',
+            class => 'Foo',
+            code  => \&Foo::BUILD 
+        },    
+        {
+            name  => 'BUILD',
+            class => 'Bar',
+            code  => \&Bar::BUILD 
+        },    
+        {
+            name  => 'BUILD',
+            class => 'Baz',
+            code  => \&Baz::BUILD 
+        },        
+    ],
+    '... got the right list of BUILD methods for Foo::Bar::Baz');
\ No newline at end of file
diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t
new file mode 100644
index 0000000..03037d5
--- /dev/null
+++ b/t/010_self_introspection.t
@@ -0,0 +1,45 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More no_plan => 1;
+use Test::Exception;
+
+BEGIN {
+    use_ok('Class::MOP::Class');        
+}
+
+
+my $meta = Class::MOP::Class->initialize('Class::MOP::Class');
+isa_ok($meta, 'Class::MOP::Class');
+
+foreach my $method_name (qw(
+    initialize create
+    name version
+    superclasses class_precedence_list
+    has_method get_method add_method remove_method 
+    get_method_list compute_all_applicable_methods find_all_methods_by_name
+    )) {
+    ok($meta->has_method($method_name), '... Class::MOP::Class->has_method(' . $method_name . ')');
+    {
+        no strict 'refs';
+        is($meta->get_method($method_name), 
+           \&{'Class::MOP::Class::' . $method_name},
+           '... Class::MOP::Class->get_method(' . $method_name . ') == &Class::MOP::Class::' . $method_name);        
+    }
+}
+
+is($meta->name, 'Class::MOP::Class', '... Class::MOP::Class->name');
+is($meta->version, $Class::MOP::Class::VERSION, '... Class::MOP::Class->version');
+
+is_deeply(
+    [ $meta->superclasses ], 
+    [], 
+    '... Class::MOP::Class->superclasses == []');
+    
+is_deeply(
+    [ $meta->class_precedence_list ], 
+    [ 'Class::MOP::Class' ], 
+    '... Class::MOP::Class->class_precedence_list == []');
+