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