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 = $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       = $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 __END__
 453
 454 =pod
 455
 456 =head1 NAME
 457
 458 Moose::Util - Utilities for working with Moose classes
 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 =head1 AUTHOR
 587
 588 Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
 589
 590 B<with contributions from:>
 591
 592 Robert (phaylon) Sedlacek
 593
 594 Stevan Little
 595
 596 =head1 COPYRIGHT AND LICENSE
 597
 598 Copyright 2007-2009 by Infinity Interactive, Inc.
 599
 600 L<http://www.iinteractive.com>
 601
 602 This library is free software; you can redistribute it and/or modify
 603 it under the same terms as Perl itself.
 604
 605 =cut
 606