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