lib/Moose/Util.pm

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