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