| File | /usr/local/lib/perl5/site_perl/5.10.1/darwin-2level/Moose/Util.pm |
| Statements Executed | 42 |
| Statement Execution Time | 1.19ms |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 4 | 1 | 1 | 34µs | 34µs | Moose::Util::_caller_info |
| 1 | 1 | 1 | 13µs | 16µs | Moose::Util::BEGIN@3 |
| 1 | 1 | 1 | 9µs | 55µs | Moose::Util::BEGIN@9 |
| 1 | 1 | 1 | 9µs | 14µs | Moose::Util::BEGIN@6 |
| 1 | 1 | 1 | 8µs | 163µs | Moose::Util::BEGIN@7 |
| 1 | 1 | 1 | 7µs | 16µs | Moose::Util::BEGIN@4 |
| 1 | 1 | 1 | 6µs | 31µs | Moose::Util::BEGIN@8 |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::__ANON__[:257] |
| 0 | 0 | 0 | 0s | 0s | Moose::Util::__ANON__[:81] |
| 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::_create_alias |
| 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 |
| Line | State ments |
Time on line |
Calls | Time in subs |
Code |
|---|---|---|---|---|---|
| 1 | package Moose::Util; | ||||
| 2 | |||||
| 3 | 3 | 20µs | 2 | 19µs | # spent 16µs (13+3) within Moose::Util::BEGIN@3 which was called
# once (13µs+3µs) by Moose::Meta::Attribute::BEGIN@17 at line 3 # spent 16µs making 1 call to Moose::Util::BEGIN@3
# spent 3µs making 1 call to strict::import |
| 4 | 3 | 18µs | 2 | 25µs | # spent 16µs (7+9) within Moose::Util::BEGIN@4 which was called
# once (7µs+9µs) by Moose::Meta::Attribute::BEGIN@17 at line 4 # spent 16µs making 1 call to Moose::Util::BEGIN@4
# spent 9µs making 1 call to warnings::import |
| 5 | |||||
| 6 | 3 | 21µs | 2 | 20µs | # spent 14µs (9+6) within Moose::Util::BEGIN@6 which was called
# once (9µs+6µs) by Moose::Meta::Attribute::BEGIN@17 at line 6 # spent 14µs making 1 call to Moose::Util::BEGIN@6
# spent 6µs making 1 call to Sub::Install::__ANON__[Sub/Install.pm:284] |
| 7 | 3 | 28µs | 2 | 318µs | # spent 163µs (8+155) within Moose::Util::BEGIN@7 which was called
# once (8µs+155µs) by Moose::Meta::Attribute::BEGIN@17 at line 7 # spent 163µs making 1 call to Moose::Util::BEGIN@7
# spent 155µs making 1 call to Sub::Exporter::__ANON__[Sub/Exporter.pm:756] |
| 8 | 3 | 22µs | 2 | 55µs | # spent 31µs (6+24) within Moose::Util::BEGIN@8 which was called
# once (6µs+24µs) by Moose::Meta::Attribute::BEGIN@17 at line 8 # spent 31µs making 1 call to Moose::Util::BEGIN@8
# spent 24µs making 1 call to Exporter::import |
| 9 | 3 | 997µs | 2 | 100µs | # spent 55µs (9+45) within Moose::Util::BEGIN@9 which was called
# once (9µs+45µs) by Moose::Meta::Attribute::BEGIN@17 at line 9 # spent 55µs making 1 call to Moose::Util::BEGIN@9
# spent 46µs making 1 call to UNIVERSAL::VERSION |
| 10 | |||||
| 11 | 1 | 700ns | our $VERSION = '0.98'; | ||
| 12 | 1 | 19µs | $VERSION = eval $VERSION; | ||
| 13 | 1 | 300ns | our $AUTHORITY = 'cpan:STEVAN'; | ||
| 14 | |||||
| 15 | 1 | 3µs | my @exports = qw[ | ||
| 16 | find_meta | ||||
| 17 | does_role | ||||
| 18 | search_class_by_role | ||||
| 19 | ensure_all_roles | ||||
| 20 | apply_all_roles | ||||
| 21 | get_all_init_args | ||||
| 22 | get_all_attribute_values | ||||
| 23 | resolve_metatrait_alias | ||||
| 24 | resolve_metaclass_alias | ||||
| 25 | add_method_modifier | ||||
| 26 | english_list | ||||
| 27 | meta_attribute_alias | ||||
| 28 | meta_class_alias | ||||
| 29 | ]; | ||||
| 30 | |||||
| 31 | 1 | 5µs | 1 | 271µs | Sub::Exporter::setup_exporter({ # spent 271µs making 1 call to Sub::Exporter::setup_exporter |
| 32 | exports => \@exports, | ||||
| 33 | groups => { all => \@exports } | ||||
| 34 | }); | ||||
| 35 | |||||
| 36 | ## some utils for the utils ... | ||||
| 37 | |||||
| 38 | sub find_meta { Class::MOP::class_of(@_) } | ||||
| 39 | |||||
| 40 | ## the functions ... | ||||
| 41 | |||||
| 42 | sub does_role { | ||||
| 43 | my ($class_or_obj, $role) = @_; | ||||
| 44 | |||||
| 45 | my $meta = find_meta($class_or_obj); | ||||
| 46 | |||||
| 47 | return unless defined $meta; | ||||
| 48 | return unless $meta->can('does_role'); | ||||
| 49 | return 1 if $meta->does_role($role); | ||||
| 50 | return; | ||||
| 51 | } | ||||
| 52 | |||||
| 53 | sub search_class_by_role { | ||||
| 54 | my ($class_or_obj, $role) = @_; | ||||
| 55 | |||||
| 56 | my $meta = find_meta($class_or_obj); | ||||
| 57 | |||||
| 58 | return unless defined $meta; | ||||
| 59 | |||||
| 60 | my $role_name = blessed $role ? $role->name : $role; | ||||
| 61 | |||||
| 62 | foreach my $class ($meta->class_precedence_list) { | ||||
| 63 | |||||
| 64 | my $_meta = find_meta($class); | ||||
| 65 | |||||
| 66 | next unless defined $_meta; | ||||
| 67 | |||||
| 68 | foreach my $role (@{ $_meta->roles || [] }) { | ||||
| 69 | return $class if $role->name eq $role_name; | ||||
| 70 | } | ||||
| 71 | } | ||||
| 72 | |||||
| 73 | return; | ||||
| 74 | } | ||||
| 75 | |||||
| 76 | # this can possibly behave in unexpected ways because the roles being composed | ||||
| 77 | # before being applied could differ from call to call; I'm not sure if or how | ||||
| 78 | # to document this possible quirk. | ||||
| 79 | sub ensure_all_roles { | ||||
| 80 | my $applicant = shift; | ||||
| 81 | _apply_all_roles($applicant, sub { !does_role($applicant, $_) }, @_); | ||||
| 82 | } | ||||
| 83 | |||||
| 84 | sub apply_all_roles { | ||||
| 85 | my $applicant = shift; | ||||
| 86 | _apply_all_roles($applicant, undef, @_); | ||||
| 87 | } | ||||
| 88 | |||||
| 89 | sub _apply_all_roles { | ||||
| 90 | my $applicant = shift; | ||||
| 91 | my $role_filter = shift; | ||||
| 92 | |||||
| 93 | unless (@_) { | ||||
| 94 | require Moose; | ||||
| 95 | Moose->throw_error("Must specify at least one role to apply to $applicant"); | ||||
| 96 | } | ||||
| 97 | |||||
| 98 | my $roles = Data::OptList::mkopt( [@_] ); | ||||
| 99 | |||||
| 100 | my @role_metas; | ||||
| 101 | foreach my $role (@$roles) { | ||||
| 102 | my $meta; | ||||
| 103 | |||||
| 104 | if ( blessed $role->[0] ) { | ||||
| 105 | $meta = $role->[0]; | ||||
| 106 | } | ||||
| 107 | else { | ||||
| 108 | Class::MOP::load_class( $role->[0] ); | ||||
| 109 | $meta = Class::MOP::class_of( $role->[0] ); | ||||
| 110 | } | ||||
| 111 | |||||
| 112 | unless ($meta && $meta->isa('Moose::Meta::Role') ) { | ||||
| 113 | require Moose; | ||||
| 114 | Moose->throw_error( "You can only consume roles, " | ||||
| 115 | . $role->[0] | ||||
| 116 | . " is not a Moose role" ); | ||||
| 117 | } | ||||
| 118 | |||||
| 119 | push @role_metas, [ $meta, $role->[1] ]; | ||||
| 120 | } | ||||
| 121 | |||||
| 122 | if ( defined $role_filter ) { | ||||
| 123 | @role_metas = grep { local $_ = $_->[0]; $role_filter->() } @role_metas; | ||||
| 124 | } | ||||
| 125 | |||||
| 126 | return unless @role_metas; | ||||
| 127 | |||||
| 128 | my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) ); | ||||
| 129 | |||||
| 130 | if ( scalar @role_metas == 1 ) { | ||||
| 131 | my ( $role, $params ) = @{ $role_metas[0] }; | ||||
| 132 | $role->apply( $meta, ( defined $params ? %$params : () ) ); | ||||
| 133 | } | ||||
| 134 | else { | ||||
| 135 | Moose::Meta::Role->combine(@role_metas)->apply($meta); | ||||
| 136 | } | ||||
| 137 | } | ||||
| 138 | |||||
| 139 | # instance deconstruction ... | ||||
| 140 | |||||
| 141 | sub get_all_attribute_values { | ||||
| 142 | my ($class, $instance) = @_; | ||||
| 143 | return +{ | ||||
| 144 | map { $_->name => $_->get_value($instance) } | ||||
| 145 | grep { $_->has_value($instance) } | ||||
| 146 | $class->get_all_attributes | ||||
| 147 | }; | ||||
| 148 | } | ||||
| 149 | |||||
| 150 | sub get_all_init_args { | ||||
| 151 | my ($class, $instance) = @_; | ||||
| 152 | return +{ | ||||
| 153 | map { $_->init_arg => $_->get_value($instance) } | ||||
| 154 | grep { $_->has_value($instance) } | ||||
| 155 | grep { defined($_->init_arg) } | ||||
| 156 | $class->get_all_attributes | ||||
| 157 | }; | ||||
| 158 | } | ||||
| 159 | |||||
| 160 | sub resolve_metatrait_alias { | ||||
| 161 | return resolve_metaclass_alias( @_, trait => 1 ); | ||||
| 162 | } | ||||
| 163 | |||||
| 164 | sub _build_alias_package_name { | ||||
| 165 | my ($type, $name, $trait) = @_; | ||||
| 166 | return 'Moose::Meta::' | ||||
| 167 | . $type | ||||
| 168 | . '::Custom::' | ||||
| 169 | . ( $trait ? 'Trait::' : '' ) | ||||
| 170 | . $name; | ||||
| 171 | } | ||||
| 172 | |||||
| 173 | { | ||||
| 174 | 2 | 400ns | my %cache; | ||
| 175 | |||||
| 176 | sub resolve_metaclass_alias { | ||||
| 177 | my ( $type, $metaclass_name, %options ) = @_; | ||||
| 178 | |||||
| 179 | my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' ); | ||||
| 180 | return $cache{$cache_key}{$metaclass_name} | ||||
| 181 | if $cache{$cache_key}{$metaclass_name}; | ||||
| 182 | |||||
| 183 | my $possible_full_name = _build_alias_package_name( | ||||
| 184 | $type, $metaclass_name, $options{trait} | ||||
| 185 | ); | ||||
| 186 | |||||
| 187 | my $loaded_class = Class::MOP::load_first_existing_class( | ||||
| 188 | $possible_full_name, | ||||
| 189 | $metaclass_name | ||||
| 190 | ); | ||||
| 191 | |||||
| 192 | return $cache{$cache_key}{$metaclass_name} | ||||
| 193 | = $loaded_class->can('register_implementation') | ||||
| 194 | ? $loaded_class->register_implementation | ||||
| 195 | : $loaded_class; | ||||
| 196 | } | ||||
| 197 | } | ||||
| 198 | |||||
| 199 | sub add_method_modifier { | ||||
| 200 | my ( $class_or_obj, $modifier_name, $args ) = @_; | ||||
| 201 | my $meta | ||||
| 202 | = $class_or_obj->can('add_before_method_modifier') | ||||
| 203 | ? $class_or_obj | ||||
| 204 | : find_meta($class_or_obj); | ||||
| 205 | my $code = pop @{$args}; | ||||
| 206 | my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier'; | ||||
| 207 | if ( my $method_modifier_type = ref( @{$args}[0] ) ) { | ||||
| 208 | if ( $method_modifier_type eq 'Regexp' ) { | ||||
| 209 | my @all_methods = $meta->get_all_methods; | ||||
| 210 | my @matched_methods | ||||
| 211 | = grep { $_->name =~ @{$args}[0] } @all_methods; | ||||
| 212 | $meta->$add_modifier_method( $_->name, $code ) | ||||
| 213 | for @matched_methods; | ||||
| 214 | } | ||||
| 215 | elsif ($method_modifier_type eq 'ARRAY') { | ||||
| 216 | $meta->$add_modifier_method( $_, $code ) for @{$args->[0]}; | ||||
| 217 | } | ||||
| 218 | else { | ||||
| 219 | $meta->throw_error( | ||||
| 220 | sprintf( | ||||
| 221 | "Methods passed to %s must be provided as a list, arrayref or regex, not %s", | ||||
| 222 | $modifier_name, | ||||
| 223 | $method_modifier_type, | ||||
| 224 | ) | ||||
| 225 | ); | ||||
| 226 | } | ||||
| 227 | } | ||||
| 228 | else { | ||||
| 229 | $meta->$add_modifier_method( $_, $code ) for @{$args}; | ||||
| 230 | } | ||||
| 231 | } | ||||
| 232 | |||||
| 233 | sub english_list { | ||||
| 234 | my @items = sort @_; | ||||
| 235 | |||||
| 236 | return $items[0] if @items == 1; | ||||
| 237 | return "$items[0] and $items[1]" if @items == 2; | ||||
| 238 | |||||
| 239 | my $tail = pop @items; | ||||
| 240 | my $list = join ', ', @items; | ||||
| 241 | $list .= ', and ' . $tail; | ||||
| 242 | |||||
| 243 | return $list; | ||||
| 244 | } | ||||
| 245 | |||||
| 246 | # spent 34µs within Moose::Util::_caller_info which was called 4 times, avg 9µs/call:
# 4 times (34µs+0s) by Moose::has at line 67 of Moose.pm, avg 9µs/call | ||||
| 247 | 16 | 36µs | my $level = @_ ? ($_[0] + 1) : 2; | ||
| 248 | my %info; | ||||
| 249 | @info{qw(package file line)} = caller($level); | ||||
| 250 | return \%info; | ||||
| 251 | } | ||||
| 252 | |||||
| 253 | sub _create_alias { | ||||
| 254 | my ($type, $name, $trait, $for) = @_; | ||||
| 255 | my $package = _build_alias_package_name($type, $name, $trait); | ||||
| 256 | Class::MOP::Class->initialize($package)->add_method( | ||||
| 257 | register_implementation => sub { $for } | ||||
| 258 | ); | ||||
| 259 | } | ||||
| 260 | |||||
| 261 | sub meta_attribute_alias { | ||||
| 262 | my ($to, $from) = @_; | ||||
| 263 | $from ||= caller; | ||||
| 264 | my $meta = Class::MOP::class_of($from); | ||||
| 265 | my $trait = $meta->isa('Moose::Meta::Role'); | ||||
| 266 | _create_alias('Attribute', $to, $trait, $from); | ||||
| 267 | } | ||||
| 268 | |||||
| 269 | sub meta_class_alias { | ||||
| 270 | my ($to, $from) = @_; | ||||
| 271 | $from ||= caller; | ||||
| 272 | my $meta = Class::MOP::class_of($from); | ||||
| 273 | my $trait = $meta->isa('Moose::Meta::Role'); | ||||
| 274 | _create_alias('Class', $to, $trait, $from); | ||||
| 275 | } | ||||
| 276 | |||||
| 277 | 1 | 19µs | 1; | ||
| 278 | |||||
| 279 | __END__ | ||||
| 280 | |||||
| 281 | =pod | ||||
| 282 | |||||
| 283 | =head1 NAME | ||||
| 284 | |||||
| 285 | Moose::Util - Utilities for working with Moose classes | ||||
| 286 | |||||
| 287 | =head1 SYNOPSIS | ||||
| 288 | |||||
| 289 | use Moose::Util qw/find_meta does_role search_class_by_role/; | ||||
| 290 | |||||
| 291 | my $meta = find_meta($object) || die "No metaclass found"; | ||||
| 292 | |||||
| 293 | if (does_role($object, $role)) { | ||||
| 294 | print "The object can do $role!\n"; | ||||
| 295 | } | ||||
| 296 | |||||
| 297 | my $class = search_class_by_role($object, 'FooRole'); | ||||
| 298 | print "Nearest class with 'FooRole' is $class\n"; | ||||
| 299 | |||||
| 300 | =head1 DESCRIPTION | ||||
| 301 | |||||
| 302 | This module provides a set of utility functions. Many of these | ||||
| 303 | functions are intended for use in Moose itself or MooseX modules, but | ||||
| 304 | some of them may be useful for use in your own code. | ||||
| 305 | |||||
| 306 | =head1 EXPORTED FUNCTIONS | ||||
| 307 | |||||
| 308 | =over 4 | ||||
| 309 | |||||
| 310 | =item B<find_meta($class_or_obj)> | ||||
| 311 | |||||
| 312 | This method takes a class name or object and attempts to find a | ||||
| 313 | metaclass for the class, if one exists. It will B<not> create one if it | ||||
| 314 | does not yet exist. | ||||
| 315 | |||||
| 316 | =item B<does_role($class_or_obj, $role_or_obj)> | ||||
| 317 | |||||
| 318 | Returns true if C<$class_or_obj> does the given C<$role_or_obj>. The role can | ||||
| 319 | be provided as a name or a L<Moose::Meta::Role> object. | ||||
| 320 | |||||
| 321 | The class must already have a metaclass for this to work. If it doesn't, this | ||||
| 322 | function simply returns false. | ||||
| 323 | |||||
| 324 | =item B<search_class_by_role($class_or_obj, $role_or_obj)> | ||||
| 325 | |||||
| 326 | Returns the first class in the class's precedence list that does | ||||
| 327 | C<$role_or_obj>, if any. The role can be either a name or a | ||||
| 328 | L<Moose::Meta::Role> object. | ||||
| 329 | |||||
| 330 | The class must already have a metaclass for this to work. | ||||
| 331 | |||||
| 332 | =item B<apply_all_roles($applicant, @roles)> | ||||
| 333 | |||||
| 334 | This function applies one or more roles to the given C<$applicant> The | ||||
| 335 | applicant can be a role name, class name, or object. | ||||
| 336 | |||||
| 337 | The C<$applicant> must already have a metaclass object. | ||||
| 338 | |||||
| 339 | The list of C<@roles> should a list of names or L<Moose::Meta::Role> objects, | ||||
| 340 | each of which can be followed by an optional hash reference of options | ||||
| 341 | (C<-excludes> and C<-alias>). | ||||
| 342 | |||||
| 343 | =item B<ensure_all_roles($applicant, @roles)> | ||||
| 344 | |||||
| 345 | This function is similar to L</apply_all_roles>, but only applies roles that | ||||
| 346 | C<$applicant> does not already consume. | ||||
| 347 | |||||
| 348 | =item B<get_all_attribute_values($meta, $instance)> | ||||
| 349 | |||||
| 350 | Returns a hash reference containing all of the C<$instance>'s | ||||
| 351 | attributes. The keys are attribute names. | ||||
| 352 | |||||
| 353 | =item B<get_all_init_args($meta, $instance)> | ||||
| 354 | |||||
| 355 | Returns a hash reference containing all of the C<init_arg> values for | ||||
| 356 | the instance's attributes. The values are the associated attribute | ||||
| 357 | values. If an attribute does not have a defined C<init_arg>, it is | ||||
| 358 | skipped. | ||||
| 359 | |||||
| 360 | This could be useful in cloning an object. | ||||
| 361 | |||||
| 362 | =item B<resolve_metaclass_alias($category, $name, %options)> | ||||
| 363 | |||||
| 364 | =item B<resolve_metatrait_alias($category, $name, %options)> | ||||
| 365 | |||||
| 366 | Resolves a short name to a full class name. Short names are often used | ||||
| 367 | when specifying the C<metaclass> or C<traits> option for an attribute: | ||||
| 368 | |||||
| 369 | has foo => ( | ||||
| 370 | metaclass => "Bar", | ||||
| 371 | ); | ||||
| 372 | |||||
| 373 | The name resolution mechanism is covered in | ||||
| 374 | L<Moose/Metaclass and Trait Name Resolution>. | ||||
| 375 | |||||
| 376 | =item B<english_list(@items)> | ||||
| 377 | |||||
| 378 | Given a list of scalars, turns them into a proper list in English | ||||
| 379 | ("one and two", "one, two, three, and four"). This is used to help us | ||||
| 380 | make nicer error messages. | ||||
| 381 | |||||
| 382 | =item B<meta_class_alias($to[, $from])> | ||||
| 383 | |||||
| 384 | =item B<meta_attribute_alias($to[, $from])> | ||||
| 385 | |||||
| 386 | Create an alias from the class C<$from> (or the current package, if | ||||
| 387 | C<$from> is unspecified), so that | ||||
| 388 | L<Moose/Metaclass and Trait Name Resolution> works properly. | ||||
| 389 | |||||
| 390 | =back | ||||
| 391 | |||||
| 392 | =head1 TODO | ||||
| 393 | |||||
| 394 | Here is a list of possible functions to write | ||||
| 395 | |||||
| 396 | =over 4 | ||||
| 397 | |||||
| 398 | =item discovering original method from modified method | ||||
| 399 | |||||
| 400 | =item search for origin class of a method or attribute | ||||
| 401 | |||||
| 402 | =back | ||||
| 403 | |||||
| 404 | =head1 BUGS | ||||
| 405 | |||||
| 406 | See L<Moose/BUGS> for details on reporting bugs. | ||||
| 407 | |||||
| 408 | =head1 AUTHOR | ||||
| 409 | |||||
| 410 | Anders Nor Berle E<lt>debolaz@gmail.comE<gt> | ||||
| 411 | |||||
| 412 | B<with contributions from:> | ||||
| 413 | |||||
| 414 | Robert (phaylon) Sedlacek | ||||
| 415 | |||||
| 416 | Stevan Little | ||||
| 417 | |||||
| 418 | =head1 COPYRIGHT AND LICENSE | ||||
| 419 | |||||
| 420 | Copyright 2007-2009 by Infinity Interactive, Inc. | ||||
| 421 | |||||
| 422 | L<http://www.iinteractive.com> | ||||
| 423 | |||||
| 424 | This library is free software; you can redistribute it and/or modify | ||||
| 425 | it under the same terms as Perl itself. | ||||
| 426 | |||||
| 427 | =cut | ||||
| 428 |