required-methods

diff --git a/Changes b/Changes
index 1c10192..8c754b8 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,9 +1,21 @@
 Revision history for Perl extension Moose
 
 0.04
+    * Moose::Role
+      - Roles can now consume other roles
+        - added tests for this
+      - Roles can specify required methods now with 
+        the requires() keyword
+        - added tests for this
+
     * Moose::Meta::Role
       - ripped out much of it's guts ,.. much cleaner now
-        - applied the needed changs to Moose::Role too
+      - added required methods and correct handling of 
+        them in apply()
+      - no longer adds a does() method to consuming classes 
+        it relys on the one in Moose::Object
+      - added roles attribute and some methods to support 
+        roles consuming roles
 
 0.03_02 Wed. April 12, 2006
     * Moose

diff --git a/lib/Moose/Meta/Role.pm b/lib/Moose/Meta/Role.pm
index ad07e36..aa68ba8 100644 (file)
--- a/lib/Moose/Meta/Role.pm
+++ b/lib/Moose/Meta/Role.pm
@@ -35,6 +35,13 @@ __PACKAGE__->meta->add_attribute('attribute_map' => (
     default  => sub { {} }
 ));
 
+## required methods
+
+__PACKAGE__->meta->add_attribute('required_methods' => (
+    reader  => 'get_required_methods_map',
+    default => sub { {} }
+));
+
 ## method modifiers
 
 __PACKAGE__->meta->add_attribute('before_method_modifiers' => (
@@ -92,6 +99,23 @@ sub does_role {
     return 0;
 }
 
+## required methods
+
+sub add_required_methods {
+    my ($self, @methods) = @_;
+    $self->get_required_methods_map->{$_} = undef foreach @methods;
+}
+
+sub get_required_method_list {
+    my ($self) = @_;
+    keys %{$self->get_required_methods_map};
+}
+
+sub requires_method {
+    my ($self, $method_name) = @_;
+    exists $self->get_required_methods_map->{$method_name} ? 1 : 0;
+}
+
 ## methods
 
 # NOTE:
@@ -114,7 +138,7 @@ sub get_method_list {
         # should not be showing up in the list at all, 
         # but they do, so we need to switch Moose::Role
         # and Moose to use Sub::Exporter to prevent this
-        !/^(meta|has|extends|blessed|confess|augment|inner|override|super|before|after|around|with)$/ 
+        !/^(meta|has|extends|blessed|confess|augment|inner|override|super|before|after|around|with|requires)$/ 
     } $self->_role_meta->get_method_list;
 }
 
@@ -211,6 +235,18 @@ sub get_method_modifier_list {
 sub apply {
     my ($self, $other) = @_;
     
+    # NOTE:
+    # we might need to move this down below the 
+    # the attributes so that we can require any 
+    # attribute accessors. However I am thinking 
+    # that maybe those are somehow exempt from 
+    # the require methods stuff.  
+    foreach my $required_method_name ($self->get_required_method_list) {
+        ($other->has_method($required_method_name))
+            || confess "Role (" . $self->name . ") requires the method '$required_method_name'" . 
+                      "is implemented by the class '" . $other->name . "'";
+    }    
+    
     foreach my $attribute_name ($self->get_attribute_list) {
         # skip it if it has one already
         next if $other->has_attribute($attribute_name);
@@ -263,8 +299,6 @@ sub apply {
         ) foreach $self->get_around_method_modifiers($method_name);
     }    
     
-    ## add the roles and set does()
-    
     $other->add_role($self);
 }
 
@@ -354,6 +388,18 @@ for more information.
 
 =over 4
 
+=item B<add_required_methods>
+
+=item B<get_required_method_list>
+
+=item B<get_required_methods_map>
+
+=item B<requires_method>
+
+=back
+
+=over 4
+
 =item B<add_after_method_modifier>
 
 =item B<add_around_method_modifier>

diff --git a/lib/Moose/Role.pm b/lib/Moose/Role.pm
index 7e143d8..afd0a4c 100644 (file)
--- a/lib/Moose/Role.pm
+++ b/lib/Moose/Role.pm
@@ -48,6 +48,11 @@ sub import {
         $role->meta->apply($meta);
        });     
        
+       # required methods
+       $meta->alias_method('requires' => subname 'Moose::requires' => sub { 
+        $meta->add_required_methods(@_);
+       });     
+       
        # handle attributes
        $meta->alias_method('has' => subname 'Moose::Role::has' => sub { 
                my ($name, %options) = @_;

diff --git a/t/007_basic.t b/t/007_basic.t
index fa4549e..90c5ceb 100644 (file)
--- a/t/007_basic.t
+++ b/t/007_basic.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 52;
+use Test::More tests => 54;
 use Test::Exception;
 
 BEGIN {
@@ -18,7 +18,8 @@ BEGIN {
     use warnings;
     use Moose::Role;
     
-    sub equal_to    { confess "equal must be implemented" }
+    requires 'equal_to';
+    
     sub not_equal_to { 
         my ($self, $other) = @_;
         !$self->equal_to($other);
@@ -31,7 +32,7 @@ BEGIN {
     
     with 'Eq';
     
-    sub compare { confess "compare must be implemented" }
+    requires 'compare';
     
     sub equal_to {
         my ($self, $other) = @_;
@@ -95,26 +96,26 @@ isa_ok($fifty, 'US::Currency');
 can_ok($fifty, 'amount');
 is($fifty->amount, 50, '... got the right amount');
 
-ok($hundred->greater_than($fifty), '... 100 gt 50');
+ok($hundred->greater_than($fifty),             '... 100 gt 50');
 ok($hundred->greater_than_or_equal_to($fifty), '... 100 ge 50');
-ok(!$hundred->less_than($fifty), '... !100 lt 50');
-ok(!$hundred->less_than_or_equal_to($fifty), '... !100 le 50');
-ok(!$hundred->equal_to($fifty), '... !100 eq 50');
-ok($hundred->not_equal_to($fifty), '... 100 ne 50');
+ok(!$hundred->less_than($fifty),               '... !100 lt 50');
+ok(!$hundred->less_than_or_equal_to($fifty),   '... !100 le 50');
+ok(!$hundred->equal_to($fifty),                '... !100 eq 50');
+ok($hundred->not_equal_to($fifty),             '... 100 ne 50');
 
-ok(!$fifty->greater_than($hundred), '... !50 gt 100');
+ok(!$fifty->greater_than($hundred),             '... !50 gt 100');
 ok(!$fifty->greater_than_or_equal_to($hundred), '... !50 ge 100');
-ok($fifty->less_than($hundred), '... 50 lt 100');
-ok($fifty->less_than_or_equal_to($hundred), '... 50 le 100');
-ok(!$fifty->equal_to($hundred), '... !50 eq 100');
-ok($fifty->not_equal_to($hundred), '... 50 ne 100');
+ok($fifty->less_than($hundred),                 '... 50 lt 100');
+ok($fifty->less_than_or_equal_to($hundred),     '... 50 le 100');
+ok(!$fifty->equal_to($hundred),                 '... !50 eq 100');
+ok($fifty->not_equal_to($hundred),              '... 50 ne 100');
 
-ok(!$fifty->greater_than($fifty), '... !50 gt 50');
+ok(!$fifty->greater_than($fifty),            '... !50 gt 50');
 ok($fifty->greater_than_or_equal_to($fifty), '... !50 ge 50');
-ok(!$fifty->less_than($fifty), '... 50 lt 50');
-ok($fifty->less_than_or_equal_to($fifty), '... 50 le 50');
-ok($fifty->equal_to($fifty), '... 50 eq 50');
-ok(!$fifty->not_equal_to($fifty), '... !50 ne 50');
+ok(!$fifty->less_than($fifty),               '... 50 lt 50');
+ok($fifty->less_than_or_equal_to($fifty),    '... 50 le 50');
+ok($fifty->equal_to($fifty),                 '... 50 eq 50');
+ok(!$fifty->not_equal_to($fifty),            '... !50 ne 50');
 
 ## ... check some meta-stuff
 
@@ -123,28 +124,26 @@ ok(!$fifty->not_equal_to($fifty), '... !50 ne 50');
 my $eq_meta = Eq->meta;
 isa_ok($eq_meta, 'Moose::Meta::Role');
 
-foreach my $method_name (qw(
-                        equal_to not_equal_to
-                        )) {
-    ok($eq_meta->has_method($method_name), '... Eq has_method ' . $method_name);
-}
+ok($eq_meta->has_method('not_equal_to'), '... Eq has_method not_equal_to');
+ok($eq_meta->requires_method('equal_to'), '... Eq requires_method not_equal_to');
 
 # Ord
 
-my $comparable_meta = Ord->meta;
-isa_ok($comparable_meta, 'Moose::Meta::Role');
+my $ord_meta = Ord->meta;
+isa_ok($ord_meta, 'Moose::Meta::Role');
 
-ok($comparable_meta->does_role('Eq'), '... Ord does Eq');
+ok($ord_meta->does_role('Eq'), '... Ord does Eq');
 
 foreach my $method_name (qw(
                         equal_to not_equal_to
-                        compare
                         greater_than greater_than_or_equal_to
                         less_than less_than_or_equal_to                            
                         )) {
-    ok($comparable_meta->has_method($method_name), '... Ord has_method ' . $method_name);
+    ok($ord_meta->has_method($method_name), '... Ord has_method ' . $method_name);
 }
 
+ok($ord_meta->requires_method('compare'), '... Ord requires_method compare');
+
 # US::Currency
 
 my $currency_meta = US::Currency->meta;
@@ -163,3 +162,14 @@ foreach my $method_name (qw(
     ok($currency_meta->has_method($method_name), '... US::Currency has_method ' . $method_name);
 }
 
+# check some errors
+
+{
+    package Foo;
+    use strict;
+    use warnings;
+    use Moose;
+    ::dies_ok { with('Eq') } '... no equal_to method implemented by Foo';
+    ::dies_ok { with('Ord') } '... no compare method implemented by Foo';    
+}
+