File Coverage

blib/lib/MooX/Options.pm

Criterion	Covered	Total	%
statement	95	103	92.2
branch	36	44	81.8
condition	20	21	95.2
subroutine	13	13	100.0
pod			n/a
total	164	181	90.6

package MooX::Options;

use strictures 2;

our $VERSION = "4.101";

use Carp ('croak');
use Module::Runtime qw(use_module);

my @OPTIONS_ATTRIBUTES
    = qw/format short repeatable negatable autosplit autorange doc long_doc order json hidden spacer_before spacer_after/;

sub import {
    my ( undef, @import ) = @_;
    my $options_config = {
        protect_argv              => 1,
        flavour                   => [],
        skip_options              => [],
        prefer_commandline        => 0,
        with_config_from_file     => 0,
        with_locale_textdomain_oo => 0,
        usage_string              => undef,

        #long description (manual)
        description => undef,
        authors     => [],
        synopsis    => undef,
        spacer      => " ",
        @import
    };

    my $target = caller;
    for my $needed_methods (qw/with around has/) {
        next if $target->can($needed_methods);
        croak(    "Can't find the method <$needed_methods> in <$target>!\n"
                . "Ensure to load a Role::Tiny compatible module like Moo or Moose before using MooX::Options."
        );
    }

    my $with   = $target->can('with');
    my $around = $target->can('around');
    my $has    = $target->can('has');

    my @target_isa;
    { no strict 'refs'; @target_isa = @{"${target}::ISA"} };

    if (@target_isa) {    #only in the main class, not a role

        ## no critic (ProhibitStringyEval, ErrorHandling::RequireCheckingReturnValueOfEval, ValuesAndExpressions::ProhibitImplicitNewlines)
        eval "#line ${\(__LINE__+1 . ' ' . __FILE__)}\n" . '{
        package ' . $target . ';
        use MRO::Compat ();

            sub _options_data {
                my ( $class, @meta ) = @_;
                return $class->maybe::next::method(@meta);
            }

            sub _options_config {
                my ( $class, @params ) = @_;
                return $class->maybe::next::method(@params);
            }

        1;
        }';

        croak($@) if $@;

        $around->(
            _options_config => sub {
                my ( $orig, $self ) = ( shift, shift );
                return $self->$orig(@_), %$options_config;
            }
        );

        ## use critic
    }
    else {
        if ( $options_config->{with_config_from_file} ) {
            croak(
                "Please, don't use the option  into a role."
            );
        }
    }

    my $options_data = {};
    if ( $options_config->{with_config_from_file} ) {
        $options_data->{config_prefix} = {
            format => 's',
            doc    => 'config prefix',
            order  => 0,
        };
        $options_data->{config_files} = {
            format => 's@',
            doc    => 'config files',
            order  => 0,
        };
    }

    my $apply_modifiers = sub {
        return if $target->can('new_with_options');
        $with->('MooX::Options::Role');
        if ( $options_config->{with_config_from_file} ) {
            $with->('MooX::ConfigFromFile::Role');
        }
        if ( $options_config->{with_locale_textdomain_oo} ) {
            $with->('MooX::Locale::TextDomain::OO');
            use_module("MooX::Options::Descriptive::Usage");
            MooX::Options::Descriptive::Usage->can("localizer")
                or MooX::Options::Descriptive::Usage->can("with")
                ->("MooX::Locale::TextDomain::OO");
        }

        $around->(
            _options_data => sub {
                my ( $orig, $self ) = ( shift, shift );
                return ( $self->$orig(@_), %$options_data );
            }
        );
    };

    my @banish_keywords
        = qw/h help man usage option new_with_options parse_options options_usage _options_data _options_config/;
    if ( $options_config->{with_config_from_file} ) {
        push @banish_keywords, qw/config_files config_prefix config_dirs/;
    }

    my $option = sub {
        my ( $name, %attributes ) = @_;
        for my $ban (@banish_keywords) {
            croak(
                "You cannot use an option with the name '$ban', it is implied by MooX::Options"
            ) if $name eq $ban;
        }

        my %_moo_attrs = _filter_attributes(%attributes);
        $has->( $name => %_moo_attrs ) if %_moo_attrs;

        ## no critic (RegularExpressions::RequireExtendedFormatting)
        $name =~ s/^\+//;    # one enhances an attribute being an option
        $options_data->{$name}
            = { _validate_and_filter_options(%attributes) };

        $apply_modifiers->();
        return;
    };

    if ( my $info = $Role::Tiny::INFO{$target} ) {
        $info->{not_methods}{$option} = $option;
    }

    { no strict 'refs'; *{"${target}::option"} = $option; }

    $apply_modifiers->();

    return;
}

my %filter_key = map { $_ => 1 } ( @OPTIONS_ATTRIBUTES, 'negativable' );

sub _filter_attributes {
    my %attributes = @_;
    return map { ( $_ => $attributes{$_} ) }
        grep { !exists $filter_key{$_} } keys %attributes;
}

sub _validate_and_filter_options {
    my (%options) = @_;
    $options{doc} = $options{documentation} if !defined $options{doc};
    $options{order} = 0 if !defined $options{order};

    if ( $options{json}
        || ( defined $options{format} && $options{format} eq 'json' ) )
    {
        delete $options{repeatable};
        delete $options{autosplit};
        delete $options{autorange};
        delete $options{negativable};
        delete $options{negatable};
        $options{json}   = 1;
        $options{format} = 's';
    }

    if ( $options{autorange} and not defined $options{autosplit} ) {

# XXX maybe we should warn here since a previously beloved feature isn't enabled automatically
        eval { use_module("Data::Record"); use_module("Regexp::Common"); }
            and $options{autosplit} = ',';
    }

    exists $options{negativable}
        and $options{negatable} = delete $options{negativable};

    my %cmdline_options = map { ( $_ => $options{$_} ) }
        grep { exists $options{$_} } @OPTIONS_ATTRIBUTES, 'required';

    $cmdline_options{repeatable} = 1
        if $cmdline_options{autosplit} or $cmdline_options{autorange};
    $cmdline_options{format} .= "@"
        if $cmdline_options{repeatable}
        && defined $cmdline_options{format}
        && substr( $cmdline_options{format}, -1 ) ne '@';

    croak(
        "Negatable params is not usable with non boolean value, don't pass format to use it !"
        )
        if ( $cmdline_options{negatable} )
        and defined $cmdline_options{format};

    return %cmdline_options;
}

1;

__END__