lib/Mouse/Util/MetaRole.pm

   1 package Mouse::Util::MetaRole;
   2 use Mouse::Util; # enables strict and warnings
   3
   4 our @Classes = qw(constructor_class destructor_class);
   5
   6 sub apply_metaclass_roles {
   7     my %options = @_;
   8
   9     my $for = Scalar::Util::blessed($options{for_class})
  10         ? $options{for_class}
  11         : Mouse::Util::class_of($options{for_class});
  12
  13     my %old_classes = map { $for->can($_) ? ($_ => $for->$_) : () }
  14                       @Classes;
  15
  16     my $meta = _make_new_metaclass( $for, \%options );
  17
  18     for my $c ( grep { $meta->can($_) } @Classes ) {
  19         if ( $options{ $c . '_roles' } ) {
  20             my $class = _make_new_class(
  21                 $meta->$c(),
  22                 $options{ $c . '_roles' }
  23             );
  24
  25             $meta->$c($class);
  26         }
  27         elsif($meta->$c ne $old_classes{$c}){
  28             $meta->$c( $old_classes{$c} );
  29         }
  30     }
  31
  32     return $meta;
  33 }
  34
  35 sub apply_base_class_roles {
  36     my %options = @_;
  37
  38     my $for = $options{for_class};
  39
  40     my $meta = Mouse::Util::class_of($for);
  41
  42     my $new_base = _make_new_class(
  43         $for,
  44         $options{roles},
  45         [ $meta->superclasses() ],
  46     );
  47
  48     $meta->superclasses($new_base)
  49         if $new_base ne $meta->name();
  50     return;
  51 }
  52
  53
  54 my @Metaclasses = qw(
  55     metaclass
  56     attribute_metaclass
  57     method_metaclass
  58 );
  59
  60 sub _make_new_metaclass {
  61     my($for, $options) = @_;
  62
  63     return $for
  64         if !grep { exists $options->{ $_ . '_roles' } } @Metaclasses;
  65
  66     my $new_metaclass
  67         = _make_new_class( ref $for, $options->{metaclass_roles} );
  68
  69     # This could get called for a Mouse::Meta::Role as well as a Mouse::Meta::Class
  70     my %classes = map {
  71         $_ => _make_new_class( $for->$_(), $options->{ $_ . '_roles' } )
  72     }  grep { $for->can($_) } @Metaclasses;
  73
  74     return $new_metaclass->reinitialize( $for, %classes );
  75 }
  76
  77
  78 sub _make_new_class {
  79     my($existing_class, $roles, $superclasses) = @_;
  80
  81     return $existing_class if !$roles;
  82
  83     my $meta = Mouse::Meta::Class->initialize($existing_class);
  84
  85     return $existing_class
  86         if !grep { !ref($_) && !$meta->does_role($_) } @{$roles};
  87
  88     return Mouse::Meta::Class->create_anon_class(
  89         superclasses => $superclasses ? $superclasses : [$existing_class],
  90         roles        => $roles,
  91         cache        => 1,
  92     )->name();
  93 }
  94
  95 1;
  96
  97 __END__
  98
  99 =head1 NAME
 100
 101 Mouse::Util::MetaRole - Apply roles to any metaclass, as well as the object base class
 102
 103 =head1 SYNOPSIS
 104
 105   package MyApp::Mouse;
 106
 107   use Mouse ();
 108   use Mouse::Exporter;
 109   use Mouse::Util::MetaRole;
 110
 111   use MyApp::Role::Meta::Class;
 112   use MyApp::Role::Meta::Method::Constructor;
 113   use MyApp::Role::Object;
 114
 115   Mouse::Exporter->setup_import_methods( also => 'Mouse' );
 116
 117   sub init_meta {
 118       shift;
 119       my %options = @_;
 120
 121       Mouse->init_meta(%options);
 122
 123       Mouse::Util::MetaRole::apply_metaclass_roles(
 124           for_class               => $options{for_class},
 125           metaclass_roles         => ['MyApp::Role::Meta::Class'],
 126           constructor_class_roles => ['MyApp::Role::Meta::Method::Constructor'],
 127       );
 128
 129       Mouse::Util::MetaRole::apply_base_class_roles(
 130           for_class => $options{for_class},
 131           roles     => ['MyApp::Role::Object'],
 132       );
 133
 134       return $options{for_class}->meta();
 135   }
 136
 137 =head1 DESCRIPTION
 138
 139 This utility module is designed to help authors of Mouse extensions
 140 write extensions that are able to cooperate with other Mouse
 141 extensions. To do this, you must write your extensions as roles, which
 142 can then be dynamically applied to the caller's metaclasses.
 143
 144 This module makes sure to preserve any existing superclasses and roles
 145 already set for the meta objects, which means that any number of
 146 extensions can apply roles in any order.
 147
 148 =head1 USAGE
 149
 150 B<It is very important that you only call this module's functions when
 151 your module is imported by the caller>. The process of applying roles
 152 to the metaclass reinitializes the metaclass object, which wipes out
 153 any existing attributes already defined. However, as long as you do
 154 this when your module is imported, the caller should not have any
 155 attributes defined yet.
 156
 157 The easiest way to ensure that this happens is to use
 158 L<Mouse::Exporter>, which can generate the appropriate C<init_meta>
 159 method for you, and make sure it is called when imported.
 160
 161 =head1 FUNCTIONS
 162
 163 This module provides two functions.
 164
 165 =head2 apply_metaclass_roles( ... )
 166
 167 This function will apply roles to one or more metaclasses for the
 168 specified class. It accepts the following parameters:
 169
 170 =over 4
 171
 172 =item * for_class => $name
 173
 174 This specifies the class for which to alter the meta classes.
 175
 176 =item * metaclass_roles => \@roles
 177
 178 =item * attribute_metaclass_roles => \@roles
 179
 180 =item * method_metaclass_roles => \@roles
 181
 182 =item * constructor_class_roles => \@roles
 183
 184 =item * destructor_class_roles => \@roles
 185
 186 These parameter all specify one or more roles to be applied to the
 187 specified metaclass. You can pass any or all of these parameters at
 188 once.
 189
 190 =back
 191
 192 =head2 apply_base_class_roles( for_class => $class, roles => \@roles )
 193
 194 This function will apply the specified roles to the object's base class.
 195
 196 =head1 SEE ASLSO
 197
 198 L<Moose::Util::MetaRole>
 199
 200 =cut