This will need serious review before merging.
},
);
-has '+default' => ( required => 1 );
-has '+type_constraint' => ( required => 1 );
-
# methods called prior to instantiation
before '_process_options' => sub {
--- /dev/null
+package Moose::Meta::Attribute::Trait::InRole;
+
+use Moose::Role;
+
+use Carp 'confess';
+use Scalar::Util 'blessed', 'weaken';
+
+our $VERSION = '0.93';
+our $AUTHORITY = 'cpan:STEVAN';
+
+around attach_to_class => sub {
+ shift;
+ my ( $self, $class ) = @_;
+
+ ( blessed($class) && $class->isa('Moose::Meta::Role') )
+ || confess
+ "You must pass a Moose::Meta::Role instance (or a subclass)";
+
+ weaken( $self->{'associated_class'} = $class );
+};
+
+# XXX - This is a no-op, since trying to add accessors to a role just blows
+# up. Ideally, we _would_ add accessors, or somehow make the role aware that
+# they exist for the purposes of method conflict checking, etc.
+around install_accessors => sub { };
+
+around _check_associated_methods => sub { };
+
+around clone => sub {
+ my $orig = shift;
+ my $self = shift;
+
+ my $meta = $self->meta;
+
+ my @supers = $meta->superclasses();
+ my @traits_to_keep = grep { $_ ne __PACKAGE__ }
+ map { $_->name }
+ grep { !$_->isa('Moose::Meta::Role::Composite') }
+ $meta->calculate_all_roles;
+
+ my $new_class;
+
+ if ( @traits_to_keep || @supers > 1 ) {
+ my $anon_class = Moose::Meta::Class->create_anon_class(
+ superclasses => \@supers,
+ roles => \@traits_to_keep,
+ cache => 1,
+ );
+
+ $new_class = $anon_class->name;
+ }
+ else {
+ $new_class = $supers[0];
+ }
+
+ return $self->$orig( @_, metaclass => $new_class );
+};
+
+no Moose::Role;
+
+1;
use Moose::Meta::Role::Method;
use Moose::Meta::Role::Method::Required;
use Moose::Meta::Role::Method::Conflicting;
+use Moose::Util qw( ensure_all_roles );
-use base 'Class::MOP::Module';
+use base 'Class::MOP::Module', 'Class::MOP::HasAttributes';
## ------------------------------------------------------------------
## NOTE:
existence => 'requires_method',
}
},
- {
- name => '_attribute_map',
- attr_reader => '_attribute_map',
- methods => {
- get => 'get_attribute',
- get_keys => 'get_attribute_list',
- existence => 'has_attribute',
- remove => 'remove_attribute',
- }
- }
) {
my $attr_reader = $action->{attr_reader};
predicate => 'has_composition_class_roles',
);
-## some things don't always fit, so they go here ...
+# More or less copied from Moose::Meta::Class
+sub initialize {
+ my $class = shift;
+ my $pkg = shift;
+ return Class::MOP::get_metaclass_by_name($pkg)
+ || $class->SUPER::initialize(
+ $pkg,
+ 'attribute_metaclass' => 'Moose::Meta::Attribute',
+ @_
+ );
+}
+my $Role_Loaded;
+# XXX - copied from Moose::Meta::Class
sub add_attribute {
my $self = shift;
- my $name = shift;
- unless ( defined $name ) {
- require Moose;
- Moose->throw_error("You must provide a name for the attribute");
+
+ # Since this _is_ a role, it needs to be loaded after Moose::Meta::Role is
+ # done setting itself up.
+ unless ($Role_Loaded) {
+ require Moose::Meta::Attribute::Trait::InRole;
+ $Role_Loaded = 1;
}
- my $attr_desc;
- if (scalar @_ == 1 && ref($_[0]) eq 'HASH') {
- $attr_desc = $_[0];
+
+ my $attr = (
+ blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
+ ? $self->_ensure_attribute_trait($_[0] )
+ : $self->_process_attribute(@_)
+ );
+
+ $self->SUPER::add_attribute($attr);
+
+ return $attr;
+}
+
+sub _ensure_attribute_trait {
+ my $self = shift;
+ my $attr = shift;
+
+ ensure_all_roles( $attr, 'Moose::Meta::Attribute::Trait::InRole' );
+
+ return $attr;
+}
+
+sub _process_attribute {
+ my ( $self, $name, @args ) = @_;
+
+ my %args = scalar @args == 1
+ && ref( $args[0] ) eq 'HASH' ? %{ $args[0] } : @args;
+
+ if ( $args{traits} ) {
+ push @{ $args{traits} }, 'Moose::Meta::Attribute::Trait::InRole';
}
else {
- $attr_desc = { @_ };
+ $args{traits} = ['Moose::Meta::Attribute::Trait::InRole'];
}
- $self->_attribute_map->{$name} = $attr_desc;
+
+ $self->attribute_metaclass->interpolate_class_and_new( $name, %args );
}
sub add_required_methods {
# }
# );
#
-# has 'attribute_map' => (
-# metaclass => 'Hash',
-# reader => '_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 => 'Hash',
# reader => 'get_required_methods_map',
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 @all_attributes;
+
+ for my $role ( @{ $c->get_roles } ) {
+ push @all_attributes,
+ map { $role->get_attribute($_) } $role->get_attribute_list;
+ }
my %seen;
foreach my $attr (@all_attributes) {
- if (exists $seen{$attr->{name}}) {
- if ( $seen{$attr->{name}} != $attr->{attr} ) {
+ my $name = $attr->name;
+
+ if ( exists $seen{$name} ) {
+ if ( $seen{$name} != $attr ) {
+ my $role1 = $seen{$name}->associated_class->name;
+ my $role2 = $attr->associated_class->name;
+
require Moose;
- Moose->throw_error("We have encountered an attribute conflict with '" . $attr->{name} . "' "
- . "during composition. This is fatal error and cannot be disambiguated.")
+ Moose->throw_error(
+ "We have encountered an attribute conflict with '$name' "
+ . "during role composition. "
+ . " This attribute is defined in both $role1 and $role2."
+ . " This is fatal error and cannot be disambiguated."
+ );
}
}
- $seen{$attr->{name}} = $attr->{attr};
+
+ $seen{$name} = $attr;
}
foreach my $attr (@all_attributes) {
- $c->add_attribute($attr->{name}, $attr->{attr});
+ $c->add_attribute($attr);
}
}
sub check_role_exclusions {
my ($self, $role, $class) = @_;
+ if (ref $class eq 'Class::MOP::Class' ){
+ Carp::cluck('wtf');
+ }
if ($class->excludes_role($role->name)) {
$class->throw_error("Conflict detected: " . $class->name . " excludes role '" . $role->name . "'");
}
}
else {
$class->add_attribute(
- $attribute_name,
- $role->get_attribute($attribute_name)
+ $role->get_attribute($attribute_name)->clone
);
}
}
}
else {
my $obj_meta = Class::MOP::class_of($object) || 'Moose::Meta::Class';
+
+ # This is a special case to handle the case where the object's
+ # metaclass is a Class::MOP::Class, but _not_ a Moose::Meta::Class
+ # (for example, when applying a role to a Moose::Meta::Attribute
+ # object).
+ $obj_meta = 'Moose::Meta::Class'
+ unless $obj_meta->isa('Moose::Meta::Class');
+
$class = $obj_meta->create_anon_class(
superclasses => [ blessed($object) ]
);
}
else {
$role2->add_attribute(
- $attribute_name,
$role1->get_attribute($attribute_name)
);
}
does => role_type('Bar::Role')
);
+ package Foo::Class;
+ use Moose;
+
+ with 'Foo::Role';
+
package Bar::Role;
use Moose::Role;
# since the isa() check will imply the does() check
has 'foo' => (is => 'rw', isa => 'Foo::Class', does => 'Foo::Role');
- package Foo::Class;
- use Moose;
-
- with 'Foo::Role';
-
package Bar::Class;
use Moose;
with 'Bar::Role';
-
}
my $foo = Foo::Class->new;
ok($foo_role->has_attribute('bar'), '... FooRole does have the bar attribute');
-is_deeply(
- $foo_role->get_attribute('bar'),
- { is => 'rw', isa => 'Foo' },
- '... got the correct description of the bar attribute');
+my $bar = $foo_role->get_attribute('bar');
+is( $bar->get_read_method, 'bar', 'bar has a reader named bar' );
+is( $bar->get_write_method, 'bar', 'bar has a writer named bar' );
+is(
+ $bar->type_constraint,
+ Moose::Util::TypeConstraints::class_type('Foo'),
+ 'bar has a Foo class type'
+);
lives_ok {
$foo_role->add_attribute('baz' => (is => 'ro'));
ok($foo_role->has_attribute('baz'), '... FooRole does have the baz attribute');
-is_deeply(
- $foo_role->get_attribute('baz'),
- { is => 'ro' },
- '... got the correct description of the baz attribute');
+my $baz = $foo_role->get_attribute('baz');
+is( $baz->get_read_method, 'baz', 'baz has a reader named baz' );
+is( $baz->get_write_method, undef, 'baz does not have a writer' );
lives_ok {
$foo_role->remove_attribute('bar');
package Role::WithCustomApplication;
use Moose::Role;
- has '+composition_class_roles' => (
- default => ['Role::Composite'],
+ has 'composition_class_roles' => (
+ is => 'bare',
+ default => sub { ['Role::Composite'] },
);
}
isa_ok( $gorch, "Moose::Meta::Role" );
ok( $gorch->has_attribute("attr"), "has attribute 'attr'" );
-
-{
- local $TODO = "role attribute isn't a meta attribute yet";
- isa_ok( $gorch->get_attribute("attr"), "Moose::Meta::Attribute" );
-}
+isa_ok( $gorch->get_attribute("attr"), "Moose::Meta::Attribute" );
req_or_has($gorch, "gorch_method");
ok( $gorch->has_method("gorch_method"), "has_method gorch_method" );
isa_ok( $robot, "Moose::Meta::Role" );
ok( $robot->has_attribute("twist"), "has attr 'twist'" );
-
-{
- local $TODO = "role attribute isn't a meta attribute yet";
- isa_ok( $robot->get_attribute("twist"), "Moose::Meta::Attribute" );
-}
+isa_ok( $robot->get_attribute("twist"), "Moose::Meta::Attribute" );
{
req_or_has($robot, "twist");
projects / gitmo/Moose.git / commitdiff