lib/Moose/Util.pm

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