File Coverage

blib/lib/MooseX/Getopt/Usage.pm

Criterion	Covered	Total	%
statement	4	6	66.6
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	6	8	75.0

package MooseX::Getopt::Usage;

use 5.010;
our $VERSION = '0.24';

use Moose::Role;
use Try::Tiny;
use MooseX::Getopt::Usage::Formatter;

with 'MooseX::Getopt::Basic';

# As we don't use GLD insert our own help_flag.
has help_flag => (
    is            => 'rw',
    isa           => 'Bool',
    traits        => ['Getopt'],
    cmd_flag      => 'help',
    cmd_aliases   => [qw/? usage/],
    documentation => "Display the usage message and exit"
);

# Promote warnings to errors to capture invalid and missing options errors from
# Getopt::Long::GetOptions.
around _getopt_spec_warnings => sub {
    shift; my $class = shift;
    die @_;
};

sub getopt_usage_config { () }

sub getopt_usage {
    my $proto = shift;
    my $class = ref $proto || $proto;
    my %args  = @_;
    my $conf  = { $class->getopt_usage_config, %args };
    if ( ! exists $conf->{colours} && exists $conf->{colors} ) {
        $conf->{colours} = delete $conf->{colors}
    }
    $conf->{getopt_class} = $class;
    my $fmtr = MooseX::Getopt::Usage::Formatter->new($conf);
    return $args{man} ? $fmtr->manpage(%args) : $fmtr->usage(%args);
}

# Replace new_with_options.  The way it decides if usage is needed does not fit
# our needs as we don't supply a usage object. So we do it here.  We also want
# access to the $pa object returned from process_argv.
around new_with_options => sub {
    my $orig  = shift;
    my $class = shift;
    my @params = @_;
    my $self;

    my $conf = { $class->getopt_usage_config };
    $conf->{auto_man} = 1 if not exists $conf->{auto_man};
    $conf->{auto_help} = 1 if not exists $conf->{auto_help};

    try {
        # Get in early on the arg passing to look for help or man options.
        # This makes sure they still work even when required options are missing,
        # (which would fail construction and stop us seeing the man option).
        # See github issue #4
        my $pa = $class->process_argv(@params);
        my $cli_params = $pa->cli_params;
        $class->getopt_usage( man => 1)
            if $conf->{auto_man} and $class->can('man') and $cli_params->{man};
        $class->getopt_usage( exit => 0 )
            if $conf->{auto_help} and $cli_params->{help_flag};

        # Construct the object in the same way as our super new_with_options
        $self = $class->new(
            ARGV       => $pa->argv_copy,
            extra_argv => $pa->extra_argv,
            ( $pa->usage ? ( usage => $pa->usage ) : () ),
            %{ $pa->constructor_params }, # explicit params to ->new
            %{ $pa->cli_params }, # params from CLI
        );
        return $self;
    }
    catch {
        if (
            /Attribute \((\w+)\) does not pass the type constraint because: (.*?) at/
        ) {
            $class->getopt_usage( exit => 1, err => "Invalid '$1' : $2" );
        }
        elsif (/Attribute \((\w+)\) is required /) {
            $class->getopt_usage( exit => 2, err => "Required option missing: $1" );
        }
        elsif (/^Unknown option:|^Value .*? for option |Option .* does not take an argument/) {
            # Getopt::Long warnings we promoted in _getopt_spec_warnings
            s/\n+$//;
            $class->getopt_usage( exit => 3, err => $_ );
        }
        else {
            die $_;
        }
    };
};

no Moose::Role;

1;
__END__