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