From: Stevan Little Date: Thu, 13 Apr 2006 18:06:36 +0000 (+0000) Subject: required-methods X-Git-Tag: 0_05~36 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1331430ae4a190913fb8dfff77634fafe804f74a;p=gitmo%2FMoose.git required-methods --- diff --git a/Changes b/Changes index 1c10192..8c754b8 100644 --- 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 --- 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 + +=item B + +=item B + +=item B + +=back + +=over 4 + =item B =item B diff --git a/lib/Moose/Role.pm b/lib/Moose/Role.pm index 7e143d8..afd0a4c 100644 --- 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 --- 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'; +} +