lib/Moose/Util/MetaRole.pm

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