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 MooseX::Getopt::OptionTypeMap;
   9
  10 use Getopt::Long::Descriptive ();
  11
  12
  13 # Special configuration for parser
  14 has config => (
  15     is      => 'rw',
  16     isa     => 'ArrayRef[Str]',
  17     default => sub { ['default'] },
  18 );
  19
  20 # Format for usage description
  21 has format => (
  22     is      => 'rw',
  23     isa     => 'Str',
  24     default => 'usage: %c %o',
  25 );
  26
  27 # Usage object
  28 has usage => (
  29     is        => 'rw',
  30     isa       => 'Maybe[Getopt::Long::Descriptive::Usage]',
  31     predicate => 'has_usage',
  32 );
  33
  34
  35 sub build_options {
  36     my $self = shift;
  37     my ( $getopt, @attrs ) = @_;
  38
  39     Moose->throw_error("First argument is not a MooseX::Getopt::Session")
  40         unless $getopt->isa('MooseX::Getopt::Session');
  41
  42     my $options     = $getopt->options;
  43     my $new_options = {};
  44
  45     my $usage;
  46     my ( @opts, %cmd_flags_to_names );
  47
  48     foreach my $attr (@attrs) {
  49         my $name = $attr->name;
  50
  51         my ( $flag, @aliases ) = $getopt->_get_cmd_flags_for_attr($attr);
  52         my $type = $getopt->_get_cmd_type_for_attr($attr);
  53
  54         my $opt_string = join '|', $flag, @aliases;
  55         $opt_string .= MooseX::Getopt::OptionTypeMap->get_option_type($type)
  56             if $type;
  57
  58         # opt_string is unmangled; parsed options keys are mangled
  59         $flag =~ tr/-/_/;
  60         $cmd_flags_to_names{$flag} = $name;
  61
  62         my $doc;
  63         $doc = $attr->documentation if $attr->has_documentation;
  64         $doc = ' ' unless $doc;
  65
  66         my $is_required = !exists $options->{$name}
  67                           && $attr->is_required
  68                           && !$attr->has_default
  69                           && !$attr->has_builder;
  70
  71         push @opts, [
  72             $opt_string => $doc,
  73             {
  74                 ( $is_required ? ( required => $attr->is_required ) : () ),
  75             },
  76         ];
  77     };
  78
  79     my $warnings = '';
  80
  81     GETOPT: {
  82         local @ARGV = @{ $getopt->ARGV };
  83
  84         local $SIG{__WARN__} = sub {
  85             $warnings .= $_[0];
  86         };
  87
  88         eval {
  89             ( $new_options, $usage ) =
  90                 Getopt::Long::Descriptive::describe_options(
  91                     $self->format,
  92                     @opts,
  93                     { getopt_conf => $self->config }
  94                 );
  95         };
  96         $warnings .= $@ if $@;
  97
  98         my $extra_argv = \@ARGV;
  99         $getopt->extra_argv($extra_argv);
 100     };
 101
 102     # Store usage object
 103     $self->usage( $usage );
 104
 105     # Convert cmd_flags back to names in options hashref
 106     $new_options = {
 107         map { $cmd_flags_to_names{$_} => $new_options->{$_} }
 108             keys %$new_options
 109     };
 110
 111     # Include old options
 112     $new_options = { %$options, %$new_options };
 113
 114     $getopt->status( ! $warnings );
 115     $getopt->options( $new_options );
 116
 117     die $warnings if $warnings;
 118
 119     return $new_options;
 120 };
 121
 122
 123 1;
 124
 125
 126 __END__
 127
 128 =pod
 129
 130 =head1 NAME
 131
 132 MooseX::Getopt::Parser::Descriptive - A Getopt::Long::Descriptive parser for MooseX::Getopt
 133
 134 =head1 SYNOPSIS
 135
 136   use MooseX::Getopt::Parser::Descriptive;
 137
 138   my $parser = MooseX::Getopt::Parser::Descriptive->new(
 139       format => 'Usage: %c %o',
 140       config => ['pass_through']
 141   );
 142   my $getopt = MooseX::Getopt::Session->new( parser => $parser );
 143   my $app = My::App->new( getopt => $getopt );
 144
 145 =head1 DESCRIPTION
 146
 147 This class does L<MooseX::Getopt::Parser> for L<MooseX::Getopt>.  This
 148 class is used by default if L<Getopt::Long::Descriptive> module is
 149 missing.
 150
 151 =head1 METHODS
 152
 153 =over 4
 154
 155 =item B<build_options ($getopt, @attrs)>
 156
 157 This method parses the CLI options with L<Getopt::Long> and returns a hashref to options list.
 158
 159 The first argument have to be L<MooseX::Getopt::Session> object and
 160 second argument is a list of attributes which contains options.
 161
 162 =item B<config>
 163
 164 This accessor contains the arrayref to list with special configuration
 165 keywords for L<Getopt::Long>.
 166
 167 =item B<format>
 168
 169 This accessor contains the string with message printed by
 170 L<Getopt::Long::Descriptive> if error is occured.
 171
 172 =back
 173
 174 =head1 BUGS
 175
 176 All complex software has bugs lurking in it, and this module is no
 177 exception. If you find a bug please either email me, or add the bug
 178 to cpan-RT.
 179
 180 =head1 SEE ALSO
 181
 182 =over 4
 183
 184 =item L<MooseX::Getopt::Parser>
 185
 186 =item L<MooseX::Getopt::Parser::Default>
 187
 188 =item L<MooseX::Getopt::Parser::Long>
 189
 190 =item L<Getopt::Long::Descriptive>
 191
 192 =back
 193
 194 =head1 AUTHOR
 195
 196 Piotr Roszatycki, E<lt>dexter@cpan.orgE<gt>
 197
 198 =head1 COPYRIGHT AND LICENSE
 199
 200 Copyright 2007-2008 by Infinity Interactive, Inc.
 201
 202 L<http://www.iinteractive.com>
 203
 204 This library is free software; you can redistribute it and/or modify
 205 it under the same terms as Perl itself.
 206
 207 =cut