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