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
use strict;
use warnings;
-our $VERSION = '0.03_02';
+our $VERSION = '0.04';
use Scalar::Util 'blessed', 'reftype';
use Carp 'confess';
(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;
}
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
__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 { {} } # (<name> => [ (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 { {} } # (<name> => [ (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 { {} } # (<name> => [ (CODE) ])
));
__PACKAGE__->meta->add_attribute('override_method_modifiers' => (
default => sub { {} } # (<name> => 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'
);
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 {
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;
}
# 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)
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;
=item B<has_method>
+=item B<alias_method>
+
=item B<get_method_list>
=back
# 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;
use Carp 'confess';
use Sub::Name 'subname';
-our $VERSION = '0.01';
+our $VERSION = '0.02';
use Moose::Meta::Role;
}
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:
# 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;
sub equal {
my ($self, $other) = @_;
- $other->as_float == $other->as_float;
+ $self->as_float == $other->as_float;
}
=head1 DESCRIPTION
--- /dev/null
+#!/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);
+}
+
);
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');
use strict;
use warnings;
-use Test::More tests => 17;
+use Test::More tests => 35;
use Test::Exception;
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');
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 ...
[ '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');
+
projects / gitmo/Moose.git / commitdiff