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