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