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