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.89_02';
   8 $VERSION = eval $VERSION;
   9 our $AUTHORITY = 'cpan:STEVAN';
  10
  11 use List::MoreUtils qw( all );
  12
  13 my @Classes = qw( constructor_class destructor_class error_class );
  14
  15 sub apply_metaclass_roles {
  16     my %options = @_;
  17
  18     my $for = blessed $options{for_class}
  19         ? $options{for_class}
  20         : Class::MOP::class_of($options{for_class});
  21
  22     my %old_classes = map { $_ => $for->$_ }
  23                       grep { $for->can($_) }
  24                       @Classes;
  25
  26     my $meta = _make_new_metaclass( $for, \%options );
  27
  28     for my $c ( grep { $meta->can($_) } @Classes ) {
  29         if ( $options{ $c . '_roles' } ) {
  30             my $class = _make_new_class(
  31                 $meta->$c(),
  32                 $options{ $c . '_roles' }
  33             );
  34
  35             $meta->$c($class);
  36         }
  37         else {
  38             $meta->$c( $old_classes{$c} );
  39         }
  40     }
  41
  42     return $meta;
  43 }
  44
  45 sub _make_new_metaclass {
  46     my $for     = shift;
  47     my $options = shift;
  48
  49     return $for
  50         unless grep { exists $options->{ $_ . '_roles' } }
  51             qw(
  52             metaclass
  53             attribute_metaclass
  54             method_metaclass
  55             wrapped_method_metaclass
  56             instance_metaclass
  57             application_to_class_class
  58             application_to_role_class
  59             application_to_instance_class
  60     );
  61
  62     my $new_metaclass
  63         = _make_new_class( ref $for, $options->{metaclass_roles} );
  64
  65     # This could get called for a Moose::Meta::Role as well as a Moose::Meta::Class
  66     my %classes = map {
  67         $_ => _make_new_class( $for->$_(), $options->{ $_ . '_roles' } )
  68         }
  69         grep { $for->can($_) }
  70         qw(
  71         attribute_metaclass
  72         method_metaclass
  73         wrapped_method_metaclass
  74         instance_metaclass
  75         application_to_class_class
  76         application_to_role_class
  77         application_to_instance_class
  78     );
  79
  80     return $new_metaclass->reinitialize( $for, %classes );
  81 }
  82
  83 sub apply_base_class_roles {
  84     my %options = @_;
  85
  86     my $for = $options{for_class};
  87
  88     my $meta = Class::MOP::class_of($for);
  89
  90     my $new_base = _make_new_class(
  91         $for,
  92         $options{roles},
  93         [ $meta->superclasses() ],
  94     );
  95
  96     $meta->superclasses($new_base)
  97         if $new_base ne $meta->name();
  98 }
  99
 100 sub _make_new_class {
 101     my $existing_class = shift;
 102     my $roles          = shift;
 103     my $superclasses   = shift || [$existing_class];
 104
 105     return $existing_class unless $roles;
 106
 107     my $meta = Class::MOP::Class->initialize($existing_class);
 108
 109     return $existing_class
 110         if $meta->can('does_role') && all  { $meta->does_role($_) }
 111                                       grep { !ref $_ } @{$roles};
 112
 113     return Moose::Meta::Class->create_anon_class(
 114         superclasses => $superclasses,
 115         roles        => $roles,
 116         cache        => 1,
 117     )->name();
 118 }
 119
 120 1;
 121
 122 __END__
 123
 124 =head1 NAME
 125
 126 Moose::Util::MetaRole - Apply roles to any metaclass, as well as the object base class
 127
 128 =head1 SYNOPSIS
 129
 130   package MyApp::Moose;
 131
 132   use Moose ();
 133   use Moose::Exporter;
 134   use Moose::Util::MetaRole;
 135
 136   use MyApp::Role::Meta::Class;
 137   use MyApp::Role::Meta::Method::Constructor;
 138   use MyApp::Role::Object;
 139
 140   Moose::Exporter->setup_import_methods( also => 'Moose' );
 141
 142   sub init_meta {
 143       shift;
 144       my %options = @_;
 145
 146       Moose->init_meta(%options);
 147
 148       Moose::Util::MetaRole::apply_metaclass_roles(
 149           for_class               => $options{for_class},
 150           metaclass_roles         => ['MyApp::Role::Meta::Class'],
 151           constructor_class_roles => ['MyApp::Role::Meta::Method::Constructor'],
 152       );
 153
 154       Moose::Util::MetaRole::apply_base_class_roles(
 155           for_class => $options{for_class},
 156           roles     => ['MyApp::Role::Object'],
 157       );
 158
 159       return $options{for_class}->meta();
 160   }
 161
 162 =head1 DESCRIPTION
 163
 164 This utility module is designed to help authors of Moose extensions
 165 write extensions that are able to cooperate with other Moose
 166 extensions. To do this, you must write your extensions as roles, which
 167 can then be dynamically applied to the caller's metaclasses.
 168
 169 This module makes sure to preserve any existing superclasses and roles
 170 already set for the meta objects, which means that any number of
 171 extensions can apply roles in any order.
 172
 173 =head1 USAGE
 174
 175 B<It is very important that you only call this module's functions when
 176 your module is imported by the caller>. The process of applying roles
 177 to the metaclass reinitializes the metaclass object, which wipes out
 178 any existing attributes already defined. However, as long as you do
 179 this when your module is imported, the caller should not have any
 180 attributes defined yet.
 181
 182 The easiest way to ensure that this happens is to use
 183 L<Moose::Exporter>, which can generate the appropriate C<init_meta>
 184 method for you, and make sure it is called when imported.
 185
 186 =head1 FUNCTIONS
 187
 188 This module provides two functions.
 189
 190 =head2 apply_metaclass_roles( ... )
 191
 192 This function will apply roles to one or more metaclasses for the
 193 specified class. It accepts the following parameters:
 194
 195 =over 4
 196
 197 =item * for_class => $name
 198
 199 This specifies the class for which to alter the meta classes.
 200
 201 =item * metaclass_roles => \@roles
 202
 203 =item * attribute_metaclass_roles => \@roles
 204
 205 =item * method_metaclass_roles => \@roles
 206
 207 =item * wrapped_method_metaclass_roles => \@roles
 208
 209 =item * instance_metaclass_roles => \@roles
 210
 211 =item * constructor_class_roles => \@roles
 212
 213 =item * destructor_class_roles => \@roles
 214
 215 =item * application_to_class_class_roles => \@roles
 216
 217 =item * application_to_role_class_roles => \@roles
 218
 219 =item * application_to_instance_class_roles => \@roles
 220
 221 These parameter all specify one or more roles to be applied to the
 222 specified metaclass. You can pass any or all of these parameters at
 223 once.
 224
 225 =back
 226
 227 =head2 apply_base_class_roles( for_class => $class, roles => \@roles )
 228
 229 This function will apply the specified roles to the object's base class.
 230
 231 =head1 AUTHOR
 232
 233 Dave Rolsky E<lt>autarch@urth.orgE<gt>
 234
 235 =head1 COPYRIGHT AND LICENSE
 236
 237 Copyright 2009 by Infinity Interactive, Inc.
 238
 239 L<http://www.iinteractive.com>
 240
 241 This library is free software; you can redistribute it and/or modify
 242 it under the same terms as Perl itself.
 243
 244 =cut