-
package Moose::Meta::Role;
use strict;
use warnings;
use metaclass;
+use Class::Load qw(load_class);
use Scalar::Util 'blessed';
use Carp 'confess';
use Devel::GlobalDestruction 'in_global_destruction';
-our $VERSION = '1.9900';
-$VERSION = eval $VERSION;
-our $AUTHORITY = 'cpan:STEVAN';
-
use Moose::Meta::Class;
use Moose::Meta::Role::Attribute;
use Moose::Meta::Role::Method;
# NOTE:
# since roles are lazy, we hold all the attributes
-# of the individual role in 'statis' until which
+# of the individual role in 'stasis' 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
# create the attribute
$META->add_attribute($action->{name} => (
reader => $attr_reader,
- default => sub { {} }
+ default => sub { {} },
+ Class::MOP::_definition_context(),
));
# create some helper methods
'method_metaclass',
reader => 'method_metaclass',
default => 'Moose::Meta::Role::Method',
+ Class::MOP::_definition_context(),
);
$META->add_attribute(
'required_method_metaclass',
reader => 'required_method_metaclass',
default => 'Moose::Meta::Role::Method::Required',
+ Class::MOP::_definition_context(),
);
$META->add_attribute(
'conflicting_method_metaclass',
reader => 'conflicting_method_metaclass',
default => 'Moose::Meta::Role::Method::Conflicting',
+ Class::MOP::_definition_context(),
);
$META->add_attribute(
'application_to_class_class',
reader => 'application_to_class_class',
default => 'Moose::Meta::Role::Application::ToClass',
+ Class::MOP::_definition_context(),
);
$META->add_attribute(
'application_to_role_class',
reader => 'application_to_role_class',
default => 'Moose::Meta::Role::Application::ToRole',
+ Class::MOP::_definition_context(),
);
$META->add_attribute(
'application_to_instance_class',
reader => 'application_to_instance_class',
default => 'Moose::Meta::Role::Application::ToInstance',
+ Class::MOP::_definition_context(),
);
$META->add_attribute(
'applied_attribute_metaclass',
reader => 'applied_attribute_metaclass',
default => 'Moose::Meta::Attribute',
+ Class::MOP::_definition_context(),
);
# More or less copied from Moose::Meta::Class
sub initialize {
my $class = shift;
- my $pkg = shift;
-
- if (defined(my $meta = Class::MOP::get_metaclass_by_name($pkg))) {
- return $meta;
- }
-
- my %options = @_;
-
- my $meta = $class->SUPER::initialize(
- $pkg,
- 'attribute_metaclass' => 'Moose::Meta::Role::Attribute',
- %options,
- );
-
- Class::MOP::weaken_metaclass($pkg) if $options{weaken};
-
- return $meta;
+ my @args = @_;
+ unshift @args, 'package' if @args % 2;
+ my %opts = @args;
+ my $package = delete $opts{package};
+ return Class::MOP::get_metaclass_by_name($package)
+ || $class->SUPER::initialize($package,
+ 'attribute_metaclass' => 'Moose::Meta::Role::Attribute',
+ %opts,
+ );
}
sub reinitialize {
$self->_restore_metamethods_from($old_meta);
$self->_restore_metaattributes_from($old_meta);
+
+ for my $role ( @{ $old_meta->get_roles } ) {
+ $self->add_role($role);
+ }
}
sub add_attribute {
# create the attribute ...
$META->add_attribute("${modifier_type}_method_modifiers" => (
reader => $attr_reader,
- default => sub { {} }
+ default => sub { {} },
+ Class::MOP::_definition_context(),
));
# and some helper methods ...
$META->add_attribute('override_method_modifiers' => (
reader => 'get_override_method_modifiers_map',
- default => sub { {} }
+ default => sub { {} },
+ Class::MOP::_definition_context(),
));
# NOTE:
$META->add_attribute('roles' => (
reader => 'get_roles',
- default => sub { [] }
+ default => sub { [] },
+ Class::MOP::_definition_context(),
));
sub add_role {
$application_class = $self->application_to_instance_class;
}
- Class::MOP::load_class($application_class);
-
- my $deprecation_check = 0;
-
- if ( exists $args{excludes} && !exists $args{'-excludes'} ) {
- $args{'-excludes'} = delete $args{excludes};
- $deprecation_check = 1;
- }
- if ( exists $args{alias} && !exists $args{'-alias'} ) {
- $args{'-alias'} = delete $args{alias};
- $deprecation_check = 1;
- }
-
- if ( $deprecation_check ) {
- Moose::Deprecated::deprecated(
- feature => 'alias or excludes',
- message =>
- 'The alias and excludes options for role application'.
- ' have been renamed -alias and -excludes'.
- " (${\$other->name} is consuming ${\$self->name}".
- " - do you need to upgrade ${\$other->name}?)"
- );
- }
+ load_class($application_class);
if ( exists $args{'-excludes'} ) {
# I wish we had coercion here :)
}
sub create {
- my ( $role, $package_name, %options ) = @_;
+ my $class = shift;
+ my @args = @_;
- $options{package} = $package_name;
+ unshift @args, 'package' if @args % 2 == 1;
+ my %options = @args;
(ref $options{attributes} eq 'HASH')
|| confess "You must pass a HASH ref of attributes"
|| confess "You must pass a HASH ref of methods"
if exists $options{methods};
- $options{meta_name} = 'meta'
- unless exists $options{meta_name};
-
- my (%initialize_options) = %options;
- delete @initialize_options{qw(
- package
- attributes
- methods
- meta_name
- version
- authority
- )};
+ (ref $options{roles} eq 'ARRAY')
+ || confess "You must pass an ARRAY ref of roles"
+ if exists $options{roles};
- my $meta = $role->initialize( $package_name => %initialize_options );
+ my $package = delete $options{package};
+ my $roles = delete $options{roles};
+ my $attributes = delete $options{attributes};
+ my $methods = delete $options{methods};
+ my $meta_name = exists $options{meta_name}
+ ? delete $options{meta_name}
+ : 'meta';
- $meta->_instantiate_module( $options{version}, $options{authority} );
+ my $meta = $class->SUPER::create($package => %options);
- $meta->_add_meta_method($options{meta_name})
- if defined $options{meta_name};
+ $meta->_add_meta_method($meta_name)
+ if defined $meta_name;
- if (exists $options{attributes}) {
- foreach my $attribute_name (keys %{$options{attributes}}) {
- my $attr = $options{attributes}->{$attribute_name};
+ if (defined $attributes) {
+ foreach my $attribute_name (keys %{$attributes}) {
+ my $attr = $attributes->{$attribute_name};
$meta->add_attribute(
$attribute_name => blessed $attr ? $attr : %{$attr} );
}
}
- if (exists $options{methods}) {
- foreach my $method_name (keys %{$options{methods}}) {
- $meta->add_method($method_name, $options{methods}->{$method_name});
+ if (defined $methods) {
+ foreach my $method_name (keys %{$methods}) {
+ $meta->add_method($method_name, $methods->{$method_name});
}
}
+ if ($roles) {
+ Moose::Util::apply_all_roles($meta, @$roles);
+ }
+
return $meta;
}
return @consumers;
}
-# anonymous roles. most of it is copied straight out of Class::MOP::Class.
-# an intrepid hacker might find great riches if he unifies this code with that
-# code in Class::MOP::Module or Class::MOP::Package
-{
- # NOTE:
- # this should be sufficient, if you have a
- # use case where it is not, write a test and
- # I will change it.
- my $ANON_ROLE_SERIAL = 0;
+# XXX: something more intelligent here?
+sub _anon_package_prefix { 'Moose::Meta::Role::__ANON__::SERIAL::' }
- # NOTE:
- # we need a sufficiently annoying prefix
- # this should suffice for now, this is
- # used in a couple of places below, so
- # need to put it up here for now.
- my $ANON_ROLE_PREFIX = 'Moose::Meta::Role::__ANON__::SERIAL::';
-
- sub is_anon_role {
- my $self = shift;
- no warnings 'uninitialized';
- $self->name =~ /^$ANON_ROLE_PREFIX/;
- }
+sub create_anon_role { shift->create_anon(@_) }
+sub is_anon_role { shift->is_anon(@_) }
- sub create_anon_role {
- my ($role, %options) = @_;
- $options{weaken} = 1 unless exists $options{weaken};
- my $package_name = $ANON_ROLE_PREFIX . ++$ANON_ROLE_SERIAL;
- return $role->create($package_name, %options);
- }
+sub _anon_cache_key {
+ my $class = shift;
+ my %options = @_;
- # NOTE:
- # this will only get called for
- # anon-roles, all other calls
- # are assumed to occur during
- # global destruction and so don't
- # really need to be handled explicitly
- sub DESTROY {
- my $self = shift;
-
- return if in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
-
- no warnings 'uninitialized';
- return unless $self->name =~ /^$ANON_ROLE_PREFIX/;
-
- # XXX: is this necessary for us? I don't understand what it's doing
- # -sartak
-
- # Moose does a weird thing where it replaces the metaclass for
- # class when fixing metaclass incompatibility. In that case,
- # we don't want to clean out the namespace now. We can detect
- # that because Moose will explicitly update the singleton
- # cache in Class::MOP.
- #my $current_meta = Class::MOP::get_metaclass_by_name($self->name);
- #return if $current_meta ne $self;
-
- my ($serial_id) = ($self->name =~ /^$ANON_ROLE_PREFIX(\d+)/);
- no strict 'refs';
- foreach my $key (keys %{$ANON_ROLE_PREFIX . $serial_id}) {
- delete ${$ANON_ROLE_PREFIX . $serial_id}{$key};
+ # XXX fix this duplication (see MMC::_anon_cache_key
+ my $roles = Data::OptList::mkopt(($options{roles} || []), {
+ moniker => 'role',
+ val_test => sub { ref($_[0]) eq 'HASH' },
+ });
+
+ my @role_keys;
+ for my $role_spec (@$roles) {
+ my ($role, $params) = @$role_spec;
+ $params = { %$params };
+
+ my $key = blessed($role) ? $role->name : $role;
+
+ if ($params && %$params) {
+ my $alias = delete $params->{'-alias'}
+ || delete $params->{'alias'}
+ || {};
+ my $excludes = delete $params->{'-excludes'}
+ || delete $params->{'excludes'}
+ || [];
+ $excludes = [$excludes] unless ref($excludes) eq 'ARRAY';
+
+ if (%$params) {
+ warn "Roles with parameters cannot be cached. Consider "
+ . "applying the parameters before calling "
+ . "create_anon_class, or using 'weaken => 0' instead";
+ return;
+ }
+
+ my $alias_key = join('%',
+ map { $_ => $alias->{$_} } sort keys %$alias
+ );
+ my $excludes_key = join('%',
+ sort @$excludes
+ );
+ $key .= '<' . join('+', 'a', $alias_key, 'e', $excludes_key) . '>';
}
- delete ${'main::' . $ANON_ROLE_PREFIX}{$serial_id . '::'};
+
+ push @role_keys, $key;
}
+
+ # Makes something like Role|Role::1
+ return join('|', sort @role_keys);
}
#####################################################################
1;
+# ABSTRACT: The Moose Role metaclass
+
__END__
=pod
-=head1 NAME
-
-Moose::Meta::Role - The Moose Role metaclass
-
=head1 DESCRIPTION
This class is a subclass of L<Class::MOP::Module> that provides
additional Moose-specific functionality.
-It's API looks a lot like L<Moose::Meta::Class>, but internally it
+Its API looks a lot like L<Moose::Meta::Class>, but internally it
implements many things differently. This may change in the future.
=head1 INHERITANCE
See L<Moose/BUGS> for details on reporting bugs.
-=head1 AUTHOR
-
-Stevan Little E<lt>stevan@iinteractive.comE<gt>
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright 2006-2010 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
projects / gitmo/Moose.git / blobdiff