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