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