lib/Moose/Util/MetaRole.pm

   1 package Moose::Util::MetaRole;
   2
   3 use strict;
   4 use warnings;
   5 use Scalar::Util 'blessed';
   6
   7 use List::MoreUtils qw( all );
   8 use List::Util qw( first );
   9 use Moose::Deprecated;
  10
  11 sub apply_metaclass_roles {
  12     Moose::Deprecated::deprecated(
  13         feature => 'pre-0.94 MetaRole API',
  14         message =>
  15             'The old Moose::Util::MetaRole API (before version 0.94) has been deprecated'
  16     );
  17
  18     goto &apply_metaroles;
  19 }
  20
  21 sub apply_metaroles {
  22     my %args = @_;
  23
  24     _fixup_old_style_args(\%args);
  25
  26     my $for
  27         = blessed $args{for}
  28         ? $args{for}
  29         : Class::MOP::class_of( $args{for} );
  30
  31     if ( $for->isa('Moose::Meta::Role') ) {
  32         return _make_new_metaclass( $for, $args{role_metaroles}, 'role' );
  33     }
  34     else {
  35         return _make_new_metaclass( $for, $args{class_metaroles}, 'class' );
  36     }
  37 }
  38
  39 sub _fixup_old_style_args {
  40     my $args = shift;
  41
  42     return if $args->{class_metaroles} || $args->{role_metaroles};
  43
  44     Moose::Deprecated::deprecated(
  45         feature => 'pre-0.94 MetaRole API',
  46         message =>
  47             'The old Moose::Util::MetaRole API (before version 0.94) has been deprecated'
  48     );
  49
  50     $args->{for} = delete $args->{for_class}
  51         if exists $args->{for_class};
  52
  53     my @old_keys = qw(
  54         attribute_metaclass_roles
  55         method_metaclass_roles
  56         wrapped_method_metaclass_roles
  57         instance_metaclass_roles
  58         constructor_class_roles
  59         destructor_class_roles
  60         error_class_roles
  61
  62         application_to_class_class_roles
  63         application_to_role_class_roles
  64         application_to_instance_class_roles
  65         application_role_summation_class_roles
  66     );
  67
  68     my $for
  69         = blessed $args->{for}
  70         ? $args->{for}
  71         : Class::MOP::class_of( $args->{for} );
  72
  73     my $top_key;
  74     if ( $for->isa('Moose::Meta::Class') ) {
  75         $top_key = 'class_metaroles';
  76
  77         $args->{class_metaroles}{class} = delete $args->{metaclass_roles}
  78             if exists $args->{metaclass_roles};
  79     }
  80     else {
  81         $top_key = 'role_metaroles';
  82
  83         $args->{role_metaroles}{role} = delete $args->{metaclass_roles}
  84             if exists $args->{metaclass_roles};
  85     }
  86
  87     for my $old_key (@old_keys) {
  88         my ($new_key) = $old_key =~ /^(.+)_(?:class|metaclass)_roles$/;
  89
  90         $args->{$top_key}{$new_key} = delete $args->{$old_key}
  91             if exists $args->{$old_key};
  92     }
  93
  94     return;
  95 }
  96
  97 sub _make_new_metaclass {
  98     my $for     = shift;
  99     my $roles   = shift;
 100     my $primary = shift;
 101
 102     return $for unless keys %{$roles};
 103
 104     my $new_metaclass
 105         = exists $roles->{$primary}
 106         ? _make_new_class( ref $for, $roles->{$primary} )
 107         : blessed $for;
 108
 109     my %classes;
 110
 111     for my $key ( grep { $_ ne $primary } keys %{$roles} ) {
 112         my $attr = first {$_}
 113             map { $for->meta->find_attribute_by_name($_) } (
 114             $key . '_metaclass',
 115             $key . '_class'
 116         );
 117
 118         my $reader = $attr->get_read_method;
 119
 120         $classes{ $attr->init_arg }
 121             = _make_new_class( $for->$reader(), $roles->{$key} );
 122     }
 123
 124     my $new_meta = $new_metaclass->reinitialize( $for, %classes );
 125
 126     return $new_meta;
 127 }
 128
 129 sub apply_base_class_roles {
 130     my %args = @_;
 131
 132     my $for = $args{for} || $args{for_class};
 133
 134     my $meta = Class::MOP::class_of($for);
 135
 136     my $new_base = _make_new_class(
 137         $for,
 138         $args{roles},
 139         [ $meta->superclasses() ],
 140     );
 141
 142     $meta->superclasses($new_base)
 143         if $new_base ne $meta->name();
 144 }
 145
 146 sub _make_new_class {
 147     my $existing_class = shift;
 148     my $roles          = shift;
 149     my $superclasses   = shift || [$existing_class];
 150
 151     return $existing_class unless $roles;
 152
 153     my $meta = Class::MOP::Class->initialize($existing_class);
 154
 155     return $existing_class
 156         if $meta->can('does_role') && all  { $meta->does_role($_) }
 157                                       grep { !ref $_ } @{$roles};
 158
 159     return Moose::Meta::Class->create_anon_class(
 160         superclasses => $superclasses,
 161         roles        => $roles,
 162         cache        => 1,
 163     )->name();
 164 }
 165
 166 1;
 167
 168 # ABSTRACT: Apply roles to any metaclass, as well as the object base class
 169
 170 __END__
 171
 172 =head1 SYNOPSIS
 173
 174   package MyApp::Moose;
 175
 176   use Moose ();
 177   use Moose::Exporter;
 178   use Moose::Util::MetaRole;
 179
 180   use MyApp::Role::Meta::Class;
 181   use MyApp::Role::Meta::Method::Constructor;
 182   use MyApp::Role::Object;
 183
 184   Moose::Exporter->setup_import_methods( also => 'Moose' );
 185
 186   sub init_meta {
 187       shift;
 188       my %args = @_;
 189
 190       Moose->init_meta(%args);
 191
 192       Moose::Util::MetaRole::apply_metaroles(
 193           for             => $args{for_class},
 194           class_metaroles => {
 195               class => => ['MyApp::Role::Meta::Class'],
 196               constructor => ['MyApp::Role::Meta::Method::Constructor'],
 197           },
 198       );
 199
 200       Moose::Util::MetaRole::apply_base_class_roles(
 201           for   => $args{for_class},
 202           roles => ['MyApp::Role::Object'],
 203       );
 204
 205       return $args{for_class}->meta();
 206   }
 207
 208 =head1 DESCRIPTION
 209
 210 This utility module is designed to help authors of Moose extensions
 211 write extensions that are able to cooperate with other Moose
 212 extensions. To do this, you must write your extensions as roles, which
 213 can then be dynamically applied to the caller's metaclasses.
 214
 215 This module makes sure to preserve any existing superclasses and roles
 216 already set for the meta objects, which means that any number of
 217 extensions can apply roles in any order.
 218
 219 =head1 USAGE
 220
 221 The easiest way to use this module is through L<Moose::Exporter>, which can
 222 generate the appropriate C<init_meta> method for you, and make sure it is
 223 called when imported.
 224
 225 =head1 FUNCTIONS
 226
 227 This module provides two functions.
 228
 229 =head2 apply_metaroles( ... )
 230
 231 This function will apply roles to one or more metaclasses for the specified
 232 class. It will return a new metaclass object for the class or role passed in
 233 the "for" parameter.
 234
 235 It accepts the following parameters:
 236
 237 =over 4
 238
 239 =item * for => $name
 240
 241 This specifies the class or for which to alter the meta classes. This can be a
 242 package name, or an appropriate meta-object (a L<Moose::Meta::Class> or
 243 L<Moose::Meta::Role>).
 244
 245 =item * class_metaroles => \%roles
 246
 247 This is a hash reference specifying which metaroles will be applied to the
 248 class metaclass and its contained metaclasses and helper classes.
 249
 250 Each key should in turn point to an array reference of role names.
 251
 252 It accepts the following keys:
 253
 254 =over 8
 255
 256 =item class
 257
 258 =item attribute
 259
 260 =item method
 261
 262 =item wrapped_method
 263
 264 =item instance
 265
 266 =item constructor
 267
 268 =item destructor
 269
 270 =item error
 271
 272 =back
 273
 274 =item * role_metaroles => \%roles
 275
 276 This is a hash reference specifying which metaroles will be applied to the
 277 role metaclass and its contained metaclasses and helper classes.
 278
 279 It accepts the following keys:
 280
 281 =over 8
 282
 283 =item role
 284
 285 =item attribute
 286
 287 =item method
 288
 289 =item required_method
 290
 291 =item conflicting_method
 292
 293 =item application_to_class
 294
 295 =item application_to_role
 296
 297 =item application_to_instance
 298
 299 =item application_role_summation
 300
 301 =back
 302
 303 =back
 304
 305 =head2 apply_base_class_roles( for => $class, roles => \@roles )
 306
 307 This function will apply the specified roles to the object's base class.
 308
 309 =head1 BUGS
 310
 311 See L<Moose/BUGS> for details on reporting bugs.
 312
 313 =cut