lib/Moose/Util/MetaRole.pm

   1 package Moose::Util::MetaRole;
   2
   3 use strict;
   4 use warnings;
   5 use Scalar::Util 'blessed';
   6
   7 our $VERSION   = '0.97';
   8 $VERSION = eval $VERSION;
   9 our $AUTHORITY = 'cpan:STEVAN';
  10
  11 use List::MoreUtils qw( all );
  12 use List::Util qw( first );
  13
  14 sub apply_metaclass_roles {
  15     goto &apply_metaroles;
  16 }
  17
  18 sub apply_metaroles {
  19     my %args = @_;
  20
  21     _fixup_old_style_args(\%args);
  22     Carp::cluck('applying') if $::D;
  23     my $for
  24         = blessed $args{for}
  25         ? $args{for}
  26         : Class::MOP::class_of( $args{for} );
  27
  28     if ( $for->isa('Moose::Meta::Role') ) {
  29         return _make_new_metaclass( $for, $args{role_metaroles}, 'role' );
  30     }
  31     else {
  32         return _make_new_metaclass( $for, $args{class_metaroles}, 'class' );
  33     }
  34 }
  35
  36 sub _fixup_old_style_args {
  37     my $args = shift;
  38
  39     return if $args->{class_metaroles} || $args->{roles_metaroles};
  40
  41     $args->{for} = delete $args->{for_class}
  42         if exists $args->{for_class};
  43
  44     my @old_keys = qw(
  45         attribute_metaclass_roles
  46         method_metaclass_roles
  47         wrapped_method_metaclass_roles
  48         instance_metaclass_roles
  49         constructor_class_roles
  50         destructor_class_roles
  51         error_class_roles
  52
  53         application_to_class_class_roles
  54         application_to_role_class_roles
  55         application_to_instance_class_roles
  56         application_role_summation_class_roles
  57     );
  58
  59     my $for
  60         = blessed $args->{for}
  61         ? $args->{for}
  62         : Class::MOP::class_of( $args->{for} );
  63
  64     my $top_key;
  65     if ( $for->isa('Moose::Meta::Class') ) {
  66         $top_key = 'class_metaroles';
  67
  68         $args->{class_metaroles}{class} = delete $args->{metaclass_roles}
  69             if exists $args->{metaclass_roles};
  70     }
  71     else {
  72         $top_key = 'role_metaroles';
  73
  74         $args->{role_metaroles}{role} = delete $args->{metaclass_roles}
  75             if exists $args->{metaclass_roles};
  76     }
  77
  78     for my $old_key (@old_keys) {
  79         my ($new_key) = $old_key =~ /^(.+)_(?:class|metaclass)_roles$/;
  80
  81         $args->{$top_key}{$new_key} = delete $args->{$old_key}
  82             if exists $args->{$old_key};
  83     }
  84
  85     return;
  86 }
  87
  88 sub _make_new_metaclass {
  89     my $for     = shift;
  90     my $roles   = shift;
  91     my $primary = shift;
  92
  93     return $for unless keys %{$roles};
  94
  95     my $new_metaclass
  96         = exists $roles->{$primary}
  97         ? _make_new_class( ref $for, $roles->{$primary} )
  98         : blessed $for;
  99
 100     my %classes;
 101
 102     for my $key ( grep { $_ ne $primary } keys %{$roles} ) {
 103         my $attr = first {$_}
 104             map { $for->meta->find_attribute_by_name($_) } (
 105             $key . '_metaclass',
 106             $key . '_class'
 107         );
 108
 109         my $reader = $attr->get_read_method;
 110
 111         $classes{ $attr->init_arg }
 112             = _make_new_class( $for->$reader(), $roles->{$key} );
 113     }
 114
 115     my $new_meta = $new_metaclass->reinitialize( $for, %classes );
 116
 117     return $new_meta;
 118 }
 119
 120 sub apply_base_class_roles {
 121     my %args = @_;
 122
 123     my $for = $args{for} || $args{for_class};
 124
 125     my $meta = Class::MOP::class_of($for);
 126
 127     my $new_base = _make_new_class(
 128         $for,
 129         $args{roles},
 130         [ $meta->superclasses() ],
 131     );
 132
 133     $meta->superclasses($new_base)
 134         if $new_base ne $meta->name();
 135 }
 136
 137 sub _make_new_class {
 138     my $existing_class = shift;
 139     my $roles          = shift;
 140     my $superclasses   = shift || [$existing_class];
 141
 142     return $existing_class unless $roles;
 143
 144     my $meta = Class::MOP::Class->initialize($existing_class);
 145
 146     return $existing_class
 147         if $meta->can('does_role') && all  { $meta->does_role($_) }
 148                                       grep { !ref $_ } @{$roles};
 149
 150     return Moose::Meta::Class->create_anon_class(
 151         superclasses => $superclasses,
 152         roles        => $roles,
 153         cache        => 1,
 154     )->name();
 155 }
 156
 157 1;
 158
 159 __END__
 160
 161 =head1 NAME
 162
 163 Moose::Util::MetaRole - Apply roles to any metaclass, as well as the object base class
 164
 165 =head1 SYNOPSIS
 166
 167   package MyApp::Moose;
 168
 169   use Moose ();
 170   use Moose::Exporter;
 171   use Moose::Util::MetaRole;
 172
 173   use MyApp::Role::Meta::Class;
 174   use MyApp::Role::Meta::Method::Constructor;
 175   use MyApp::Role::Object;
 176
 177   Moose::Exporter->setup_import_methods( also => 'Moose' );
 178
 179   sub init_meta {
 180       shift;
 181       my %args = @_;
 182
 183       Moose->init_meta(%args);
 184
 185       Moose::Util::MetaRole::apply_metaroles(
 186           for             => $args{for_class},
 187           class_metaroles => {
 188               class => => ['MyApp::Role::Meta::Class'],
 189               constructor => ['MyApp::Role::Meta::Method::Constructor'],
 190           },
 191       );
 192
 193       Moose::Util::MetaRole::apply_base_class_roles(
 194           for   => $args{for_class},
 195           roles => ['MyApp::Role::Object'],
 196       );
 197
 198       return $args{for_class}->meta();
 199   }
 200
 201 =head1 DESCRIPTION
 202
 203 This utility module is designed to help authors of Moose extensions
 204 write extensions that are able to cooperate with other Moose
 205 extensions. To do this, you must write your extensions as roles, which
 206 can then be dynamically applied to the caller's metaclasses.
 207
 208 This module makes sure to preserve any existing superclasses and roles
 209 already set for the meta objects, which means that any number of
 210 extensions can apply roles in any order.
 211
 212 =head1 USAGE
 213
 214 B<It is very important that you only call this module's functions when
 215 your module is imported by the caller>. The process of applying roles
 216 to the metaclass reinitializes the metaclass object, which wipes out
 217 any existing attributes already defined. However, as long as you do
 218 this when your module is imported, the caller should not have any
 219 attributes defined yet.
 220
 221 The easiest way to ensure that this happens is to use
 222 L<Moose::Exporter>, which can generate the appropriate C<init_meta>
 223 method for you, and make sure it is called when imported.
 224
 225 =head1 FUNCTIONS
 226
 227 This module provides two functions.
 228
 229 =head2 apply_metaroles( ... )
 230
 231 This function will apply roles to one or more metaclasses for the specified
 232 class. It will return a new metaclass object for the class or role passed in
 233 the "for" parameter.
 234
 235 It accepts the following parameters:
 236
 237 =over 4
 238
 239 =item * for => $name
 240
 241 This specifies the class or for which to alter the meta classes. This can be a
 242 package name, or an appropriate meta-object (a L<Moose::Meta::Class> or
 243 L<Moose::Meta::Role>).
 244
 245 =item * class_metaroles => \%roles
 246
 247 This is a hash reference specifying which metaroles will be applied to the
 248 class metaclass and its contained metaclasses and helper classes.
 249
 250 Each key should in turn point to an array reference of role names.
 251
 252 It accepts the following keys:
 253
 254 =over 8
 255
 256 =item class
 257
 258 =item attribute
 259
 260 =item method
 261
 262 =item wrapped_method
 263
 264 =item instance
 265
 266 =item constructor
 267
 268 =item destructor
 269
 270 =item error
 271
 272 =back
 273
 274 =item * role_metaroles => \%roles
 275
 276 This is a hash reference specifying which metaroles will be applied to the
 277 role metaclass and its contained metaclasses and helper classes.
 278
 279 It accepts the following keys:
 280
 281 =over 8
 282
 283 =item role
 284
 285 =item attribute
 286
 287 =item method
 288
 289 =item required_method
 290
 291 =item conflicting_method
 292
 293 =item application_to_class
 294
 295 =item application_to_role
 296
 297 =item application_to_instance
 298
 299 =item application_role_summation
 300
 301 =back
 302
 303 =back
 304
 305 =head2 apply_base_class_roles( for => $class, roles => \@roles )
 306
 307 This function will apply the specified roles to the object's base class.
 308
 309 =head1 BUGS
 310
 311 See L<Moose/BUGS> for details on reporting bugs.
 312
 313 =head1 AUTHOR
 314
 315 Dave Rolsky E<lt>autarch@urth.orgE<gt>
 316
 317 =head1 COPYRIGHT AND LICENSE
 318
 319 Copyright 2009 by Infinity Interactive, Inc.
 320
 321 L<http://www.iinteractive.com>
 322
 323 This library is free software; you can redistribute it and/or modify
 324 it under the same terms as Perl itself.
 325
 326 =cut