lib/MooseX/Getopt/Parser/Descriptive.pm

   1
   2 package MooseX::Getopt::Parser::Descriptive;
   3
   4 use Moose;
   5
   6 with 'MooseX::Getopt::Parser';
   7
   8 use Getopt::Long::Descriptive;
   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 # Format for usage description
  22 has 'format' => (
  23     is => 'rw',
  24     isa => 'Str',
  25     default => 'usage: %c %o',
  26 );
  27
  28
  29 sub build_options {
  30     my $self = shift;
  31     my ($getopt, @attrs) = @_;
  32
  33     Moose->throw_error('First argument is not a MooseX::Getopt::Session')
  34         unless $getopt->isa('MooseX::Getopt::Session');
  35
  36     my $options = {};
  37     my $usage;
  38     my (@opts, %cmd_flags_to_names);
  39
  40     foreach my $attr (@attrs) {
  41         my $name = $attr->name;
  42
  43         my ($flag, @aliases) = $getopt->_get_cmd_flags_for_attr($attr);
  44         my $type = $getopt->_get_cmd_type_for_attr($attr);
  45
  46         $cmd_flags_to_names{$flag} = $name;
  47
  48         my $opt_string = join '|', $flag, @aliases;
  49         $opt_string .= MooseX::Getopt::OptionTypeMap->get_option_type($type);
  50
  51         my $doc;
  52         $doc = $attr->documentation if $attr->has_documentation;
  53         $doc = ' ' unless $doc;
  54
  55         my $is_required = !exists $getopt->params->{$name}
  56                           && $attr->is_required
  57                           && !$attr->has_default
  58                           && !$attr->has_builder;
  59
  60         push @opts, [
  61             $opt_string => $doc,
  62             {
  63                 ( $is_required ? ( required => $attr->is_required ) : () ),
  64             }
  65         ];
  66     };
  67
  68     ### MooseX::Getopt::Parser::Descriptive::build_options @opts : @opts
  69
  70     GETOPT: {
  71         local @ARGV = $getopt->argv;
  72         ### MooseX::Getopt::Parser::Descriptive::build_options @ARGV : @ARGV
  73
  74         local $SIG{__WARN__} = sub {
  75             return warn @_ if $_[0]=~/^\###/;   # Smart::Comments
  76             $getopt->strcat_warning( $_[0] )
  77         };
  78
  79         eval {
  80             ($options, $usage) = Getopt::Long::Descriptive::describe_options(
  81                 $self->format, @opts, { getopt_conf => [ $self->config ] }
  82             );
  83         };
  84         my $e = $@;
  85         $getopt->strcat_warning( $e ) if $e;
  86         $getopt->status( ! $e );
  87
  88         my $extra_argv = \@ARGV;
  89         $getopt->extra_argv( $extra_argv );
  90     };
  91
  92     # Convert cmd_flags back to names in options hashref
  93     $options = {
  94         map {
  95             $cmd_flags_to_names{$_} => $options->{$_}
  96         } keys %$options,
  97     };
  98
  99     #%options = map { $_ => $options{$_} } grep { defined $options{$_} } keys %options;
 100     $getopt->options( $options );
 101
 102     ### MooseX::Getopt::Parser::Descriptive::build_options $options : $options
 103     ### MooseX::Getopt::Parser::Descriptive::build_options $usage : $usage
 104     ### MooseX::Getopt::Parser::Descriptive::build_options $getopt->status : $getopt->status
 105
 106     die join '', $getopt->warning if ($getopt->has_warning || !$getopt->status);
 107
 108     return $options;
 109 };
 110
 111
 112 1;