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 #use Smart::Comments;
  12
  13 # Special configuration for parser
  14 has 'config' => (
  15     is => 'rw',
  16     isa => 'ArrayRef[Str]',
  17     auto_deref => 1,
  18     default => sub { [] },
  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;
  30
  31     my @opts;
  32
  33     foreach my $attr (@attrs) {
  34         my $name = $attr->name;
  35
  36         my $is_cmd = $attr->does('MooseX::Getopt::Meta::Attribute::Trait');
  37
  38         my $opt_string = $is_cmd && $attr->has_cmd_flag
  39                          ? $attr->cmd_flag
  40                          : $name;
  41
  42         if ($is_cmd && $attr->has_cmd_aliases && scalar @{ $attr->cmd_aliases }) {
  43             $opt_string .= '|' . join '|', @{ $attr->cmd_aliases };
  44         };
  45
  46         if ($is_cmd && $attr->has_cmd_type || $attr->has_type_constraint) {
  47             my $type = $is_cmd && $attr->has_cmd_type ? $attr->cmd_type : $attr->type_constraint;
  48             if (MooseX::Getopt::OptionTypeMap->has_option_type($type)) {
  49                 $opt_string .= MooseX::Getopt::OptionTypeMap->get_option_type($type)
  50             };
  51         };
  52
  53         $options{$name} = undef;
  54         push @opts, $opt_string => \$options{$name};
  55     };
  56
  57     ### MooseX::Getopt::Parser::Long::build_options @opts : @opts
  58
  59     GETOPT: {
  60         my $parser = new Getopt::Long::Parser;
  61         $parser->configure( $self->config );
  62
  63         local @ARGV = $getopt->argv;
  64         ### MooseX::Getopt::Parser::Long::build_options @ARGV : @ARGV
  65
  66         local $SIG{__WARN__} = sub {
  67             return warn @_ if $_[0]=~/^\###/;   # Smart::Comments
  68             my $warning = $getopt->has_warning ? $getopt->warning : '';
  69             $warning .= $_[0];
  70             $getopt->warning( $warning )
  71         };
  72
  73         my $status = $parser->getoptions( @opts );
  74         $getopt->status( $status );
  75
  76         my $extra_argv = \@ARGV;
  77         $getopt->extra_argv( $extra_argv );
  78     };
  79
  80     %options = map { $_ => $options{$_} } grep { defined $options{$_} } keys %options;
  81     $getopt->options( \%options );
  82
  83     die join '', $getopt->warning if $getopt->die_on_warning && $getopt->has_warning;
  84
  85     ### MooseX::Getopt::Parser::Long::build_options %options : %options
  86     return \%options;
  87 };
  88
  89
  90 1;