package Mouse::Util::MetaRole;
use Mouse::Util; # enables strict and warnings
+use Scalar::Util ();
-my @MetaClassTypes = qw(
- metaclass
- attribute_metaclass
- method_metaclass
- constructor_class
- destructor_class
-);
-
-# In Mouse::Exporter::do_import():
-# apply_metaclass_roles(for_class => $class, metaclass_roles => \@traits)
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;
+
+ return if $args->{class_metaroles} || $args->{roles_metaroles};
+
+ $args->{for} = delete $args->{for_class}
+ if exists $args->{for_class};
- my $for = Scalar::Util::blessed($options{for_class})
- ? $options{for_class}
- : Mouse::Util::get_metaclass_by_name($options{for_class});
+ 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
- my $new_metaclass = _make_new_class( ref $for,
- $options{metaclass_roles},
- $options{metaclass} ? [$options{metaclass}] : undef,
+ application_to_class_class_roles
+ application_to_role_class_roles
+ application_to_instance_class_roles
+ application_role_summation_class_roles
);
- my @metaclass_map;
+ my $for = Scalar::Util::blessed($args->{for})
+ ? $args->{for}
+ : Mouse::Util::get_metaclass_by_name( $args->{for} );
- foreach my $mc_type(@MetaClassTypes){
- next if !$for->can($mc_type);
+ my $top_key;
+ if( Mouse::Util::is_a_metaclass($for) ){
+ $top_key = 'class_metaroles';
- if(my $roles = $options{ $mc_type . '_roles' }){
- push @metaclass_map,
- ($mc_type => _make_new_class($for->$mc_type(), $roles));
- }
- elsif(my $mc = $options{$mc_type}){
- push @metaclass_map, ($mc_type => $mc);
- }
+ $args->{class_metaroles}{class} = delete $args->{metaclass_roles}
+ if exists $args->{metaclass_roles};
}
+ else {
+ $top_key = 'role_metaroles';
- return $new_metaclass->reinitialize( $for, @metaclass_map );
+ $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$/;
+
+ $args->{$top_key}{$new_key} = delete $args->{$old_key}
+ if exists $args->{$old_key};
+ }
+
+ return;
}
+
sub apply_base_class_roles {
my %options = @_;
}
1;
-
__END__
=head1 NAME
sub init_meta {
shift;
- my %options = @_;
+ my %args = @_;
- Mouse->init_meta(%options);
+ Mouse->init_meta(%args);
- Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => $options{for_class},
- metaclass_roles => ['MyApp::Role::Meta::Class'],
- constructor_class_roles => ['MyApp::Role::Meta::Method::Constructor'],
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => $args{for_class},
+ class_metaroles => {
+ class => ['MyApp::Role::Meta::Class'],
+ constructor => ['MyApp::Role::Meta::Method::Constructor'],
+ },
);
Mouse::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
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 accepts the following parameters:
=over 4
-=item * for_class => $name
+=item * for => $name
+
+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<Mouse::Meta::Class> or
+L<Mouse::Meta::Role>).
+
+=item * class_metaroles => \%roles
+
+This is a hash reference specifying which metaroles will be applied to the
+class metaclass and its contained metaclasses and helper classes.
-This specifies the class for which to alter the meta classes.
+Each key should in turn point to an array reference of role names.
-=item * metaclass_roles => \@roles
+It accepts the following keys:
-=item * attribute_metaclass_roles => \@roles
+=over 8
-=item * method_metaclass_roles => \@roles
+=item class
-=item * constructor_class_roles => \@roles
+=item attribute
-=item * destructor_class_roles => \@roles
+=item method
-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
+
+=back
+
+=item * role_metaroles => \%roles
+
+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 method
+
+=back
=back
-=head2 apply_base_class_roles( for_class => $class, roles => \@roles )
+=head2 apply_base_class_roles( for => $class, roles => \@roles )
This function will apply the specified roles to the object's base class.
projects / gitmo/Mouse.git / blobdiff