view release on metacpan or  search on metacpan

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

    return;
} # end parse_command_line()


sub _getopt_get_option_attributes {
    my ($self) = @_;

    my $metadata = $self->meta();
    my @option_attributes =
        grep {
            $_->does('MooseX::Getopt::Defanged::Meta::Attribute::Trait::_Getopt')
        }
        $metadata->get_all_attributes();

    return \@option_attributes;
} # end _getopt_get_option_attributes()


sub _getopt_invoke_getopt_long {
    my ($self, $argv_ref) = @_;

    my $stderr;

    my $parser = Getopt::Long::Parser->new(
        config => [
            # Unfortunately, bundling is incompatible with allowing multiple
            # values for a given option (why I don't know, but Getopt::Long
            # complains if gnu_getopt, and thus bundling, is turned on).
            qw<
                no_auto_abbrev
                no_auto_help
                no_auto_version
                no_bundling
                no_getopt_compat
                   gnu_compat
                no_ignore_case
                   permute
            >
        ],
    );

    my @option_attributes =
        @{ $self->_getopt_get_option_attributes() };
    my $type_metadata = $self->get_option_type_metadata();
    my %option_values =
        map { ## no critic (Lax::ProhibitComplexMappings::LinesNotStatements)
                $_->get_actual_option_name()
            =>  $_->get_stringified_value_or_default($self, $type_metadata)
        }
        grep {
            defined $_->get_stringified_value_or_default($self, $type_metadata)
        }
            @option_attributes;
    my @specification_strings =
        map { $_->get_full_specification($type_metadata) } @option_attributes;

    my $parse_worked;

    {
        local @ARGV = @{$argv_ref};

        open my $stderr_handle, '>', \$stderr;
        $parse_worked = _getopt_invoke_getopt_long_while_handling_exceptions(
            $parser, $stderr_handle, \%option_values, \@specification_strings,
        );
        close $stderr_handle;

        $self->_set_remaining_argv( [ @ARGV ] );
    } # end scoping block

    throw_user $stderr // 'Could not parse command-line.'
        if not $parse_worked;

    return \%option_values;
} # end _getopt_invoke_getopt_long()


# If an exception is unhandled while STDERR is localized, STDERR never gets
# un-localized, meaning that the error never gets emitted to the real STDERR.
# So we run Getopt::Long::Parser::getoptions() inside of an eval and rethrow
# any exception after STDERR is no longer localized.
sub _getopt_invoke_getopt_long_while_handling_exceptions {
    my ($parser, $stderr_handle, $option_values_ref, $specification_strings_ref)
        = @_;

    my $getopt_error;
    my $parse_worked;
    {
        local *STDERR = $stderr_handle;

        eval {
            $parse_worked =
                $parser->getoptions(
                    $option_values_ref, @{$specification_strings_ref},
                );
            1;
        }
            or do {
                $getopt_error =
                        $EVAL_ERROR
                    //  'Getopt::Long::Parser::getoptions() failed for an unknown reason.';
            };
    } # end scoping block

    if (defined $getopt_error) {
        throw_generic $getopt_error;
    } # end if

    return $parse_worked;
} # end _getopt_invoke_getopt_long_while_handling_exceptions()


sub _getopt_assign_option_values {
    my ($self, $option_values_ref) = @_;

    my $type_metadata = $self->get_option_type_metadata();

    my $error_message;
    foreach my $option_attribute (
        @{ $self->_getopt_get_option_attributes() }