lib/Mouse/Util/MetaRole.pm

   1 package Mouse::Util::MetaRole;
   2 use Mouse::Util; # enables strict and warnings
   3 use Scalar::Util ();
   4
   5 sub apply_metaclass_roles {
   6     my %args = @_;
   7     _fixup_old_style_args(\%args);
   8
   9     return apply_metaroles(%args);
  10 }
  11
  12 sub apply_metaroles {
  13     my %args = @_;
  14
  15     my $for = Scalar::Util::blessed($args{for})
  16         ?                                     $args{for}
  17         : Mouse::Util::get_metaclass_by_name( $args{for} );
  18
  19     if ( Mouse::Util::is_a_metarole($for) ) {
  20         return _make_new_metaclass( $for, $args{role_metaroles}, 'role' );
  21     }
  22     else {
  23         return _make_new_metaclass( $for, $args{class_metaroles}, 'class' );
  24     }
  25 }
  26
  27 sub _make_new_metaclass {
  28     my($for, $roles, $primary) = @_;
  29
  30     return $for unless keys %{$roles};
  31
  32     my $new_metaclass = exists($roles->{$primary})
  33         ? _make_new_class( ref $for, $roles->{$primary} ) # new class with traits
  34         :                  ref $for;
  35
  36     my %classes;
  37
  38     for my $key ( grep { $_ ne $primary } keys %{$roles} ) {
  39         my $metaclass;
  40         my $attr = $for->can($metaclass = ($key . '_metaclass'))
  41                 || $for->can($metaclass = ($key . '_class'))
  42                 || $for->throw_error("Unknown metaclass '$key'");
  43
  44         $classes{ $metaclass }
  45             = _make_new_class( $for->$attr(), $roles->{$key} );
  46     }
  47
  48     return $new_metaclass->reinitialize( $for, %classes );
  49 }
  50
  51
  52 sub _fixup_old_style_args {
  53     my $args = shift;
  54
  55     return if $args->{class_metaroles} || $args->{roles_metaroles};
  56
  57     $args->{for} = delete $args->{for_class}
  58         if exists $args->{for_class};
  59
  60     my @old_keys = qw(
  61         attribute_metaclass_roles
  62         method_metaclass_roles
  63         wrapped_method_metaclass_roles
  64         instance_metaclass_roles
  65         constructor_class_roles
  66         destructor_class_roles
  67         error_class_roles
  68
  69         application_to_class_class_roles
  70         application_to_role_class_roles
  71         application_to_instance_class_roles
  72         application_role_summation_class_roles
  73     );
  74
  75     my $for = Scalar::Util::blessed($args->{for})
  76         ?                                     $args->{for}
  77         : Mouse::Util::get_metaclass_by_name( $args->{for} );
  78
  79     my $top_key;
  80     if( Mouse::Util::is_a_metaclass($for) ){
  81         $top_key = 'class_metaroles';
  82
  83         $args->{class_metaroles}{class} = delete $args->{metaclass_roles}
  84             if exists $args->{metaclass_roles};
  85     }
  86     else {
  87         $top_key = 'role_metaroles';
  88
  89         $args->{role_metaroles}{role} = delete $args->{metaclass_roles}
  90             if exists $args->{metaclass_roles};
  91     }
  92
  93     for my $old_key (@old_keys) {
  94         my ($new_key) = $old_key =~ /^(.+)_(?:class|metaclass)_roles$/;
  95
  96         $args->{$top_key}{$new_key} = delete $args->{$old_key}
  97             if exists $args->{$old_key};
  98     }
  99
 100     return;
 101 }
 102
 103
 104 sub apply_base_class_roles {
 105     my %options = @_;
 106
 107     my $for = $options{for_class};
 108
 109     my $meta = Mouse::Util::class_of($for);
 110
 111     my $new_base = _make_new_class(
 112         $for,
 113         $options{roles},
 114         [ $meta->superclasses() ],
 115     );
 116
 117     $meta->superclasses($new_base)
 118         if $new_base ne $meta->name();
 119     return;
 120 }
 121
 122 sub _make_new_class {
 123     my($existing_class, $roles, $superclasses) = @_;
 124
 125     if(!$superclasses){
 126         return $existing_class if !$roles;
 127
 128         my $meta = Mouse::Meta::Class->initialize($existing_class);
 129
 130         return $existing_class
 131             if !grep { !ref($_) && !$meta->does_role($_) } @{$roles};
 132     }
 133
 134     return Mouse::Meta::Class->create_anon_class(
 135         superclasses => $superclasses ? $superclasses : [$existing_class],
 136         roles        => $roles,
 137         cache        => 1,
 138     )->name();
 139 }
 140
 141 1;
 142 __END__
 143
 144 =head1 NAME
 145
 146 Mouse::Util::MetaRole - Apply roles to any metaclass, as well as the object base class
 147
 148 =head1 SYNOPSIS
 149
 150   package MyApp::Mouse;
 151
 152   use Mouse ();
 153   use Mouse::Exporter;
 154   use Mouse::Util::MetaRole;
 155
 156   use MyApp::Role::Meta::Class;
 157   use MyApp::Role::Meta::Method::Constructor;
 158   use MyApp::Role::Object;
 159
 160   Mouse::Exporter->setup_import_methods( also => 'Mouse' );
 161
 162   sub init_meta {
 163       shift;
 164       my %options = @_;
 165
 166       Mouse->init_meta(%options);
 167
 168       Mouse::Util::MetaRole::apply_metaclass_roles(
 169           for_class               => $options{for_class},
 170           metaclass_roles         => ['MyApp::Role::Meta::Class'],
 171           constructor_class_roles => ['MyApp::Role::Meta::Method::Constructor'],
 172       );
 173
 174       Mouse::Util::MetaRole::apply_base_class_roles(
 175           for_class => $options{for_class},
 176           roles     => ['MyApp::Role::Object'],
 177       );
 178
 179       return $options{for_class}->meta();
 180   }
 181
 182 =head1 DESCRIPTION
 183
 184 This utility module is designed to help authors of Mouse extensions
 185 write extensions that are able to cooperate with other Mouse
 186 extensions. To do this, you must write your extensions as roles, which
 187 can then be dynamically applied to the caller's metaclasses.
 188
 189 This module makes sure to preserve any existing superclasses and roles
 190 already set for the meta objects, which means that any number of
 191 extensions can apply roles in any order.
 192
 193 =head1 USAGE
 194
 195 B<It is very important that you only call this module's functions when
 196 your module is imported by the caller>. The process of applying roles
 197 to the metaclass reinitializes the metaclass object, which wipes out
 198 any existing attributes already defined. However, as long as you do
 199 this when your module is imported, the caller should not have any
 200 attributes defined yet.
 201
 202 The easiest way to ensure that this happens is to use
 203 L<Mouse::Exporter>, which can generate the appropriate C<init_meta>
 204 method for you, and make sure it is called when imported.
 205
 206 =head1 FUNCTIONS
 207
 208 This module provides two functions.
 209
 210 =head2 apply_metaclass_roles( ... )
 211
 212 This function will apply roles to one or more metaclasses for the
 213 specified class. It accepts the following parameters:
 214
 215 =over 4
 216
 217 =item * for_class => $name
 218
 219 This specifies the class for which to alter the meta classes.
 220
 221 =item * metaclass_roles => \@roles
 222
 223 =item * attribute_metaclass_roles => \@roles
 224
 225 =item * method_metaclass_roles => \@roles
 226
 227 =item * constructor_class_roles => \@roles
 228
 229 =item * destructor_class_roles => \@roles
 230
 231 These parameter all specify one or more roles to be applied to the
 232 specified metaclass. You can pass any or all of these parameters at
 233 once.
 234
 235 =back
 236
 237 =head2 apply_base_class_roles( for_class => $class, roles => \@roles )
 238
 239 This function will apply the specified roles to the object's base class.
 240
 241 =head1 SEE ALSO
 242
 243 L<Moose::Util::MetaRole>
 244
 245 =cut