* MooseX::Getopt::Session: Drop die_on_warning attribute.

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

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

use Moose;

with 'MooseX::Getopt::Parser';

use Getopt::Long::Descriptive;
use MooseX::Getopt::OptionTypeMap;

#use Smart::Comments;

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

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


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 = {};
    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);

	$cmd_flags_to_names{$flag} = $name;

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

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

        my $is_required = $attr->is_required && !$attr->has_default && !$attr->has_builder;

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

    ### MooseX::Getopt::Parser::Descriptive::build_options @opts : @opts

    GETOPT: {
        local @ARGV = $getopt->argv;
        ### MooseX::Getopt::Parser::Descriptive::build_options @ARGV : @ARGV

        local $SIG{__WARN__} = sub {
            return warn @_ if $_[0]=~/^\###/;   # Smart::Comments
            $getopt->strcat_warning( $_[0] )
        };

        eval {
            ($options, $usage) = Getopt::Long::Descriptive::describe_options(
                $self->format, @opts, { getopt_conf => [ $self->config ] }
            );
        };
        my $e = $@;
        $getopt->strcat_warning( $e ) if $e;
        $getopt->status( ! $e );

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

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

    #%options = map { $_ => $options{$_} } grep { defined $options{$_} } keys %options;
    $getopt->options( $options );

    ### MooseX::Getopt::Parser::Descriptive::build_options $options : $options
    ### MooseX::Getopt::Parser::Descriptive::build_options $usage : $usage
    ### MooseX::Getopt::Parser::Descriptive::build_options $getopt->status : $getopt->status

    die join '', $getopt->warning if ($getopt->has_warning || !$getopt->status);

    return $options;
};


1;