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