view release on metacpan or  search on metacpan

lib/MooseX/Getopt/Basic.pm  view on Meta::CPAN

package MooseX::Getopt::Basic;
# ABSTRACT: MooseX::Getopt::Basic - role to implement the Getopt::Long functionality

our $VERSION = '0.78';

use Moose::Role;

use MooseX::Getopt::OptionTypeMap;
use MooseX::Getopt::Meta::Attribute;
use MooseX::Getopt::Meta::Attribute::NoGetopt;
use MooseX::Getopt::ProcessedArgv;
use Try::Tiny;
use Carp ();

use Getopt::Long 2.37 ();
use namespace::autoclean;

has ARGV       => (is => 'rw', isa => 'ArrayRef', traits => ['NoGetopt']);
has extra_argv => (is => 'rw', isa => 'ArrayRef', traits => ['NoGetopt']);

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

    my $constructor_params = ( @params == 1 ? $params[0] : {@params} );

    my $config_from_file;
    if($class->meta->does_role('MooseX::ConfigFromFile')) {
        local @ARGV = @ARGV;

        # just get the configfile arg now out of @ARGV; the rest of the args
        # will be fetched later
        my $configfile;
        my $opt_parser = Getopt::Long::Parser->new( config => [ qw( no_auto_help pass_through no_auto_version ) ] );
        $opt_parser->getoptions( "configfile=s" => \$configfile );

        my $cfmeta = $class->meta->find_attribute_by_name('configfile');
        my $init_arg = $cfmeta->init_arg;

        # was it passed to the constructor?
        if (!defined $configfile)
        {
            $configfile = $constructor_params->{$init_arg} if defined $init_arg;
        }

        if(!defined $configfile) {
            # this is a classic legacy usecase documented in
            # MooseX::ConfigFromFile that we should continue to support
            $configfile = try { $class->configfile };

            $configfile = $cfmeta->default
                if not defined $configfile and $cfmeta->has_default;

            # note that this will die horribly if the default sub depends on
            # other attributes
            $configfile = $configfile->($class) if ref $configfile eq 'CODE';
            if (defined $configfile) {
                $config_from_file = try {
                    $class->get_config_from_file($configfile);
                }
                catch {
                    die $_ unless /Specified configfile '\Q$configfile\E' does not exist/;
                };
            }

            $constructor_params->{$init_arg} = $configfile
                if defined $configfile and defined $init_arg;
        }
        else {
            $config_from_file = $class->get_config_from_file($configfile);
        }
    }

    Carp::croak("Single parameters to new_with_options() must be a HASH ref")
        unless ref($constructor_params) eq 'HASH';

    my %processed = $class->_parse_argv(
        options => [
            $class->_attrs_to_options( $config_from_file )
        ],
        params => $config_from_file ? { %$config_from_file, %$constructor_params } : $constructor_params,
    );

    my $params = $config_from_file ? { %$config_from_file, %{$processed{params}} } : $processed{params};

    # did the user request usage information?
    if ( $processed{usage} and $params->{help_flag} ) {
        $class->print_usage_text($processed{usage});
        exit 0;
    }

    return MooseX::Getopt::ProcessedArgv->new(
         argv_copy          => $processed{argv_copy},
         extra_argv         => $processed{argv},
         usage              => $processed{usage},
         constructor_params => $constructor_params, # explicit params to ->new
         cli_params         => $params, # params from CLI
    );
}

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

    my $pa = $class->process_argv(@params);

    # $pa->constructor_params contains everything passed to new_with_options,
    # so it may contain the "argv" key, which may not exist on the class
    my %constructor_params = %{ $pa->constructor_params };
    delete $constructor_params{argv} if (not $class->meta->find_attribute_by_name('argv'));

    $class->new(
        ARGV       => $pa->argv_copy,
        extra_argv => $pa->extra_argv,
        ( $pa->usage ? ( usage => $pa->usage ) : () ),
        %constructor_params,  # explicit params to ->new
        %{ $pa->cli_params }, # params from CLI
    );
}

sub _getopt_spec { shift->_traditional_spec(@_); }

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

    local @ARGV = @{ $params{params}{argv} || \@ARGV };

    my ( $opt_spec, $name_to_init_arg ) = $class->_getopt_spec(%params);

    # Get a clean copy of the original @ARGV
    my $argv_copy = [ @ARGV ];

    my @warnings;
    my ( $parsed_options, $usage ) = try {
        local $SIG{__WARN__} = sub { push @warnings, @_ };

        return $class->_getopt_get_options(\%params, $opt_spec);
    }
    catch {
        $class->_getopt_spec_exception(\@warnings, $_);
    };

    $class->_getopt_spec_warnings(@warnings) if @warnings;

    # Get a copy of the Getopt::Long-mangled @ARGV
    my $argv_mangled = [ @ARGV ];

    my %constructor_args = (
        map {
            $name_to_init_arg->{$_} => $parsed_options->{$_}
        } keys %$parsed_options,
    );

    return (
        params    => \%constructor_args,
        argv_copy => $argv_copy,
        argv      => $argv_mangled,
        ( defined($usage) ? ( usage => $usage ) : () ),
    );
}

sub _getopt_get_options {
    my ($class, $params, $opt_spec) = @_;
    my %options;
    Getopt::Long::GetOptions(\%options, @$opt_spec);
    return ( \%options, undef );
}

sub _getopt_spec_warnings { }

sub _getopt_spec_exception {
    my ($self, $warnings, $exception) = @_;
    die @$warnings, $exception;
}

# maintained for backwards compatibility only
sub _getopt_full_usage
{
    my ($self, $usage) = @_;
    print $usage->text;
}
#(this is already documented in MooseX::Getopt. But FIXME later, via RT#82195)
#pod =for Pod::Coverage
#pod     print_usage_text
#pod =cut
sub print_usage_text { shift->_getopt_full_usage(@_) }