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