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