view release on metacpan or  search on metacpan

lib/MooX/Options/Role.pm  view on Meta::CPAN

        return $class->options_usage( $params{h}, $cmdline_params{h} );
    }
    if ( $cmdline_params{help} ) {
        return $class->options_help( $params{help}, $cmdline_params{help} );
    }
    if ( $cmdline_params{man} ) {
        return $class->options_man( $cmdline_params{man} );
    }
    if ( $cmdline_params{usage} ) {
        return $class->options_short_usage( $params{usage},
            $cmdline_params{usage} );
    }

    my $self;
    return $self
        if eval { $self = $class->new(%cmdline_params); 1 };
    if ( $@ =~ /^Attribute\s\((.*?)\)\sis\srequired/x ) {
        print STDERR "$1 is missing\n";
    }
    elsif ( $@ =~ /^Missing\srequired\sarguments:\s(.*)\sat\s/x ) {
        my @missing_required = split /,\s/x, $1;
        print STDERR
            join( "\n",
            ( map { $_ . " is missing" } @missing_required ), '' );
    }
    elsif ( $@ =~ /^(.*?)\srequired/x ) {
        print STDERR "$1 is missing\n";
    }
    elsif ( $@ =~ /^isa\scheck.*?failed:\s/x ) {
        print STDERR substr( $@, index( $@, ':' ) + 2 );
    }
    else {
        print STDERR $@;
    }
    %cmdline_params = $class->parse_options( h => 1 );
    return $class->options_usage( 1, $cmdline_params{h} );
}

=head2 parse_options

Parse your options, call L<Getopt::Long::Descriptive> and convert the result for the "new" method.

It is use by "new_with_options".

=cut

my $decode_json;

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

    my %options_data   = $class->_options_data;
    my %options_config = $class->_options_config;
    if ( defined $options_config{skip_options} ) {
        delete @options_data{ @{ $options_config{skip_options} } };
    }

    my ( $options, $has_to_split, $all_options )
        = _options_prepare_descriptive( \%options_data );

    local @ARGV = @ARGV if $options_config{protect_argv};
    @ARGV = _options_fix_argv( \%options_data, $has_to_split, $all_options );

    my @flavour;
    if ( defined $options_config{flavour} ) {
        push @flavour, { getopt_conf => $options_config{flavour} };
    }

    my $prog_name = $class->_options_prog_name();

    # create usage str
    my $usage_str = $options_config{usage_string};
    $usage_str = sprintf( $class->__("USAGE: %s %s"),
        $prog_name, " [-h] [" . $class->__("long options ...") . "]" )
        if !defined $usage_str;

    my ( $opt, $usage ) = describe_options(
        ($usage_str),
        @$options,
        [],
        [ 'usage', $class->__("show a short help message") ],
        [ 'h',     $class->__("show a compact help message") ],
        [ 'help',  $class->__("show a long help message") ],
        [ 'man',   $class->__("show the manual") ],
        ,
        @flavour
    );

    $usage->{prog_name} = $prog_name;
    $usage->{target}    = $class;

    if ( $usage->{should_die} ) {
        return $class->options_usage( 1, $usage );
    }

    my %cmdline_params = %params;
    for my $name ( keys %options_data ) {
        my %data = %{ $options_data{$name} };
        if ( !defined $cmdline_params{$name}
            || $options_config{prefer_commandline} )
        {
            my $val = $opt->$name();
            if ( defined $val ) {
                if ( $data{json} ) {
                    defined $decode_json
                        or $decode_json = eval {
                        use_module("JSON::MaybeXS");
                        JSON::MaybeXS->can("decode_json");
                        };
                    defined $decode_json
                        or $decode_json = eval {
                        use_module("JSON::PP");
                        JSON::PP->can("decode_json");
                        };
                    ## no critic (ErrorHandling::RequireCarping)
                    $@ and die $@;
                    if (!eval {
                            $cmdline_params{$name} = $decode_json->($val);
                            1;
                        }
                        )
                    {
                        print STDERR $@;
                        return $class->options_usage( 1, $usage );
                    }
                }
                else {
                    $cmdline_params{$name} = $val;
                }
            }
        }
    }

    if ( $opt->h() || defined $params{h} ) {
        $cmdline_params{h} = $usage;
    }

    if ( $opt->help() || defined $params{help} ) {
        $cmdline_params{help} = $usage;
    }

    if ( $opt->man() || defined $params{man} ) {
        $cmdline_params{man} = $usage;
    }

    if ( $opt->usage() || defined $params{usage} ) {
        $cmdline_params{usage} = $usage;
    }

    return %cmdline_params;
}

=head2 options_usage

Display help message.

Check full doc L<MooX::Options> for more details.

=cut

sub options_usage {
    my ( $class, $code, @messages ) = @_;
    my $usage;
    if ( @messages
        && ref $messages[-1] eq 'MooX::Options::Descriptive::Usage' )
    {
        $usage = shift @messages;
    }
    $code = 0 if !defined $code;
    if ( !$usage ) {
        local @ARGV = ();
        my %cmdline_params = $class->parse_options( help => $code );
        $usage = $cmdline_params{help};
    }
    my $message = "";
    $message .= join( "\n", @messages, '' ) if @messages;
    $message .= $usage . "\n";
    if ( $code > 0 ) {
        CORE::warn $message;
    }
    else {
        print $message;
    }
    exit($code) if $code >= 0;
    return;
}

=head2 options_help

Display long usage message

=cut

sub options_help {
    my ( $class, $code, $usage ) = @_;
    $code = 0 if !defined $code;

    if ( !defined $usage || !ref $usage ) {
        local @ARGV = ();
        my %cmdline_params = $class->parse_options( help => $code );
        $usage = $cmdline_params{help};
    }
    my $message = $usage->option_help . "\n";
    if ( $code > 0 ) {
        CORE::warn $message;
    }
    else {
        print $message;
    }
    exit($code) if $code >= 0;
    return;
}

=head2 options_short_usage

Display quick usage message, with only the list of options

=cut

sub options_short_usage {
    my ( $class, $code, $usage ) = @_;
    $code = 0 if !defined $code;

    if ( !defined $usage || !ref $usage ) {
        local @ARGV = ();
        my %cmdline_params = $class->parse_options( help => $code );
        $usage = $cmdline_params{help};
    }
    my $message = "USAGE: " . $usage->option_short_usage . "\n";
    if ( $code > 0 ) {
        CORE::warn $message;
    }
    else {
        print $message;
    }
    exit($code) if $code >= 0;
    return;
}

=head2 options_man

Display a pod like a manual

=cut

sub options_man {
    my ( $class, $usage, $output ) = @_;
    local @ARGV = ();
    if ( !$usage ) {
        local @ARGV = ();
        my %cmdline_params = $class->parse_options( man => 1 );
        $usage = $cmdline_params{man};
    }

    use_module( "Path::Class", "0.32" );
    my $man_file
        = Path::Class::file( Path::Class::tempdir( CLEANUP => 1 ),
        'help.pod' );
    $man_file->spew( iomode => '>:encoding(UTF-8)', $usage->option_pod );

    use_module("Pod::Usage");
    Pod::Usage::pod2usage(
        -verbose => 2,
        -input   => $man_file->stringify,
        -exitval => 'NOEXIT',
        -output  => $output
    );

    exit(0);
}

### PRIVATE NEED TO BE EXPORTED

sub _options_prog_name {
    return Getopt::Long::Descriptive::prog_name;
}

sub _options_sub_commands {
    return;
}

### PRIVATE NEED TO BE EXPORTED

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc MooX::ConfigFromFile

You can also look for information at:

=over 4

=item * RT: CPAN's request tracker (report bugs here)

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=MooX-ConfigFromFile>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/MooX-ConfigFromFile>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/MooX-ConfigFromFile>

=item * Search CPAN

L<http://search.cpan.org/dist/MooX-ConfigFromFile/>

=back