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