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