lib/MooseX/Getopt/Parser/Long.pm

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