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 _STRING( $_[0] )
 312         || ( defined $_[0]
 313         && $_[0] eq q{} )
 314         || ( blessed $_[0]
 315         && overload::Method( $_[0], q{""} )
 316         && length "$_[0]" );
 317 }
 318
 319 sub _reconcile_roles_for_metaclass {
 320     my ($class_meta_name, $super_meta_name) = @_;
 321
 322     my @role_differences = _role_differences(
 323         $class_meta_name, $super_meta_name,
 324     );
 325
 326     # handle the case where we need to fix compatibility between a class and
 327     # its parent, but all roles in the class are already also done by the
 328     # parent
 329     # see t/metaclasses/metaclass_compat_no_fixing_bug.t
 330     return $super_meta_name
 331         unless @role_differences;
 332
 333     return Moose::Meta::Class->create_anon_class(
 334         superclasses => [$super_meta_name],
 335         roles        => [map { $_->name } @role_differences],
 336         cache        => 1,
 337     )->name;
 338 }
 339
 340 sub _role_differences {
 341     my ($class_meta_name, $super_meta_name) = @_;
 342     my @super_role_metas
 343         = grep { !$_->isa('Moose::Meta::Role::Composite') }
 344                $super_meta_name->meta->can('calculate_all_roles_with_inheritance')
 345                    ? $super_meta_name->meta->calculate_all_roles_with_inheritance
 346                    : $super_meta_name->meta->can('calculate_all_roles')
 347                    ? $super_meta_name->meta->calculate_all_roles
 348                    : ();
 349     my @role_metas
 350         = grep { !$_->isa('Moose::Meta::Role::Composite') }
 351                $class_meta_name->meta->can('calculate_all_roles_with_inheritance')
 352                    ? $class_meta_name->meta->calculate_all_roles_with_inheritance
 353                    : $class_meta_name->meta->can('calculate_all_roles')
 354                    ? $class_meta_name->meta->calculate_all_roles
 355                    : ();
 356     my @differences;
 357     for my $role_meta (@role_metas) {
 358         push @differences, $role_meta
 359             unless any { $_->name eq $role_meta->name } @super_role_metas;
 360     }
 361     return @differences;
 362 }
 363
 364 sub _classes_differ_by_roles_only {
 365     my ( $self_meta_name, $super_meta_name ) = @_;
 366
 367     my $common_base_name
 368         = _find_common_base( $self_meta_name, $super_meta_name );
 369
 370     return unless defined $common_base_name;
 371
 372     my @super_meta_name_ancestor_names
 373         = _get_ancestors_until( $super_meta_name, $common_base_name );
 374     my @class_meta_name_ancestor_names
 375         = _get_ancestors_until( $self_meta_name, $common_base_name );
 376
 377     return
 378         unless all { _is_role_only_subclass($_) }
 379         @super_meta_name_ancestor_names,
 380         @class_meta_name_ancestor_names;
 381
 382     return 1;
 383 }
 384
 385 sub _find_common_base {
 386     my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_;
 387     return unless defined $meta1 && defined $meta2;
 388
 389     # FIXME? This doesn't account for multiple inheritance (not sure
 390     # if it needs to though). For example, if somewhere in $meta1's
 391     # history it inherits from both ClassA and ClassB, and $meta2
 392     # inherits from ClassB & ClassA, does it matter? And what crazy
 393     # fool would do that anyway?
 394
 395     my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
 396
 397     return first { $meta1_parents{$_} } $meta2->linearized_isa;
 398 }
 399
 400 sub _get_ancestors_until {
 401     my ($start_name, $until_name) = @_;
 402
 403     my @ancestor_names;
 404     for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) {
 405         last if $ancestor_name eq $until_name;
 406         push @ancestor_names, $ancestor_name;
 407     }
 408     return @ancestor_names;
 409 }
 410
 411 sub _is_role_only_subclass {
 412     my ($meta_name) = @_;
 413     my $meta = Class::MOP::Class->initialize($meta_name);
 414     my @parent_names = $meta->superclasses;
 415
 416     # XXX: don't feel like messing with multiple inheritance here... what would
 417     # that even do?
 418     return unless @parent_names == 1;
 419     my ($parent_name) = @parent_names;
 420     my $parent_meta = Class::MOP::Class->initialize($parent_name);
 421
 422     # only get the roles attached to this particular class, don't look at
 423     # superclasses
 424     my @roles = $meta->can('calculate_all_roles')
 425                     ? $meta->calculate_all_roles
 426                     : ();
 427
 428     # it's obviously not a role-only subclass if it doesn't do any roles
 429     return unless @roles;
 430
 431     # loop over all methods that are a part of the current class
 432     # (not inherited)
 433     for my $method ( $meta->_get_local_methods ) {
 434         # always ignore meta
 435         next if $method->isa('Class::MOP::Method::Meta');
 436         # we'll deal with attributes below
 437         next if $method->can('associated_attribute');
 438         # if the method comes from a role we consumed, ignore it
 439         next if $meta->can('does_role')
 440              && $meta->does_role($method->original_package_name);
 441         # FIXME - this really isn't right. Just because a modifier is
 442         # defined in a role doesn't mean it isn't _also_ defined in the
 443         # subclass.
 444         next if $method->isa('Class::MOP::Method::Wrapped')
 445              && (
 446                  (!scalar($method->around_modifiers)
 447                || any { $_->has_around_method_modifiers($method->name) } @roles)
 448               && (!scalar($method->before_modifiers)
 449                || any { $_->has_before_method_modifiers($method->name) } @roles)
 450               && (!scalar($method->after_modifiers)
 451                || any { $_->has_after_method_modifiers($method->name) } @roles)
 452                 );
 453
 454         return 0;
 455     }
 456
 457     # loop over all attributes that are a part of the current class
 458     # (not inherited)
 459     # FIXME - this really isn't right. Just because an attribute is
 460     # defined in a role doesn't mean it isn't _also_ defined in the
 461     # subclass.
 462     for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) {
 463         next if any { $_->has_attribute($attr->name) } @roles;
 464
 465         return 0;
 466     }
 467
 468     return 1;
 469 }
 470
 471 1;
 472
 473 # ABSTRACT: Utilities for working with Moose classes
 474
 475 __END__
 476
 477 =pod
 478
 479 =head1 SYNOPSIS
 480
 481   use Moose::Util qw/find_meta does_role search_class_by_role/;
 482
 483   my $meta = find_meta($object) || die "No metaclass found";
 484
 485   if (does_role($object, $role)) {
 486     print "The object can do $role!\n";
 487   }
 488
 489   my $class = search_class_by_role($object, 'FooRole');
 490   print "Nearest class with 'FooRole' is $class\n";
 491
 492 =head1 DESCRIPTION
 493
 494 This module provides a set of utility functions. Many of these
 495 functions are intended for use in Moose itself or MooseX modules, but
 496 some of them may be useful for use in your own code.
 497
 498 =head1 EXPORTED FUNCTIONS
 499
 500 =over 4
 501
 502 =item B<find_meta($class_or_obj)>
 503
 504 This method takes a class name or object and attempts to find a
 505 metaclass for the class, if one exists. It will B<not> create one if it
 506 does not yet exist.
 507
 508 =item B<does_role($class_or_obj, $role_or_obj)>
 509
 510 Returns true if C<$class_or_obj> does the given C<$role_or_obj>. The role can
 511 be provided as a name or a L<Moose::Meta::Role> object.
 512
 513 The class must already have a metaclass for this to work. If it doesn't, this
 514 function simply returns false.
 515
 516 =item B<search_class_by_role($class_or_obj, $role_or_obj)>
 517
 518 Returns the first class in the class's precedence list that does
 519 C<$role_or_obj>, if any. The role can be either a name or a
 520 L<Moose::Meta::Role> object.
 521
 522 The class must already have a metaclass for this to work.
 523
 524 =item B<apply_all_roles($applicant, @roles)>
 525
 526 This function applies one or more roles to the given C<$applicant> The
 527 applicant can be a role name, class name, or object.
 528
 529 The C<$applicant> must already have a metaclass object.
 530
 531 The list of C<@roles> should a list of names or L<Moose::Meta::Role> objects,
 532 each of which can be followed by an optional hash reference of options
 533 (C<-excludes> and C<-alias>).
 534
 535 =item B<ensure_all_roles($applicant, @roles)>
 536
 537 This function is similar to C<apply_all_roles>, but only applies roles that
 538 C<$applicant> does not already consume.
 539
 540 =item B<with_traits($class_name, @role_names)>
 541
 542 This function creates a new class from C<$class_name> with each of
 543 C<@role_names> applied. It returns the name of the new class.
 544
 545 =item B<get_all_attribute_values($meta, $instance)>
 546
 547 Returns a hash reference containing all of the C<$instance>'s
 548 attributes. The keys are attribute names.
 549
 550 =item B<get_all_init_args($meta, $instance)>
 551
 552 Returns a hash reference containing all of the C<init_arg> values for
 553 the instance's attributes. The values are the associated attribute
 554 values. If an attribute does not have a defined C<init_arg>, it is
 555 skipped.
 556
 557 This could be useful in cloning an object.
 558
 559 =item B<resolve_metaclass_alias($category, $name, %options)>
 560
 561 =item B<resolve_metatrait_alias($category, $name, %options)>
 562
 563 Resolves a short name to a full class name. Short names are often used
 564 when specifying the C<metaclass> or C<traits> option for an attribute:
 565
 566     has foo => (
 567         metaclass => "Bar",
 568     );
 569
 570 The name resolution mechanism is covered in
 571 L<Moose/Metaclass and Trait Name Resolution>.
 572
 573 =item B<meta_class_alias($to[, $from])>
 574
 575 =item B<meta_attribute_alias($to[, $from])>
 576
 577 Create an alias from the class C<$from> (or the current package, if
 578 C<$from> is unspecified), so that
 579 L<Moose/Metaclass and Trait Name Resolution> works properly.
 580
 581 =item B<english_list(@items)>
 582
 583 Given a list of scalars, turns them into a proper list in English
 584 ("one and two", "one, two, three, and four"). This is used to help us
 585 make nicer error messages.
 586
 587 =back
 588
 589 =head1 TODO
 590
 591 Here is a list of possible functions to write
 592
 593 =over 4
 594
 595 =item discovering original method from modified method
 596
 597 =item search for origin class of a method or attribute
 598
 599 =back
 600
 601 =head1 BUGS
 602
 603 See L<Moose/BUGS> for details on reporting bugs.
 604
 605 =cut
 606