File Coverage

blib/lib/MouseX/Getopt/GLD.pm
Criterion Covered Total %
statement 19 19 100.0
branch 2 2 100.0
condition 5 5 100.0
subroutine 4 4 100.0
pod n/a
total 30 30 100.0


line stmt bran cond sub pod time code
1             package MouseX::Getopt::GLD;
2             # ABSTRACT: A Mouse role for processing command line options with Getopt::Long::Descriptive
3              
4 21     21   10657 use Mouse::Role;
  21         47  
  21         113  
5              
6 21     21   15883 use Getopt::Long::Descriptive 0.081;
  21         795260  
  21         155  
7              
8             with 'MouseX::Getopt::Basic';
9              
10             has usage => (
11             is => 'rw', isa => 'Getopt::Long::Descriptive::Usage',
12             traits => ['NoGetopt'],
13             );
14              
15             # captures the options: --help --usage --?
16             has help_flag => (
17             is => 'ro', isa => 'Bool',
18             traits => ['Getopt'],
19             cmd_flag => 'help',
20             cmd_aliases => [ qw(usage ?) ],
21             documentation => 'Prints this usage information.',
22             );
23              
24             around _getopt_spec => sub {
25             shift;
26             shift->_gld_spec(@_);
27             };
28              
29             around _getopt_get_options => sub {
30             shift;
31             my ($class, $params, $opt_spec) = @_;
32             return Getopt::Long::Descriptive::describe_options($class->_usage_format(%$params), @$opt_spec);
33             };
34              
35             sub _gld_spec {
36 86     86   242 my ( $class, %params ) = @_;
37              
38 86         195 my ( @options, %name_to_init_arg );
39              
40 86         164 my $constructor_params = $params{params};
41              
42 86         136 foreach my $opt ( @{ $params{options} } ) {
  86         225  
43             push @options, [
44             $opt->{opt_string},
45             $opt->{doc} || ' ', # FIXME new GLD shouldn't need this hack
46             {
47 437 100 100     2062 ( ( $opt->{required} && !exists($constructor_params->{$opt->{init_arg}}) ) ? (required => $opt->{required}) : () ),
      100        
48             # NOTE:
49             # remove this 'feature' because it didn't work
50             # all the time, and so is better to not bother
51             # since Mouse will handle the defaults just
52             # fine anyway.
53             # - SL
54             #( exists $opt->{default} ? (default => $opt->{default}) : () ),
55             },
56             ];
57              
58 437         880 my $identifier = lc($opt->{name});
59 437         906 $identifier =~ s/\W/_/g; # Getopt::Long does this to all option names
60              
61 437         1143 $name_to_init_arg{$identifier} = $opt->{init_arg};
62             }
63              
64 86         565 return ( \@options, \%name_to_init_arg );
65             }
66              
67 21     21   13858 no Mouse::Role;
  21         60  
  21         196  
68              
69             1;
70              
71             =head1 SYNOPSIS
72              
73             ## In your class
74             package My::App;
75             use Mouse;
76              
77             with 'MouseX::Getopt::GLD';
78              
79             has 'out' => (is => 'rw', isa => 'Str', required => 1);
80             has 'in' => (is => 'rw', isa => 'Str', required => 1);
81              
82             # ... rest of the class here
83              
84             ## in your script
85             #!/usr/bin/perl
86              
87             use My::App;
88              
89             my $app = My::App->new_with_options();
90             # ... rest of the script here
91              
92             ## on the command line
93             % perl my_app_script.pl -in file.input -out file.dump
94              
95             =cut