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 This utility module is designed to help authors of Moose extensions
 144 write extensions that are able to cooperate with other Moose
 145 extensions. To do this, you must write your extensions as roles, which
 146 can then be dynamically applyied to the caller's metaclasses.
 147
 148 This module makes sure to preserve any existing superclasses and roles
 149 already set for the meta objects, which means that any number of
 150 extensions can apply roles in any order.
 151
 152 =head1 USAGE
 153
 154 B<It is very important that you only call this module's functions when
 155 your module is imported by the caller>. The process of applying roles
 156 to the metaclass reinitializes the metaclass object, which wipes out
 157 any existing attributes already defined. However, as long as you do
 158 this when your module is imported, the caller should not have any
 159 attributes defined yet.
 160
 161 The easiest way to ensure that this happens is to use
 162 L<Moose::Exporter> and provide an C<init_meta> method that will be
 163 called when imported.
 164
 165 =head1 FUNCTIONS
 166
 167 This module provides two functions.
 168
 169 =head2 apply_metaclass_roles( ... )
 170
 171 This function will apply roles to one or more metaclasses for the
 172 specified class. It accepts the following parameters:
 173
 174 =over 4
 175
 176 =item * for_class => $name
 177
 178 This specifies the class for which to alter the meta classes.
 179
 180 =item * metaclass_roles => \@roles
 181
 182 =item * attribute_metaclass_roles => \@roles
 183
 184 =item * method_metaclass_roles => \@roles
 185
 186 =item * instance_metaclass_roles => \@roles
 187
 188 =item * constructor_class_roles => \@roles
 189
 190 =item * destructor_class_roles => \@roles
 191
 192 These parameter all specify one or more roles to be applied to the
 193 specified metaclass. You can pass any or all of these parameters at
 194 once.
 195
 196 =back
 197
 198 =head2 apply_base_class_roles( for_class => $class, roles => \@roles )
 199
 200 This function will apply the specified roles to the object's base class.
 201
 202 =head1 AUTHOR
 203
 204 Dave Rolsky E<lt>autarch@urth.orgE<gt>
 205
 206 =head1 COPYRIGHT AND LICENSE
 207
 208 Copyright 2008 by Infinity Interactive, Inc.
 209
 210 L<http://www.iinteractive.com>
 211
 212 This library is free software; you can redistribute it and/or modify
 213 it under the same terms as Perl itself.
 214
 215 =cut