use strict;
use warnings;
+use Scalar::Util 'blessed';
-our $VERSION = '0.89_02';
-$VERSION = eval $VERSION;
-our $AUTHORITY = 'cpan:STEVAN';
-
+use Carp qw( croak );
use List::MoreUtils qw( all );
+use List::Util qw( first );
+use Moose::Deprecated;
+use Scalar::Util qw( blessed );
+
+sub apply_metaroles {
+ my %args = @_;
+
+ my $for = _metathing_for( $args{for} );
-my @Classes = qw( constructor_class destructor_class error_class );
+ if ( $for->isa('Moose::Meta::Role') ) {
+ return _make_new_metaclass( $for, $args{role_metaroles}, 'role' );
+ }
+ else {
+ return _make_new_metaclass( $for, $args{class_metaroles}, 'class' );
+ }
+}
-sub apply_metaclass_roles {
- my %options = @_;
+sub _metathing_for {
+ my $passed = shift;
- my $for = $options{for_class};
+ my $found
+ = blessed $passed
+ ? $passed
+ : Class::MOP::class_of($passed);
- my %old_classes = map { $_ => Class::MOP::class_of($for)->$_ }
- grep { Class::MOP::class_of($for)->can($_) }
- @Classes;
+ return $found
+ if defined $found
+ && blessed $found
+ && ( $found->isa('Moose::Meta::Role')
+ || $found->isa('Moose::Meta::Class') );
- my $meta = _make_new_metaclass( $for, \%options );
+ local $Carp::CarpLevel = $Carp::CarpLevel + 1;
- for my $c ( grep { $meta->can($_) } @Classes ) {
- if ( $options{ $c . '_roles' } ) {
- my $class = _make_new_class(
- $meta->$c(),
- $options{ $c . '_roles' }
- );
+ my $error_start
+ = 'When using Moose::Util::MetaRole, you must pass a Moose class name,'
+ . ' role name, metaclass object, or metarole object.';
- $meta->$c($class);
- }
- else {
- $meta->$c( $old_classes{$c} );
- }
+ if ( defined $found && blessed $found ) {
+ croak $error_start
+ . " You passed $passed, and we resolved this to a "
+ . ( blessed $found )
+ . ' object.';
}
- return $meta;
+ if ( defined $passed && !defined $found ) {
+ croak $error_start
+ . " You passed $passed, and this did not resolve to a metaclass or metarole."
+ . ' Maybe you need to call Moose->init_meta to initialize the metaclass first?';
+ }
+
+ if ( !defined $passed ) {
+ croak $error_start
+ . " You passed an undef."
+ . ' Maybe you need to call Moose->init_meta to initialize the metaclass first?';
+ }
}
sub _make_new_metaclass {
my $for = shift;
- my $options = shift;
-
- return Class::MOP::class_of($for)
- unless grep { exists $options->{ $_ . '_roles' } }
- qw(
- metaclass
- attribute_metaclass
- method_metaclass
- wrapped_method_metaclass
- instance_metaclass
- application_to_class_class
- application_to_role_class
- application_to_instance_class
- );
+ my $roles = shift;
+ my $primary = shift;
+
+ return $for unless keys %{$roles};
- my $old_meta = Class::MOP::class_of($for);
my $new_metaclass
- = _make_new_class( ref $old_meta, $options->{metaclass_roles} );
-
- # This could get called for a Moose::Meta::Role as well as a Moose::Meta::Class
- my %classes = map {
- $_ => _make_new_class( $old_meta->$_(), $options->{ $_ . '_roles' } )
- }
- grep { $old_meta->can($_) }
- qw(
- attribute_metaclass
- method_metaclass
- wrapped_method_metaclass
- instance_metaclass
- application_to_class_class
- application_to_role_class
- application_to_instance_class
- );
+ = exists $roles->{$primary}
+ ? _make_new_class( ref $for, $roles->{$primary} )
+ : blessed $for;
+
+ my %classes;
+
+ for my $key ( grep { $_ ne $primary } keys %{$roles} ) {
+ my $attr = first {$_}
+ map { $for->meta->find_attribute_by_name($_) } (
+ $key . '_metaclass',
+ $key . '_class'
+ );
+
+ my $reader = $attr->get_read_method;
+
+ $classes{ $attr->init_arg }
+ = _make_new_class( $for->$reader(), $roles->{$key} );
+ }
+
+ my $new_meta = $new_metaclass->reinitialize( $for, %classes );
- return $new_metaclass->reinitialize( $for, %classes );
+ return $new_meta;
}
sub apply_base_class_roles {
- my %options = @_;
-
- my $for = $options{for_class};
+ my %args = @_;
- my $meta = Class::MOP::class_of($for);
+ my $meta = _metathing_for( $args{for} || $args{for_class} );
+ croak 'You can only apply base class roles to a Moose class, not a role.'
+ if $meta->isa('Moose::Meta::Role');
my $new_base = _make_new_class(
- $for,
- $options{roles},
+ $meta->name,
+ $args{roles},
[ $meta->superclasses() ],
);
1;
-__END__
-
-=head1 NAME
+# ABSTRACT: Apply roles to any metaclass, as well as the object base class
-Moose::Util::MetaRole - Apply roles to any metaclass, as well as the object base class
+__END__
=head1 SYNOPSIS
sub init_meta {
shift;
- my %options = @_;
+ my %args = @_;
- Moose->init_meta(%options);
+ Moose->init_meta(%args);
- Moose::Util::MetaRole::apply_metaclass_roles(
- for_class => $options{for_class},
- metaclass_roles => ['MyApp::Role::Meta::Class'],
- constructor_class_roles => ['MyApp::Role::Meta::Method::Constructor'],
+ Moose::Util::MetaRole::apply_metaroles(
+ for => $args{for_class},
+ class_metaroles => {
+ class => => ['MyApp::Role::Meta::Class'],
+ constructor => ['MyApp::Role::Meta::Method::Constructor'],
+ },
);
Moose::Util::MetaRole::apply_base_class_roles(
- for_class => $options{for_class},
- roles => ['MyApp::Role::Object'],
+ for => $args{for_class},
+ roles => ['MyApp::Role::Object'],
);
- return $options{for_class}->meta();
+ return $args{for_class}->meta();
}
=head1 DESCRIPTION
=head1 USAGE
-B<It is very important that you only call this module's functions when
-your module is imported by the caller>. The process of applying roles
-to the metaclass reinitializes the metaclass object, which wipes out
-any existing attributes already defined. However, as long as you do
-this when your module is imported, the caller should not have any
-attributes defined yet.
-
-The easiest way to ensure that this happens is to use
-L<Moose::Exporter>, which can generate the appropriate C<init_meta>
-method for you, and make sure it is called when imported.
+The easiest way to use this module is through L<Moose::Exporter>, which can
+generate the appropriate C<init_meta> method for you, and make sure it is
+called when imported.
=head1 FUNCTIONS
This module provides two functions.
-=head2 apply_metaclass_roles( ... )
+=head2 apply_metaroles( ... )
+
+This function will apply roles to one or more metaclasses for the specified
+class. It will return a new metaclass object for the class or role passed in
+the "for" parameter.
-This function will apply roles to one or more metaclasses for the
-specified class. It accepts the following parameters:
+It accepts the following parameters:
=over 4
-=item * for_class => $name
+=item * for => $name
-This specifies the class for which to alter the meta classes.
+This specifies the class or for which to alter the meta classes. This can be a
+package name, or an appropriate meta-object (a L<Moose::Meta::Class> or
+L<Moose::Meta::Role>).
-=item * metaclass_roles => \@roles
+=item * class_metaroles => \%roles
-=item * attribute_metaclass_roles => \@roles
+This is a hash reference specifying which metaroles will be applied to the
+class metaclass and its contained metaclasses and helper classes.
-=item * method_metaclass_roles => \@roles
+Each key should in turn point to an array reference of role names.
-=item * wrapped_method_metaclass_roles => \@roles
+It accepts the following keys:
-=item * instance_metaclass_roles => \@roles
+=over 8
-=item * constructor_class_roles => \@roles
+=item class
-=item * destructor_class_roles => \@roles
+=item attribute
-=item * application_to_class_class_roles => \@roles
+=item method
-=item * application_to_role_class_roles => \@roles
+=item wrapped_method
-=item * application_to_instance_class_roles => \@roles
+=item instance
-These parameter all specify one or more roles to be applied to the
-specified metaclass. You can pass any or all of these parameters at
-once.
+=item constructor
+
+=item destructor
+
+=item error
=back
-=head2 apply_base_class_roles( for_class => $class, roles => \@roles )
+=item * role_metaroles => \%roles
-This function will apply the specified roles to the object's base class.
+This is a hash reference specifying which metaroles will be applied to the
+role metaclass and its contained metaclasses and helper classes.
+
+It accepts the following keys:
+
+=over 8
+
+=item role
+
+=item attribute
+
+=item method
-=head1 AUTHOR
+=item required_method
-Dave Rolsky E<lt>autarch@urth.orgE<gt>
+=item conflicting_method
-=head1 COPYRIGHT AND LICENSE
+=item application_to_class
-Copyright 2009 by Infinity Interactive, Inc.
+=item application_to_role
+
+=item application_to_instance
+
+=item application_role_summation
+
+=item applied_attribute
+
+=back
+
+=back
+
+=head2 apply_base_class_roles( for => $class, roles => \@roles )
+
+This function will apply the specified roles to the object's base class.
-L<http://www.iinteractive.com>
+=head1 BUGS
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
+See L<Moose/BUGS> for details on reporting bugs.
=cut