Commit | Line | Data |
550da402 |
1 | |
2 | package MooseX::Getopt::Parser::Descriptive; |
3 | |
4 | use Moose; |
5 | |
6 | with 'MooseX::Getopt::Parser'; |
7 | |
8 | use Getopt::Long::Descriptive; |
dd012666 |
9 | use MooseX::Getopt::OptionTypeMap; |
550da402 |
10 | |
dd012666 |
11 | #use Smart::Comments; |
c6c1f628 |
12 | |
dd012666 |
13 | # Special configuration for parser |
14 | has 'config' => ( |
15 | is => 'rw', |
16 | isa => 'ArrayRef[Str]', |
17 | auto_deref => 1, |
18 | default => sub { [] }, |
19 | ); |
550da402 |
20 | |
dd012666 |
21 | # Format for usage description |
22 | has 'format' => ( |
23 | is => 'rw', |
24 | isa => 'Str', |
25 | default => 'usage: %c %o', |
26 | ); |
550da402 |
27 | |
550da402 |
28 | |
dd012666 |
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 | |
19b87ede |
36 | my $options = {}; |
37 | my $usage; |
38 | my (@opts, %cmd_flags_to_names); |
dd012666 |
39 | |
40 | foreach my $attr (@attrs) { |
41 | my $name = $attr->name; |
c6c1f628 |
42 | |
dd012666 |
43 | my ($flag, @aliases) = $getopt->_get_cmd_flags_for_attr($attr); |
44 | my $type = $getopt->_get_cmd_type_for_attr($attr); |
550da402 |
45 | |
19b87ede |
46 | $cmd_flags_to_names{$flag} = $name; |
47 | |
dd012666 |
48 | my $opt_string = join '|', $flag, @aliases; |
49 | $opt_string .= MooseX::Getopt::OptionTypeMap->get_option_type($type); |
550da402 |
50 | |
dd012666 |
51 | my $doc; |
52 | $doc = $attr->documentation if $attr->has_documentation; |
53 | $doc = ' ' unless $doc; |
550da402 |
54 | |
053fa19e |
55 | my $is_required = !exists $getopt->params->{$name} |
56 | && $attr->is_required |
57 | && !$attr->has_default |
58 | && !$attr->has_builder; |
550da402 |
59 | |
dd012666 |
60 | push @opts, [ |
61 | $opt_string => $doc, |
550da402 |
62 | { |
dd012666 |
63 | ( $is_required ? ( required => $attr->is_required ) : () ), |
64 | } |
550da402 |
65 | ]; |
dd012666 |
66 | }; |
550da402 |
67 | |
dd012666 |
68 | ### MooseX::Getopt::Parser::Descriptive::build_options @opts : @opts |
550da402 |
69 | |
dd012666 |
70 | GETOPT: { |
71 | local @ARGV = $getopt->argv; |
72 | ### MooseX::Getopt::Parser::Descriptive::build_options @ARGV : @ARGV |
550da402 |
73 | |
dd012666 |
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 | |
19b87ede |
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 | |
dd012666 |
99 | #%options = map { $_ => $options{$_} } grep { defined $options{$_} } keys %options; |
19b87ede |
100 | $getopt->options( $options ); |
550da402 |
101 | |
dd012666 |
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 |
550da402 |
105 | |
19b87ede |
106 | die join '', $getopt->warning if ($getopt->has_warning || !$getopt->status); |
550da402 |
107 | |
dd012666 |
108 | return $options; |
109 | }; |
550da402 |
110 | |
550da402 |
111 | |
112 | 1; |