lib/MooseX/Getopt/Parser/Long.pm

   1
   2 package MooseX::Getopt::Parser::Long;
   3
   4 our $VERSION   = '0.150001';
   5
   6 use Moose;
   7
   8 with 'MooseX::Getopt::Parser';
   9
  10 use MooseX::Getopt::OptionTypeMap;
  11
  12 use Getopt::Long ();
  13
  14
  15 # Special configuration for parser
  16 has config => (
  17     is         => 'rw',
  18     isa        => 'ArrayRef[Str]',
  19     auto_deref => 1,
  20     default    => sub { ['default'] },
  21 );
  22
  23
  24 sub build_options {
  25     my $self = shift;
  26     my ( $getopt, @attrs ) = @_;
  27
  28     Moose->throw_error("First argument is not a MooseX::Getopt::Session")
  29         unless $getopt->isa('MooseX::Getopt::Session');
  30
  31     my $options     = $getopt->options;
  32     my $new_options = { %$options };
  33
  34     my @opts;
  35
  36     foreach my $attr (@attrs) {
  37         my $name = $attr->name;
  38
  39         my ( $flag, @aliases ) = $getopt->_get_cmd_flags_for_attr($attr);
  40         my $type = $getopt->_get_cmd_type_for_attr($attr);
  41
  42         my $opt_string = join '|', $flag, @aliases;
  43         $opt_string .= MooseX::Getopt::OptionTypeMap->get_option_type($type)
  44             if $type;
  45
  46         $new_options->{$name} = undef;
  47         push @opts, $opt_string => \$new_options->{$name};
  48     };
  49
  50     my $warnings = '';
  51
  52     GETOPT: {
  53         my $parser = new Getopt::Long::Parser;
  54         $parser->configure( $self->config );
  55
  56         local @ARGV = @{ $getopt->ARGV };
  57
  58         local $SIG{__WARN__} = sub {
  59             $warnings .= $_[0];
  60         };
  61
  62         $parser->getoptions( @opts );
  63
  64         my $extra_argv = \@ARGV;
  65         $getopt->extra_argv( $extra_argv );
  66     };
  67
  68     # Filter not defined values in new_options hashref
  69     $new_options = {
  70         map { $_ => $new_options->{$_} }
  71             grep { defined $new_options->{$_} } keys %$new_options
  72     };
  73
  74     $getopt->status( ! $warnings );
  75     $getopt->options( $new_options );
  76
  77     die $warnings if $warnings;
  78
  79     return $new_options;
  80 };
  81
  82
  83 1;
  84
  85
  86 __END__
  87
  88 =pod
  89
  90 =head1 NAME
  91
  92 MooseX::Getopt::Parser::Long - A Getopt::Long parser for MooseX::Getopt
  93
  94 =head1 SYNOPSIS
  95
  96   use MooseX::Getopt::Parser::Long;
  97
  98   my $parser = MooseX::Getopt::Parser::Long->new( config => ['pass_through'] );
  99   my $getopt = MooseX::Getopt::Session->new( parser => $parser );
 100   my $app = My::App->new( getopt => $getopt );
 101
 102 =head1 DESCRIPTION
 103
 104 This class does L<MooseX::Getopt::Parser> for L<MooseX::Getopt>.  This
 105 class is used by default if L<Getopt::Long::Descriptive> module is
 106 missing.
 107
 108 =head1 METHODS
 109
 110 =over 4
 111
 112 =item B<build_options ($getopt, @attrs)>
 113
 114 This method parses the CLI options with L<Getopt::Long> and returns a hashref to options list.
 115
 116 The first argument have to be L<MooseX::Getopt::Session> object and
 117 second argument is a list of attributes which contains options.
 118
 119 =item B<config>
 120
 121 This accessor contains the arrayref to list with special configuration
 122 keywords for L<Getopt::Long>.
 123
 124 =back
 125
 126 =head1 BUGS
 127
 128 All complex software has bugs lurking in it, and this module is no
 129 exception. If you find a bug please either email me, or add the bug
 130 to cpan-RT.
 131
 132 =head1 SEE ALSO
 133
 134 =over 4
 135
 136 =item L<MooseX::Getopt::Parser>
 137
 138 =item L<MooseX::Getopt::Parser::Default>
 139
 140 =item L<MooseX::Getopt::Parser::Descriptive>
 141
 142 =item L<Getopt::Long>
 143
 144 =back
 145
 146 =head1 AUTHOR
 147
 148 Piotr Roszatycki, E<lt>dexter@cpan.orgE<gt>
 149
 150 =head1 COPYRIGHT AND LICENSE
 151
 152 Copyright 2007-2008 by Infinity Interactive, Inc.
 153
 154 L<http://www.iinteractive.com>
 155
 156 This library is free software; you can redistribute it and/or modify
 157 it under the same terms as Perl itself.
 158
 159 =cut