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