—

              
# ABSTRACT: App::Spec framework to run your app
use strict;
use warnings;
package App::Spec::Run;
use 5.010;
our $VERSION = '0.013'; # VERSION
use App::Spec::Run::Validator;
use App::Spec::Run::Response;
use Getopt::Long qw/ :config pass_through bundling /;
use Ref::Util qw/ is_arrayref /;
use Moo;
has spec => ( is => 'ro' );
has options => ( is => 'rw' );
has parameters => ( is => 'rw', default => sub { +{} } );
has commands => ( is => 'rw' );
has argv => ( is => 'rw' );
has argv_orig => ( is => 'rw' );
#has runmode => ( is => 'rw', default => 'normal' );
has validation_errors => ( is => 'rw' );
has op => ( is => 'rw' );
has cmd => ( is => 'rw' );
has response => ( is => 'rw', default => sub { App::Spec::Run::Response->new } );
has subscribers => ( is => 'rw', default => sub { +{} } );
my %EVENTS = (
    print_output => 1,
    global_options => 1,
);
sub process {
    my ($self) = @_;
    my $plugins = $self->spec->plugins || [];
    for my $plugin (@$plugins) {
        $plugin->init_run($self);
    }
    my @callbacks;
    my $subscriber_events = $self->subscribers;
    for my $key (qw/ global_options print_output /) {
        my $subscribers = $subscriber_events->{ $key };
        for my $sub (@$subscribers) {
            my $plugin = $sub->{plugin};
            my $method = $sub->{method};
            my $callback = sub {
                $plugin->$method( run => $self, @_);
            };
            push @callbacks, $callback;
        }
        $self->response->add_callbacks($key => \@callbacks);
    }
    my $argv = $self->argv;
    unless ($argv) {
        $argv = \@ARGV;
        $self->argv($argv);
        $self->argv_orig([ @$argv ]);
    }
    my $completion_parameter = $ENV{PERL5_APPSPECRUN_COMPLETION_PARAMETER};
    my %option_specs;
    my %param_specs;
    unless ($self->op) {
        $self->process_input(
            option_specs => \%option_specs,
            param_specs => \%param_specs,
        );
    }
    unless ($self->response->halted) {
        my $opt = App::Spec::Run::Validator->new({
            options => $self->options,
            option_specs => \%option_specs,
            parameters => $self->parameters,
            param_specs => \%param_specs,
        });
        my %errs;
        my $ok = $opt->process( $self, \%errs );
        unless ($ok) {
            $self->validation_errors(\%errs);
            # if we are in completion mode, some errors might be ok
            if (not $completion_parameter) {
                $self->error_output;
            }
        }
    }
    unless ($self->response->halted) {
        my $op = $self->op;
        if ($completion_parameter) {
            $self->completion_output(
                param_specs => \%param_specs,
                option_specs => \%option_specs,
                completion_parameter => $completion_parameter,
            );
        }
        else {
            $self->run_op($op);
        }
    }
}
sub run {
    my ($self) = @_;
    $self->process;
#    $self->event_processed;
    $self->finish;
}
sub run_op {
    my ($self, $op, $args) = @_;
    $self->cmd->$op($self, $args);
}
sub out {
    my ($self, $text) = @_;
    $text .= "\n" if (not ref $text and $text !~ m/\n\z/);
    $self->response->add_output($text);
}
sub err {
    my ($self, $text) = @_;
    $text .= "\n" if (not ref $text and $text !~ m/\n\z/);
    $self->response->add_error($text);
}
sub halt {
    my ($self, $exit) = @_;
    $self->response->halted(1);
    $self->response->exit($exit || 0);
}
sub finish {
    my ($self) = @_;
    my $res = $self->response;
    $res->print_output;
    $res->finished(1);
    if (my $exit = $res->exit) {
        exit $exit;
    }
}
sub completion_output {
    my ($self, %args) = @_;
    my $completion_parameter = $args{completion_parameter};
    my $param_specs = $args{param_specs};
    my $option_specs = $args{option_specs};
    my $shell = $ENV{PERL5_APPSPECRUN_SHELL} or return;
    my $param = $param_specs->{ $completion_parameter };
    $param ||= $option_specs->{ $completion_parameter };
    my $unique = $param->{unique};
    my $completion = $param->completion or return;
    my $op;
    if (ref $completion) {
        $op = $completion->{op} or return;
    }
    else {
        my $possible_values = $param->values or return;
        $op = $possible_values->{op} or return;
    }
    my $args = {
        runmode => "completion",
        parameter => $completion_parameter,
    };
    my $result = $self->run_op($op, $args);
    my $string = '';
    my %seen;
    if ($unique) {
        my $params = $self->parameters;
        my $value = $params->{ $completion_parameter };
        $value = [$value] unless is_arrayref $value;
        # cmd param1 param2<TAB> results in
        # @ARGV = ["param1", "param2"]
        # cmd param1 param2 <TAB> results in
        # @ARGV = ["param1", "param2", ""]
        # so we know that there is a new value to be completed
        my $last = pop @$value;
        @seen{ @$value } = (1) x @$value;
    }
    for my $item (@$result) {
        if (ref $item eq 'HASH') {
            my $name = $item->{name};
            $unique and $seen{ $name }++ and next;
            my $desc = $item->{description};
            $string .= "$name\t$desc\n";
        }
        else {
            $unique and $seen{ $item }++ and next;
            $string .= "$item\n";
        }
    }
    $self->out($string);
    return;
}
sub error_output {
    my ($self) = @_;
    my $errs = $self->validation_errors;
    my @error_output;
    for my $key (sort keys %$errs) {
        my $errors = $errs->{ $key };
        if ($key eq "parameters" or $key eq "options") {
            for my $name (sort keys %$errors) {
                my $error = $errors->{ $name };
                $key =~ s/s$//;
                push @error_output, "Error: $key '$name': $error";
            }
        }
        else {
            require Data::Dumper;
            my $err = Data::Dumper->Dump([$errs], ['errs']);
            push @error_output, $err;
        }
    }
    my $help = $self->spec->usage(
        commands => $self->commands,
        highlights => $errs,
        colored => $self->colorize_code('err'),
    );
    $self->err($help);
    for my $msg (@error_output) {
        $msg = $self->colored('err', [qw/ error /], $msg);
        $self->err("$msg\n");
    }
    $self->halt(1);
}
sub colorize_code {
    my ($self, $out) = @_;
    $self->colorize($out)
        ? sub {
            my $colored = $self->colored($out, $_[0], $_[1]);
            unless (defined wantarray) {
                $_[1] = $colored;
            }
            return $colored;
        }
        : sub { $_[1] },
}
sub colorize {
    my ($self, $out) = @_;
    $out ||= 'out';
    if (($ENV{PERL5_APPSPECRUN_COLOR} // '') eq 'always') {
        return 1;
    }
    if (($ENV{PERL5_APPSPECRUN_COLOR} // '') eq 'never') {
        return 0;
    }
    if ($out eq 'out' and -t STDOUT or $out eq 'err' and -t STDERR) {
        return 1;
    }
    return 0;
}
sub process_parameters {
    my ($self, %args) = @_;
    my $param_list = $args{parameter_list};
    my $parameters = $self->parameters;
    my $param_specs = $args{param_specs};
    for my $p (@$param_list) {
        my $name = $p->name;
        my $type = $p->type;
        my $multiple = $p->multiple;
        my $required = $p->required;
        my $value;
        if ($multiple) {
            $value = [@{ $self->argv }];
            @{ $self->argv } = ();
        }
        else {
            $value = shift @{ $self->argv };
        }
        $parameters->{ $name } = $value;
        $param_specs->{ $name } = $p;
    }
}
sub process_input {
    my ($self, %args) = @_;
    my %options;
    $self->options(\%options);
    my @cmds;
    my $spec = $self->spec;
    my $option_specs = $args{option_specs};
    my $param_specs = $args{param_specs};
    my $global_options = $spec->options;
    my $global_parameters = $spec->parameters;
    my @getopt = $spec->make_getopt($global_options, \%options, $option_specs);
    GetOptions(@getopt);
    $self->event_globaloptions;
    my $op = $self->op;
    $self->process_parameters(
        parameter_list => $global_parameters,
        param_specs => $param_specs,
    );
    my $commands = $spec->subcommands;
    my $opclass = $self->spec->class;
    my $cmd_spec;
    my $subcommand_required = 1;
    while (keys %$commands) {
        my $cmd = shift @{ $self->argv };
        if (not defined $cmd) {
            if (not $op or $subcommand_required) {
                $self->err($spec->usage(
                    commands => \@cmds,
                    colored => $self->colorize_code('err'),
                    highlights => {
                        subcommands => 1,
                    },
                ));
                $self->err( $self->colorize_error("Missing subcommand(s)") );
                $self->halt(1);
            }
            last;
        }
        $cmd_spec = $commands->{ $cmd } or do {
            $self->err($spec->usage(
                commands => \@cmds,
                colored => $self->colorize_code('err'),
                highlights => {
                    subcommands => 1,
                },
            ));
            $self->err( $self->colorize_error("Unknown subcommand '$cmd'") );
            $self->halt(1);
            last;
        };
        $subcommand_required = $cmd_spec->{subcommand_required} // 1;
        my $cmd_options = $cmd_spec->options;
        my @getopt = $spec->make_getopt($cmd_options, \%options, $option_specs);
        GetOptions(@getopt);
        push @cmds, $cmd;
        $commands = $cmd_spec->subcommands || {};
        $op = '::' . $cmd_spec->op if $cmd_spec->op;
        $opclass = $cmd_spec->class if $cmd_spec->class;
        $self->process_parameters(
            parameter_list => $cmd_spec->parameters,
            param_specs => $param_specs,
        );
    }
    unless ($self->response->halted) {
        unless ($op) {
            if ($spec->has_subcommands) {
                $self->err( "Missing op for commands (@cmds)\n" );
                my $help = $spec->usage(
                    commands => \@cmds,
                    colored => $self->colorize_code('err'),
                );
                $self->err( $help );
                $self->halt(1);
            }
            else {
                $op = "::execute";
            }
        }
        $self->commands(\@cmds);
        $self->options(\%options);
        if ($op =~ m/^::/) {
            $op = $opclass . $op;
        }
        $self->op($op);
        return $op;
    }
    return;
}
sub colorize_error {
    my ($self, $msg) = @_;
    $msg = $self->colored('err', [qw/ error /], $msg) . "\n";
}
sub colored {
    my ($self, $out, $colors, $msg) = @_;
    $colors = [ map { $_ eq 'error' ? qw/ bold red / : $_ } @$colors ];
    require Term::ANSIColor;
    $self->colorize($out)
        and $msg = Term::ANSIColor::colored($colors, $msg);
    return $msg;
}
sub subscribe {
    my ($self, %args) = @_;
    for my $event (sort keys %args) {
        next unless exists $EVENTS{ $event };
        my $info = $args{ $event };
        push @{ $self->subscribers->{ $event } }, $info;
    }
}
sub event_globaloptions {
    my ($self) = @_;
    my $subscribers = $self->subscribers->{global_options};
    for my $sub (@$subscribers) {
        my $plugin = $sub->{plugin};
        my $method = $sub->{method};
        $plugin->$method( run => $self);
    }
}
#sub event_processed {
#    my ($self) = @_;
#    my $plugins = $self->spec->plugins_by_type->{GlobalOptions};
#    for my $plugin (@$plugins) {
#        next unless $plugin->can("event_processed");
#        $plugin->event_processed(
#            run => $self,
#        );
#    }
#}
1;
HideShow 248 lines of Pod
__END__
=pod
=head1 NAME
App::Spec::Run - App::Spec framework to run your app
=head1 DESCRIPTION
App::Spec::Run is the framework which runs your app defined by the spec.
Your app class should inherit from L<App::Spec::Run::Cmd>.
=head1 SYNOPSIS
    sub your_command {
        my ($self, $run) = @_;
        my $options = $run->options;
        $run->out("It works");
    }
=head1 METHODS
=over 4
=item Constructor
You can create the object yourself like this:
    my $run = App::Spec::Run->new(
        spec => $appspec,
        cmd => App::YourApp->new,
    );
Or you use the runner method of L<App::Spec>, which will create it for you:
    my $run = $appspec->runner(...);
Both methods take optional arguments:
    my $run = App::Spec::Run->new(
        spec => $appspec,
        cmd => App::YourApp->new,
        # Custom array instead of the default ARGV.
        # The contents of this array will be modified
        argv => \@my_arguments,
    );
=item run
    $run->run;
Actually runs your app. Calls C<process> and C<finish>.
=item process
    $run->process;
Processes input, validates, runs your command and fills the
response object.
Does not print the output and does not exit.
=item out
    $run->out("Hello world!");
Appends to response output. Adds a newline if not present. You can also
pass a data structure:
    $run->out($hashref);
This will be formatted with L<Data::Dumper>.
See also L<App::Spec::Plugin::Format>.
=item err
    $run->err("Oops, that went wrong");
Appends to response error output. Adds a newline if not present
=item halt
    $run->halt;
Further processing is halted.
=item finish
    $run->finish;
Prints the output and exits with the exit code stored in C<response>.
=item process_input
    $run->process_input(
        option_specs => \%option_specs,
        param_specs => \%param_specs,
    );
=item process_parameters
    $run->process_parameters(
        parameter_list => $global_parameters,
        param_specs => $param_specs,
    );
=item run_op
    $run->run_op("yourcommand");
    # shortcut for
    $run->cmd->yourcommand($run);
=item completion_output
    $run->completion_output(
        param_specs => \%param_specs,
        completion_parameter => $completion_parameter,
    );
Is called when in completion mode
=item colored
Returns the given text colored, if colors are active for the given
output.
    $msg = $run->colored('err', [qw/ error /], "Oops");
    $msg = $run->colored('out', [qw/ green /], "Everything is fine!");
=item colorize
    my $color_active = $run->colorize('out');
    my $color_error_active = $run->colorize('err');
Returns 1 or 0 if given output color are active. That means, the output
is going to a terminal instead of being redirected.
=item colorize_code
    my $colored = $run->colorize_code('out');
    my $text = $colored->(['green'], "Hurray");
    # or
    my $text = "Hurray";
    $colored->(['green'], $text);
Returns a coderef which you can use for coloring
=item colorize_error
    my $msg = $run->colorize_error("ouch");
Returns the message in the standard error color (bold red).
=item error_output
    $run->error_output;
Outputs any errors.
Calls C<halt>
=item event_globaloptions
Calls any plugin that needs to know
=item subscribe
A plugin can subscribe for an event:
    $run->subscribe(
        print_output => {
            plugin => $self,
            method => "print_output",
        },
=back
=head1 ATTRIBUTES
=over 4
=item spec
Your spec, (App::Spec)
=item options
A hashref with the given options
    {
        verbose => 1,
        foo => 23,
    }
=item parameters
A hashref with the given parameters
=item commands
An arrayref containing all subcommands from the commandline
=item argv_orig
This contains the original contents of C<argv> before processing
=item argv
This is a reference to the commandline arguments array C<@ARGV>, or the
array reference you specified otherwise. When calling your command method,
it will contain the rest of the arguments which weren't processed as
any subcommand, option or parameter.
=item validation_errors
Contains errors from option/parameter validation
=item op
Contains the operation (subroutine) which will be executed to run
yor command
=item cmd
This is an instance of your app class
=item response
This contains the response of your command (exit code, output, ...)
See L<App::Spec::Run::Response>
=item subscribers
Contains a hashref
    {
        print_output => {
            module => $plugin,
            method => 'print_output',
        },
    }
=back
=cut