From: Stevan Little Date: Thu, 13 Apr 2006 17:20:12 +0000 (+0000) Subject: roles-do-roles X-Git-Tag: 0_05~37 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=bdabd6208bd07e58651c7db41c998ec3e391b529;p=gitmo%2FMoose.git roles-do-roles --- diff --git a/Changes b/Changes index 1f82770..1c10192 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,10 @@ Revision history for Perl extension Moose +0.04 + * Moose::Meta::Role + - ripped out much of it's guts ,.. much cleaner now + - applied the needed changs to Moose::Role too + 0.03_02 Wed. April 12, 2006 * Moose - you must now explictly use Moose::Util::TypeConstraints diff --git a/lib/Moose.pm b/lib/Moose.pm index ddc0a3d..a7f185c 100644 --- a/lib/Moose.pm +++ b/lib/Moose.pm @@ -4,7 +4,7 @@ package Moose; use strict; use warnings; -our $VERSION = '0.03_02'; +our $VERSION = '0.04'; use Scalar::Util 'blessed', 'reftype'; use Carp 'confess'; diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm index 0bd30d7..3dc6611 100644 --- a/lib/Moose/Meta/Class.pm +++ b/lib/Moose/Meta/Class.pm @@ -28,7 +28,7 @@ sub does_role { (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 1 if $role->does_role($role_name); } return 0; } diff --git a/lib/Moose/Meta/Role.pm b/lib/Moose/Meta/Role.pm index c4b32b8..ad07e36 100644 --- a/lib/Moose/Meta/Role.pm +++ b/lib/Moose/Meta/Role.pm @@ -5,14 +5,20 @@ use strict; use warnings; use metaclass; -use Carp 'confess'; +use Carp 'confess'; +use Scalar::Util 'blessed'; + +use Moose::Meta::Class; our $VERSION = '0.02'; +## Attributes + ## the meta for the role package -__PACKAGE__->meta->add_attribute('role_meta' => ( - reader => 'role_meta' +__PACKAGE__->meta->add_attribute('_role_meta' => ( + reader => '_role_meta', + init_arg => ':role_meta' )); ## roles @@ -33,17 +39,17 @@ __PACKAGE__->meta->add_attribute('attribute_map' => ( __PACKAGE__->meta->add_attribute('before_method_modifiers' => ( reader => 'get_before_method_modifiers_map', - default => sub { {} } # keyed by method name, then arrays of method-modifiers + default => sub { {} } # ( => [ (CODE) ]) )); __PACKAGE__->meta->add_attribute('after_method_modifiers' => ( reader => 'get_after_method_modifiers_map', - default => sub { {} } # keyed by method name, then arrays of method-modifiers + default => sub { {} } # ( => [ (CODE) ]) )); __PACKAGE__->meta->add_attribute('around_method_modifiers' => ( reader => 'get_around_method_modifiers_map', - default => sub { {} } # keyed by method name, then arrays of method-modifiers + default => sub { {} } # ( => [ (CODE) ]) )); __PACKAGE__->meta->add_attribute('override_method_modifiers' => ( @@ -51,12 +57,12 @@ __PACKAGE__->meta->add_attribute('override_method_modifiers' => ( default => sub { {} } # ( => CODE) )); -## methods ... +## Methods sub new { my $class = shift; my %options = @_; - $options{'role_meta'} = Class::MOP::Class->initialize( + $options{':role_meta'} = Moose::Meta::Class->initialize( $options{role_name}, ':method_metaclass' => 'Moose::Meta::Role::Method' ); @@ -64,88 +70,6 @@ sub new { return $self; } -sub apply { - my ($self, $other) = @_; - - foreach my $attribute_name ($self->get_attribute_list) { - # skip it if it has one already - next if $other->has_attribute($attribute_name); - # add it, although it could be overriden - $other->add_attribute( - $attribute_name, - %{$self->get_attribute($attribute_name)} - ); - } - - foreach my $method_name ($self->get_method_list) { - # skip it if it has one already - next if $other->has_method($method_name); - # add it, although it could be overriden - $other->alias_method( - $method_name, - $self->get_method($method_name) - ); - } - - foreach my $method_name ($self->get_method_modifier_list('override')) { - # skip it if it has one already - next if $other->has_method($method_name); - # add it, although it could be overriden - $other->add_override_method_modifier( - $method_name, - $self->get_override_method_modifier($method_name), - $self->name - ); - } - - foreach my $method_name ($self->get_method_modifier_list('before')) { - $other->add_before_method_modifier( - $method_name, - $_ - ) foreach $self->get_before_method_modifiers($method_name); - } - - foreach my $method_name ($self->get_method_modifier_list('after')) { - $other->add_after_method_modifier( - $method_name, - $_ - ) foreach $self->get_after_method_modifiers($method_name); - } - - foreach my $method_name ($self->get_method_modifier_list('around')) { - $other->add_around_method_modifier( - $method_name, - $_ - ) foreach $self->get_around_method_modifiers($method_name); - } - - ## 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'); -} - ## subroles sub add_role { @@ -159,8 +83,11 @@ sub does_role { my ($self, $role_name) = @_; (defined $role_name) || confess "You must supply a role name to look for"; + # if we are it,.. then return true + return 1 if $role_name eq $self->name; + # otherwise.. check our children foreach my $role (@{$self->get_roles}) { - return 1 if $role->name eq $role_name; + return 1 if $role->does_role($role_name); } return 0; } @@ -173,16 +100,22 @@ sub does_role { # to the underlying role package, if you want to manipulate # that, just use ->role_meta -sub name { (shift)->role_meta->name } -sub version { (shift)->role_meta->version } +sub name { (shift)->_role_meta->name } +sub version { (shift)->_role_meta->version } -sub get_method { (shift)->role_meta->get_method(@_) } -sub has_method { (shift)->role_meta->has_method(@_) } +sub get_method { (shift)->_role_meta->get_method(@_) } +sub has_method { (shift)->_role_meta->has_method(@_) } +sub alias_method { (shift)->_role_meta->alias_method(@_) } sub get_method_list { my ($self) = @_; - # meta is not applicable in this context, - # if you want to see it use the ->role_meta - grep { !/^meta$/ } $self->role_meta->get_method_list; + grep { + # NOTE: + # this is a kludge for now,... these functions + # 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)$/ + } $self->_role_meta->get_method_list; } # ... however the items in statis (attributes & method modifiers) @@ -273,6 +206,68 @@ sub get_method_modifier_list { keys %{$self->$accessor}; } +## applying a role to a class ... + +sub apply { + my ($self, $other) = @_; + + foreach my $attribute_name ($self->get_attribute_list) { + # skip it if it has one already + next if $other->has_attribute($attribute_name); + # add it, although it could be overriden + $other->add_attribute( + $attribute_name, + %{$self->get_attribute($attribute_name)} + ); + } + + foreach my $method_name ($self->get_method_list) { + # skip it if it has one already + next if $other->has_method($method_name); + # add it, although it could be overriden + $other->alias_method( + $method_name, + $self->get_method($method_name) + ); + } + + foreach my $method_name ($self->get_method_modifier_list('override')) { + # skip it if it has one already + next if $other->has_method($method_name); + # add it, although it could be overriden + $other->add_override_method_modifier( + $method_name, + $self->get_override_method_modifier($method_name), + $self->name + ); + } + + foreach my $method_name ($self->get_method_modifier_list('before')) { + $other->add_before_method_modifier( + $method_name, + $_ + ) foreach $self->get_before_method_modifiers($method_name); + } + + foreach my $method_name ($self->get_method_modifier_list('after')) { + $other->add_after_method_modifier( + $method_name, + $_ + ) foreach $self->get_after_method_modifiers($method_name); + } + + foreach my $method_name ($self->get_method_modifier_list('around')) { + $other->add_around_method_modifier( + $method_name, + $_ + ) foreach $self->get_around_method_modifiers($method_name); + } + + ## add the roles and set does() + + $other->add_role($self); +} + package Moose::Meta::Role::Method; use strict; @@ -335,6 +330,8 @@ for more information. =item B +=item B + =item B =back diff --git a/lib/Moose/Object.pm b/lib/Moose/Object.pm index c497104..569246b 100644 --- a/lib/Moose/Object.pm +++ b/lib/Moose/Object.pm @@ -38,10 +38,15 @@ sub DESTROY { goto &DEMOLISHALL } # new does() methods will be created # as approiate see Moose::Meta::Role sub does { - my (undef, $role_name) = @_; + my ($self, $role_name) = @_; (defined $role_name) || confess "You much supply a role name to does()"; - 0; + my $meta = $self->meta; + foreach my $class ($meta->class_precedence_list) { + return 1 + if $meta->initialize($class)->does_role($role_name); + } + return 0; } 1; diff --git a/lib/Moose/Role.pm b/lib/Moose/Role.pm index 229c6f9..7e143d8 100644 --- a/lib/Moose/Role.pm +++ b/lib/Moose/Role.pm @@ -8,7 +8,7 @@ use Scalar::Util (); use Carp 'confess'; use Sub::Name 'subname'; -our $VERSION = '0.01'; +our $VERSION = '0.02'; use Moose::Meta::Role; @@ -29,7 +29,7 @@ sub import { } else { $meta = Moose::Meta::Role->new(role_name => $pkg); - $meta->role_meta->add_method('meta' => sub { $meta }) + $meta->_role_meta->add_method('meta' => sub { $meta }) } # NOTE: @@ -37,47 +37,54 @@ sub import { # will not name it with # handle superclasses - $meta->role_meta->alias_method('extends' => subname 'Moose::Role::extends' => sub { + $meta->alias_method('extends' => subname 'Moose::Role::extends' => sub { confess "Moose::Role does not currently support 'extends'" }); + # handle roles + $meta->alias_method('with' => subname 'Moose::with' => sub { + my ($role) = @_; + Moose::_load_all_classes($role); + $role->meta->apply($meta); + }); + # handle attributes - $meta->role_meta->alias_method('has' => subname 'Moose::Role::has' => sub { + $meta->alias_method('has' => subname 'Moose::Role::has' => sub { my ($name, %options) = @_; $meta->add_attribute($name, %options) }); # handle method modifers - $meta->role_meta->alias_method('before' => subname 'Moose::Role::before' => sub { + $meta->alias_method('before' => subname 'Moose::Role::before' => sub { my $code = pop @_; $meta->add_before_method_modifier($_, $code) for @_; }); - $meta->role_meta->alias_method('after' => subname 'Moose::Role::after' => sub { + $meta->alias_method('after' => subname 'Moose::Role::after' => sub { my $code = pop @_; $meta->add_after_method_modifier($_, $code) for @_; }); - $meta->role_meta->alias_method('around' => subname 'Moose::Role::around' => sub { + $meta->alias_method('around' => subname 'Moose::Role::around' => sub { my $code = pop @_; $meta->add_around_method_modifier($_, $code) for @_; }); - $meta->role_meta->alias_method('super' => subname 'Moose::Role::super' => sub {}); - $meta->role_meta->alias_method('override' => subname 'Moose::Role::override' => sub { + $meta->alias_method('super' => subname 'Moose::Role::super' => sub {}); + $meta->alias_method('override' => subname 'Moose::Role::override' => sub { my ($name, $code) = @_; $meta->add_override_method_modifier($name, $code); }); - $meta->role_meta->alias_method('inner' => subname 'Moose::Role::inner' => sub { + $meta->alias_method('inner' => subname 'Moose::Role::inner' => sub { confess "Moose::Role does not currently support 'inner'"; }); - $meta->role_meta->alias_method('augment' => subname 'Moose::Role::augment' => sub { + $meta->alias_method('augment' => subname 'Moose::Role::augment' => sub { confess "Moose::Role does not currently support 'augment'"; }); # we recommend using these things # so export them for them - $meta->role_meta->alias_method('confess' => \&Carp::confess); - $meta->role_meta->alias_method('blessed' => \&Scalar::Util::blessed); + $meta->alias_method('confess' => \&Carp::confess); + $meta->alias_method('blessed' => \&Scalar::Util::blessed); } 1; @@ -115,7 +122,7 @@ Moose::Role - The Moose Role sub equal { my ($self, $other) = @_; - $other->as_float == $other->as_float; + $self->as_float == $other->as_float; } =head1 DESCRIPTION diff --git a/t/007_basic.t b/t/007_basic.t new file mode 100644 index 0000000..fa4549e --- /dev/null +++ b/t/007_basic.t @@ -0,0 +1,165 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 52; +use Test::Exception; + +BEGIN { + use_ok('Moose'); +} + +## Roles + +{ + package Eq; + use strict; + use warnings; + use Moose::Role; + + sub equal_to { confess "equal must be implemented" } + sub not_equal_to { + my ($self, $other) = @_; + !$self->equal_to($other); + } + + package Ord; + use strict; + use warnings; + use Moose::Role; + + with 'Eq'; + + sub compare { confess "compare must be implemented" } + + sub equal_to { + my ($self, $other) = @_; + $self->compare($other) == 0; + } + + sub greater_than { + my ($self, $other) = @_; + $self->compare($other) == 1; + } + + sub less_than { + my ($self, $other) = @_; + $self->compare($other) == -1; + } + + sub greater_than_or_equal_to { + my ($self, $other) = @_; + $self->greater_than($other) || $self->equal_to($other); + } + + sub less_than_or_equal_to { + my ($self, $other) = @_; + $self->less_than($other) || $self->equal_to($other); + } +} + +## Classes + +{ + package US::Currency; + use strict; + use warnings; + use Moose; + + with 'Ord'; + + has 'amount' => (is => 'rw', isa => 'Int', default => 0); + + sub compare { + my ($self, $other) = @_; + $self->amount <=> $other->amount; + } +} + +ok(US::Currency->does('Ord'), '... US::Currency does Ord'); +ok(US::Currency->does('Eq'), '... US::Currency does Eq'); + +my $hundred = US::Currency->new(amount => 100.00); +isa_ok($hundred, 'US::Currency'); + +can_ok($hundred, 'amount'); +is($hundred->amount, 100, '... got the right amount'); + +ok($hundred->does('Ord'), '... US::Currency does Ord'); +ok($hundred->does('Eq'), '... US::Currency does Eq'); + +my $fifty = US::Currency->new(amount => 50.00); +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_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(!$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->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'); + +## ... check some meta-stuff + +# Eq + +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); +} + +# Ord + +my $comparable_meta = Ord->meta; +isa_ok($comparable_meta, 'Moose::Meta::Role'); + +ok($comparable_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); +} + +# US::Currency + +my $currency_meta = US::Currency->meta; +isa_ok($currency_meta, 'Moose::Meta::Class'); + +ok($currency_meta->does_role('Ord'), '... US::Currency does Ord'); +ok($currency_meta->does_role('Eq'), '... US::Currency does Eq'); + +foreach my $method_name (qw( + amount + equal_to not_equal_to + compare + greater_than greater_than_or_equal_to + less_than less_than_or_equal_to + )) { + ok($currency_meta->has_method($method_name), '... US::Currency has_method ' . $method_name); +} + diff --git a/t/040_meta_role.t b/t/040_meta_role.t index 05b54a9..a68aaf1 100644 --- a/t/040_meta_role.t +++ b/t/040_meta_role.t @@ -23,7 +23,7 @@ my $foo_role = Moose::Meta::Role->new( ); isa_ok($foo_role, 'Moose::Meta::Role'); -isa_ok($foo_role->role_meta, 'Class::MOP::Class'); +isa_ok($foo_role->_role_meta, 'Class::MOP::Class'); is($foo_role->name, 'FooRole', '... got the right name of FooRole'); is($foo_role->version, '0.01', '... got the right version of FooRole'); diff --git a/t/041_role.t b/t/041_role.t index a8d81b1..eaefa07 100644 --- a/t/041_role.t +++ b/t/041_role.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 17; +use Test::More tests => 35; use Test::Exception; BEGIN { @@ -23,14 +23,27 @@ BEGIN { has 'baz' => (is => 'ro'); sub foo { 'FooRole::foo' } + sub boo { 'FooRole::boo' } before 'boo' => sub { "FooRole::boo:before" }; + + after 'boo' => sub { "FooRole::boo:after1" }; + after 'boo' => sub { "FooRole::boo:after2" }; + + around 'boo' => sub { "FooRole::boo:around" }; + + override 'bling' => sub { "FooRole::bling:override" }; + override 'fling' => sub { "FooRole::fling:override" }; + + ::dies_ok { extends() } '... extends() is not supported'; + ::dies_ok { augment() } '... augment() is not supported'; + ::dies_ok { inner() } '... inner() is not supported'; } my $foo_role = FooRole->meta; isa_ok($foo_role, 'Moose::Meta::Role'); -isa_ok($foo_role->role_meta, 'Class::MOP::Class'); +isa_ok($foo_role->_role_meta, 'Class::MOP::Class'); is($foo_role->name, 'FooRole', '... got the right name of FooRole'); is($foo_role->version, '0.01', '... got the right version of FooRole'); @@ -42,9 +55,14 @@ is($foo_role->get_method('foo'), \&FooRole::foo, '... FooRole got the foo method isa_ok($foo_role->get_method('foo'), 'Moose::Meta::Role::Method'); +ok($foo_role->has_method('boo'), '... FooRole has the boo method'); +is($foo_role->get_method('boo'), \&FooRole::boo, '... FooRole got the boo method'); + +isa_ok($foo_role->get_method('boo'), 'Moose::Meta::Role::Method'); + is_deeply( - [ $foo_role->get_method_list() ], - [ 'foo' ], + [ sort $foo_role->get_method_list() ], + [ 'boo', 'foo' ], '... got the right method list'); # attributes ... @@ -80,3 +98,43 @@ is_deeply( [ 'boo' ], '... got the right list of before method modifiers'); +ok($foo_role->has_after_method_modifiers('boo'), '... now we have a boo:after modifier'); +is(($foo_role->get_after_method_modifiers('boo'))[0]->(), + "FooRole::boo:after1", + '... got the right method back'); +is(($foo_role->get_after_method_modifiers('boo'))[1]->(), + "FooRole::boo:after2", + '... got the right method back'); + +is_deeply( + [ $foo_role->get_method_modifier_list('after') ], + [ 'boo' ], + '... got the right list of after method modifiers'); + +ok($foo_role->has_around_method_modifiers('boo'), '... now we have a boo:around modifier'); +is(($foo_role->get_around_method_modifiers('boo'))[0]->(), + "FooRole::boo:around", + '... got the right method back'); + +is_deeply( + [ $foo_role->get_method_modifier_list('around') ], + [ 'boo' ], + '... got the right list of around method modifiers'); + +## overrides + +ok($foo_role->has_override_method_modifier('bling'), '... now we have a bling:override modifier'); +is($foo_role->get_override_method_modifier('bling')->(), + "FooRole::bling:override", + '... got the right method back'); + +ok($foo_role->has_override_method_modifier('fling'), '... now we have a fling:override modifier'); +is($foo_role->get_override_method_modifier('fling')->(), + "FooRole::fling:override", + '... got the right method back'); + +is_deeply( + [ sort $foo_role->get_method_modifier_list('override') ], + [ 'bling', 'fling' ], + '... got the right list of override method modifiers'); +