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