fix RT#44429 after discussion on the mailing list

[gitmo/Moose.git] / lib / Moose / Util.pm

package Moose::Util;

use strict;
use warnings;

use Sub::Exporter;
use Scalar::Util 'blessed';
use Class::MOP   0.60;

our $VERSION   = '0.73';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';

my @exports = qw[
    find_meta 
    does_role
    search_class_by_role   
    apply_all_roles
    get_all_init_args
    get_all_attribute_values
    resolve_metatrait_alias
    resolve_metaclass_alias
    add_method_modifier
    english_list
];

Sub::Exporter::setup_exporter({
    exports => \@exports,
    groups  => { all => \@exports }
});

## some utils for the utils ...

sub find_meta { 
    return unless $_[0];
    return Class::MOP::get_metaclass_by_name(blessed($_[0]) || $_[0]);
}

## the functions ...

sub does_role {
    my ($class_or_obj, $role) = @_;

    my $meta = find_meta($class_or_obj);
    
    return unless defined $meta;
    return unless $meta->can('does_role');
    return 1 if $meta->does_role($role);
    return;
}

sub search_class_by_role {
    my ($class_or_obj, $role_name) = @_;
    
    my $meta = find_meta($class_or_obj);

    return unless defined $meta;

    foreach my $class ($meta->class_precedence_list) {
        
        my $_meta = find_meta($class);        

        next unless defined $_meta;

        foreach my $role (@{ $_meta->roles || [] }) {
            return $class if $role->name eq $role_name;
        }
    }

    return;
}

sub apply_all_roles {
    my $applicant = shift;

    unless (@_) {
        require Moose;
        Moose->throw_error("Must specify at least one role to apply to $applicant");
    }

    my $roles = Data::OptList::mkopt( [@_] );

    foreach my $role (@$roles) {
        my $meta = Class::MOP::load_class( $role->[0] );

        unless ($meta->isa('Moose::Meta::Role') ) {
            require Moose;
            Moose->throw_error( "You can only consume roles, "
                    . $role->[0]
                    . " is not a Moose role" );
        }
    }

    my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) );

    if ( scalar @$roles == 1 ) {
        my ( $role, $params ) = @{ $roles->[0] };
        my $role_meta = Class::MOP::class_of($role);
        $role_meta->apply( $meta, ( defined $params ? %$params : () ) );
    }
    else {
        Moose::Meta::Role->combine( @$roles )->apply($meta);
    }
}

# instance deconstruction ...

sub get_all_attribute_values {
    my ($class, $instance) = @_;
    return +{
        map { $_->name => $_->get_value($instance) }
            grep { $_->has_value($instance) }
                $class->compute_all_applicable_attributes
    };
}

sub get_all_init_args {
    my ($class, $instance) = @_;
    return +{
        map { $_->init_arg => $_->get_value($instance) }
            grep { $_->has_value($instance) }
                grep { defined($_->init_arg) } 
                    $class->compute_all_applicable_attributes
    };
}

sub resolve_metatrait_alias {
    return resolve_metaclass_alias( @_, trait => 1 );
}

{
    my %cache;

    sub resolve_metaclass_alias {
        my ( $type, $metaclass_name, %options ) = @_;

        my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
        return $cache{$cache_key}{$metaclass_name}
            if $cache{$cache_key}{$metaclass_name};

        my $possible_full_name
            = 'Moose::Meta::' 
            . $type
            . '::Custom::'
            . ( $options{trait} ? "Trait::" : "" )
            . $metaclass_name;

        my $loaded_class = Class::MOP::load_first_existing_class(
            $possible_full_name,
            $metaclass_name
        );

        return $cache{$cache_key}{$metaclass_name}
            = $loaded_class->can('register_implementation')
            ? $loaded_class->register_implementation
            : $loaded_class;
    }
}

sub add_method_modifier {
    my ( $class_or_obj, $modifier_name, $args ) = @_;
    my $meta                = find_meta($class_or_obj);
    my $code                = pop @{$args};
    my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
    if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
        if ( $method_modifier_type eq 'Regexp' ) {
            my @all_methods = $meta->get_all_methods;
            my @matched_methods
                = grep { $_->name =~ @{$args}[0] } @all_methods;
            $meta->$add_modifier_method( $_->name, $code )
                for @matched_methods;
        }
    }
    else {
        $meta->$add_modifier_method( $_, $code ) for @{$args};
    }
}

sub english_list {
    my @items = sort @_;

    return $items[0] if @items == 1;
    return "$items[0] and $items[1]" if @items == 2;

    my $tail = pop @items;
    my $list = join ', ', @items;
    $list .= ', and ' . $tail;

    return $list;
}

1;

__END__

=pod

=head1 NAME

Moose::Util - Utilities for working with Moose classes

=head1 SYNOPSIS

  use Moose::Util qw/find_meta does_role search_class_by_role/;

  my $meta = find_meta($object) || die "No metaclass found";

  if (does_role($object, $role)) {
    print "The object can do $role!\n";
  }

  my $class = search_class_by_role($object, 'FooRole');
  print "Nearest class with 'FooRole' is $class\n";

=head1 DESCRIPTION

This module provides a set of utility functions. Many of these
functions are intended for use in Moose itself or MooseX modules, but
some of them may be useful for use in your own code.

=head1 EXPORTED FUNCTIONS

=over 4

=item B<find_meta($class_or_obj)>

This method takes a class name or object and attempts to find a
metaclass for the class, if one exists. It will not create one if it
does not yet exist.

=item B<does_role($class_or_obj, $role_name)>

Returns true if C<$class_or_obj> does the given C<$role_name>.

The class must already have a metaclass for this to work.

=item B<search_class_by_role($class_or_obj, $role_name)>

Returns the first class in the class's precedence list that does
C<$role_name>, if any.

The class must already have a metaclass for this to work.

=item B<apply_all_roles($applicant, @roles)>

This function applies one or more roles to the given C<$applicant> The
applicant can be a role name, class name, or object.

The C<$applicant> must already have a metaclass object.

The list of C<@roles> should be a list of names, each of which can be
followed by an optional hash reference of options (C<exclude> and
C<alias>).

=item B<get_all_attribute_values($meta, $instance)>

Returns a hash reference containing all of the C<$instance>'s
attributes. The keys are attribute names.

=item B<get_all_init_args($meta, $instance)>

Returns a hash reference containing all of the C<init_arg> values for
the instance's attributes. The values are the associated attribute
values. If an attribute does not have a defined C<init_arg>, it is
skipped.

This could be useful in cloning an object.

=item B<resolve_metaclass_alias($category, $name, %options)>

=item B<resolve_metatrait_alias($category, $name, %options)>

Resolves a short name to a full class name. Short names are often used
when specifying the C<metaclass> or C<traits> option for an attribute:

    has foo => (
        metaclass => "Bar",
    );

The name resolution mechanism is covered in L<Moose/Trait Name
Resolution>.

=item B<english_list(@items)>

Given a list of scalars, turns them into a proper list in English
("one and two", "one, two, three, and four"). This is used to help us
make nicer error messages.

=back

=head1 TODO

Here is a list of possible functions to write

=over 4

=item discovering original method from modified method

=item search for origin class of a method or attribute

=back

=head1 BUGS

All complex software has bugs lurking in it, and this module is no 
exception. If you find a bug please either email me, or add the bug
to cpan-RT.

=head1 AUTHOR

Anders Nor Berle E<lt>debolaz@gmail.comE<gt>

B<with contributions from:>

Robert (phaylon) Sedlacek

Stevan Little

=head1 COPYRIGHT AND LICENSE

Copyright 2007-2009 by Infinity Interactive, Inc.

L<http://www.iinteractive.com>

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut