lib/Mouse/Util/MetaRole.pm

   1 package Mouse::Util::MetaRole;
   2 use Mouse::Util; # enables strict and warnings
   3 use Scalar::Util ();
   4
   5 sub apply_metaclass_roles {
   6     my %args = @_;
   7     _fixup_old_style_args(\%args);
   8
   9     return apply_metaroles(%args);
  10 }
  11
  12 sub apply_metaroles {
  13     my %args = @_;
  14
  15     my $for = Scalar::Util::blessed($args{for})
  16         ?                                     $args{for}
  17         : Mouse::Util::get_metaclass_by_name( $args{for} );
  18
  19     if ( Mouse::Util::is_a_metarole($for) ) {
  20         return _make_new_metaclass( $for, $args{role_metaroles}, 'role' );
  21     }
  22     else {
  23         return _make_new_metaclass( $for, $args{class_metaroles}, 'class' );
  24     }
  25 }
  26
  27 sub _make_new_metaclass {
  28     my($for, $roles, $primary) = @_;
  29
  30     return $for unless keys %{$roles};
  31
  32     my $new_metaclass = exists($roles->{$primary})
  33         ? _make_new_class( ref $for, $roles->{$primary} ) # new class with traits
  34         :                  ref $for;
  35
  36     my %classes;
  37
  38     for my $key ( grep { $_ ne $primary } keys %{$roles} ) {
  39         my $metaclass;
  40         my $attr = $for->can($metaclass = ($key . '_metaclass'))
  41                 || $for->can($metaclass = ($key . '_class'))
  42                 || $for->throw_error("Unknown metaclass '$key'");
  43
  44         $classes{ $metaclass }
  45             = _make_new_class( $for->$attr(), $roles->{$key} );
  46     }
  47
  48     return $new_metaclass->reinitialize( $for, %classes );
  49 }
  50
  51
  52 sub _fixup_old_style_args {
  53     my $args = shift;
  54
  55     return if $args->{class_metaroles} || $args->{roles_metaroles};
  56
  57     $args->{for} = delete $args->{for_class}
  58         if exists $args->{for_class};
  59
  60     my @old_keys = qw(
  61         attribute_metaclass_roles
  62         method_metaclass_roles
  63         wrapped_method_metaclass_roles
  64         instance_metaclass_roles
  65         constructor_class_roles
  66         destructor_class_roles
  67         error_class_roles
  68
  69         application_to_class_class_roles
  70         application_to_role_class_roles
  71         application_to_instance_class_roles
  72         application_role_summation_class_roles
  73     );
  74
  75     my $for = Scalar::Util::blessed($args->{for})
  76         ?                                     $args->{for}
  77         : Mouse::Util::get_metaclass_by_name( $args->{for} );
  78
  79     my $top_key;
  80     if( Mouse::Util::is_a_metaclass($for) ){
  81         $top_key = 'class_metaroles';
  82
  83         $args->{class_metaroles}{class} = delete $args->{metaclass_roles}
  84             if exists $args->{metaclass_roles};
  85     }
  86     else {
  87         $top_key = 'role_metaroles';
  88
  89         $args->{role_metaroles}{role} = delete $args->{metaclass_roles}
  90             if exists $args->{metaclass_roles};
  91     }
  92
  93     for my $old_key (@old_keys) {
  94         my ($new_key) = $old_key =~ /^(.+)_(?:class|metaclass)_roles$/;
  95
  96         $args->{$top_key}{$new_key} = delete $args->{$old_key}
  97             if exists $args->{$old_key};
  98     }
  99
 100     return;
 101 }
 102
 103
 104 sub apply_base_class_roles {
 105     my %options = @_;
 106
 107     my $for = $options{for_class};
 108
 109     my $meta = Mouse::Util::class_of($for);
 110
 111     my $new_base = _make_new_class(
 112         $for,
 113         $options{roles},
 114         [ $meta->superclasses() ],
 115     );
 116
 117     $meta->superclasses($new_base)
 118         if $new_base ne $meta->name();
 119     return;
 120 }
 121
 122 sub _make_new_class {
 123     my($existing_class, $roles, $superclasses) = @_;
 124
 125     if(!$superclasses){
 126         return $existing_class if !$roles;
 127
 128         my $meta = Mouse::Meta::Class->initialize($existing_class);
 129
 130         return $existing_class
 131             if !grep { !ref($_) && !$meta->does_role($_) } @{$roles};
 132     }
 133
 134     return Mouse::Meta::Class->create_anon_class(
 135         superclasses => $superclasses ? $superclasses : [$existing_class],
 136         roles        => $roles,
 137         cache        => 1,
 138     )->name();
 139 }
 140
 141 1;
 142 __END__
 143
 144 =head1 NAME
 145
 146 Mouse::Util::MetaRole - Apply roles to any metaclass, as well as the object base class
 147
 148 =head1 SYNOPSIS
 149
 150   package MyApp::Mouse;
 151
 152   use Mouse ();
 153   use Mouse::Exporter;
 154   use Mouse::Util::MetaRole;
 155
 156   use MyApp::Role::Meta::Class;
 157   use MyApp::Role::Meta::Method::Constructor;
 158   use MyApp::Role::Object;
 159
 160   Mouse::Exporter->setup_import_methods( also => 'Mouse' );
 161
 162   sub init_meta {
 163       shift;
 164       my %args = @_;
 165
 166       Mouse->init_meta(%args);
 167
 168       Mouse::Util::MetaRole::apply_metaroles(
 169           for             => $args{for_class},
 170           class_metaroles => {
 171               class       => ['MyApp::Role::Meta::Class'],
 172               constructor => ['MyApp::Role::Meta::Method::Constructor'],
 173           },
 174       );
 175
 176       Mouse::Util::MetaRole::apply_base_class_roles(
 177           for   => $args{for_class},
 178           roles => ['MyApp::Role::Object'],
 179       );
 180
 181       return $args{for_class}->meta();
 182   }
 183
 184 =head1 DESCRIPTION
 185
 186 This utility module is designed to help authors of Mouse extensions
 187 write extensions that are able to cooperate with other Mouse
 188 extensions. To do this, you must write your extensions as roles, which
 189 can then be dynamically applied to the caller's metaclasses.
 190
 191 This module makes sure to preserve any existing superclasses and roles
 192 already set for the meta objects, which means that any number of
 193 extensions can apply roles in any order.
 194
 195 =head1 USAGE
 196
 197 B<It is very important that you only call this module's functions when
 198 your module is imported by the caller>. The process of applying roles
 199 to the metaclass reinitializes the metaclass object, which wipes out
 200 any existing attributes already defined. However, as long as you do
 201 this when your module is imported, the caller should not have any
 202 attributes defined yet.
 203
 204 The easiest way to ensure that this happens is to use
 205 L<Mouse::Exporter>, which can generate the appropriate C<init_meta>
 206 method for you, and make sure it is called when imported.
 207
 208 =head1 FUNCTIONS
 209
 210 This module provides two functions.
 211
 212 =head2 apply_metaroles( ... )
 213
 214 This function will apply roles to one or more metaclasses for the
 215 specified class. It accepts the following parameters:
 216
 217 =over 4
 218
 219 =item * for => $name
 220
 221 This specifies the class or for which to alter the meta classes. This can be a
 222 package name, or an appropriate meta-object (a L<Mouse::Meta::Class> or
 223 L<Mouse::Meta::Role>).
 224
 225 =item * class_metaroles => \%roles
 226
 227 This is a hash reference specifying which metaroles will be applied to the
 228 class metaclass and its contained metaclasses and helper classes.
 229
 230 Each key should in turn point to an array reference of role names.
 231
 232 It accepts the following keys:
 233
 234 =over 8
 235
 236 =item class
 237
 238 =item attribute
 239
 240 =item method
 241
 242 =item constructor
 243
 244 =item destructor
 245
 246 =back
 247
 248 =item * role_metaroles => \%roles
 249
 250 This is a hash reference specifying which metaroles will be applied to the
 251 role metaclass and its contained metaclasses and helper classes.
 252
 253 It accepts the following keys:
 254
 255 =over 8
 256
 257 =item role
 258
 259 =item method
 260
 261 =back
 262
 263 =back
 264
 265 =head2 apply_base_class_roles( for => $class, roles => \@roles )
 266
 267 This function will apply the specified roles to the object's base class.
 268
 269 =head1 SEE ALSO
 270
 271 L<Moose::Util::MetaRole>
 272
 273 =cut