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