lib/Moose/Util/MetaRole.pm

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