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