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