| File | /usr/local/lib/perl/5.10.0/Moose/Util.pm |
| Statements Executed | 67 |
| Total Time | 0.0032478 seconds |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 8 | 1 | 1 | 121µs | 121µs | Moose::Util::_caller_info |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::BEGIN |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::_STRINGLIKE |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::__ANON__[:271] |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::__ANON__[:335] |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::__ANON__[:354] |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::__ANON__[:373] |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::__ANON__[:423] |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::__ANON__[:425] |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::__ANON__[:427] |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::__ANON__[:439] |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::__ANON__[:85] |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::_apply_all_roles |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::_build_alias_package_name |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::_classes_differ_by_roles_only |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::_create_alias |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::_find_common_base |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::_get_ancestors_until |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::_is_role_only_subclass |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::_reconcile_roles_for_metaclass |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::_role_differences |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::add_method_modifier |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::apply_all_roles |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::does_role |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::english_list |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::ensure_all_roles |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::find_meta |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::get_all_attribute_values |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::get_all_init_args |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::meta_attribute_alias |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::meta_class_alias |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::resolve_metaclass_alias |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::resolve_metatrait_alias |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::search_class_by_role |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::with_traits |
| Line | Stmts. | Exclusive Time | Avg. | Code |
|---|---|---|---|---|
| 1 | package Moose::Util; | |||
| 2 | ||||
| 3 | 3 | 38µs | 13µs | use strict; # spent 22µs making 1 call to strict::import |
| 4 | 3 | 26µs | 9µs | use warnings; # spent 26µs making 1 call to warnings::import |
| 5 | ||||
| 6 | 3 | 32µs | 11µs | use Data::OptList; # spent 11µs making 1 call to Sub::Install::__ANON__[/usr/local/share/perl/5.10.0/Sub/Install.pm:284] |
| 7 | 3 | 29µs | 10µs | use Params::Util qw( _STRING ); # spent 47µs making 1 call to Exporter::import |
| 8 | 3 | 34µs | 11µs | use Sub::Exporter; # spent 219µs making 1 call to Sub::Exporter::__ANON__[/usr/local/share/perl/5.10.0/Sub/Exporter.pm:756] |
| 9 | 3 | 32µs | 11µs | use Scalar::Util 'blessed'; # spent 48µs making 1 call to Exporter::import |
| 10 | 3 | 34µs | 11µs | use List::Util qw(first); # spent 41µs making 1 call to Exporter::import |
| 11 | 3 | 36µs | 12µs | use List::MoreUtils qw(any all); # spent 46µs making 1 call to Exporter::import |
| 12 | 3 | 2.83ms | 942µs | use Class::MOP 0.60; # spent 38µs making 1 call to UNIVERSAL::VERSION
# spent 3µs making 1 call to import |
| 13 | ||||
| 14 | 1 | 900ns | 900ns | our $VERSION = '1.15'; |
| 15 | 1 | 24µs | 24µs | $VERSION = eval $VERSION; |
| 16 | 1 | 600ns | 600ns | our $AUTHORITY = 'cpan:STEVAN'; |
| 17 | ||||
| 18 | 1 | 10µs | 10µs | my @exports = qw[ |
| 19 | find_meta | |||
| 20 | does_role | |||
| 21 | search_class_by_role | |||
| 22 | ensure_all_roles | |||
| 23 | apply_all_roles | |||
| 24 | with_traits | |||
| 25 | get_all_init_args | |||
| 26 | get_all_attribute_values | |||
| 27 | resolve_metatrait_alias | |||
| 28 | resolve_metaclass_alias | |||
| 29 | add_method_modifier | |||
| 30 | english_list | |||
| 31 | meta_attribute_alias | |||
| 32 | meta_class_alias | |||
| 33 | ]; | |||
| 34 | ||||
| 35 | 1 | 14µs | 14µs | Sub::Exporter::setup_exporter({ # spent 466µs making 1 call to Sub::Exporter::setup_exporter |
| 36 | exports => \@exports, | |||
| 37 | groups => { all => \@exports } | |||
| 38 | }); | |||
| 39 | ||||
| 40 | ## some utils for the utils ... | |||
| 41 | ||||
| 42 | sub find_meta { Class::MOP::class_of(@_) } | |||
| 43 | ||||
| 44 | ## the functions ... | |||
| 45 | ||||
| 46 | sub does_role { | |||
| 47 | my ($class_or_obj, $role) = @_; | |||
| 48 | ||||
| 49 | my $meta = find_meta($class_or_obj); | |||
| 50 | ||||
| 51 | return unless defined $meta; | |||
| 52 | return unless $meta->can('does_role'); | |||
| 53 | return 1 if $meta->does_role($role); | |||
| 54 | return; | |||
| 55 | } | |||
| 56 | ||||
| 57 | sub search_class_by_role { | |||
| 58 | my ($class_or_obj, $role) = @_; | |||
| 59 | ||||
| 60 | my $meta = find_meta($class_or_obj); | |||
| 61 | ||||
| 62 | return unless defined $meta; | |||
| 63 | ||||
| 64 | my $role_name = blessed $role ? $role->name : $role; | |||
| 65 | ||||
| 66 | foreach my $class ($meta->class_precedence_list) { | |||
| 67 | ||||
| 68 | my $_meta = find_meta($class); | |||
| 69 | ||||
| 70 | next unless defined $_meta; | |||
| 71 | ||||
| 72 | foreach my $role (@{ $_meta->roles || [] }) { | |||
| 73 | return $class if $role->name eq $role_name; | |||
| 74 | } | |||
| 75 | } | |||
| 76 | ||||
| 77 | return; | |||
| 78 | } | |||
| 79 | ||||
| 80 | # this can possibly behave in unexpected ways because the roles being composed | |||
| 81 | # before being applied could differ from call to call; I'm not sure if or how | |||
| 82 | # to document this possible quirk. | |||
| 83 | sub ensure_all_roles { | |||
| 84 | my $applicant = shift; | |||
| 85 | _apply_all_roles($applicant, sub { !does_role($applicant, $_) }, @_); | |||
| 86 | } | |||
| 87 | ||||
| 88 | sub apply_all_roles { | |||
| 89 | my $applicant = shift; | |||
| 90 | _apply_all_roles($applicant, undef, @_); | |||
| 91 | } | |||
| 92 | ||||
| 93 | sub _apply_all_roles { | |||
| 94 | my $applicant = shift; | |||
| 95 | my $role_filter = shift; | |||
| 96 | ||||
| 97 | unless (@_) { | |||
| 98 | require Moose; | |||
| 99 | Moose->throw_error("Must specify at least one role to apply to $applicant"); | |||
| 100 | } | |||
| 101 | ||||
| 102 | my $roles = Data::OptList::mkopt( [@_] ); | |||
| 103 | ||||
| 104 | my @role_metas; | |||
| 105 | foreach my $role (@$roles) { | |||
| 106 | my $meta; | |||
| 107 | ||||
| 108 | if ( blessed $role->[0] ) { | |||
| 109 | $meta = $role->[0]; | |||
| 110 | } | |||
| 111 | else { | |||
| 112 | Class::MOP::load_class( $role->[0] , $role->[1] ); | |||
| 113 | $meta = Class::MOP::class_of( $role->[0] ); | |||
| 114 | } | |||
| 115 | ||||
| 116 | unless ($meta && $meta->isa('Moose::Meta::Role') ) { | |||
| 117 | require Moose; | |||
| 118 | Moose->throw_error( "You can only consume roles, " | |||
| 119 | . $role->[0] | |||
| 120 | . " is not a Moose role" ); | |||
| 121 | } | |||
| 122 | ||||
| 123 | push @role_metas, [ $meta, $role->[1] ]; | |||
| 124 | } | |||
| 125 | ||||
| 126 | if ( defined $role_filter ) { | |||
| 127 | @role_metas = grep { local $_ = $_->[0]; $role_filter->() } @role_metas; | |||
| 128 | } | |||
| 129 | ||||
| 130 | return unless @role_metas; | |||
| 131 | ||||
| 132 | my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) ); | |||
| 133 | ||||
| 134 | if ( scalar @role_metas == 1 ) { | |||
| 135 | my ( $role, $params ) = @{ $role_metas[0] }; | |||
| 136 | $role->apply( $meta, ( defined $params ? %$params : () ) ); | |||
| 137 | } | |||
| 138 | else { | |||
| 139 | Moose::Meta::Role->combine(@role_metas)->apply($meta); | |||
| 140 | } | |||
| 141 | } | |||
| 142 | ||||
| 143 | sub with_traits { | |||
| 144 | my ($class, @roles) = @_; | |||
| 145 | return $class unless @roles; | |||
| 146 | return Moose::Meta::Class->create_anon_class( | |||
| 147 | superclasses => [$class], | |||
| 148 | roles => \@roles, | |||
| 149 | cache => 1, | |||
| 150 | )->name; | |||
| 151 | } | |||
| 152 | ||||
| 153 | # instance deconstruction ... | |||
| 154 | ||||
| 155 | sub get_all_attribute_values { | |||
| 156 | my ($class, $instance) = @_; | |||
| 157 | return +{ | |||
| 158 | map { $_->name => $_->get_value($instance) } | |||
| 159 | grep { $_->has_value($instance) } | |||
| 160 | $class->get_all_attributes | |||
| 161 | }; | |||
| 162 | } | |||
| 163 | ||||
| 164 | sub get_all_init_args { | |||
| 165 | my ($class, $instance) = @_; | |||
| 166 | return +{ | |||
| 167 | map { $_->init_arg => $_->get_value($instance) } | |||
| 168 | grep { $_->has_value($instance) } | |||
| 169 | grep { defined($_->init_arg) } | |||
| 170 | $class->get_all_attributes | |||
| 171 | }; | |||
| 172 | } | |||
| 173 | ||||
| 174 | sub resolve_metatrait_alias { | |||
| 175 | return resolve_metaclass_alias( @_, trait => 1 ); | |||
| 176 | } | |||
| 177 | ||||
| 178 | sub _build_alias_package_name { | |||
| 179 | my ($type, $name, $trait) = @_; | |||
| 180 | return 'Moose::Meta::' | |||
| 181 | . $type | |||
| 182 | . '::Custom::' | |||
| 183 | . ( $trait ? 'Trait::' : '' ) | |||
| 184 | . $name; | |||
| 185 | } | |||
| 186 | ||||
| 187 | { | |||
| 188 | 2 | 1µs | 550ns | my %cache; |
| 189 | ||||
| 190 | sub resolve_metaclass_alias { | |||
| 191 | my ( $type, $metaclass_name, %options ) = @_; | |||
| 192 | ||||
| 193 | my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' ); | |||
| 194 | return $cache{$cache_key}{$metaclass_name} | |||
| 195 | if $cache{$cache_key}{$metaclass_name}; | |||
| 196 | ||||
| 197 | my $possible_full_name = _build_alias_package_name( | |||
| 198 | $type, $metaclass_name, $options{trait} | |||
| 199 | ); | |||
| 200 | ||||
| 201 | my $loaded_class = Class::MOP::load_first_existing_class( | |||
| 202 | $possible_full_name, | |||
| 203 | $metaclass_name | |||
| 204 | ); | |||
| 205 | ||||
| 206 | return $cache{$cache_key}{$metaclass_name} | |||
| 207 | = $loaded_class->can('register_implementation') | |||
| 208 | ? $loaded_class->register_implementation | |||
| 209 | : $loaded_class; | |||
| 210 | } | |||
| 211 | } | |||
| 212 | ||||
| 213 | sub add_method_modifier { | |||
| 214 | my ( $class_or_obj, $modifier_name, $args ) = @_; | |||
| 215 | my $meta | |||
| 216 | = $class_or_obj->can('add_before_method_modifier') | |||
| 217 | ? $class_or_obj | |||
| 218 | : find_meta($class_or_obj); | |||
| 219 | my $code = pop @{$args}; | |||
| 220 | my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier'; | |||
| 221 | if ( my $method_modifier_type = ref( @{$args}[0] ) ) { | |||
| 222 | if ( $method_modifier_type eq 'Regexp' ) { | |||
| 223 | my @all_methods = $meta->get_all_methods; | |||
| 224 | my @matched_methods | |||
| 225 | = grep { $_->name =~ @{$args}[0] } @all_methods; | |||
| 226 | $meta->$add_modifier_method( $_->name, $code ) | |||
| 227 | for @matched_methods; | |||
| 228 | } | |||
| 229 | elsif ($method_modifier_type eq 'ARRAY') { | |||
| 230 | $meta->$add_modifier_method( $_, $code ) for @{$args->[0]}; | |||
| 231 | } | |||
| 232 | else { | |||
| 233 | $meta->throw_error( | |||
| 234 | sprintf( | |||
| 235 | "Methods passed to %s must be provided as a list, arrayref or regex, not %s", | |||
| 236 | $modifier_name, | |||
| 237 | $method_modifier_type, | |||
| 238 | ) | |||
| 239 | ); | |||
| 240 | } | |||
| 241 | } | |||
| 242 | else { | |||
| 243 | $meta->$add_modifier_method( $_, $code ) for @{$args}; | |||
| 244 | } | |||
| 245 | } | |||
| 246 | ||||
| 247 | sub english_list { | |||
| 248 | my @items = sort @_; | |||
| 249 | ||||
| 250 | return $items[0] if @items == 1; | |||
| 251 | return "$items[0] and $items[1]" if @items == 2; | |||
| 252 | ||||
| 253 | my $tail = pop @items; | |||
| 254 | my $list = join ', ', @items; | |||
| 255 | $list .= ', and ' . $tail; | |||
| 256 | ||||
| 257 | return $list; | |||
| 258 | } | |||
| 259 | ||||
| 260 | # spent 121µs within Moose::Util::_caller_info which was called 8 times, avg 15µs/call:
# 8 times (121µs+0s) by Moose::has at line 68 of /usr/local/lib/perl/5.10.0/Moose.pm, avg 15µs/call | |||
| 261 | 32 | 91µs | 3µs | my $level = @_ ? ($_[0] + 1) : 2; |
| 262 | my %info; | |||
| 263 | @info{qw(package file line)} = caller($level); | |||
| 264 | return \%info; | |||
| 265 | } | |||
| 266 | ||||
| 267 | sub _create_alias { | |||
| 268 | my ($type, $name, $trait, $for) = @_; | |||
| 269 | my $package = _build_alias_package_name($type, $name, $trait); | |||
| 270 | Class::MOP::Class->initialize($package)->add_method( | |||
| 271 | register_implementation => sub { $for } | |||
| 272 | ); | |||
| 273 | } | |||
| 274 | ||||
| 275 | sub meta_attribute_alias { | |||
| 276 | my ($to, $from) = @_; | |||
| 277 | $from ||= caller; | |||
| 278 | my $meta = Class::MOP::class_of($from); | |||
| 279 | my $trait = $meta->isa('Moose::Meta::Role'); | |||
| 280 | _create_alias('Attribute', $to, $trait, $from); | |||
| 281 | } | |||
| 282 | ||||
| 283 | sub meta_class_alias { | |||
| 284 | my ($to, $from) = @_; | |||
| 285 | $from ||= caller; | |||
| 286 | my $meta = Class::MOP::class_of($from); | |||
| 287 | my $trait = $meta->isa('Moose::Meta::Role'); | |||
| 288 | _create_alias('Class', $to, $trait, $from); | |||
| 289 | } | |||
| 290 | ||||
| 291 | # XXX - this should be added to Params::Util | |||
| 292 | sub _STRINGLIKE ($) { | |||
| 293 | return _STRING( $_[0] ) | |||
| 294 | || ( blessed $_[0] | |||
| 295 | && overload::Method( $_[0], q{""} ) | |||
| 296 | && length "$_[0]" ); | |||
| 297 | } | |||
| 298 | ||||
| 299 | sub _reconcile_roles_for_metaclass { | |||
| 300 | my ($class_meta_name, $super_meta_name) = @_; | |||
| 301 | ||||
| 302 | my @role_differences = _role_differences( | |||
| 303 | $class_meta_name, $super_meta_name, | |||
| 304 | ); | |||
| 305 | ||||
| 306 | # handle the case where we need to fix compatibility between a class and | |||
| 307 | # its parent, but all roles in the class are already also done by the | |||
| 308 | # parent | |||
| 309 | # see t/050/054.t | |||
| 310 | return $super_meta_name | |||
| 311 | unless @role_differences; | |||
| 312 | ||||
| 313 | return Moose::Meta::Class->create_anon_class( | |||
| 314 | superclasses => [$super_meta_name], | |||
| 315 | roles => [map { $_->name } @role_differences], | |||
| 316 | cache => 1, | |||
| 317 | )->name; | |||
| 318 | } | |||
| 319 | ||||
| 320 | sub _role_differences { | |||
| 321 | my ($class_meta_name, $super_meta_name) = @_; | |||
| 322 | my @super_role_metas = $super_meta_name->meta->can('calculate_all_roles_with_inheritance') | |||
| 323 | ? $super_meta_name->meta->calculate_all_roles_with_inheritance | |||
| 324 | : $super_meta_name->meta->can('calculate_all_roles') | |||
| 325 | ? $super_meta_name->meta->calculate_all_roles | |||
| 326 | : (); | |||
| 327 | my @role_metas = $class_meta_name->meta->can('calculate_all_roles_with_inheritance') | |||
| 328 | ? $class_meta_name->meta->calculate_all_roles_with_inheritance | |||
| 329 | : $class_meta_name->meta->can('calculate_all_roles') | |||
| 330 | ? $class_meta_name->meta->calculate_all_roles | |||
| 331 | : (); | |||
| 332 | my @differences; | |||
| 333 | for my $role_meta (@role_metas) { | |||
| 334 | push @differences, $role_meta | |||
| 335 | unless any { $_->name eq $role_meta->name } @super_role_metas; | |||
| 336 | } | |||
| 337 | return @differences; | |||
| 338 | } | |||
| 339 | ||||
| 340 | sub _classes_differ_by_roles_only { | |||
| 341 | my ( $self_meta_name, $super_meta_name ) = @_; | |||
| 342 | ||||
| 343 | my $common_base_name | |||
| 344 | = _find_common_base( $self_meta_name, $super_meta_name ); | |||
| 345 | ||||
| 346 | return unless defined $common_base_name; | |||
| 347 | ||||
| 348 | my @super_meta_name_ancestor_names | |||
| 349 | = _get_ancestors_until( $super_meta_name, $common_base_name ); | |||
| 350 | my @class_meta_name_ancestor_names | |||
| 351 | = _get_ancestors_until( $self_meta_name, $common_base_name ); | |||
| 352 | ||||
| 353 | return | |||
| 354 | unless all { _is_role_only_subclass($_) } | |||
| 355 | @super_meta_name_ancestor_names, | |||
| 356 | @class_meta_name_ancestor_names; | |||
| 357 | ||||
| 358 | return 1; | |||
| 359 | } | |||
| 360 | ||||
| 361 | sub _find_common_base { | |||
| 362 | my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_; | |||
| 363 | return unless defined $meta1 && defined $meta2; | |||
| 364 | ||||
| 365 | # FIXME? This doesn't account for multiple inheritance (not sure | |||
| 366 | # if it needs to though). For example, if somewhere in $meta1's | |||
| 367 | # history it inherits from both ClassA and ClassB, and $meta2 | |||
| 368 | # inherits from ClassB & ClassA, does it matter? And what crazy | |||
| 369 | # fool would do that anyway? | |||
| 370 | ||||
| 371 | my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa; | |||
| 372 | ||||
| 373 | return first { $meta1_parents{$_} } $meta2->linearized_isa; | |||
| 374 | } | |||
| 375 | ||||
| 376 | sub _get_ancestors_until { | |||
| 377 | my ($start_name, $until_name) = @_; | |||
| 378 | ||||
| 379 | my @ancestor_names; | |||
| 380 | for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) { | |||
| 381 | last if $ancestor_name eq $until_name; | |||
| 382 | push @ancestor_names, $ancestor_name; | |||
| 383 | } | |||
| 384 | return @ancestor_names; | |||
| 385 | } | |||
| 386 | ||||
| 387 | sub _is_role_only_subclass { | |||
| 388 | my ($meta_name) = @_; | |||
| 389 | my $meta = Class::MOP::Class->initialize($meta_name); | |||
| 390 | my @parent_names = $meta->superclasses; | |||
| 391 | ||||
| 392 | # XXX: don't feel like messing with multiple inheritance here... what would | |||
| 393 | # that even do? | |||
| 394 | return unless @parent_names == 1; | |||
| 395 | my ($parent_name) = @parent_names; | |||
| 396 | my $parent_meta = Class::MOP::Class->initialize($parent_name); | |||
| 397 | ||||
| 398 | # only get the roles attached to this particular class, don't look at | |||
| 399 | # superclasses | |||
| 400 | my @roles = $meta->can('calculate_all_roles') | |||
| 401 | ? $meta->calculate_all_roles | |||
| 402 | : (); | |||
| 403 | ||||
| 404 | # it's obviously not a role-only subclass if it doesn't do any roles | |||
| 405 | return unless @roles; | |||
| 406 | ||||
| 407 | # loop over all methods that are a part of the current class | |||
| 408 | # (not inherited) | |||
| 409 | for my $method ( $meta->_get_local_methods ) { | |||
| 410 | # always ignore meta | |||
| 411 | next if $method->isa('Class::MOP::Method::Meta'); | |||
| 412 | # we'll deal with attributes below | |||
| 413 | next if $method->can('associated_attribute'); | |||
| 414 | # if the method comes from a role we consumed, ignore it | |||
| 415 | next if $meta->can('does_role') | |||
| 416 | && $meta->does_role($method->original_package_name); | |||
| 417 | # FIXME - this really isn't right. Just because a modifier is | |||
| 418 | # defined in a role doesn't mean it isn't _also_ defined in the | |||
| 419 | # subclass. | |||
| 420 | next if $method->isa('Class::MOP::Method::Wrapped') | |||
| 421 | && ( | |||
| 422 | (!scalar($method->around_modifiers) | |||
| 423 | || any { $_->has_around_method_modifiers($method->name) } @roles) | |||
| 424 | && (!scalar($method->before_modifiers) | |||
| 425 | || any { $_->has_before_method_modifiers($method->name) } @roles) | |||
| 426 | && (!scalar($method->after_modifiers) | |||
| 427 | || any { $_->has_after_method_modifiers($method->name) } @roles) | |||
| 428 | ); | |||
| 429 | ||||
| 430 | return 0; | |||
| 431 | } | |||
| 432 | ||||
| 433 | # loop over all attributes that are a part of the current class | |||
| 434 | # (not inherited) | |||
| 435 | # FIXME - this really isn't right. Just because an attribute is | |||
| 436 | # defined in a role doesn't mean it isn't _also_ defined in the | |||
| 437 | # subclass. | |||
| 438 | for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) { | |||
| 439 | next if any { $_->has_attribute($attr->name) } @roles; | |||
| 440 | ||||
| 441 | return 0; | |||
| 442 | } | |||
| 443 | ||||
| 444 | return 1; | |||
| 445 | } | |||
| 446 | ||||
| 447 | 1 | 19µs | 19µs | 1; |
| 448 | ||||
| 449 | __END__ | |||
| 450 | ||||
| 451 | =pod | |||
| 452 | ||||
| 453 | =head1 NAME | |||
| 454 | ||||
| 455 | Moose::Util - Utilities for working with Moose classes | |||
| 456 | ||||
| 457 | =head1 SYNOPSIS | |||
| 458 | ||||
| 459 | use Moose::Util qw/find_meta does_role search_class_by_role/; | |||
| 460 | ||||
| 461 | my $meta = find_meta($object) || die "No metaclass found"; | |||
| 462 | ||||
| 463 | if (does_role($object, $role)) { | |||
| 464 | print "The object can do $role!\n"; | |||
| 465 | } | |||
| 466 | ||||
| 467 | my $class = search_class_by_role($object, 'FooRole'); | |||
| 468 | print "Nearest class with 'FooRole' is $class\n"; | |||
| 469 | ||||
| 470 | =head1 DESCRIPTION | |||
| 471 | ||||
| 472 | This module provides a set of utility functions. Many of these | |||
| 473 | functions are intended for use in Moose itself or MooseX modules, but | |||
| 474 | some of them may be useful for use in your own code. | |||
| 475 | ||||
| 476 | =head1 EXPORTED FUNCTIONS | |||
| 477 | ||||
| 478 | =over 4 | |||
| 479 | ||||
| 480 | =item B<find_meta($class_or_obj)> | |||
| 481 | ||||
| 482 | This method takes a class name or object and attempts to find a | |||
| 483 | metaclass for the class, if one exists. It will B<not> create one if it | |||
| 484 | does not yet exist. | |||
| 485 | ||||
| 486 | =item B<does_role($class_or_obj, $role_or_obj)> | |||
| 487 | ||||
| 488 | Returns true if C<$class_or_obj> does the given C<$role_or_obj>. The role can | |||
| 489 | be provided as a name or a L<Moose::Meta::Role> object. | |||
| 490 | ||||
| 491 | The class must already have a metaclass for this to work. If it doesn't, this | |||
| 492 | function simply returns false. | |||
| 493 | ||||
| 494 | =item B<search_class_by_role($class_or_obj, $role_or_obj)> | |||
| 495 | ||||
| 496 | Returns the first class in the class's precedence list that does | |||
| 497 | C<$role_or_obj>, if any. The role can be either a name or a | |||
| 498 | L<Moose::Meta::Role> object. | |||
| 499 | ||||
| 500 | The class must already have a metaclass for this to work. | |||
| 501 | ||||
| 502 | =item B<apply_all_roles($applicant, @roles)> | |||
| 503 | ||||
| 504 | This function applies one or more roles to the given C<$applicant> The | |||
| 505 | applicant can be a role name, class name, or object. | |||
| 506 | ||||
| 507 | The C<$applicant> must already have a metaclass object. | |||
| 508 | ||||
| 509 | The list of C<@roles> should a list of names or L<Moose::Meta::Role> objects, | |||
| 510 | each of which can be followed by an optional hash reference of options | |||
| 511 | (C<-excludes> and C<-alias>). | |||
| 512 | ||||
| 513 | =item B<ensure_all_roles($applicant, @roles)> | |||
| 514 | ||||
| 515 | This function is similar to L</apply_all_roles>, but only applies roles that | |||
| 516 | C<$applicant> does not already consume. | |||
| 517 | ||||
| 518 | =item B<with_traits($class_name, @role_names)> | |||
| 519 | ||||
| 520 | This function creates a new class from C<$class_name> with each of | |||
| 521 | C<@role_names> applied. It returns the name of the new class. | |||
| 522 | ||||
| 523 | =item B<get_all_attribute_values($meta, $instance)> | |||
| 524 | ||||
| 525 | Returns a hash reference containing all of the C<$instance>'s | |||
| 526 | attributes. The keys are attribute names. | |||
| 527 | ||||
| 528 | =item B<get_all_init_args($meta, $instance)> | |||
| 529 | ||||
| 530 | Returns a hash reference containing all of the C<init_arg> values for | |||
| 531 | the instance's attributes. The values are the associated attribute | |||
| 532 | values. If an attribute does not have a defined C<init_arg>, it is | |||
| 533 | skipped. | |||
| 534 | ||||
| 535 | This could be useful in cloning an object. | |||
| 536 | ||||
| 537 | =item B<resolve_metaclass_alias($category, $name, %options)> | |||
| 538 | ||||
| 539 | =item B<resolve_metatrait_alias($category, $name, %options)> | |||
| 540 | ||||
| 541 | Resolves a short name to a full class name. Short names are often used | |||
| 542 | when specifying the C<metaclass> or C<traits> option for an attribute: | |||
| 543 | ||||
| 544 | has foo => ( | |||
| 545 | metaclass => "Bar", | |||
| 546 | ); | |||
| 547 | ||||
| 548 | The name resolution mechanism is covered in | |||
| 549 | L<Moose/Metaclass and Trait Name Resolution>. | |||
| 550 | ||||
| 551 | =item B<meta_class_alias($to[, $from])> | |||
| 552 | ||||
| 553 | =item B<meta_attribute_alias($to[, $from])> | |||
| 554 | ||||
| 555 | Create an alias from the class C<$from> (or the current package, if | |||
| 556 | C<$from> is unspecified), so that | |||
| 557 | L<Moose/Metaclass and Trait Name Resolution> works properly. | |||
| 558 | ||||
| 559 | =item B<english_list(@items)> | |||
| 560 | ||||
| 561 | Given a list of scalars, turns them into a proper list in English | |||
| 562 | ("one and two", "one, two, three, and four"). This is used to help us | |||
| 563 | make nicer error messages. | |||
| 564 | ||||
| 565 | =back | |||
| 566 | ||||
| 567 | =head1 TODO | |||
| 568 | ||||
| 569 | Here is a list of possible functions to write | |||
| 570 | ||||
| 571 | =over 4 | |||
| 572 | ||||
| 573 | =item discovering original method from modified method | |||
| 574 | ||||
| 575 | =item search for origin class of a method or attribute | |||
| 576 | ||||
| 577 | =back | |||
| 578 | ||||
| 579 | =head1 BUGS | |||
| 580 | ||||
| 581 | See L<Moose/BUGS> for details on reporting bugs. | |||
| 582 | ||||
| 583 | =head1 AUTHOR | |||
| 584 | ||||
| 585 | Anders Nor Berle E<lt>debolaz@gmail.comE<gt> | |||
| 586 | ||||
| 587 | B<with contributions from:> | |||
| 588 | ||||
| 589 | Robert (phaylon) Sedlacek | |||
| 590 | ||||
| 591 | Stevan Little | |||
| 592 | ||||
| 593 | =head1 COPYRIGHT AND LICENSE | |||
| 594 | ||||
| 595 | Copyright 2007-2009 by Infinity Interactive, Inc. | |||
| 596 | ||||
| 597 | L<http://www.iinteractive.com> | |||
| 598 | ||||
| 599 | This library is free software; you can redistribute it and/or modify | |||
| 600 | it under the same terms as Perl itself. | |||
| 601 | ||||
| 602 | =cut | |||
| 603 |