File Coverage

blib/lib/MooseX/Role/TraitConstructor.pm

Criterion	Covered	Total	%
statement	1	3	33.3
branch			n/a
condition			n/a
subroutine	1	1	100.0
pod			n/a
total	2	4	50.0

#!/usr/bin/perl

package MooseX::Role::TraitConstructor;
use Moose::Role;

use List::Util ();

our $VERSION = "0.01";

use constant constructor_trait_param => "traits";

sub new_with_traits {
    my ( $class, @opts ) = @_;

    my %params;

    if (scalar @opts == 1) {
        if (defined $opts[0]) {
            (ref($opts[0]) eq 'HASH')
                || confess "Single parameters to new() must be a HASH ref";
            %params = %{$opts[0]};
        }
    }
    else {
        %params = @opts;
    }

    $class->interpolate_class_from_params(\%params)->new(%params);
}

sub interpolate_class_from_params {
    my ($class, $params) = @_;

    $class = ref($class) || $class;

    my @traits;

    if (my $traits = delete $params->{$class->constructor_trait_param($params)}) {
        if ( @traits = $class->process_constructor_traits($params, @$traits) ) {
            my $anon_class = Moose::Meta::Class->create_anon_class(
                superclasses => [ $class ],
                roles        => [ @traits ],
                cache        => 1,
            );

            $class = $anon_class->name;
        }
    }

    return ( wantarray ? ( $class, @traits ) : $class );
}

sub process_constructor_traits {
    my ( $class, $params, @traits ) = @_;

    $class->filter_constructor_traits( $params, $class->resolve_constructor_traits( $params, @traits ) );

}

sub resolve_constructor_traits {
    my ( $class, $params, @traits ) = @_;

    my $root = $class->guess_original_class_name($params);

    map { $class->resolve_constructor_trait($params, $root, $_) } @traits;
}

sub guess_original_class_name {
    my ( $class, $params ) = @_;

    my $meta = $class->meta;

    if ( $meta->is_anon_class ) {
        if ( my $root = List::Util::first(sub { not $_->meta->is_anon_class }, $meta->linearized_isa ) ) {
            return $root;
        }
    }

    return $class;
}

sub resolve_constructor_trait {
    my ( $class, $params, $possible_root, $trait ) = @_;

    if ( ref $trait ) {
        return $trait->anme;
    } else {
        my $processed_trait;

        {
            local $@;
            if ( $processed_trait = $class->process_trait_name($trait, $params, $possible_root) ) {
                if ( eval { Class::MOP::load_class($processed_trait); 1 } ) {
                    return $processed_trait;
                }
            }

            if ( eval { Class::MOP::load_class($trait); 1 } ) {
                return $trait;
            }
        }

        require Carp;
        Carp::croak("Couldn't load $trait" . ( $processed_trait ? " or $processed_trait" : "" ) . " to mix in with $class" . ( $class->meta->is_anon_class ? " ($possible_root)" : "" ));
    }
}

sub process_trait_name {
    my ( $class, $trait, $params, $possible_root) = @_;

    return join "::", $possible_root, $trait;
}

sub filter_constructor_traits {
    my ( $class, $params, @traits ) = @_;

    return grep { not $class->does($_) } @traits;
}

__PACKAGE__

__END__

=pod

=head1 NAME

MooseX::Role::TraitConstructor - A wrapper for C<new> that can accept a
C<traits> parameter.

=head1 SYNOPSIS

    package Foo;
    use Moose;

	with qw(MooseX::Role::TraitConstructor);


    package Foo::Bah;

    sub bah_method { ... }



    my $foo = Foo->new( traits => [qw( Bah )] );

    $foo->bah_method;

=head1 DESCRIPTION

This role allows you to easily accept a C<traits> argument (or another name)
into your constructor, which will easily mix roles into an anonymous class
before construction, much like L<Moose::Meta::Attribute> does.

=head1 METHODS

=over 4

=item constructor_trait_param

Returns the string C<traits>.

Override to rename the parameter.

=item new_with_traits %params

=item new_with_traits $params

A L<Moose::Object/new> like parameter processor which will call C<new> on the
return value of C<interpolate_class_from_params>.

=item interpolate_class_from_params $params

This method will automatically create an anonymous class with the roles from
the C<traits> param mixed into it if one exists.

If not the normal class name will be returned.

Will remove the C<traits> parameter from C<$params>.

Also works as an instance method, but always returns a class name.

In list context also returns the actual list of roles mixed into the class.

=item process_constructor_traits $params, @traits

Calls C<filter_constructor_traits> on the result of C<resolve_constructor_traits>.

=item resolve_constructor_traits $params, @traits

Attempt to load the traits specified in C<@traits> usinc C<resolve_constructor_trait>

=item guess_original_class_name $params

=item resolve_constructor_trait $params, $possible_root, $trait

Attempts to get a processed name from C<process_trait_name>, and then tries to load that.

If C<process_trait_name> didn't return a true value or its return value could
not be loaded then C<$trait> will be tried.

If nothing could be loaded an error is thrown.

C<$possible_root> is the name of the first non anonymous class in the
C<linearized_isa>, usually C<$class>, but will DWIM in case C<$class> has
already been interpolated with traits from a named class.

=item process_trait_name $trait, $params, $possible_root

Returns C<< join "::", $possible_root, $trait >>.

You probably want to override this method.

=item filter_constructor_traits $params, $traits,

Returns all the the roles that the invocant class doesn't already do (uses
C<does>).

=back

=head1 VERSION CONTROL

L<http://code2.0beta.co.uk/moose/svn/>. Ask on #moose for commit bits.

=head1 AUTHOR

Yuval Kogman E<lt>[e-mail]<gt>

=head1 COPYRIGHT

	Copyright (c) 2008 Yuval Kogman. All rights reserved
	This program is free software; you can redistribute
	it and/or modify it under the same terms as Perl itself.

=cut