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