lib/Moose/Util/MetaRole.pm

   1 package Moose::Util::MetaRole;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION   = '0.73';
   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     );
  55
  56     my $new_metaclass
  57         = _make_new_class( ref $for->meta(), $options->{metaclass_roles} );
  58
  59     my $old_meta = $for->meta();
  60
  61     # This could get called for a Moose::Meta::Role as well as a Moose::Meta::Class
  62     my %classes = map {
  63         $_ => _make_new_class( $old_meta->$_(), $options->{ $_ . '_roles' } )
  64         }
  65         grep { $old_meta->can($_) }
  66         qw(
  67         attribute_metaclass
  68         method_metaclass
  69         wrapped_method_metaclass
  70         instance_metaclass
  71     );
  72
  73     return $new_metaclass->reinitialize( $for, %classes );
  74 }
  75
  76 sub apply_base_class_roles {
  77     my %options = @_;
  78
  79     my $for = $options{for_class};
  80
  81     my $meta = $for->meta();
  82
  83     my $new_base = _make_new_class(
  84         $for,
  85         $options{roles},
  86         [ $meta->superclasses() ],
  87     );
  88
  89     $meta->superclasses($new_base)
  90         if $new_base ne $meta->name();
  91 }
  92
  93 sub _make_new_class {
  94     my $existing_class = shift;
  95     my $roles          = shift;
  96     my $superclasses   = shift || [$existing_class];
  97
  98     return $existing_class unless $roles;
  99
 100     my $meta = Class::MOP::Class->initialize($existing_class);
 101
 102     return $existing_class
 103         if $meta->can('does_role') && all { $meta->does_role($_) } @{$roles};
 104
 105     return Moose::Meta::Class->create_anon_class(
 106         superclasses => $superclasses,
 107         roles        => $roles,
 108         cache        => 1,
 109     )->name();
 110 }
 111
 112 1;
 113
 114 __END__
 115
 116 =head1 NAME
 117
 118 Moose::Util::MetaRole - Apply roles to any metaclass, as well as the object base class
 119
 120 =head1 SYNOPSIS
 121
 122   package MyApp::Moose;
 123
 124   use strict;
 125   use warnings;
 126
 127   use Moose ();
 128   use Moose::Exporter;
 129   use Moose::Util::MetaRole;
 130
 131   use MyApp::Role::Meta::Class;
 132   use MyApp::Role::Meta::Method::Constructor;
 133   use MyApp::Role::Object;
 134
 135   Moose::Exporter->setup_import_methods( also => 'Moose' );
 136
 137   sub init_meta {
 138       shift;
 139       my %options = @_;
 140
 141       Moose->init_meta(%options);
 142
 143       Moose::Util::MetaRole::apply_metaclass_roles(
 144           for_class               => $options{for_class},
 145           metaclass_roles         => ['MyApp::Role::Meta::Class'],
 146           constructor_class_roles => ['MyApp::Role::Meta::Method::Constructor'],
 147       );
 148
 149       Moose::Util::MetaRole::apply_base_class_roles(
 150           for_class => $options{for_class},
 151           roles     => ['MyApp::Role::Object'],
 152       );
 153
 154       return $options{for_class}->meta();
 155   }
 156
 157 =head1 DESCRIPTION
 158
 159 B<The whole concept behind this module is still considered
 160 experimental, and it could go away in the future!>
 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> and provide an C<init_meta> method that will be
 182 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 These parameter all specify one or more roles to be applied to the
 214 specified metaclass. You can pass any or all of these parameters at
 215 once.
 216
 217 =back
 218
 219 =head2 apply_base_class_roles( for_class => $class, roles => \@roles )
 220
 221 This function will apply the specified roles to the object's base class.
 222
 223 =head1 AUTHOR
 224
 225 Dave Rolsky E<lt>autarch@urth.orgE<gt>
 226
 227 =head1 COPYRIGHT AND LICENSE
 228
 229 Copyright 2009 by Infinity Interactive, Inc.
 230
 231 L<http://www.iinteractive.com>
 232
 233 This library is free software; you can redistribute it and/or modify
 234 it under the same terms as Perl itself.
 235
 236 =cut