lib/Moose/Util/MetaRole.pm

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