adding more crap

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 1609a77..ae5be70 100644 (file)
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -5,7 +5,7 @@ use strict;
 use warnings;
 
 use Carp         'confess';
-use Scalar::Util 'blessed';
+use Scalar::Util 'blessed', 'reftype';
 use Sub::Name    'subname';
 use B            'svref_2object';
 
@@ -68,19 +68,51 @@ sub class_precedence_list {
     );   
 }
 
+## Methods
+
+sub add_method {
+    my ($self, $method_name, $method) = @_;
+    (defined $method_name && $method_name)
+        || confess "You must define a method name";
+    (reftype($method) && reftype($method) eq 'CODE')
+        || confess "Your code block must be a CODE reference";
+    my $full_method_name = ($self->name . '::' . $method_name);    
+        
+    no strict 'refs';
+    *{$full_method_name} = subname $full_method_name => $method;
+}
+
+sub has_method {
+    my ($self, $method_name, $method) = @_;
+    (defined $method_name && $method_name)
+        || confess "You must define a method name";    
+    
+    my $sub_name = ($self->name . '::' . $method_name);    
+        
+    no strict 'refs';
+    return 0 unless defined &{$sub_name};        
+    return 0 unless _find_subroutine_package(\&{$sub_name}) eq $self->name;
+    return 1;
+}
+
+sub get_method {
+    my ($self, $method_name, $method) = @_;
+    (defined $method_name && $method_name)
+        || confess "You must define a method name";
+
+    no strict 'refs';    
+    return \&{$self->name . '::' . $method_name} 
+        if $self->has_method($method_name);    
+}
+
 ## Private Utility Methods
 
-# borrowed from Class::Trait 0.20 - Thanks Ovid :)
+# initially borrowed from Class::Trait 0.20 - Thanks Ovid :)
+# later re-worked to support subs named with Sub::Name
 sub _find_subroutine_package {
     my $sub     = shift;
-    my $package = '';
-    eval {
-        my $stash = svref_2object($sub)->STASH;
-        $package = $stash->NAME 
-            if $stash && $stash->can('NAME');
-    };
-    confess "Could not determine calling package: $@" 
-        if $@;
+    my $package = eval { svref_2object($sub)->GV->STASH->NAME };
+    confess "Could not determine calling package: $@" if $@;
     return $package;
 }
 

diff --git a/t/001_basic.t b/t/001_basic.t
index 9ffcea2..ce622a8 100644 (file)
--- a/t/001_basic.t
+++ b/t/001_basic.t
@@ -4,6 +4,7 @@ use strict;
 use warnings;
 
 use Test::More no_plan => 1;
+use Test::Exception;
 
 BEGIN {
     use_ok('Class::MOP');   
@@ -65,5 +66,3 @@ is_deeply(
     [ $Baz->class_precedence_list ], 
     [ 'Baz', 'Bar', 'Foo', 'UNIVERSAL' ], 
     '... Baz->class_precedence_list == (Baz, Bar, Foo, UNIVERSAL)');
-
-

diff --git a/t/002_class_precedence_list.t b/t/002_class_precedence_list.t
new file mode 100644 (file)
index 0000000..cc99286
--- /dev/null
+++ b/t/002_class_precedence_list.t
@@ -0,0 +1,80 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More no_plan => 1;
+
+BEGIN {
+    use_ok('Class::MOP');   
+    use_ok('Class::MOP::Class');        
+}
+
+=pod
+
+  A
+ / \
+B   C
+ \ / 
+  D
+
+=cut
+
+{
+    package My::A;
+    package My::B;
+    our @ISA = ('My::A');
+    package My::C;
+    our @ISA = ('My::A');    
+    package My::D;       
+    our @ISA = ('My::B', 'My::C');         
+}
+
+is_deeply(
+    [ My::D->meta->class_precedence_list ], 
+    [ 'My::D', 'My::B', 'My::A', 'My::C', 'My::A' ], 
+    '... My::D->meta->class_precedence_list == (D B A C A)');
+
+=pod
+
++-- B <-+
+|       |
++-> A --+
+
+=cut
+
+{
+    package My::2::A;
+    our @ISA = ('My::2::B');
+    package My::2::B;
+    our @ISA = ('My::2::A');       
+}
+
+eval { My::2::B->meta->class_precedence_list };
+ok($@, '... recursive inheritance breaks correctly :)');
+
+=pod
+
+ +--------+
+ |    A   |
+ |   / \  |
+ +->B   C-+
+     \ / 
+      D
+
+=cut
+
+{
+    package My::3::A;
+    package My::3::B;
+    our @ISA = ('My::3::A');
+    package My::3::C;
+    our @ISA = ('My::3::A', 'My::3::B');    
+    package My::3::D;       
+    our @ISA = ('My::3::B', 'My::3::C');         
+}
+
+is_deeply(
+    [ My::3::D->meta->class_precedence_list ], 
+    [ 'My::3::D', 'My::3::B', 'My::3::A', 'My::3::C', 'My::3::A', 'My::3::B', 'My::3::A' ], 
+    '... My::3::D->meta->class_precedence_list == (D B A C A B A)');

diff --git a/t/003_methods.t b/t/003_methods.t
new file mode 100644 (file)
index 0000000..f06f70b
--- /dev/null
+++ b/t/003_methods.t
@@ -0,0 +1,38 @@
+#!/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');        
+}
+
+{   
+    package Foo;
+    
+    # import a sub
+    use Scalar::Util 'blessed'; 
+    
+    # define a sub in package
+    sub bar { 'Foo::bar' } 
+}
+
+my $Foo = Foo->meta;
+
+my $foo = sub { 'Foo::foo' };
+
+lives_ok {
+    $Foo->add_method('foo' => $foo);
+} '... we added the method successfully';
+
+ok($Foo->has_method('foo'), '... Foo->has_method(foo) (defined with Sub::Name)');
+ok(!$Foo->has_method('blessed'), '... !Foo->has_method(blessed) (imported into Foo)');
+ok($Foo->has_method('bar'), '... Foo->has_method(bar) (defined in Foo)');
+
+is($Foo->get_method('foo'), $foo, '... Foo->get_method(foo) == \&foo');
+
+is(Foo->foo(), 'Foo::foo', '... Foo->foo() returns "Foo::foo"');
\ No newline at end of file