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.9900';
   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
  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 The easiest way to use this module is through L<Moose::Exporter>, which can
 228 generate the appropriate C<init_meta> method for you, and make sure it is
 229 called when imported.
 230
 231 =head1 FUNCTIONS
 232
 233 This module provides two functions.
 234
 235 =head2 apply_metaroles( ... )
 236
 237 This function will apply roles to one or more metaclasses for the specified
 238 class. It will return a new metaclass object for the class or role passed in
 239 the "for" parameter.
 240
 241 It accepts the following parameters:
 242
 243 =over 4
 244
 245 =item * for => $name
 246
 247 This specifies the class or for which to alter the meta classes. This can be a
 248 package name, or an appropriate meta-object (a L<Moose::Meta::Class> or
 249 L<Moose::Meta::Role>).
 250
 251 =item * class_metaroles => \%roles
 252
 253 This is a hash reference specifying which metaroles will be applied to the
 254 class metaclass and its contained metaclasses and helper classes.
 255
 256 Each key should in turn point to an array reference of role names.
 257
 258 It accepts the following keys:
 259
 260 =over 8
 261
 262 =item class
 263
 264 =item attribute
 265
 266 =item method
 267
 268 =item wrapped_method
 269
 270 =item instance
 271
 272 =item constructor
 273
 274 =item destructor
 275
 276 =item error
 277
 278 =back
 279
 280 =item * role_metaroles => \%roles
 281
 282 This is a hash reference specifying which metaroles will be applied to the
 283 role metaclass and its contained metaclasses and helper classes.
 284
 285 It accepts the following keys:
 286
 287 =over 8
 288
 289 =item role
 290
 291 =item attribute
 292
 293 =item method
 294
 295 =item required_method
 296
 297 =item conflicting_method
 298
 299 =item application_to_class
 300
 301 =item application_to_role
 302
 303 =item application_to_instance
 304
 305 =item application_role_summation
 306
 307 =back
 308
 309 =back
 310
 311 =head2 apply_base_class_roles( for => $class, roles => \@roles )
 312
 313 This function will apply the specified roles to the object's base class.
 314
 315 =head1 BUGS
 316
 317 See L<Moose/BUGS> for details on reporting bugs.
 318
 319 =head1 AUTHOR
 320
 321 Dave Rolsky E<lt>autarch@urth.orgE<gt>
 322
 323 =head1 COPYRIGHT AND LICENSE
 324
 325 Copyright 2009 by Infinity Interactive, Inc.
 326
 327 L<http://www.iinteractive.com>
 328
 329 This library is free software; you can redistribute it and/or modify
 330 it under the same terms as Perl itself.
 331
 332 =cut