lib/Moose/Util/MetaRole.pm

   1 package Moose::Util::MetaRole;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION   = '0.87';
   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($_) } @{$roles};
 109
 110     return Moose::Meta::Class->create_anon_class(
 111         superclasses => $superclasses,
 112         roles        => $roles,
 113         cache        => 1,
 114     )->name();
 115 }
 116
 117 1;
 118
 119 __END__
 120
 121 =head1 NAME
 122
 123 Moose::Util::MetaRole - Apply roles to any metaclass, as well as the object base class
 124
 125 =head1 SYNOPSIS
 126
 127   package MyApp::Moose;
 128
 129   use Moose ();
 130   use Moose::Exporter;
 131   use Moose::Util::MetaRole;
 132
 133   use MyApp::Role::Meta::Class;
 134   use MyApp::Role::Meta::Method::Constructor;
 135   use MyApp::Role::Object;
 136
 137   Moose::Exporter->setup_import_methods( also => 'Moose' );
 138
 139   sub init_meta {
 140       shift;
 141       my %options = @_;
 142
 143       Moose->init_meta(%options);
 144
 145       Moose::Util::MetaRole::apply_metaclass_roles(
 146           for_class               => $options{for_class},
 147           metaclass_roles         => ['MyApp::Role::Meta::Class'],
 148           constructor_class_roles => ['MyApp::Role::Meta::Method::Constructor'],
 149       );
 150
 151       Moose::Util::MetaRole::apply_base_class_roles(
 152           for_class => $options{for_class},
 153           roles     => ['MyApp::Role::Object'],
 154       );
 155
 156       return $options{for_class}->meta();
 157   }
 158
 159 =head1 DESCRIPTION
 160
 161 This utility module is designed to help authors of Moose extensions
 162 write extensions that are able to cooperate with other Moose
 163 extensions. To do this, you must write your extensions as roles, which
 164 can then be dynamically applied to the caller's metaclasses.
 165
 166 This module makes sure to preserve any existing superclasses and roles
 167 already set for the meta objects, which means that any number of
 168 extensions can apply roles in any order.
 169
 170 =head1 USAGE
 171
 172 B<It is very important that you only call this module's functions when
 173 your module is imported by the caller>. The process of applying roles
 174 to the metaclass reinitializes the metaclass object, which wipes out
 175 any existing attributes already defined. However, as long as you do
 176 this when your module is imported, the caller should not have any
 177 attributes defined yet.
 178
 179 The easiest way to ensure that this happens is to use
 180 L<Moose::Exporter> and provide an C<init_meta> method that will be
 181 called when imported.
 182
 183 =head1 FUNCTIONS
 184
 185 This module provides two functions.
 186
 187 =head2 apply_metaclass_roles( ... )
 188
 189 This function will apply roles to one or more metaclasses for the
 190 specified class. It accepts the following parameters:
 191
 192 =over 4
 193
 194 =item * for_class => $name
 195
 196 This specifies the class for which to alter the meta classes.
 197
 198 =item * metaclass_roles => \@roles
 199
 200 =item * attribute_metaclass_roles => \@roles
 201
 202 =item * method_metaclass_roles => \@roles
 203
 204 =item * wrapped_method_metaclass_roles => \@roles
 205
 206 =item * instance_metaclass_roles => \@roles
 207
 208 =item * constructor_class_roles => \@roles
 209
 210 =item * destructor_class_roles => \@roles
 211
 212 =item * application_to_class_class_roles => \@roles
 213
 214 =item * application_to_role_class_roles => \@roles
 215
 216 =item * application_to_instance_class_roles => \@roles
 217
 218 These parameter all specify one or more roles to be applied to the
 219 specified metaclass. You can pass any or all of these parameters at
 220 once.
 221
 222 =back
 223
 224 =head2 apply_base_class_roles( for_class => $class, roles => \@roles )
 225
 226 This function will apply the specified roles to the object's base class.
 227
 228 =head1 AUTHOR
 229
 230 Dave Rolsky E<lt>autarch@urth.orgE<gt>
 231
 232 =head1 COPYRIGHT AND LICENSE
 233
 234 Copyright 2009 by Infinity Interactive, Inc.
 235
 236 L<http://www.iinteractive.com>
 237
 238 This library is free software; you can redistribute it and/or modify
 239 it under the same terms as Perl itself.
 240
 241 =cut