| File | /usr/local/lib/perl/5.10.0/Moose/Util/MetaRole.pm |
| Statements Executed | 22 |
| Total Time | 0.0011041 seconds |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 0 | 0 | 0 | 0s | 0s | Moose::Util::MetaRole::BEGIN |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::MetaRole::__ANON__[:116] |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::MetaRole::__ANON__[:160] |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::MetaRole::_fixup_old_style_args |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::MetaRole::_make_new_class |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::MetaRole::_make_new_metaclass |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::MetaRole::apply_base_class_roles |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::MetaRole::apply_metaclass_roles |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::MetaRole::apply_metaroles |
| Line | Stmts. | Exclusive Time | Avg. | Code |
|---|---|---|---|---|
| 1 | package Moose::Util::MetaRole; | |||
| 2 | ||||
| 3 | 3 | 22µs | 7µs | use strict; # spent 7µs making 1 call to strict::import |
| 4 | 3 | 31µs | 10µs | use warnings; # spent 25µs making 1 call to warnings::import |
| 5 | 3 | 62µs | 21µs | use Scalar::Util 'blessed'; # spent 40µs making 1 call to Exporter::import |
| 6 | ||||
| 7 | 1 | 900ns | 900ns | our $VERSION = '1.15'; |
| 8 | 1 | 22µs | 22µs | $VERSION = eval $VERSION; |
| 9 | 1 | 600ns | 600ns | our $AUTHORITY = 'cpan:STEVAN'; |
| 10 | ||||
| 11 | 3 | 31µs | 10µs | use List::MoreUtils qw( all ); # spent 43µs making 1 call to Exporter::import |
| 12 | 3 | 27µs | 9µs | use List::Util qw( first ); # spent 44µs making 1 call to Exporter::import |
| 13 | 3 | 902µs | 301µs | use Moose::Deprecated; # spent 17µs making 1 call to Package::DeprecationManager::__ANON__[/usr/local/share/perl/5.10.0/Package/DeprecationManager.pm:61] |
| 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 | 4µs | 4µs | 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 |