package Mouse::Util::MetaRole;
use Mouse::Util; # enables strict and warnings
-
-our @Classes = qw(constructor_class destructor_class);
+use Scalar::Util ();
sub apply_metaclass_roles {
- my %options = @_;
+ my %args = @_;
+ _fixup_old_style_args(\%args);
+
+ return apply_metaroles(%args);
+}
+
+sub apply_metaroles {
+ my %args = @_;
+
+ my $for = Scalar::Util::blessed($args{for})
+ ? $args{for}
+ : Mouse::Util::get_metaclass_by_name( $args{for} );
+
+ if ( Mouse::Util::is_a_metarole($for) ) {
+ return _make_new_metaclass( $for, $args{role_metaroles}, 'role' );
+ }
+ else {
+ return _make_new_metaclass( $for, $args{class_metaroles}, 'class' );
+ }
+}
+
+sub _make_new_metaclass {
+ my($for, $roles, $primary) = @_;
+
+ return $for unless keys %{$roles};
+
+ my $new_metaclass = exists($roles->{$primary})
+ ? _make_new_class( ref $for, $roles->{$primary} ) # new class with traits
+ : ref $for;
+
+ my %classes;
+
+ for my $key ( grep { $_ ne $primary } keys %{$roles} ) {
+ my $metaclass;
+ my $attr = $for->can($metaclass = ($key . '_metaclass'))
+ || $for->can($metaclass = ($key . '_class'))
+ || $for->throw_error("Unknown metaclass '$key'");
+
+ $classes{ $metaclass }
+ = _make_new_class( $for->$attr(), $roles->{$key} );
+ }
+
+ return $new_metaclass->reinitialize( $for, %classes );
+}
+
+
+sub _fixup_old_style_args {
+ my $args = shift;
- my $for = Scalar::Util::blessed($options{for_class})
- ? $options{for_class}
- : Mouse::Util::class_of($options{for_class});
+ return if $args->{class_metaroles} || $args->{roles_metaroles};
- my %old_classes = map { $for->can($_) ? ($_ => $for->$_) : () }
- @Classes;
+ $args->{for} = delete $args->{for_class}
+ if exists $args->{for_class};
- my $meta = _make_new_metaclass( $for, \%options );
+ my @old_keys = qw(
+ attribute_metaclass_roles
+ method_metaclass_roles
+ wrapped_method_metaclass_roles
+ instance_metaclass_roles
+ constructor_class_roles
+ destructor_class_roles
+ error_class_roles
- for my $c ( grep { $meta->can($_) } @Classes ) {
- if ( $options{ $c . '_roles' } ) {
- my $class = _make_new_class(
- $meta->$c(),
- $options{ $c . '_roles' }
- );
+ application_to_class_class_roles
+ application_to_role_class_roles
+ application_to_instance_class_roles
+ application_role_summation_class_roles
+ );
+
+ my $for = Scalar::Util::blessed($args->{for})
+ ? $args->{for}
+ : Mouse::Util::get_metaclass_by_name( $args->{for} );
+
+ my $top_key;
+ if( Mouse::Util::is_a_metaclass($for) ){
+ $top_key = 'class_metaroles';
+
+ $args->{class_metaroles}{class} = delete $args->{metaclass_roles}
+ if exists $args->{metaclass_roles};
+ }
+ else {
+ $top_key = 'role_metaroles';
+
+ $args->{role_metaroles}{role} = delete $args->{metaclass_roles}
+ if exists $args->{metaclass_roles};
+ }
+
+ for my $old_key (@old_keys) {
+ my ($new_key) = $old_key =~ /^(.+)_(?:class|metaclass)_roles$/;
- $meta->$c($class);
- }
- elsif($meta->$c ne $old_classes{$c}){
- $meta->$c( $old_classes{$c} );
- }
+ $args->{$top_key}{$new_key} = delete $args->{$old_key}
+ if exists $args->{$old_key};
}
- return $meta;
+ return;
}
+
sub apply_base_class_roles {
my %options = @_;
return;
}
-
-my @Metaclasses = qw(
- metaclass
- attribute_metaclass
- method_metaclass
-);
-
-sub _make_new_metaclass {
- my($for, $options) = @_;
-
- return $for
- if !grep { exists $options->{ $_ . '_roles' } } @Metaclasses;
-
- my $new_metaclass
- = _make_new_class( ref $for, $options->{metaclass_roles} );
-
- # This could get called for a Mouse::Meta::Role as well as a Mouse::Meta::Class
- my %classes = map {
- $_ => _make_new_class( $for->$_(), $options->{ $_ . '_roles' } )
- } grep { $for->can($_) } @Metaclasses;
-
- return $new_metaclass->reinitialize( $for, %classes );
-}
-
-
sub _make_new_class {
my($existing_class, $roles, $superclasses) = @_;
- return $existing_class if !$roles;
+ if(!$superclasses){
+ return $existing_class if !$roles;
- my $meta = Mouse::Meta::Class->initialize($existing_class);
+ my $meta = Mouse::Meta::Class->initialize($existing_class);
- return $existing_class
- if !grep { !ref($_) && !$meta->does_role($_) } @{$roles};
+ return $existing_class
+ if !grep { !ref($_) && !$meta->does_role($_) } @{$roles};
+ }
return Mouse::Meta::Class->create_anon_class(
superclasses => $superclasses ? $superclasses : [$existing_class],
}
1;
-
__END__
=head1 NAME
This function will apply the specified roles to the object's base class.
-=head1 SEE ASLSO
+=head1 SEE ALSO
L<Moose::Util::MetaRole>