* MooseX::Getopt::Parser::Long: Operate on options copy.

[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;


# 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 = $getopt->options;
    my $new_options = { %$options };

    my @opts;

    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;

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

    my $warnings = '';

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

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

        local $SIG{__WARN__} = sub {
            return warn @_ if $_[0]=~/^\###/;   # Smart::Comments
            $warnings .= $_[0];
        };

        $parser->getoptions( @opts );

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

    # Filter not defined values in new_options hashref
    $new_options = { map { $_ => $new_options->{$_} } grep { defined $new_options->{$_} } keys %$new_options };

    $getopt->options( $new_options );

    die $warnings if $warnings;

    return $new_options;
};


1;

__END__

=pod

=head1 NAME

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

=head1 SYNOPSIS

  use MooseX::Getopt::Parser::Long;

  my $parser = MooseX::Getopt::Parser::Long->new( 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>.

=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::Descriptive>

=item L<Getopt::Long>

=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