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     my %args;
 476     if (@_ == 1) {
 477         $args{message} = shift;
 478     }
 479     else {
 480         %args = @_;
 481     }
 482
 483     my $superclass = delete($args{superclass}) || 'Throwable::Error';
 484     my $roles = delete($args{roles});
 485
 486     my $metaclass;
 487
 488     load_class($superclass);
 489
 490     if ($roles) {
 491         $metaclass = Moose::Meta::Class->create_anon_class(
 492             superclasses => [$superclass],
 493             roles        => $roles,
 494         );
 495     }
 496     else {
 497         $metaclass = Moose::Meta::Class->initialize($superclass);
 498     }
 499
 500     $metaclass->name->throw(\%args);
 501 }
 502
 503
 504 1;
 505
 506 # ABSTRACT: Utilities for working with Moose classes
 507
 508 __END__
 509
 510 =pod
 511
 512 =head1 SYNOPSIS
 513
 514   use Moose::Util qw/find_meta does_role search_class_by_role/;
 515
 516   my $meta = find_meta($object) || die "No metaclass found";
 517
 518   if (does_role($object, $role)) {
 519     print "The object can do $role!\n";
 520   }
 521
 522   my $class = search_class_by_role($object, 'FooRole');
 523   print "Nearest class with 'FooRole' is $class\n";
 524
 525 =head1 DESCRIPTION
 526
 527 This module provides a set of utility functions. Many of these
 528 functions are intended for use in Moose itself or MooseX modules, but
 529 some of them may be useful for use in your own code.
 530
 531 =head1 EXPORTED FUNCTIONS
 532
 533 =over 4
 534
 535 =item B<find_meta($class_or_obj)>
 536
 537 This method takes a class name or object and attempts to find a
 538 metaclass for the class, if one exists. It will B<not> create one if it
 539 does not yet exist.
 540
 541 =item B<does_role($class_or_obj, $role_or_obj)>
 542
 543 Returns true if C<$class_or_obj> does the given C<$role_or_obj>. The role can
 544 be provided as a name or a L<Moose::Meta::Role> object.
 545
 546 The class must already have a metaclass for this to work. If it doesn't, this
 547 function simply returns false.
 548
 549 =item B<search_class_by_role($class_or_obj, $role_or_obj)>
 550
 551 Returns the first class in the class's precedence list that does
 552 C<$role_or_obj>, if any. The role can be either a name or a
 553 L<Moose::Meta::Role> object.
 554
 555 The class must already have a metaclass for this to work.
 556
 557 =item B<apply_all_roles($applicant, @roles)>
 558
 559 This function applies one or more roles to the given C<$applicant> The
 560 applicant can be a role name, class name, or object.
 561
 562 The C<$applicant> must already have a metaclass object.
 563
 564 The list of C<@roles> should a list of names or L<Moose::Meta::Role> objects,
 565 each of which can be followed by an optional hash reference of options
 566 (C<-excludes> and C<-alias>).
 567
 568 =item B<ensure_all_roles($applicant, @roles)>
 569
 570 This function is similar to C<apply_all_roles>, but only applies roles that
 571 C<$applicant> does not already consume.
 572
 573 =item B<with_traits($class_name, @role_names)>
 574
 575 This function creates a new class from C<$class_name> with each of
 576 C<@role_names> applied. It returns the name of the new class.
 577
 578 =item B<get_all_attribute_values($meta, $instance)>
 579
 580 Returns a hash reference containing all of the C<$instance>'s
 581 attributes. The keys are attribute names.
 582
 583 =item B<get_all_init_args($meta, $instance)>
 584
 585 Returns a hash reference containing all of the C<init_arg> values for
 586 the instance's attributes. The values are the associated attribute
 587 values. If an attribute does not have a defined C<init_arg>, it is
 588 skipped.
 589
 590 This could be useful in cloning an object.
 591
 592 =item B<resolve_metaclass_alias($category, $name, %options)>
 593
 594 =item B<resolve_metatrait_alias($category, $name, %options)>
 595
 596 Resolves a short name to a full class name. Short names are often used
 597 when specifying the C<metaclass> or C<traits> option for an attribute:
 598
 599     has foo => (
 600         metaclass => "Bar",
 601     );
 602
 603 The name resolution mechanism is covered in
 604 L<Moose/Metaclass and Trait Name Resolution>.
 605
 606 =item B<meta_class_alias($to[, $from])>
 607
 608 =item B<meta_attribute_alias($to[, $from])>
 609
 610 Create an alias from the class C<$from> (or the current package, if
 611 C<$from> is unspecified), so that
 612 L<Moose/Metaclass and Trait Name Resolution> works properly.
 613
 614 =item B<english_list(@items)>
 615
 616 Given a list of scalars, turns them into a proper list in English
 617 ("one and two", "one, two, three, and four"). This is used to help us
 618 make nicer error messages.
 619
 620 =back
 621
 622 =head1 TODO
 623
 624 Here is a list of possible functions to write
 625
 626 =over 4
 627
 628 =item discovering original method from modified method
 629
 630 =item search for origin class of a method or attribute
 631
 632 =back
 633
 634 =head1 BUGS
 635
 636 See L<Moose/BUGS> for details on reporting bugs.
 637
 638 =cut
 639