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;