* Perltidy.

[gitmo/MooseX-Getopt.git] / lib / MooseX / Getopt / Parser / Descriptive.pm

package MooseX::Getopt::Parser::Descriptive;

use Moose;

with 'MooseX::Getopt::Parser';

use MooseX::Getopt::OptionTypeMap;

use Getopt::Long::Descriptive ();


# Special configuration for parser
has config => (
    is      => 'rw',
    isa     => 'ArrayRef[Str]',
    default => sub { ['default'] },
);

# Format for usage description
has format => (
    is      => 'rw',
    isa     => 'Str',
    default => 'usage: %c %o',
);

# Usage object
has usage => (
    is        => 'rw',
    isa       => 'Maybe[Getopt::Long::Descriptive::Usage]',
    predicate => 'has_usage',
);


sub build_options {
    my $self = shift;
    my ( $getopt, @attrs ) = @_;

    Moose->throw_error("First argument is not a MooseX::Getopt::Session")
        unless $getopt->isa('MooseX::Getopt::Session');

    my $options     = $getopt->options;
    my $new_options = {};

    my $usage;
    my ( @opts, %cmd_flags_to_names );

    foreach my $attr (@attrs) {
        my $name = $attr->name;

        my ( $flag, @aliases ) = $getopt->_get_cmd_flags_for_attr($attr);
        my $type = $getopt->_get_cmd_type_for_attr($attr);

        my $opt_string = join '|', $flag, @aliases;
        $opt_string .= MooseX::Getopt::OptionTypeMap->get_option_type($type)
            if $type;

        # opt_string is unmangled; parsed options keys are mangled
        $flag =~ tr/-/_/;
        $cmd_flags_to_names{$flag} = $name;

        my $doc;
        $doc = $attr->documentation if $attr->has_documentation;
        $doc = ' ' unless $doc;

        my $is_required = !exists $options->{$name}
                          && $attr->is_required
                          && !$attr->has_default
                          && !$attr->has_builder;

        push @opts, [
            $opt_string => $doc,
            {
                ( $is_required ? ( required => $attr->is_required ) : () ),
            },
        ];
    };

    my $warnings = '';

    GETOPT: {
        local @ARGV = @{ $getopt->ARGV };

        local $SIG{__WARN__} = sub {
            $warnings .= $_[0];
        };

        eval {
            ( $new_options, $usage ) =
                Getopt::Long::Descriptive::describe_options(
                    $self->format,
                    @opts,
                    { getopt_conf => $self->config }
                );
        };
        $warnings .= $@ if $@;

        my $extra_argv = \@ARGV;
        $getopt->extra_argv($extra_argv);
    };

    # Store usage object
    $self->usage( $usage );

    # Convert cmd_flags back to names in options hashref
    $new_options = {
        map { $cmd_flags_to_names{$_} => $new_options->{$_} }
            keys %$new_options
    };

    # Include old options
    $new_options = { %$options, %$new_options };

    $getopt->status( ! $warnings );
    $getopt->options( $new_options );

    die $warnings if $warnings;

    return $new_options;
};


1;


__END__

=pod

=head1 NAME

MooseX::Getopt::Parser::Descriptive - A Getopt::Long::Descriptive parser for MooseX::Getopt

=head1 SYNOPSIS

  use MooseX::Getopt::Parser::Descriptive;

  my $parser = MooseX::Getopt::Parser::Descriptive->new(
      format => 'Usage: %c %o',
      config => ['pass_through']
  );
  my $getopt = MooseX::Getopt::Session->new( parser => $parser );
  my $app = My::App->new( getopt => $getopt );

=head1 DESCRIPTION

This class does L<MooseX::Getopt::Parser> for L<MooseX::Getopt>.  This
class is used by default if L<Getopt::Long::Descriptive> module is
missing.

=head1 METHODS

=over 4

=item B<build_options ($getopt, @attrs)>

This method parses the CLI options with L<Getopt::Long> and returns a hashref to options list.

The first argument have to be L<MooseX::Getopt::Session> object and
second argument is a list of attributes which contains options.

=item B<config>

This accessor contains the arrayref to list with special configuration
keywords for L<Getopt::Long>.

=item B<format>

This accessor contains the string with message printed by
L<Getopt::Long::Descriptive> if error is occured.

=back

=head1 BUGS

All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.

=head1 SEE ALSO

=over 4

=item L<MooseX::Getopt::Parser>

=item L<MooseX::Getopt::Parser::Default>

=item L<MooseX::Getopt::Parser::Long>

=item L<Getopt::Long::Descriptive>

=back

=head1 AUTHOR

Piotr Roszatycki, E<lt>dexter@cpan.orgE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2007-2008 by Infinity Interactive, Inc.

L<http://www.iinteractive.com>

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut