use Carp 'confess';
use overload ();
-our $VERSION = '0.15';
+our $VERSION = '0.16';
our $AUTHORITY = 'cpan:STEVAN';
use Moose::Meta::Method::Accessor;
use warnings;
use metaclass;
+use Sub::Name 'subname';
use Carp 'confess';
-use Scalar::Util 'blessed';
+use Scalar::Util 'blessed', 'reftype';
-our $VERSION = '0.11';
+our $VERSION = '0.12';
our $AUTHORITY = 'cpan:STEVAN';
use Moose::Meta::Class;
use base 'Class::MOP::Module';
-
-# NOTE:
-# I normally don't do this, but I am doing
-# a whole bunch of meta-programmin in this
-# module, so it just makes sense.
-# - SL
+## ------------------------------------------------------------------
+## NOTE:
+## I normally don't do this, but I am doing
+## a whole bunch of meta-programmin in this
+## module, so it just makes sense. For a clearer
+## picture of what is going on in the next
+## several lines of code, look at the really
+## big comment at the end of this file (right
+## before the POD).
+## - SL
+## ------------------------------------------------------------------
my $META = __PACKAGE__->meta;
# NOTE:
# since roles are lazy, we hold all the attributes
-# of the individual role in 'statis' until which
-# time when it is applied to a class. This means
-# keeping a lot of things in hash maps, so we are
+# of the individual role in 'statis' until which
+# time when it is applied to a class. This means
+# keeping a lot of things in hash maps, so we are
# using a little of that meta-programmin' magic
-# here an saving lots of extra typin.
-# - SL
-
-$META->add_attribute($_->{name} => (
- reader => $_->{reader},
- default => sub { {} }
-)) for (
- { name => 'excluded_roles_map', reader => 'get_excluded_roles_map' },
- { name => 'attribute_map', reader => 'get_attribute_map' },
- { name => 'required_methods', reader => 'get_required_methods_map' },
-);
-
-# NOTE:
-# many of these attributes above require similar
-# functionality to support them, so we again use
-# the wonders of meta-programmin' to deliver a
+# here an saving lots of extra typin. And since
+# many of these attributes above require similar
+# functionality to support them, so we again use
+# the wonders of meta-programmin' to deliver a
# very compact solution to this normally verbose
# problem.
# - SL
foreach my $action (
- {
- attr_reader => 'get_excluded_roles_map' ,
+ {
+ name => 'excluded_roles_map',
+ attr_reader => 'get_excluded_roles_map' ,
methods => {
- add => 'add_excluded_roles',
- get_list => 'get_excluded_roles_list',
- existence => 'excludes_role',
+ add => 'add_excluded_roles',
+ get_list => 'get_excluded_roles_list',
+ existence => 'excludes_role',
}
},
- {
+ {
+ name => 'required_methods',
attr_reader => 'get_required_methods_map',
methods => {
- add => 'add_required_methods',
+ add => 'add_required_methods',
remove => 'remove_required_methods',
get_list => 'get_required_method_list',
existence => 'requires_method',
}
},
{
+ name => 'attribute_map',
attr_reader => 'get_attribute_map',
methods => {
get => 'get_attribute',
}
}
) {
-
+
my $attr_reader = $action->{attr_reader};
my $methods = $action->{methods};
-
+
+ # create the attribute
+ $META->add_attribute($action->{name} => (
+ reader => $attr_reader,
+ default => sub { {} }
+ ));
+
+ # create some helper methods
$META->add_method($methods->{add} => sub {
my ($self, @values) = @_;
- $self->$attr_reader->{$_} = undef foreach @values;
+ $self->$attr_reader->{$_} = undef foreach @values;
}) if exists $methods->{add};
-
+
$META->add_method($methods->{get_list} => sub {
my ($self) = @_;
- keys %{$self->$attr_reader};
- }) if exists $methods->{get_list};
-
+ keys %{$self->$attr_reader};
+ }) if exists $methods->{get_list};
+
$META->add_method($methods->{get} => sub {
my ($self, $name) = @_;
- $self->$attr_reader->{$name}
- }) if exists $methods->{get};
-
+ $self->$attr_reader->{$name}
+ }) if exists $methods->{get};
+
$META->add_method($methods->{existence} => sub {
my ($self, $name) = @_;
- exists $self->$attr_reader->{$name} ? 1 : 0;
- }) if exists $methods->{existence};
-
+ exists $self->$attr_reader->{$name} ? 1 : 0;
+ }) if exists $methods->{existence};
+
$META->add_method($methods->{remove} => sub {
my ($self, @values) = @_;
delete $self->$attr_reader->{$_} foreach @values;
- }) if exists $methods->{remove};
+ }) if exists $methods->{remove};
}
## some things don't always fit, so they go here ...
foreach my $method ($self->get_required_method_list) {
$self->remove_required_methods($method)
if $self->has_method($method);
- }
+ }
}
## ------------------------------------------------------------------
## method modifiers
-$META->add_attribute($_->{name} => (
- reader => $_->{reader},
- default => sub { {} }
-)) for (
- { name => 'before_method_modifiers', reader => 'get_before_method_modifiers_map' },
- { name => 'after_method_modifiers', reader => 'get_after_method_modifiers_map' },
- { name => 'around_method_modifiers', reader => 'get_around_method_modifiers_map' },
- { name => 'override_method_modifiers', reader => 'get_override_method_modifiers_map' },
-);
-
# NOTE:
-# the before/around/after method modifiers are
+# the before/around/after method modifiers are
# stored by name, but there can be many methods
# then associated with that name. So again we have
# lots of similar functionality, so we can do some
# - SL
foreach my $modifier_type (qw[ before around after ]) {
+
+ my $attr_reader = "get_${modifier_type}_method_modifiers_map";
- my $attr_reader = "get_${modifier_type}_method_modifiers_map";
-
+ # create the attribute ...
+ $META->add_attribute("${modifier_type}_method_modifiers" => (
+ reader => $attr_reader,
+ default => sub { {} }
+ ));
+
+ # and some helper methods ...
$META->add_method("get_${modifier_type}_method_modifiers" => sub {
my ($self, $method_name) = @_;
+ #return () unless exists $self->$attr_reader->{$method_name};
@{$self->$attr_reader->{$method_name}};
});
-
+
$META->add_method("has_${modifier_type}_method_modifiers" => sub {
my ($self, $method_name) = @_;
# NOTE:
- # for now we assume that if it exists,..
+ # for now we assume that if it exists,..
# it has at least one modifier in it
(exists $self->$attr_reader->{$method_name}) ? 1 : 0;
- });
-
+ });
+
$META->add_method("add_${modifier_type}_method_modifier" => sub {
my ($self, $method_name, $method) = @_;
-
- $self->$attr_reader->{$method_name} = []
+
+ $self->$attr_reader->{$method_name} = []
unless exists $self->$attr_reader->{$method_name};
-
+
my $modifiers = $self->$attr_reader->{$method_name};
-
+
# NOTE:
- # check to see that we aren't adding the
- # same code twice. We err in favor of the
+ # check to see that we aren't adding the
+ # same code twice. We err in favor of the
# first on here, this may not be as expected
foreach my $modifier (@{$modifiers}) {
return if $modifier == $method;
}
-
+
push @{$modifiers} => $method;
});
-
+
}
## ------------------------------------------------------------------
## override method mofidiers
+$META->add_attribute('override_method_modifiers' => (
+ reader => 'get_override_method_modifiers_map',
+ default => sub { {} }
+));
+
# NOTE:
-# these are a little different because there
+# these are a little different because there
# can only be one per name, whereas the other
# method modifiers can have multiples.
# - SL
sub add_override_method_modifier {
my ($self, $method_name, $method) = @_;
(!$self->has_method($method_name))
- || confess "Cannot add an override of method '$method_name' " .
+ || confess "Cannot add an override of method '$method_name' " .
"because there is a local version of '$method_name'";
- $self->get_override_method_modifiers_map->{$method_name} = $method;
+ $self->get_override_method_modifiers_map->{$method_name} = $method;
}
sub has_override_method_modifier {
my ($self, $method_name) = @_;
# NOTE:
- # for now we assume that if it exists,..
+ # for now we assume that if it exists,..
# it has at least one modifier in it
- (exists $self->get_override_method_modifiers_map->{$method_name}) ? 1 : 0;
+ (exists $self->get_override_method_modifiers_map->{$method_name}) ? 1 : 0;
}
sub get_override_method_modifier {
my ($self, $method_name) = @_;
- $self->get_override_method_modifiers_map->{$method_name};
+ $self->get_override_method_modifiers_map->{$method_name};
}
## general list accessor ...
sub get_method_modifier_list {
my ($self, $modifier_type) = @_;
- my $accessor = "get_${modifier_type}_method_modifiers_map";
+ my $accessor = "get_${modifier_type}_method_modifiers_map";
keys %{$self->$accessor};
}
sub calculate_all_roles {
my $self = shift;
my %seen;
- grep {
- !$seen{$_->name}++
- } ($self,
- map {
- $_->calculate_all_roles
- } @{ $self->get_roles });
+ grep {
+ !$seen{$_->name}++
+ } ($self, map {
+ $_->calculate_all_roles
+ } @{ $self->get_roles });
}
sub does_role {
}
## ------------------------------------------------------------------
-## methods
+## methods
sub method_metaclass { 'Moose::Meta::Role::Method' }
-# FIXME:
-# this is an UGLY hack
-sub get_method_map {
+sub get_method_map {
my $self = shift;
- $self->{'%!methods'} ||= {};
- $self->reset_package_cache_flag;
- $self->Moose::Meta::Class::get_method_map()
+ my $map = {};
+
+ my $role_name = $self->name;
+ my $method_metaclass = $self->method_metaclass;
+
+ foreach my $symbol ($self->list_all_package_symbols('CODE')) {
+
+ my $code = $self->get_package_symbol('&' . $symbol);
+
+ my ($pkg, $name) = Class::MOP::get_code_info($code);
+
+ if ($pkg->can('meta')
+ # NOTE:
+ # we don't know what ->meta we are calling
+ # here, so we need to be careful cause it
+ # just might blow up at us, or just complain
+ # loudly (in the case of Curses.pm) so we
+ # just be a little overly cautious here.
+ # - SL
+ && eval { no warnings; blessed($pkg->meta) }
+ && $pkg->meta->isa('Moose::Meta::Role')) {
+ my $role = $pkg->meta->name;
+ next unless $self->does_role($role);
+ }
+ else {
+ next if ($pkg || '') ne $role_name &&
+ ($name || '') ne '__ANON__';
+ }
+
+ $map->{$symbol} = $method_metaclass->wrap($code);
+ }
+
+ return $map;
}
-sub update_package_cache_flag { () }
-sub reset_package_cache_flag { (shift)->{'$!_package_cache_flag'} = undef; }
-# FIXME:
-# Yes, this is a really really UGLY hack
-# but it works, and until I can figure
-# out a better way, this is gonna be it.
+sub get_method {
+ my ($self, $name) = @_;
+ $self->get_method_map->{$name}
+}
-sub get_method { (shift)->Moose::Meta::Class::get_method(@_) }
-sub has_method { (shift)->Moose::Meta::Class::has_method(@_) }
-sub alias_method { (shift)->Moose::Meta::Class::alias_method(@_) }
-sub get_method_list {
- grep {
- !/^meta$/
- } (shift)->Moose::Meta::Class::get_method_list(@_)
+sub has_method {
+ my ($self, $name) = @_;
+ exists $self->get_method_map->{$name} ? 1 : 0
}
sub find_method_by_name { (shift)->get_method(@_) }
+sub get_method_list {
+ my $self = shift;
+ grep { !/^meta$/ } keys %{$self->get_method_map};
+}
+
+sub alias_method {
+ my ($self, $method_name, $method) = @_;
+ (defined $method_name && $method_name)
+ || confess "You must define a method name";
+
+ my $body = (blessed($method) ? $method->body : $method);
+ ('CODE' eq (reftype($body) || ''))
+ || confess "Your code block must be a CODE reference";
+
+ $self->add_package_symbol("&${method_name}" => $body);
+}
+
+sub reset_package_cache_flag { () }
+sub update_package_cache_flag { () }
+
## ------------------------------------------------------------------
-## role construction
+## role construction
## ------------------------------------------------------------------
my $anon_counter = 0;
sub apply {
my ($self, $other) = @_;
-
+
unless ($other->isa('Moose::Meta::Class') || $other->isa('Moose::Meta::Role')) {
-
+
# Runtime Role mixins
-
+
# FIXME:
- # We really should do this better, and
- # cache the results of our efforts so
+ # We really should do this better, and
+ # cache the results of our efforts so
# that we don't need to repeat them.
-
+
my $pkg_name = __PACKAGE__ . "::__RUNTIME_ROLE_ANON_CLASS__::" . $anon_counter++;
eval "package " . $pkg_name . "; our \$VERSION = '0.00';";
die $@ if $@;
my $object = $other;
$other = Moose::Meta::Class->initialize($pkg_name);
- $other->superclasses(blessed($object));
-
+ $other->superclasses(blessed($object));
+
bless $object => $pkg_name;
}
-
+
$self->_check_excluded_roles($other);
- $self->_check_required_methods($other);
+ $self->_check_required_methods($other);
+
+ $self->_apply_attributes($other);
+ $self->_apply_methods($other);
- $self->_apply_attributes($other);
- $self->_apply_methods($other);
-
# NOTE:
# we need a clear cache flag too ...
- $other->reset_package_cache_flag;
+ $other->reset_package_cache_flag;
- $self->_apply_override_method_modifiers($other);
- $self->_apply_before_method_modifiers($other);
- $self->_apply_around_method_modifiers($other);
- $self->_apply_after_method_modifiers($other);
+ $self->_apply_override_method_modifiers($other);
+
+ $self->_apply_before_method_modifiers($other);
+ $self->_apply_around_method_modifiers($other);
+ $self->_apply_after_method_modifiers($other);
$other->add_role($self);
}
sub combine {
my ($class, @roles) = @_;
- my $pkg_name = __PACKAGE__ . "::__COMPOSITE_ROLE_SANDBOX__::" . $anon_counter++;
- eval "package " . $pkg_name . "; our \$VERSION = '0.00';";
- die $@ if $@;
-
- my $combined = $class->initialize($pkg_name);
-
- foreach my $role (@roles) {
- $role->apply($combined);
- }
-
- $combined->_clean_up_required_methods;
+ require Moose::Meta::Role::Application::RoleSummation;
+ require Moose::Meta::Role::Composite;
- return $combined;
+ my $c = Moose::Meta::Role::Composite->new(roles => \@roles);
+ Moose::Meta::Role::Application::RoleSummation->new->apply($c);
+ return $c;
}
## ------------------------------------------------------------------
confess "Conflict detected: " . $other->name . " excludes role '" . $self->name . "'";
}
foreach my $excluded_role_name ($self->get_excluded_roles_list) {
- if ($other->does_role($excluded_role_name)) {
+ if ($other->does_role($excluded_role_name)) {
confess "The class " . $other->name . " does the excluded role '$excluded_role_name'";
}
else {
if ($other->isa('Moose::Meta::Role')) {
$other->add_excluded_roles($excluded_role_name);
}
- # else -> ignore it :)
+ # else -> ignore it :)
}
- }
+ }
}
sub _check_required_methods {
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.
+ # 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) {
-
+
unless ($other->find_method_by_name($required_method_name)) {
if ($other->isa('Moose::Meta::Role')) {
$other->add_required_methods($required_method_name);
}
else {
- confess "'" . $self->name . "' requires the method '$required_method_name' " .
+ confess "'" . $self->name . "' requires the method '$required_method_name' " .
"to be implemented by '" . $other->name . "'";
}
}
else {
# NOTE:
- # we need to make sure that the method is
- # not a method modifier, because those do
+ # we need to make sure that the method is
+ # not a method modifier, because those do
# not satisfy the requirements ...
my $method = $other->find_method_by_name($required_method_name);
-
+
# check if it is a generated accessor ...
(!$method->isa('Class::MOP::Method::Accessor'))
- || confess "'" . $self->name . "' requires the method '$required_method_name' " .
+ || confess "'" . $self->name . "' requires the method '$required_method_name' " .
"to be implemented by '" . $other->name . "', the method is only an attribute accessor";
# NOTE:
- # All other tests here have been removed, they were tests
+ # All other tests here have been removed, they were tests
# for overriden methods and before/after/around modifiers.
# But we realized that for classes any overriden or modified
- # methods would be backed by a real method of that name
- # (and therefore meet the requirement). And for roles, the
+ # methods would be backed by a real method of that name
+ # (and therefore meet the requirement). And for roles, the
# overriden and modified methods are "in statis" and so would
# not show up in this test anyway (and as a side-effect they
- # would not fufill the requirement, which is exactly what we
+ # would not fufill the requirement, which is exactly what we
# want them to do anyway).
- # - SL
- }
- }
+ # - SL
+ }
+ }
}
sub _apply_attributes {
- my ($self, $other) = @_;
+ my ($self, $other) = @_;
foreach my $attribute_name ($self->get_attribute_list) {
# it if it has one already
if ($other->has_attribute($attribute_name) &&
# make sure we haven't seen this one already too
$other->get_attribute($attribute_name) != $self->get_attribute($attribute_name)) {
- # see if we are being composed
+ # see if we are being composed
# into a role or not
- if ($other->isa('Moose::Meta::Role')) {
- # all attribute conflicts between roles
- # result in an immediate fatal error
- confess "Role '" . $self->name . "' has encountered an attribute conflict " .
+ if ($other->isa('Moose::Meta::Role')) {
+ # all attribute conflicts between roles
+ # result in an immediate fatal error
+ confess "Role '" . $self->name . "' has encountered an attribute conflict " .
"during composition. This is fatal error and cannot be disambiguated.";
}
else {
- # but if this is a class, we
- # can safely skip adding the
+ # but if this is a class, we
+ # can safely skip adding the
# attribute to the class
next;
}
else {
# NOTE:
# this is kinda ugly ...
- if ($other->isa('Moose::Meta::Class')) {
+ if ($other->isa('Moose::Meta::Class')) {
$other->_process_attribute(
$attribute_name,
%{$self->get_attribute($attribute_name)}
- );
+ );
}
else {
$other->add_attribute(
$attribute_name,
$self->get_attribute($attribute_name)
- );
+ );
}
}
- }
+ }
}
sub _apply_methods {
- my ($self, $other) = @_;
+ my ($self, $other) = @_;
foreach my $method_name ($self->get_method_list) {
# it if it has one already
if ($other->has_method($method_name) &&
# and if they are not the same thing ...
$other->get_method($method_name)->body != $self->get_method($method_name)->body) {
# see if we are composing into a role
- if ($other->isa('Moose::Meta::Role')) {
- # method conflicts between roles result
+ if ($other->isa('Moose::Meta::Role')) {
+ # method conflicts between roles result
# in the method becoming a requirement
$other->add_required_methods($method_name);
# NOTE:
- # we have to remove the method from our
+ # we have to remove the method from our
# role, if this is being called from combine()
# which means the meta is an anon class
- # this *may* cause problems later, but it
- # is probably fairly safe to assume that
+ # this *may* cause problems later, but it
+ # is probably fairly safe to assume that
# anon classes will only be used internally
# or by people who know what they are doing
$other->Moose::Meta::Class::remove_method($method_name)
}
}
else {
- # add it, although it could be overriden
+ # add it, although it could be overriden
$other->alias_method(
$method_name,
$self->get_method($method_name)
);
}
- }
+ }
}
sub _apply_override_method_modifiers {
- my ($self, $other) = @_;
+ my ($self, $other) = @_;
foreach my $method_name ($self->get_method_modifier_list('override')) {
# it if it has one already then ...
if ($other->has_method($method_name)) {
# if it is being composed into another role
- # we have a conflict here, because you cannot
+ # we have a conflict here, because you cannot
# combine an overriden method with a locally
- # defined one
- if ($other->isa('Moose::Meta::Role')) {
- confess "Role '" . $self->name . "' has encountered an 'override' method conflict " .
- "during composition (A local method of the same name as been found). This " .
+ # defined one
+ if ($other->isa('Moose::Meta::Role')) {
+ confess "Role '" . $self->name . "' has encountered an 'override' method conflict " .
+ "during composition (A local method of the same name as been found). This " .
"is fatal error.";
}
else {
- # if it is a class, then we
+ # if it is a class, then we
# just ignore this here ...
next;
}
}
else {
- # if no local method is found, then we
+ # if no local method is found, then we
# must check if we are a role or class
- if ($other->isa('Moose::Meta::Role')) {
- # if we are a role, we need to make sure
- # we dont have a conflict with the role
+ if ($other->isa('Moose::Meta::Role')) {
+ # if we are a role, we need to make sure
+ # we dont have a conflict with the role
# we are composing into
if ($other->has_override_method_modifier($method_name) &&
$other->get_override_method_modifier($method_name) != $self->get_override_method_modifier($method_name)) {
- confess "Role '" . $self->name . "' has encountered an 'override' method conflict " .
- "during composition (Two 'override' methods of the same name encountered). " .
+ confess "Role '" . $self->name . "' has encountered an 'override' method conflict " .
+ "during composition (Two 'override' methods of the same name encountered). " .
"This is fatal error.";
}
- else {
+ else {
# if there is no conflict,
- # just add it to the role
+ # just add it to the role
$other->add_override_method_modifier(
- $method_name,
+ $method_name,
$self->get_override_method_modifier($method_name)
- );
+ );
}
}
else {
- # if this is not a role, then we need to
+ # if this is not a role, then we need to
# find the original package of the method
- # so that we can tell the class were to
+ # so that we can tell the class were to
# find the right super() method
my $method = $self->get_override_method_modifier($method_name);
my ($package) = Class::MOP::get_code_info($method);
$other->add_override_method_modifier($method_name, $method, $package);
}
}
- }
+ }
}
sub _apply_method_modifiers {
- my ($self, $modifier_type, $other) = @_;
+ my ($self, $modifier_type, $other) = @_;
my $add = "add_${modifier_type}_method_modifier";
- my $get = "get_${modifier_type}_method_modifiers";
+ my $get = "get_${modifier_type}_method_modifiers";
foreach my $method_name ($self->get_method_modifier_list($modifier_type)) {
$other->$add(
$method_name,
$_
) foreach $self->$get($method_name);
- }
+ }
}
sub _apply_before_method_modifiers { (shift)->_apply_method_modifiers('before' => @_) }
sub _apply_around_method_modifiers { (shift)->_apply_method_modifiers('around' => @_) }
sub _apply_after_method_modifiers { (shift)->_apply_method_modifiers('after' => @_) }
+#####################################################################
+## NOTE:
+## This is Moose::Meta::Role as defined by Moose (plus the use of
+## MooseX::AttributeHelpers module). It is here as a reference to
+## make it easier to see what is happening above with all the meta
+## programming. - SL
+#####################################################################
+#
+# has 'roles' => (
+# metaclass => 'Collection::Array',
+# reader => 'get_roles',
+# isa => 'ArrayRef[Moose::Meta::Roles]',
+# default => sub { [] },
+# provides => {
+# 'push' => 'add_role',
+# }
+# );
+#
+# has 'excluded_roles_map' => (
+# metaclass => 'Collection::Hash',
+# reader => 'get_excluded_roles_map',
+# isa => 'HashRef[Str]',
+# provides => {
+# # Not exactly set, cause it sets multiple
+# 'set' => 'add_excluded_roles',
+# 'keys' => 'get_excluded_roles_list',
+# 'exists' => 'excludes_role',
+# }
+# );
+#
+# has 'attribute_map' => (
+# metaclass => 'Collection::Hash',
+# reader => 'get_attribute_map',
+# isa => 'HashRef[Str]',
+# provides => {
+# # 'set' => 'add_attribute' # has some special crap in it
+# 'get' => 'get_attribute',
+# 'keys' => 'get_attribute_list',
+# 'exists' => 'has_attribute',
+# # Not exactly delete, cause it sets multiple
+# 'delete' => 'remove_attribute',
+# }
+# );
+#
+# has 'required_methods' => (
+# metaclass => 'Collection::Hash',
+# reader => 'get_required_methods_map',
+# isa => 'HashRef[Str]',
+# provides => {
+# # not exactly set, or delete since it works for multiple
+# 'set' => 'add_required_methods',
+# 'delete' => 'remove_required_methods',
+# 'keys' => 'get_required_method_list',
+# 'exists' => 'requires_method',
+# }
+# );
+#
+# # the before, around and after modifiers are
+# # HASH keyed by method-name, with ARRAY of
+# # CODE refs to apply in that order
+#
+# has 'before_method_modifiers' => (
+# metaclass => 'Collection::Hash',
+# reader => 'get_before_method_modifiers_map',
+# isa => 'HashRef[ArrayRef[CodeRef]]',
+# provides => {
+# 'keys' => 'get_before_method_modifiers',
+# 'exists' => 'has_before_method_modifiers',
+# # This actually makes sure there is an
+# # ARRAY at the given key, and pushed onto
+# # it. It also checks for duplicates as well
+# # 'add' => 'add_before_method_modifier'
+# }
+# );
+#
+# has 'after_method_modifiers' => (
+# metaclass => 'Collection::Hash',
+# reader =>'get_after_method_modifiers_map',
+# isa => 'HashRef[ArrayRef[CodeRef]]',
+# provides => {
+# 'keys' => 'get_after_method_modifiers',
+# 'exists' => 'has_after_method_modifiers',
+# # This actually makes sure there is an
+# # ARRAY at the given key, and pushed onto
+# # it. It also checks for duplicates as well
+# # 'add' => 'add_after_method_modifier'
+# }
+# );
+#
+# has 'around_method_modifiers' => (
+# metaclass => 'Collection::Hash',
+# reader =>'get_around_method_modifiers_map',
+# isa => 'HashRef[ArrayRef[CodeRef]]',
+# provides => {
+# 'keys' => 'get_around_method_modifiers',
+# 'exists' => 'has_around_method_modifiers',
+# # This actually makes sure there is an
+# # ARRAY at the given key, and pushed onto
+# # it. It also checks for duplicates as well
+# # 'add' => 'add_around_method_modifier'
+# }
+# );
+#
+# # override is similar to the other modifiers
+# # except that it is not an ARRAY of code refs
+# # but instead just a single name->code mapping
+#
+# has 'override_method_modifiers' => (
+# metaclass => 'Collection::Hash',
+# reader =>'get_override_method_modifiers_map',
+# isa => 'HashRef[CodeRef]',
+# provides => {
+# 'keys' => 'get_override_method_modifier',
+# 'exists' => 'has_override_method_modifier',
+# 'add' => 'add_override_method_modifier', # checks for local method ..
+# }
+# );
+#
+#####################################################################
+
+
1;
__END__
=head1 DESCRIPTION
-Please see L<Moose::Role> for more information about roles.
+Please see L<Moose::Role> for more information about roles.
For the most part, this has no user-serviceable parts inside
-this module. It's API is still subject to some change (although
+this module. It's API is still subject to some change (although
probably not that much really).
=head1 METHODS
=head1 BUGS
-All complex software has bugs lurking in it, and this module is no
+All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
L<http://www.iinteractive.com>
This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
+it under the same terms as Perl itself.
=cut
--- /dev/null
+package Moose::Meta::Role::Application;
+
+use strict;
+use warnings;
+use metaclass;
+
+our $VERSION = '0.01';
+our $AUTHORITY = 'cpan:STEVAN';
+
+# no need to get fancy here ...
+sub new { bless {} => shift }
+
+sub apply {
+ my ($self, $other) = @_;
+
+ $self->check_role_exclusions($other);
+ $self->check_required_methods($other);
+
+ $self->apply_attributes($other);
+ $self->apply_methods($other);
+
+ $self->apply_override_method_modifiers($other);
+
+ $self->apply_before_method_modifiers($other);
+ $self->apply_around_method_modifiers($other);
+ $self->apply_after_method_modifiers($other);
+}
+
+sub check_role_exclusions { die "Abstract Method" }
+sub check_required_methods { die "Abstract Method" }
+sub apply_attributes { die "Abstract Method" }
+sub apply_methods { die "Abstract Method" }
+sub apply_override_method_modifiers { die "Abstract Method" }
+sub apply_method_modifiers { die "Abstract Method" }
+sub apply_before_method_modifiers { die "Abstract Method" }
+sub apply_around_method_modifiers { die "Abstract Method" }
+sub apply_after_method_modifiers { die "Abstract Method" }
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Moose::Meta::Role::Application
+
+=head1 DESCRIPTION
+
+This is the abstract base class for role applications.
+
+=head2 METHODS
+
+=over 4
+
+=item B<new>
+
+=item B<meta>
+
+=item B<apply>
+
+=item B<check_required_methods>
+
+=item B<check_role_exclusions>
+
+=item B<apply_attributes>
+
+=item B<apply_methods>
+
+=item B<apply_method_modifiers>
+
+=item B<apply_before_method_modifiers>
+
+=item B<apply_after_method_modifiers>
+
+=item B<apply_around_method_modifiers>
+
+=item B<apply_override_method_modifiers>
+
+=back
+
+=head1 BUGS
+
+All complex software has bugs lurking in it, and this module is no
+exception. If you find a bug please either email me, or add the bug
+to cpan-RT.
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006, 2007 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
--- /dev/null
+package Moose::Meta::Role::Application::RoleSummation;
+
+use strict;
+use warnings;
+use metaclass;
+
+use Carp 'confess';
+use Scalar::Util 'blessed';
+use Data::Dumper;
+
+use Moose::Meta::Role::Composite;
+
+our $VERSION = '0.01';
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::Role::Application';
+
+# stolen from List::MoreUtils ...
+my $uniq = sub { my %h; map { $h{$_}++ == 0 ? $_ : () } @_ };
+
+sub check_role_exclusions {
+ my ($self, $c) = @_;
+
+ my @all_excluded_roles = $uniq->(map {
+ $_->get_excluded_roles_list
+ } @{$c->get_roles});
+
+ foreach my $role (@{$c->get_roles}) {
+ foreach my $excluded (@all_excluded_roles) {
+ confess "Conflict detected: " . $role->name . " excludes role '" . $excluded . "'"
+ if $role->does_role($excluded);
+ }
+ }
+
+ $c->add_excluded_roles(@all_excluded_roles);
+}
+
+sub check_required_methods {
+ my ($self, $c) = @_;
+
+ my %all_required_methods = map { $_ => undef } $uniq->(map {
+ $_->get_required_method_list
+ } @{$c->get_roles});
+
+ foreach my $role (@{$c->get_roles}) {
+ foreach my $required (keys %all_required_methods) {
+ delete $all_required_methods{$required}
+ if $role->has_method($required);
+ }
+ }
+
+ $c->add_required_methods(keys %all_required_methods);
+}
+
+sub apply_attributes {
+ my ($self, $c) = @_;
+
+ my @all_attributes = map {
+ my $role = $_;
+ map {
+ +{
+ name => $_,
+ attr => $role->get_attribute($_),
+ }
+ } $role->get_attribute_list
+ } @{$c->get_roles};
+
+ my %seen;
+ foreach my $attr (@all_attributes) {
+ if (exists $seen{$attr->{name}}) {
+ confess "We have encountered an attribute conflict with '" . $attr->{name} . "'"
+ . "during composition. This is fatal error and cannot be disambiguated."
+ if $seen{$attr->{name}} != $attr->{attr};
+ }
+ $seen{$attr->{name}} = $attr->{attr};
+ }
+
+ foreach my $attr (@all_attributes) {
+ $c->add_attribute($attr->{name}, $attr->{attr});
+ }
+}
+
+sub apply_methods {
+ my ($self, $c) = @_;
+
+ my @all_methods = map {
+ my $role = $_;
+ map {
+ +{
+ name => $_,
+ method => $role->get_method($_),
+ }
+ } $role->get_method_list;
+ } @{$c->get_roles};
+
+ my (%seen, %method_map);
+ foreach my $method (@all_methods) {
+ if (exists $seen{$method->{name}}) {
+ if ($seen{$method->{name}}->body != $method->{method}->body) {
+ $c->add_required_methods($method->{name});
+ delete $method_map{$method->{name}};
+ next;
+ }
+ }
+ $seen{$method->{name}} = $method->{method};
+ $method_map{$method->{name}} = $method->{method};
+ }
+
+ $c->alias_method($_ => $method_map{$_}) for keys %method_map;
+}
+
+sub apply_override_method_modifiers {
+ my ($self, $c) = @_;
+
+ my @all_overrides = map {
+ my $role = $_;
+ map {
+ +{
+ name => $_,
+ method => $role->get_override_method_modifier($_),
+ }
+ } $role->get_method_modifier_list('override');
+ } @{$c->get_roles};
+
+ my %seen;
+ foreach my $override (@all_overrides) {
+ confess "Role '" . $c->name . "' has encountered an 'override' method conflict " .
+ "during composition (A local method of the same name as been found). This " .
+ "is fatal error."
+ if $c->has_method($override->{name});
+ if (exists $seen{$override->{name}}) {
+ confess "We have encountered an 'override' method conflict during " .
+ "composition (Two 'override' methods of the same name encountered). " .
+ "This is fatal error."
+ if $seen{$override->{name}} != $override->{method};
+ }
+ $seen{$override->{name}} = $override->{method};
+ }
+
+ $c->add_override_method_modifier(
+ $_->{name}, $_->{method}
+ ) for @all_overrides;
+
+}
+
+sub apply_method_modifiers {
+ my ($self, $modifier_type, $c) = @_;
+ my $add = "add_${modifier_type}_method_modifier";
+ my $get = "get_${modifier_type}_method_modifiers";
+ foreach my $role (@{$c->get_roles}) {
+ foreach my $method_name ($role->get_method_modifier_list($modifier_type)) {
+ $c->$add(
+ $method_name,
+ $_
+ ) foreach $role->$get($method_name);
+ }
+ }
+}
+
+sub apply_before_method_modifiers { (shift)->apply_method_modifiers('before' => @_) }
+sub apply_around_method_modifiers { (shift)->apply_method_modifiers('around' => @_) }
+sub apply_after_method_modifiers { (shift)->apply_method_modifiers('after' => @_) }
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Moose::Meta::Role::Application::RoleSummation
+
+=head1 DESCRIPTION
+
+Summation composes two traits, forming the union of non-conflicting
+bindings and 'disabling' the conflicting bindings
+
+=head2 METHODS
+
+=over 4
+
+=item B<new>
+
+=item B<meta>
+
+=item B<apply>
+
+=item B<check_required_methods>
+
+=item B<check_role_exclusions>
+
+=item B<apply_attributes>
+
+=item B<apply_methods>
+
+=item B<apply_method_modifiers>
+
+=item B<apply_before_method_modifiers>
+
+=item B<apply_after_method_modifiers>
+
+=item B<apply_around_method_modifiers>
+
+=item B<apply_override_method_modifiers>
+
+=back
+
+=head1 BUGS
+
+All complex software has bugs lurking in it, and this module is no
+exception. If you find a bug please either email me, or add the bug
+to cpan-RT.
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006, 2007 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
--- /dev/null
+package Moose::Meta::Role::Application::ToClass;
+
+use strict;
+use warnings;
+use metaclass;
+
+use Carp 'confess';
+use Scalar::Util 'blessed';
+
+use Data::Dumper;
+
+our $VERSION = '0.01';
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::Role::Application';
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Moose::Meta::Role::Application::ToClass
+
+=head1 DESCRIPTION
+
+=head2 METHODS
+
+=over 4
+
+=item B<new>
+
+=item B<meta>
+
+=back
+
+=head1 BUGS
+
+All complex software has bugs lurking in it, and this module is no
+exception. If you find a bug please either email me, or add the bug
+to cpan-RT.
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006, 2007 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
--- /dev/null
+package Moose::Meta::Role::Application::ToInstance;
+
+use strict;
+use warnings;
+use metaclass;
+
+use Carp 'confess';
+use Scalar::Util 'blessed';
+
+use Data::Dumper;
+
+our $VERSION = '0.01';
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::Role::Application';
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Moose::Meta::Role::Application::ToInstance
+
+=head1 DESCRIPTION
+
+=head2 METHODS
+
+=over 4
+
+=item B<new>
+
+=item B<meta>
+
+=back
+
+=head1 BUGS
+
+All complex software has bugs lurking in it, and this module is no
+exception. If you find a bug please either email me, or add the bug
+to cpan-RT.
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006, 2007 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
--- /dev/null
+package Moose::Meta::Role::Application::ToRole;
+
+use strict;
+use warnings;
+use metaclass;
+
+use Carp 'confess';
+use Scalar::Util 'blessed';
+
+use Data::Dumper;
+
+our $VERSION = '0.01';
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::Role::Application';
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Moose::Meta::Role::Application::ToRole
+
+=head1 DESCRIPTION
+
+=head2 METHODS
+
+=over 4
+
+=item B<new>
+
+=item B<meta>
+
+=back
+
+=head1 BUGS
+
+All complex software has bugs lurking in it, and this module is no
+exception. If you find a bug please either email me, or add the bug
+to cpan-RT.
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006, 2007 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
--- /dev/null
+package Moose::Meta::Role::Composite;
+
+use strict;
+use warnings;
+use metaclass;
+
+use Carp 'confess';
+use Scalar::Util 'blessed', 'reftype';
+
+use Data::Dumper;
+
+our $VERSION = '0.01';
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::Role';
+
+# NOTE:
+# we need to override the ->name
+# method from Class::MOP::Package
+# since we don't have an actual
+# package for this.
+# - SL
+__PACKAGE__->meta->add_attribute('name' => (reader => 'name'));
+
+# NOTE:
+# Again, since we don't have a real
+# package to store our methods in,
+# we use a HASH ref instead.
+# - SL
+__PACKAGE__->meta->add_attribute('methods' => (
+ reader => 'get_method_map',
+ default => sub { {} }
+));
+
+sub new {
+ my ($class, %params) = @_;
+ # the roles param is required ...
+ ($_->isa('Moose::Meta::Role'))
+ || confess "The list of roles must be instances of Moose::Meta::Role, not $_"
+ foreach @{$params{roles}};
+ # and the name is created from the
+ # roles if one has not been provided
+ $params{name} ||= (join "|" => map { $_->name } @{$params{roles}});
+ $class->meta->new_object(%params);
+}
+
+# NOTE:
+# we need to override this cause
+# we dont have that package I was
+# talking about above.
+# - SL
+sub alias_method {
+ my ($self, $method_name, $method) = @_;
+ (defined $method_name && $method_name)
+ || confess "You must define a method name";
+
+ my $body = (blessed($method) ? $method->body : $method);
+ ('CODE' eq (reftype($body) || ''))
+ || confess "Your code block must be a CODE reference";
+
+ $self->get_method_map->{$method_name} = $body;
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Moose::Meta::Role::Composite - An object to represent the set of roles
+
+=head1 DESCRIPTION
+
+=head2 METHODS
+
+=over 4
+
+=item B<new>
+
+=item B<meta>
+
+=item B<name>
+
+=item B<get_method_map>
+
+=item B<alias_method>
+
+=back
+
+=head1 BUGS
+
+All complex software has bugs lurking in it, and this module is no
+exception. If you find a bug please either email me, or add the bug
+to cpan-RT.
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006, 2007 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
\ No newline at end of file
else {
%params = @_;
}
- my $self = $class->meta->new_object(%params);
- $self->BUILDALL(\%params);
- return $self;
+ my $self = $class->meta->new_object(%params);
+ $self->BUILDALL(\%params);
+ return $self;
}
sub BUILDALL {
# NOTE: we ask Perl if we even
# need to do this first, to avoid
# extra meta level calls
- return unless $_[0]->can('BUILD');
- my ($self, $params) = @_;
- foreach my $method (reverse $self->meta->find_all_methods_by_name('BUILD')) {
- $method->{code}->($self, $params);
- }
+ return unless $_[0]->can('BUILD');
+ my ($self, $params) = @_;
+ foreach my $method (reverse $self->meta->find_all_methods_by_name('BUILD')) {
+ $method->{code}->($self, $params);
+ }
}
sub DEMOLISHALL {
# NOTE: we ask Perl if we even
# need to do this first, to avoid
# extra meta level calls
- return unless $_[0]->can('DEMOLISH');
- my $self = shift;
- foreach my $method ($self->meta->find_all_methods_by_name('DEMOLISH')) {
- $method->{code}->($self);
- }
+ return unless $_[0]->can('DEMOLISH');
+ my $self = shift;
+ foreach my $method ($self->meta->find_all_methods_by_name('DEMOLISH')) {
+ $method->{code}->($self);
+ }
}
sub DESTROY { goto &DEMOLISHALL }
my $role = $CALLER;
return $METAS{$role} if exists $METAS{$role};
-
+
# make a subtype for each Moose class
subtype $role
=> as 'Role'
=> where { $_->does($role) }
- => optimize_as { blessed($_[0]) && $_[0]->can('does') && $_[0]->does($role) }
- unless find_type_constraint($role);
+ => optimize_as { blessed($_[0]) && $_[0]->can('does') && $_[0]->does($role) }
+ unless find_type_constraint($role);
- my $meta;
- if ($role->can('meta')) {
- $meta = $role->meta();
- (blessed($meta) && $meta->isa('Moose::Meta::Role'))
+ my $meta;
+ if ($role->can('meta')) {
+ $meta = $role->meta();
+ (blessed($meta) && $meta->isa('Moose::Meta::Role'))
|| confess "You already have a &meta function, but it does not return a Moose::Meta::Role";
- }
- else {
- $meta = Moose::Meta::Role->initialize($role);
- $meta->Moose::Meta::Class::add_method('meta' => sub { $meta })
- }
+ }
+ else {
+ $meta = Moose::Meta::Role->initialize($role);
+ $meta->alias_method('meta' => sub { $meta });
+ }
return $METAS{$role} = $meta;
}
-
-
- my %exports = (
+
+
+ my %exports = (
extends => sub {
my $meta = _find_meta();
- return subname 'Moose::Role::extends' => sub {
+ return subname 'Moose::Role::extends' => sub {
confess "Moose::Role does not currently support 'extends'"
- };
- },
- with => sub {
- my $meta = _find_meta();
- return subname 'Moose::Role::with' => sub (@) {
+ };
+ },
+ with => sub {
+ my $meta = _find_meta();
+ return subname 'Moose::Role::with' => sub (@) {
my (@roles) = @_;
confess "Must specify at least one role" unless @roles;
Class::MOP::load_class($_) for @roles;
)->apply($meta);
}
};
- },
+ },
requires => sub {
my $meta = _find_meta();
- return subname 'Moose::Role::requires' => sub (@) {
+ return subname 'Moose::Role::requires' => sub (@) {
confess "Must specify at least one method" unless @_;
$meta->add_required_methods(@_);
- };
- },
+ };
+ },
excludes => sub {
my $meta = _find_meta();
- return subname 'Moose::Role::excludes' => sub (@) {
+ return subname 'Moose::Role::excludes' => sub (@) {
confess "Must specify at least one role" unless @_;
$meta->add_excluded_roles(@_);
- };
- },
+ };
+ },
has => sub {
my $meta = _find_meta();
- return subname 'Moose::Role::has' => sub ($;%) {
- my ($name, %options) = @_;
- $meta->add_attribute($name, %options)
- };
- },
+ return subname 'Moose::Role::has' => sub ($;%) {
+ my ($name, %options) = @_;
+ $meta->add_attribute($name, %options)
+ };
+ },
before => sub {
my $meta = _find_meta();
- return subname 'Moose::Role::before' => sub (@&) {
+ return subname 'Moose::Role::before' => sub (@&) {
my $code = pop @_;
$meta->add_before_method_modifier($_, $code) for @_;
- };
- },
+ };
+ },
after => sub {
my $meta = _find_meta();
- return subname 'Moose::Role::after' => sub (@&) {
- my $code = pop @_;
- $meta->add_after_method_modifier($_, $code) for @_;
- };
- },
+ return subname 'Moose::Role::after' => sub (@&) {
+ my $code = pop @_;
+ $meta->add_after_method_modifier($_, $code) for @_;
+ };
+ },
around => sub {
my $meta = _find_meta();
- return subname 'Moose::Role::around' => sub (@&) {
- my $code = pop @_;
- $meta->add_around_method_modifier($_, $code) for @_;
- };
- },
- super => sub {
+ return subname 'Moose::Role::around' => sub (@&) {
+ my $code = pop @_;
+ $meta->add_around_method_modifier($_, $code) for @_;
+ };
+ },
+ super => sub {
{
no strict 'refs';
$Moose::SUPER_SLOT{$CALLER} = \*{"${CALLER}::super"};
return subname 'Moose::Role::override' => sub ($&) {
my ($name, $code) = @_;
$meta->add_override_method_modifier($name, $code);
- };
- },
+ };
+ },
inner => sub {
my $meta = _find_meta();
return subname 'Moose::Role::inner' => sub {
confess "Moose::Role cannot support 'inner'";
- };
- },
+ };
+ },
augment => sub {
my $meta = _find_meta();
return subname 'Moose::Role::augment' => sub {
confess "Moose::Role cannot support 'augment'";
- };
- },
+ };
+ },
confess => sub {
return \&Carp::confess;
},
blessed => sub {
return \&Scalar::Util::blessed;
- }
- );
+ }
+ );
- my $exporter = Sub::Exporter::build_exporter({
+ my $exporter = Sub::Exporter::build_exporter({
exports => \%exports,
groups => {
default => [':all']
}
});
-
+
sub import {
$CALLER =
ref $_[1] && defined $_[1]->{into} ? $_[1]->{into}
&& defined $_[1]->{into_level} ? caller( $_[1]->{into_level} )
: caller();
-
+
strict->import;
- warnings->import;
+ warnings->import;
# we should never export to main
return if $CALLER eq 'main';
package Eq;
use Moose::Role; # automatically turns on strict and warnings
-
+
requires 'equal';
-
- sub no_equal {
+
+ sub no_equal {
my ($self, $other) = @_;
!$self->equal($other);
}
-
+
# ... then in your classes
-
+
package Currency;
use Moose; # automatically turns on strict and warnings
-
+
with 'Eq';
-
+
sub equal {
my ($self, $other) = @_;
$self->as_float == $other->as_float;
=item B<requires (@method_names)>
-Roles can require that certain methods are implemented by any class which
+Roles can require that certain methods are implemented by any class which
C<does> the role.
=item B<excludes (@role_names)>
Roles can C<exclude> other roles, in effect saying "I can never be combined
-with these C<@role_names>". This is a feature which should not be used
+with these C<@role_names>". This is a feature which should not be used
lightly.
=back
=item *
-Roles cannot use the C<extends> keyword; it will throw an exception for now.
-The same is true of the C<augment> and C<inner> keywords (not sure those
-really make sense for roles). All other Moose keywords will be I<deferred>
+Roles cannot use the C<extends> keyword; it will throw an exception for now.
+The same is true of the C<augment> and C<inner> keywords (not sure those
+really make sense for roles). All other Moose keywords will be I<deferred>
so that they can be applied to the consuming class.
-=item *
+=item *
Role composition does its best to B<not> be order-sensitive when it comes to
conflict resolution and requirements detection. However, it is order-sensitive
=item *
-The C<requires> keyword currently only works with actual methods. A method
-modifier (before/around/after and override) will not count as a fufillment
+The C<requires> keyword currently only works with actual methods. A method
+modifier (before/around/after and override) will not count as a fufillment
of the requirement, and neither will an autogenerated accessor for an attribute.
It is likely that attribute accessors will eventually be allowed to fufill those
=head1 BUGS
-All complex software has bugs lurking in it, and this module is no
+All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
L<http://www.iinteractive.com>
This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
+it under the same terms as Perl itself.
=cut
use strict;
use warnings;
-use Test::More tests => 63;
+use Test::More tests => 87;
use Test::Exception;
BEGIN {
extends 'BarClass';
with 'FooRole';
- sub blau { 'FooClass::blau' }
+ sub blau { 'FooClass::blau' } # << the role wraps this ...
sub goo { 'FooClass::goo' } # << overrides the one from the role ...
my $foobar = FooBarClass->new();
isa_ok($foobar, 'FooBarClass');
-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');
+is($foo->goo, 'FooClass::goo', '... got the right value of goo');
+is($foobar->goo, 'FooRole::goo', '... got the right value of goo');
-can_ok($foobar, 'does');
-ok($foobar->does('FooRole'), '... an instance of FooBarClass does FooRole');
-ok($foobar->does('BarRole'), '... an instance of FooBarClass does BarRole');
-ok(!$foobar->does('OtherRole'), '... and instance of FooBarClass does not do OtherRole');
+is($foo->boo, 'FooRole::boo -> BarClass::boo', '... got the right value from ->boo');
+is($foobar->boo, 'FooRole::boo -> FooRole::boo -> BarClass::boo', '... got the right value from ->boo (double wrapped)');
-for my $method (qw/bar baz foo boo goo blau/) {
- can_ok($foo, $method);
-}
+is($foo->blau, 'FooRole::blau -> FooClass::blau', '... got the right value from ->blau');
+is($foobar->blau, 'FooRole::blau -> FooRole::blau -> FooClass::blau', '... got the right value from ->blau');
-is($foo->foo, 'FooRole::foo', '... got the right value of foo');
-is($foo->goo, 'FooClass::goo', '... got the right value of goo');
+foreach my $foo ($foo, $foobar) {
+ 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');
-ok(!defined($foo->baz), '... $foo->baz is undefined');
-ok(!defined($foo->bar), '... $foo->bar is undefined');
+ can_ok($foobar, 'does');
+ ok($foobar->does('FooRole'), '... an instance of FooBarClass does FooRole');
+ ok($foobar->does('BarRole'), '... an instance of FooBarClass does BarRole');
+ ok(!$foobar->does('OtherRole'), '... and instance of FooBarClass does not do OtherRole');
-dies_ok {
- $foo->baz(1)
-} '... baz is a read-only accessor';
+ for my $method (qw/bar baz foo boo goo blau/) {
+ can_ok($foo, $method);
+ }
-dies_ok {
- $foo->bar(1)
-} '... bar is a read-write accessor with a type constraint';
+ is($foo->foo, 'FooRole::foo', '... got the right value of foo');
-my $foo2 = FooClass->new();
-isa_ok($foo2, 'FooClass');
+ ok(!defined($foo->baz), '... $foo->baz is undefined');
+ ok(!defined($foo->bar), '... $foo->bar is undefined');
-lives_ok {
- $foo->bar($foo2)
-} '... bar is a read-write accessor with a type constraint';
+ dies_ok {
+ $foo->baz(1)
+ } '... baz is a read-only accessor';
-is($foo->bar, $foo2, '... got the right value for bar now');
+ dies_ok {
+ $foo->bar(1)
+ } '... bar is a read-write accessor with a type constraint';
-is($foo->boo, 'FooRole::boo -> BarClass::boo', '... got the right value from ->boo');
-is($foo->blau, 'FooRole::blau -> FooClass::blau', '... got the right value from ->blau');
+ my $foo2 = FooClass->new();
+ isa_ok($foo2, 'FooClass');
+ lives_ok {
+ $foo->bar($foo2)
+ } '... bar is a read-write accessor with a type constraint';
+
+ is($foo->bar, $foo2, '... got the right value for bar now');
+}
use strict;
use warnings;
-use Test::More tests => 90; # it's really 126 with kolibre's tests;
+use Test::More tests => 89; # it's really 126 with kolibre's tests;
use Test::Exception;
BEGIN {
ok(Role::Bling::Bling->meta->has_method('bling'), '... still got the bling method in Role::Bling::Bling');
ok(Role::Bling::Bling->meta->does_role('Role::Bling::Bling'), '... our role correctly does() the other role');
-ok(Role::Bling::Bling::Bling->meta->has_method('bling'), '... still got the bling method in Role::Bling::Bling::Bling');
+ok(Role::Bling::Bling::Bling->meta->has_method('bling'), '... dont have the bling method in Role::Bling::Bling::Bling');
is(Role::Bling::Bling::Bling->meta->get_method('bling')->(),
'Role::Bling::Bling::Bling::bling',
'... still got the bling method in Role::Bling::Bling::Bling');
+
=pod
Role attribute conflicts
::throws_ok {
with 'Role::Boo', 'Role::Boo::Hoo';
- } qr/Role \'Role::Boo::Hoo\' has encountered an attribute conflict/,
+ } qr/We have encountered an attribute conflict/,
'... role attrs conflicted and method was required';
package My::Test8;
::throws_ok {
with 'Role::Boo', 'Role::Boo::Hoo';
- } qr/Role \'Role::Boo::Hoo\' has encountered an attribute conflict/,
+ } qr/We have encountered an attribute conflict/,
'... role attrs conflicted and cannot be manually disambiguted';
}
}
ok(Role::Reality->meta->has_method('twist'), '... the twist method has not been added');
-ok(!Role::Reality->meta->does_role('Role::Plot'), '... our role does() the correct roles');
+#ok(!Role::Reality->meta->does_role('Role::Plot'), '... our role does() the correct roles');
is(Role::Reality->meta->get_method('twist')->(),
'Role::Reality::twist',
'... the twist method returns the right value');
use strict;
use warnings;
-use Test::More tests => 77;
+use Test::More tests => 75;
use Test::Exception;
BEGIN {
lives_ok { $i->foo } '... called foo successfully (again)';
is( $i->counter, 2, "after hook called (again)" );
- can_ok('SubBA', 'foo');
- my $subba_foo_rv;
- lives_ok {
- $subba_foo_rv = SubBA::foo();
- } '... called the sub as a function correctly';
- is($subba_foo_rv, 'RootB::foo', '... the SubBA->foo is still the RootB version');
+ ok(SubBA->meta->has_method('foo'), '... this has the foo method');
+ #my $subba_foo_rv;
+ #lives_ok {
+ # $subba_foo_rv = SubBA::foo();
+ #} '... called the sub as a function correctly';
+ #is($subba_foo_rv, 'RootB::foo', '... the SubBA->foo is still the RootB version');
}
{
use strict;
use warnings;
-use Test::More skip_all => "provisional test";
+use Test::More no_plan => 1; #skip_all => "provisional test";
use Test::Exception;
BEGIN {
} qr/requires.*'foo'/, "defining class Class::C fails";
lives_ok {
- package Class::D;
- use Moose;
-
- has foo => ( default => __PACKAGE__ . "::foo", is => "rw" );
-
- use constant;
- BEGIN { constant->import($_ => __PACKAGE__ . "::$_") for qw(zot) };
-
- with qw(Role::I);
- } "resolved with attr";
-
- lives_ok {
package Class::E;
use Moose;
BEGIN { constant->import($_ => __PACKAGE__ . "::$_") for qw(foo zot) };
} "resolved with method";
- can_ok( Class::D->new, qw(foo bar xxy zot) );
+ # fix these later ...
+ TODO: {
+ local $TODO = "TODO: add support for attribute methods fufilling reqs";
+
+ lives_ok {
+ package Class::D;
+ use Moose;
+
+ has foo => ( default => __PACKAGE__ . "::foo", is => "rw" );
+
+ use constant;
+ BEGIN { constant->import($_ => __PACKAGE__ . "::$_") for qw(zot) };
+
+ with qw(Role::I);
+ } "resolved with attr";
+
+ can_ok( Class::D->new, qw(foo bar xxy zot) );
+ is( eval { Class::D->new->bar }, "Role::H::bar", "bar" );
+ is( eval { Class::D->new->xxy }, "Role::I::xxy", "xxy" );
+ }
is( eval { Class::D->new->foo }, "Class::D::foo", "foo" );
is( eval { Class::D->new->zot }, "Class::D::zot", "zot" );
- is( eval { Class::D->new->bar }, "Role::H::bar", "bar" );
- is( eval { Class::D->new->xxy }, "Role::I::xxy", "xxy" );
can_ok( Class::E->new, qw(foo bar xxy zot) );
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More no_plan => 1;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Moose');
+ use_ok('Moose::Meta::Role::Application::RoleSummation');
+ use_ok('Moose::Meta::Role::Composite');
+}
+
+{
+ package Role::Foo;
+ use Moose::Role;
+
+ package Role::Bar;
+ use Moose::Role;
+
+ package Role::Baz;
+ use Moose::Role;
+}
+
+{
+ my $c = Moose::Meta::Role::Composite->new(
+ roles => [
+ Role::Foo->meta,
+ Role::Bar->meta,
+ Role::Baz->meta,
+ ]
+ );
+ isa_ok($c, 'Moose::Meta::Role::Composite');
+
+ is($c->name, 'Role::Foo|Role::Bar|Role::Baz', '... got the composite role name');
+
+ is_deeply($c->get_roles, [
+ Role::Foo->meta,
+ Role::Bar->meta,
+ Role::Baz->meta,
+ ], '... got the right roles');
+
+ lives_ok {
+ Moose::Meta::Role::Application::RoleSummation->new->apply($c);
+ } '... this composed okay';
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More no_plan => 1;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Moose');
+ use_ok('Moose::Meta::Role::Application::RoleSummation');
+ use_ok('Moose::Meta::Role::Composite');
+}
+
+{
+ package Role::Foo;
+ use Moose::Role;
+
+ package Role::Bar;
+ use Moose::Role;
+
+ package Role::ExcludesFoo;
+ use Moose::Role;
+ excludes 'Role::Foo';
+
+ package Role::DoesExcludesFoo;
+ use Moose::Role;
+ with 'Role::ExcludesFoo';
+
+ package Role::DoesFoo;
+ use Moose::Role;
+ with 'Role::Foo';
+}
+
+# test simple exclusion
+dies_ok {
+ Moose::Meta::Role::Application::RoleSummation->new->apply(
+ Moose::Meta::Role::Composite->new(
+ roles => [
+ Role::Foo->meta,
+ Role::ExcludesFoo->meta,
+ ]
+ )
+ );
+} '... this fails as expected';
+
+# test no conflicts
+{
+ my $c = Moose::Meta::Role::Composite->new(
+ roles => [
+ Role::Foo->meta,
+ Role::Bar->meta,
+ ]
+ );
+ isa_ok($c, 'Moose::Meta::Role::Composite');
+
+ is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
+
+ lives_ok {
+ Moose::Meta::Role::Application::RoleSummation->new->apply($c);
+ } '... this lives as expected';
+}
+
+# test no conflicts w/exclusion
+{
+ my $c = Moose::Meta::Role::Composite->new(
+ roles => [
+ Role::Bar->meta,
+ Role::ExcludesFoo->meta,
+ ]
+ );
+ isa_ok($c, 'Moose::Meta::Role::Composite');
+
+ is($c->name, 'Role::Bar|Role::ExcludesFoo', '... got the composite role name');
+
+ lives_ok {
+ Moose::Meta::Role::Application::RoleSummation->new->apply($c);
+ } '... this lives as expected';
+
+ is_deeply([$c->get_excluded_roles_list], ['Role::Foo'], '... has excluded roles');
+}
+
+
+# test conflict with an "inherited" exclusion
+dies_ok {
+ Moose::Meta::Role::Application::RoleSummation->new->apply(
+ Moose::Meta::Role::Composite->new(
+ roles => [
+ Role::Foo->meta,
+ Role::DoesExcludesFoo->meta,
+ ]
+ )
+ );
+
+} '... this fails as expected';
+
+# test conflict with an "inherited" exclusion of an "inherited" role
+dies_ok {
+ Moose::Meta::Role::Application::RoleSummation->new->apply(
+ Moose::Meta::Role::Composite->new(
+ roles => [
+ Role::DoesFoo->meta,
+ Role::DoesExcludesFoo->meta,
+ ]
+ )
+ );
+} '... this fails as expected';
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More no_plan => 1;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Moose');
+ use_ok('Moose::Meta::Role::Application::RoleSummation');
+ use_ok('Moose::Meta::Role::Composite');
+}
+
+{
+ package Role::Foo;
+ use Moose::Role;
+ requires 'foo';
+
+ package Role::Bar;
+ use Moose::Role;
+ requires 'bar';
+
+ package Role::ProvidesFoo;
+ use Moose::Role;
+ sub foo { 'Role::ProvidesFoo::foo' }
+
+ package Role::ProvidesBar;
+ use Moose::Role;
+ sub bar { 'Role::ProvidesBar::bar' }
+}
+
+# test simple requirement
+{
+ my $c = Moose::Meta::Role::Composite->new(
+ roles => [
+ Role::Foo->meta,
+ Role::Bar->meta,
+ ]
+ );
+ isa_ok($c, 'Moose::Meta::Role::Composite');
+
+ is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
+
+ lives_ok {
+ Moose::Meta::Role::Application::RoleSummation->new->apply($c);
+ } '... this succeeds as expected';
+
+ is_deeply(
+ [ sort $c->get_required_method_list ],
+ [ 'bar', 'foo' ],
+ '... got the right list of required methods'
+ );
+}
+
+# test requirement satisfied
+{
+ my $c = Moose::Meta::Role::Composite->new(
+ roles => [
+ Role::Foo->meta,
+ Role::ProvidesFoo->meta,
+ ]
+ );
+ isa_ok($c, 'Moose::Meta::Role::Composite');
+
+ is($c->name, 'Role::Foo|Role::ProvidesFoo', '... got the composite role name');
+
+ lives_ok {
+ Moose::Meta::Role::Application::RoleSummation->new->apply($c);
+ } '... this succeeds as expected';
+
+ is_deeply(
+ [ sort $c->get_required_method_list ],
+ [],
+ '... got the right list of required methods'
+ );
+}
+
+# test requirement satisfied
+{
+ my $c = Moose::Meta::Role::Composite->new(
+ roles => [
+ Role::Foo->meta,
+ Role::ProvidesFoo->meta,
+ Role::Bar->meta,
+ ]
+ );
+ isa_ok($c, 'Moose::Meta::Role::Composite');
+
+ is($c->name, 'Role::Foo|Role::ProvidesFoo|Role::Bar', '... got the composite role name');
+
+ lives_ok {
+ Moose::Meta::Role::Application::RoleSummation->new->apply($c);
+ } '... this succeeds as expected';
+
+ is_deeply(
+ [ sort $c->get_required_method_list ],
+ [ 'bar' ],
+ '... got the right list of required methods'
+ );
+}
+
+# test requirement satisfied
+{
+ my $c = Moose::Meta::Role::Composite->new(
+ roles => [
+ Role::Foo->meta,
+ Role::ProvidesFoo->meta,
+ Role::ProvidesBar->meta,
+ Role::Bar->meta,
+ ]
+ );
+ isa_ok($c, 'Moose::Meta::Role::Composite');
+
+ is($c->name, 'Role::Foo|Role::ProvidesFoo|Role::ProvidesBar|Role::Bar', '... got the composite role name');
+
+ lives_ok {
+ Moose::Meta::Role::Application::RoleSummation->new->apply($c);
+ } '... this succeeds as expected';
+
+ is_deeply(
+ [ sort $c->get_required_method_list ],
+ [ ],
+ '... got the right list of required methods'
+ );
+}
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More no_plan => 1;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Moose');
+ use_ok('Moose::Meta::Role::Application::RoleSummation');
+ use_ok('Moose::Meta::Role::Composite');
+}
+
+{
+ package Role::Foo;
+ use Moose::Role;
+ has 'foo' => (is => 'rw');
+
+ package Role::Bar;
+ use Moose::Role;
+ has 'bar' => (is => 'rw');
+
+ package Role::FooConflict;
+ use Moose::Role;
+ has 'foo' => (is => 'rw');
+
+ package Role::BarConflict;
+ use Moose::Role;
+ has 'bar' => (is => 'rw');
+
+ package Role::AnotherFooConflict;
+ use Moose::Role;
+ with 'Role::FooConflict';
+}
+
+# test simple attributes
+{
+ my $c = Moose::Meta::Role::Composite->new(
+ roles => [
+ Role::Foo->meta,
+ Role::Bar->meta,
+ ]
+ );
+ isa_ok($c, 'Moose::Meta::Role::Composite');
+
+ is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
+
+ lives_ok {
+ Moose::Meta::Role::Application::RoleSummation->new->apply($c);
+ } '... this succeeds as expected';
+
+ is_deeply(
+ [ sort $c->get_attribute_list ],
+ [ 'bar', 'foo' ],
+ '... got the right list of attributes'
+ );
+}
+
+# test simple conflict
+dies_ok {
+ Moose::Meta::Role::Application::RoleSummation->new->apply(
+ Moose::Meta::Role::Composite->new(
+ roles => [
+ Role::Foo->meta,
+ Role::FooConflict->meta,
+ ]
+ )
+ );
+} '... this fails as expected';
+
+# test complex conflict
+dies_ok {
+ Moose::Meta::Role::Application::RoleSummation->new->apply(
+ Moose::Meta::Role::Composite->new(
+ roles => [
+ Role::Foo->meta,
+ Role::Bar->meta,
+ Role::FooConflict->meta,
+ Role::BarConflict->meta,
+ ]
+ )
+ );
+} '... this fails as expected';
+
+# test simple conflict
+dies_ok {
+ Moose::Meta::Role::Application::RoleSummation->new->apply(
+ Moose::Meta::Role::Composite->new(
+ roles => [
+ Role::Foo->meta,
+ Role::AnotherFooConflict->meta,
+ ]
+ )
+ );
+} '... this fails as expected';
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More no_plan => 1;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Moose');
+ use_ok('Moose::Meta::Role::Application::RoleSummation');
+ use_ok('Moose::Meta::Role::Composite');
+}
+
+{
+ package Role::Foo;
+ use Moose::Role;
+
+ sub foo { 'Role::Foo::foo' }
+
+ package Role::Bar;
+ use Moose::Role;
+
+ sub bar { 'Role::Bar::bar' }
+
+ package Role::FooConflict;
+ use Moose::Role;
+
+ sub foo { 'Role::FooConflict::foo' }
+
+ package Role::BarConflict;
+ use Moose::Role;
+
+ sub bar { 'Role::BarConflict::bar' }
+
+ package Role::AnotherFooConflict;
+ use Moose::Role;
+ with 'Role::FooConflict';
+
+ sub baz { 'Role::AnotherFooConflict::baz' }
+}
+
+# test simple attributes
+{
+ my $c = Moose::Meta::Role::Composite->new(
+ roles => [
+ Role::Foo->meta,
+ Role::Bar->meta,
+ ]
+ );
+ isa_ok($c, 'Moose::Meta::Role::Composite');
+
+ is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
+
+ lives_ok {
+ Moose::Meta::Role::Application::RoleSummation->new->apply($c);
+ } '... this succeeds as expected';
+
+ is_deeply(
+ [ sort $c->get_method_list ],
+ [ 'bar', 'foo' ],
+ '... got the right list of methods'
+ );
+}
+
+# test simple conflict
+{
+ my $c = Moose::Meta::Role::Composite->new(
+ roles => [
+ Role::Foo->meta,
+ Role::FooConflict->meta,
+ ]
+ );
+ isa_ok($c, 'Moose::Meta::Role::Composite');
+
+ is($c->name, 'Role::Foo|Role::FooConflict', '... got the composite role name');
+
+ lives_ok {
+ Moose::Meta::Role::Application::RoleSummation->new->apply($c);
+ } '... this succeeds as expected';
+
+ is_deeply(
+ [ sort $c->get_method_list ],
+ [],
+ '... got the right list of methods'
+ );
+
+ is_deeply(
+ [ sort $c->get_required_method_list ],
+ [ 'foo' ],
+ '... got the right list of required methods'
+ );
+}
+
+# test complex conflict
+{
+ my $c = Moose::Meta::Role::Composite->new(
+ roles => [
+ Role::Foo->meta,
+ Role::Bar->meta,
+ Role::FooConflict->meta,
+ Role::BarConflict->meta,
+ ]
+ );
+ isa_ok($c, 'Moose::Meta::Role::Composite');
+
+ is($c->name, 'Role::Foo|Role::Bar|Role::FooConflict|Role::BarConflict', '... got the composite role name');
+
+ lives_ok {
+ Moose::Meta::Role::Application::RoleSummation->new->apply($c);
+ } '... this succeeds as expected';
+
+ is_deeply(
+ [ sort $c->get_method_list ],
+ [],
+ '... got the right list of methods'
+ );
+
+ is_deeply(
+ [ sort $c->get_required_method_list ],
+ [ 'bar', 'foo' ],
+ '... got the right list of required methods'
+ );
+}
+
+# test simple conflict
+{
+ my $c = Moose::Meta::Role::Composite->new(
+ roles => [
+ Role::Foo->meta,
+ Role::AnotherFooConflict->meta,
+ ]
+ );
+ isa_ok($c, 'Moose::Meta::Role::Composite');
+
+ is($c->name, 'Role::Foo|Role::AnotherFooConflict', '... got the composite role name');
+
+ lives_ok {
+ Moose::Meta::Role::Application::RoleSummation->new->apply($c);
+ } '... this succeeds as expected';
+
+ is_deeply(
+ [ sort $c->get_method_list ],
+ [ 'baz' ],
+ '... got the right list of methods'
+ );
+
+ is_deeply(
+ [ sort $c->get_required_method_list ],
+ [ 'foo' ],
+ '... got the right list of required methods'
+ );
+}
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More no_plan => 1;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Moose');
+ use_ok('Moose::Meta::Role::Application::RoleSummation');
+ use_ok('Moose::Meta::Role::Composite');
+}
+
+{
+ package Role::Foo;
+ use Moose::Role;
+
+ override foo => sub { 'Role::Foo::foo' };
+
+ package Role::Bar;
+ use Moose::Role;
+
+ override bar => sub { 'Role::Bar::bar' };
+
+ package Role::FooConflict;
+ use Moose::Role;
+
+ override foo => sub { 'Role::FooConflict::foo' };
+
+ package Role::FooMethodConflict;
+ use Moose::Role;
+
+ sub foo { 'Role::FooConflict::foo' }
+
+ package Role::BarMethodConflict;
+ use Moose::Role;
+
+ sub bar { 'Role::BarConflict::bar' }
+}
+
+# test simple overrides
+{
+ my $c = Moose::Meta::Role::Composite->new(
+ roles => [
+ Role::Foo->meta,
+ Role::Bar->meta,
+ ]
+ );
+ isa_ok($c, 'Moose::Meta::Role::Composite');
+
+ is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
+
+ lives_ok {
+ Moose::Meta::Role::Application::RoleSummation->new->apply($c);
+ } '... this lives ok';
+
+ is_deeply(
+ [ sort $c->get_method_modifier_list('override') ],
+ [ 'bar', 'foo' ],
+ '... got the right list of methods'
+ );
+}
+
+# test simple overrides w/ conflicts
+dies_ok {
+ Moose::Meta::Role::Application::RoleSummation->new->apply(
+ Moose::Meta::Role::Composite->new(
+ roles => [
+ Role::Foo->meta,
+ Role::FooConflict->meta,
+ ]
+ )
+ );
+} '... this fails as expected';
+
+# test simple overrides w/ conflicts
+dies_ok {
+ Moose::Meta::Role::Application::RoleSummation->new->apply(
+ Moose::Meta::Role::Composite->new(
+ roles => [
+ Role::Foo->meta,
+ Role::FooMethodConflict->meta,
+ ]
+ )
+ );
+} '... this fails as expected';
+
+
+# test simple overrides w/ conflicts
+dies_ok {
+ Moose::Meta::Role::Application::RoleSummation->new->apply(
+ Moose::Meta::Role::Composite->new(
+ roles => [
+ Role::Foo->meta,
+ Role::Bar->meta,
+ Role::FooConflict->meta,
+ ]
+ )
+ );
+} '... this fails as expected';
+
+
+# test simple overrides w/ conflicts
+dies_ok {
+ Moose::Meta::Role::Application::RoleSummation->new->apply(
+ Moose::Meta::Role::Composite->new(
+ roles => [
+ Role::Foo->meta,
+ Role::Bar->meta,
+ Role::FooMethodConflict->meta,
+ ]
+ )
+ );
+} '... this fails as expected';
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More no_plan => 1;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Moose');
+ use_ok('Moose::Meta::Role::Application::RoleSummation');
+ use_ok('Moose::Meta::Role::Composite');
+}
+
+{
+ package Role::Foo;
+ use Moose::Role;
+
+ before foo => sub { 'Role::Foo::foo' };
+ around foo => sub { 'Role::Foo::foo' };
+ after foo => sub { 'Role::Foo::foo' };
+
+ package Role::Bar;
+ use Moose::Role;
+
+ before bar => sub { 'Role::Bar::bar' };
+ around bar => sub { 'Role::Bar::bar' };
+ after bar => sub { 'Role::Bar::bar' };
+}
+
+# test simple overrides
+{
+ my $c = Moose::Meta::Role::Composite->new(
+ roles => [
+ Role::Foo->meta,
+ Role::Bar->meta,
+ ]
+ );
+ isa_ok($c, 'Moose::Meta::Role::Composite');
+
+ is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
+
+ lives_ok {
+ Moose::Meta::Role::Application::RoleSummation->new->apply($c);
+ } '... this succeeds as expected';
+
+ is_deeply(
+ [ sort $c->get_method_modifier_list('before') ],
+ [ 'bar', 'foo' ],
+ '... got the right list of methods'
+ );
+
+ is_deeply(
+ [ sort $c->get_method_modifier_list('after') ],
+ [ 'bar', 'foo' ],
+ '... got the right list of methods'
+ );
+
+ is_deeply(
+ [ sort $c->get_method_modifier_list('around') ],
+ [ 'bar', 'foo' ],
+ '... got the right list of methods'
+ );
+}
\ No newline at end of file
projects / gitmo/Moose.git / commitdiff