From: Stevan Little <stevan.little@iinteractive.com>
Date: Wed, 12 Apr 2006 23:50:01 +0000 (+0000)
Subject: does
X-Git-Tag: 0_05~41
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ef333f17a7897f50eea25b2ef40ccd0c3a57591b;p=gitmo%2FMoose.git

does
---

diff --git a/lib/Moose.pm b/lib/Moose.pm
index fcae992..56525da 100644
--- a/lib/Moose.pm
+++ b/lib/Moose.pm
@@ -39,7 +39,7 @@ sub import {
 	my $meta;
 	if ($pkg->can('meta')) {
 		$meta = $pkg->meta();
-		(blessed($meta) && $meta->isa('Class::MOP::Class'))
+		(blessed($meta) && $meta->isa('Moose::Meta::Class'))
 			|| confess "Whoops, not møøsey enough";
 	}
 	else {
diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm
index 6709a40..9c99bfc 100644
--- a/lib/Moose/Meta/Class.pm
+++ b/lib/Moose/Meta/Class.pm
@@ -11,6 +11,28 @@ our $VERSION = '0.04';
 
 use base 'Class::MOP::Class';
 
+__PACKAGE__->meta->add_attribute('@:roles' => (
+    reader  => 'roles',
+    default => sub { [] }
+));
+
+sub add_role {
+    my ($self, $role) = @_;
+    (blessed($role) && $role->isa('Moose::Meta::Role'))
+        || confess "Roles must be instances of Moose::Meta::Role";
+    push @{$self->roles} => $role;
+}
+
+sub does_role {
+    my ($self, $role_name) = @_;
+    (defined $role_name)
+        || confess "You must supply a role name to look for";
+    foreach my $role (@{$self->roles}) {
+        return 1 if $role->name eq $role_name;
+    }
+    return 0;
+}
+
 sub construct_instance {
     my ($class, %params) = @_;
     my $instance = $params{'__INSTANCE__'} || {};
@@ -169,6 +191,12 @@ methods.
 
 =item B<add_augment_method_modifier ($name, $method)>
 
+=item B<roles>
+
+=item B<add_role ($role)>
+
+=item B<does_role ($role_name)>
+
 =back
 
 =head1 BUGS
diff --git a/lib/Moose/Meta/Role.pm b/lib/Moose/Meta/Role.pm
index c604a30..1eb76bb 100644
--- a/lib/Moose/Meta/Role.pm
+++ b/lib/Moose/Meta/Role.pm
@@ -7,7 +7,7 @@ use metaclass;
 
 use Carp 'confess';
 
-our $VERSION = '0.01';
+our $VERSION = '0.02';
 
 __PACKAGE__->meta->add_attribute('role_meta' => (
     reader => 'role_meta'
@@ -96,6 +96,31 @@ sub apply {
         );
     }    
     
+    ## add the roles and set does()
+    
+    $other->add_role($self);
+    
+    # NOTE:
+    # this will not replace a locally 
+    # defined does() method, those 
+    # should work as expected since 
+    # they are working off the same 
+    # metaclass. 
+    # It will override an inherited 
+    # does() method though, since 
+    # it needs to add this new metaclass
+    # to the mix.
+    
+    $other->add_method('does' => sub { 
+        my (undef, $role_name) = @_;
+        (defined $role_name)
+            || confess "You much supply a role name to does()";
+        foreach my $class ($other->class_precedence_list) {
+            return 1 
+                if $other->initialize($class)->does_role($role_name);            
+        }
+        return 0;
+    }) unless $other->has_method('does');
 }
 
 # NOTE:
diff --git a/lib/Moose/Object.pm b/lib/Moose/Object.pm
index 64b9eeb..5773a96 100644
--- a/lib/Moose/Object.pm
+++ b/lib/Moose/Object.pm
@@ -7,7 +7,7 @@ use metaclass 'Moose::Meta::Class' => (
 	':attribute_metaclass' => 'Moose::Meta::Attribute'
 );
 
-our $VERSION = '0.03';
+our $VERSION = '0.04';
 
 sub new {
     my $class  = shift;
@@ -33,6 +33,10 @@ sub DEMOLISHALL {
 
 sub DESTROY { goto &DEMOLISHALL }
 
+# new does() methods will be created 
+# as approiate see Moose::Meta::Role
+sub does { 0 }
+
 1;
 
 __END__
@@ -75,6 +79,8 @@ and pass it a hash-ref of the the C<%params> passed to C<new>.
 
 This will call every C<DEMOLISH> method in the inheritance hierarchy.
 
+=item B<does ($role_name)>
+
 =back
 
 =head1 BUGS
diff --git a/t/006_basic.t b/t/006_basic.t
index d256933..75b416f 100644
--- a/t/006_basic.t
+++ b/t/006_basic.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 15;
+use Test::More tests => 21;
 use Test::Exception;
 
 BEGIN {
@@ -103,12 +103,16 @@ BEGIN {
 my $no_more_than_10 = Constraint::NoMoreThan->new(value => 10);
 isa_ok($no_more_than_10, 'Constraint::NoMoreThan');
 
+ok($no_more_than_10->does('Constraint'), '... Constraint::NoMoreThan does Constraint');
+
 ok(!defined($no_more_than_10->validate(1)), '... validated correctly');
 is($no_more_than_10->validate(11), 'must be no more than 10', '... validation failed correctly');
 
 my $at_least_10 = Constraint::AtLeast->new(value => 10);
 isa_ok($at_least_10, 'Constraint::AtLeast');
 
+ok($at_least_10->does('Constraint'), '... Constraint::AtLeast does Constraint');
+
 ok(!defined($at_least_10->validate(11)), '... validated correctly');
 is($at_least_10->validate(1), 'must be at least 10', '... validation failed correctly');
 
@@ -118,6 +122,9 @@ my $no_more_than_10_chars = Constraint::LengthNoMoreThan->new(value => 10, units
 isa_ok($no_more_than_10_chars, 'Constraint::LengthNoMoreThan');
 isa_ok($no_more_than_10_chars, 'Constraint::NoMoreThan');
 
+ok($no_more_than_10_chars->does('Constraint'), '... Constraint::LengthNoMoreThan does Constraint');
+ok($no_more_than_10_chars->does('Constraint::OnLength'), '... Constraint::LengthNoMoreThan does Constraint::OnLength');
+
 ok(!defined($no_more_than_10_chars->validate('foo')), '... validated correctly');
 is($no_more_than_10_chars->validate('foooooooooo'), 
     'must be no more than 10 chars', 
@@ -127,6 +134,9 @@ my $at_least_10_chars = Constraint::LengthAtLeast->new(value => 10, units => 'ch
 isa_ok($at_least_10_chars, 'Constraint::LengthAtLeast');
 isa_ok($at_least_10_chars, 'Constraint::AtLeast');
 
+ok($at_least_10_chars->does('Constraint'), '... Constraint::LengthAtLeast does Constraint');
+ok($at_least_10_chars->does('Constraint::OnLength'), '... Constraint::LengthAtLeast does Constraint::OnLength');
+
 ok(!defined($at_least_10_chars->validate('barrrrrrrrr')), '... validated correctly');
 is($at_least_10_chars->validate('bar'), 'must be at least 10 chars', '... validation failed correctly');
 
diff --git a/t/010_basic_class_setup.t b/t/010_basic_class_setup.t
index b75e1e8..6eda123 100644
--- a/t/010_basic_class_setup.t
+++ b/t/010_basic_class_setup.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 20;
+use Test::More tests => 21;
 use Test::Exception;
 
 BEGIN {
@@ -22,6 +22,8 @@ isa_ok(Foo->meta, 'Moose::Meta::Class');
 ok(Foo->meta->has_method('meta'), '... we got the &meta method');
 ok(Foo->isa('Moose::Object'), '... Foo is automagically a Moose::Object');
 
+can_ok('Foo', 'does');
+
 foreach my $function (qw(
 						 extends
     	                 has 
diff --git a/t/042_apply_role.t b/t/042_apply_role.t
index 21bcd8b..e9f819b 100644
--- a/t/042_apply_role.t
+++ b/t/042_apply_role.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 28;
+use Test::More tests => 36;
 use Test::Exception;
 
 BEGIN {  
@@ -53,6 +53,9 @@ BEGIN {
 my $foo_class_meta = FooClass->meta;
 isa_ok($foo_class_meta, 'Moose::Meta::Class');
 
+ok($foo_class_meta->does_role('FooRole'), '... the FooClass->meta does_role FooRole');
+ok(!$foo_class_meta->does_role('OtherRole'), '... the FooClass->meta !does_role OtherRole');
+
 foreach my $method_name (qw(bar baz foo boo blau goo)) {
     ok($foo_class_meta->has_method($method_name), '... FooClass has the method ' . $method_name);    
 }
@@ -61,9 +64,17 @@ foreach my $attr_name (qw(bar baz)) {
     ok($foo_class_meta->has_attribute($attr_name), '... FooClass has the attribute ' . $attr_name);    
 }
 
+can_ok('FooClass', 'does');
+ok(FooClass->does('FooRole'), '... the FooClass does FooRole');
+ok(!FooClass->does('OtherRole'), '... the FooClass does not do OtherRole');
+
 my $foo = FooClass->new();
 isa_ok($foo, 'FooClass');
 
+can_ok($foo, 'does');
+ok($foo->does('FooRole'), '... an instance of FooClass does FooRole');
+ok(!$foo->does('OtherRole'), '... and instance of FooClass does not do OtherRole');
+
 can_ok($foo, 'bar');
 can_ok($foo, 'baz');
 can_ok($foo, 'foo');