Commit | Line | Data |
550da402 |
1 | |
2 | package MooseX::Getopt::Parser::Long; |
3 | |
4 | use Moose; |
5 | |
6 | with 'MooseX::Getopt::Parser'; |
7 | |
c6c1f628 |
8 | use Getopt::Long; |
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 | |
22 | sub build_options { |
23 | my $self = shift; |
24 | my ($getopt, @attrs) = @_; |
25 | |
26 | Moose->throw_error('First argument is not a MooseX::Getopt::Session') |
27 | unless $getopt->isa('MooseX::Getopt::Session'); |
550da402 |
28 | |
29 | my %options; |
c6c1f628 |
30 | my @opts; |
31 | |
32 | foreach my $attr (@attrs) { |
33 | my $name = $attr->name; |
34 | |
5b582f22 |
35 | my ($flag, @aliases) = $getopt->_get_cmd_flags_for_attr($attr); |
36 | my $type = $getopt->_get_cmd_type_for_attr($attr); |
37 | |
38 | my $opt_string = join '|', $flag, @aliases; |
39 | $opt_string .= MooseX::Getopt::OptionTypeMap->get_option_type($type); |
c6c1f628 |
40 | |
41 | $options{$name} = undef; |
42 | push @opts, $opt_string => \$options{$name}; |
43 | }; |
44 | |
45 | ### MooseX::Getopt::Parser::Long::build_options @opts : @opts |
46 | |
47 | GETOPT: { |
48 | my $parser = new Getopt::Long::Parser; |
49 | $parser->configure( $self->config ); |
50 | |
51 | local @ARGV = $getopt->argv; |
52 | ### MooseX::Getopt::Parser::Long::build_options @ARGV : @ARGV |
53 | |
54 | local $SIG{__WARN__} = sub { |
55 | return warn @_ if $_[0]=~/^\###/; # Smart::Comments |
56 | my $warning = $getopt->has_warning ? $getopt->warning : ''; |
57 | $warning .= $_[0]; |
58 | $getopt->warning( $warning ) |
59 | }; |
550da402 |
60 | |
c6c1f628 |
61 | my $status = $parser->getoptions( @opts ); |
62 | $getopt->status( $status ); |
550da402 |
63 | |
c6c1f628 |
64 | my $extra_argv = \@ARGV; |
65 | $getopt->extra_argv( $extra_argv ); |
66 | }; |
550da402 |
67 | |
c6c1f628 |
68 | %options = map { $_ => $options{$_} } grep { defined $options{$_} } keys %options; |
69 | $getopt->options( \%options ); |
550da402 |
70 | |
c6c1f628 |
71 | die join '', $getopt->warning if $getopt->die_on_warning && $getopt->has_warning; |
550da402 |
72 | |
c6c1f628 |
73 | ### MooseX::Getopt::Parser::Long::build_options %options : %options |
74 | return \%options; |
75 | }; |
550da402 |
76 | |
550da402 |
77 | |
78 | 1; |