* MooseX::Getopt

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

package MooseX::Getopt::Parser::Long;

use Moose;

with 'MooseX::Getopt::Parser';

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

#use Smart::Comments;

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


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 @opts;

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

        my $is_cmd = $attr->does('MooseX::Getopt::Meta::Attribute::Trait');

        my $opt_string = $is_cmd && $attr->has_cmd_flag
                         ? $attr->cmd_flag
                         : $name;
        
        if ($is_cmd && $attr->has_cmd_aliases && scalar @{ $attr->cmd_aliases }) {
            $opt_string .= '|' . join '|', @{ $attr->cmd_aliases };
        };

        if ($is_cmd && $attr->has_cmd_type || $attr->has_type_constraint) {
            my $type = $is_cmd && $attr->has_cmd_type ? $attr->cmd_type : $attr->type_constraint;
            if (MooseX::Getopt::OptionTypeMap->has_option_type($type)) {
                $opt_string .= MooseX::Getopt::OptionTypeMap->get_option_type($type)
            };
        };

        $options{$name} = undef;
        push @opts, $opt_string => \$options{$name};
    };

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

    GETOPT: {
        my $parser = new Getopt::Long::Parser;
        $parser->configure( $self->config );

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

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

        my $status = $parser->getoptions( @opts );
        $getopt->status( $status );

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

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

    die join '', $getopt->warning if $getopt->die_on_warning && $getopt->has_warning;

    ### MooseX::Getopt::Parser::Long::build_options %options : %options
    return \%options;
};


1;