libmoosex-runnable-perl 0.09-1 / usr / share / perl5 / MooseX / Runnable / Invocation.pm

package MooseX::Runnable::Invocation;
BEGIN {
  $MooseX::Runnable::Invocation::AUTHORITY = 'cpan:JROCKWAY';
}
$MooseX::Runnable::Invocation::VERSION = '0.09';
use Moose;
use MooseX::Types -declare => ['RunnableClass'];
use MooseX::Types::Moose qw(Str HashRef ArrayRef);
use List::MoreUtils qw(uniq);
use Params::Util qw(_CLASS);
use Class::Load;
use namespace::autoclean;

# we can't load the class until plugins are loaded,
# so we have to handle this outside of coerce

subtype RunnableClass,
  as Str,
  where { _CLASS($_) };


with 'MooseX::Runnable'; # this class technically follows
                         # MX::Runnable's protocol

has 'class' => (
    is       => 'ro',
    isa      => RunnableClass,
    required => 1,
);

has 'plugins' => (
    is         => 'ro',
    isa        => HashRef[ArrayRef[Str]],
    default    => sub { +{} },
    required   => 1,
    auto_deref => 1,
);

sub BUILD {
    my $self = shift;

    # it would be nice to use MX::Object::Pluggable, but our plugins
    # are too configurable

    my $plugin_ns = 'MooseX::Runnable::Invocation::Plugin::';
    for my $plugin (keys %{$self->plugins}){
        my $orig = $plugin;
        $plugin = "$plugin_ns$plugin" unless $plugin =~ /^[+]/;
        $plugin =~ s/^[+]//g;

        Class::Load::load_class( $plugin );

        my $does_cmdline = $plugin->meta->
          does_role('MooseX::Runnable::Invocation::Plugin::Role::CmdlineArgs');

        my $args;
        if($does_cmdline){
            $args = eval {
                $plugin->_build_initargs_from_cmdline(
                    @{$self->plugins->{$orig}},
                );
            };

            if($@) {
                confess "Error building initargs for $plugin: $@";
            }
        }
        elsif(!$does_cmdline && scalar @{$self->plugins->{$orig}} > 0){
            confess "You supplied arguments to the $orig plugin, but it".
              " does not know how to accept them.  Perhaps the plugin".
              " should consume the".
              " 'MooseX::Runnable::Invocation::Plugin::Role::CmdlineArgs'".
              " role?";
        }

        $plugin->meta->apply(
            $self,
            defined $args ? (rebless_params => $args) : (),
        );
    }
}

sub load_class {
    my $self = shift;
    my $class = $self->class;

    Class::Load::load_class( $class );

    confess 'We can only work with Moose classes with "meta" methods'
      if !$class->can('meta');

    my $meta = $class->meta;

    confess "The metaclass of $class is not a Moose::Meta::Class, it's $meta"
      unless $meta->isa('Moose::Meta::Class');

    confess 'MooseX::Runnable can only run classes tagged with '.
      'the MooseX::Runnable role'
        unless $meta->does_role('MooseX::Runnable');

    return $meta;
}

sub apply_scheme {
    my ($self, $class) = @_;

    my @schemes = grep { defined } map {
        eval { $self->_convert_role_to_scheme($_) }
    } map {
        eval { $_->meta->calculate_all_roles };
    } $class->linearized_isa;

    eval {
        foreach my $scheme (uniq @schemes) {
            $scheme->apply($self);
        }
    };
}


sub _convert_role_to_scheme {
    my ($self, $role) = @_;

    my $name = $role->name;
    return if $name =~ /\|/;
    $name = "MooseX::Runnable::Invocation::Scheme::$name";

    return eval {
        Class::Load::load_class($name);
        warn "$name was loaded OK, but it's not a role!" and return
          unless $name->meta->isa('Moose::Meta::Role');
        return $name->meta;
    };
}

sub validate_class {
    my ($self, $class) = @_;

    my @bad_attributes = map { $_->name } grep {
        $_->is_required && !($_->has_default || $_->has_builder)
    } $class->get_all_attributes;

    confess
       'By default, MooseX::Runnable calls the constructor with no'.
       ' args, but that will result in an error for your class.  You'.
       ' need to provide a MooseX::Runnable::Invocation::Plugin or'.
       ' ::Scheme for this class that will satisfy the requirements.'.
       "\n".
       "The class is @{[$class->name]}, and the required attributes are ".
         join ', ', map { "'$_'" } @bad_attributes
           if @bad_attributes;

    return; # return value is meaningless
}

sub create_instance {
    my ($self, $class, @args) = @_;
    return ($class->name->new, @args);
}

sub start_application {
    my $self = shift;
    my $instance = shift;
    my @args = @_;

    return $instance->run(@args);
}

sub run {
    my $self = shift;
    my @args = @_;

    my $class = $self->load_class;
    $self->apply_scheme($class);
    $self->validate_class($class);
    my ($instance, @more_args) = $self->create_instance($class, @args);
    my $exit_code = $self->start_application($instance, @more_args);
    return $exit_code;
}

1;