File Coverage

blib/lib/MooseX/App/ParsedArgv.pm
Criterion Covered Total %
statement 121 125 96.8
branch 31 34 91.1
condition 12 17 70.5
subroutine 16 16 100.0
pod 5 8 62.5
total 185 200 92.5


line stmt bran cond sub pod time code
1             # ============================================================================
2             package MooseX::App::ParsedArgv;
3             # ============================================================================
4              
5 16     16   839 use 5.010;
  16         58  
6 16     16   94 use utf8;
  16         38  
  16         127  
7              
8 16     16   3255 use Moose;
  16         993421  
  16         126  
9              
10 16     16   127469 use Encode qw(decode);
  16         144591  
  16         1162  
11 16     16   7066 use MooseX::App::ParsedArgv::Element;
  16         77  
  16         830  
12 16     16   10102 use MooseX::App::ParsedArgv::Value;
  16         59  
  16         809  
13              
14 16     16   124 no if $] >= 5.018000, warnings => qw(experimental::smartmatch);
  16         34  
  16         147  
15              
16             my $SINGLETON;
17              
18             has 'argv' => (
19             is => 'ro',
20             isa => 'ArrayRef[Str]',
21             traits => ['Array'],
22             handles => {
23             length_argv => 'count',
24             elements_argv => 'elements',
25             _shift_argv => 'shift',
26             },
27             default => sub {
28             my @argv;
29             @argv = eval {
30             require I18N::Langinfo;
31             I18N::Langinfo->import(qw(langinfo CODESET));
32             my $codeset = langinfo(CODESET());
33             # TODO Not sure if this is the right place?
34             if ($codeset =~ m/^UTF-?8$/i) {
35             binmode(STDOUT, ":encoding(UTF-8)");
36             binmode(STDERR, ":encoding(UTF-8)");
37             }
38             return map { decode($codeset,$_) } @ARGV;
39             };
40             # Fallback to standard
41             if ($@) {
42             @argv = @ARGV;
43             }
44             return \@argv;
45             },
46             );
47              
48             has 'hints_novalue' => (
49             is => 'rw',
50             isa => 'ArrayRef[Str]',
51             default => sub { [] },
52             ); # No value hints for the parser (such as for flags)
53              
54             has 'hints_permute' => (
55             is => 'rw',
56             isa => 'ArrayRef[Str]',
57             default => sub { [] },
58             ); # Permute hints for the parser
59              
60             has 'hints_fixedvalue' => (
61             is => 'rw',
62             isa => 'HashRef[Str]',
63             default => sub { {} },
64             ); # fixed value hints for the parser
65              
66             has 'elements' => (
67             is => 'ro',
68             isa => 'ArrayRef[MooseX::App::ParsedArgv::Element]',
69             lazy => 1,
70             builder => '_build_elements',
71             clearer => 'reset_elements',
72             );
73              
74             sub BUILD {
75 77     77 0 217 my ($self) = @_;
76              
77             # Register singleton
78 77         2049 $SINGLETON = $self;
79 77         2103 return $self;
80             }
81              
82             sub DEMOLISH {
83 63     63 0 202 my ($self) = @_;
84              
85             # Unregister singleton if it is stll the same
86 63 50 33     461 $SINGLETON = undef
87             if defined $SINGLETON
88             && $SINGLETON == $self;
89              
90 63         202 return;
91             }
92              
93             sub instance {
94 420     420 1 945 my ($class) = @_;
95 420 100       936 unless (defined $SINGLETON) {
96 3         100 return $class->new();
97             }
98 417         957 return $SINGLETON;
99             }
100              
101             sub first_argv {
102 67     67 1 175 my ($self) = @_;
103 67         2618 return ($self->elements_argv)[0];
104             }
105              
106             sub shift_argv {
107 64     64 0 204 my ($self) = @_;
108 64         2224 $self->reset_elements;
109 64         2990 return $self->_shift_argv;
110             }
111              
112             sub _build_elements {
113 70     70   202 my ($self) = @_;
114              
115 70         277 my (@elements);
116              
117             my %options;
118 70         0 my $lastkey;
119 70         0 my $lastelement;
120 70         142 my $stopprocessing = 0; # Flag that is set after ' -- ' and inticated end of processing
121 70         131 my $position = 0; # Argument position
122 70         125 my $expecting = 0; # Flag that indicates that a value is expected
123              
124             # Loop all elements of our ARGV copy
125 70         2646 foreach my $element ($self->elements_argv) {
126             # We are behind first ' -- ' occurrence: Do not process further
127 245 100       544 if ($stopprocessing) {
128 4         144 push (@elements,MooseX::App::ParsedArgv::Element->new(
129             key => $element,
130             type => 'extra',
131             ));
132             # Process element
133             } else {
134 241         389 given ($element) {
135             # Flags with only one leading dash (-h or -vh)
136 241         658 when (m/^-([^-][[:alnum:]]*)$/) {
137 4         10 undef $lastkey;
138 4         6 undef $lastelement;
139 4         8 $expecting = 0;
140             # Split into single letter flags
141 4         18 foreach my $flag (split(//,$1)) {
142 8 100       25 unless (defined $options{$flag}) {
143 7         203 $options{$flag} = MooseX::App::ParsedArgv::Element->new(
144             key => $flag,
145             type => 'option',
146             raw => $element,
147             );
148 7         20 push(@elements,$options{$flag});
149             }
150 8         33 $options{$flag}->add_value(
151             1,
152             $position,
153             $element,
154             );
155 8         16 $lastkey = $options{$flag};
156 8         20 $lastelement = $element;
157             }
158             }
159             # Key-value combined (--key=value)
160 237         638 when (m/^--([^-=][^=]+)=(.+)$/) {
161 2         3 undef $lastkey;
162 2         3 undef $lastelement;
163 2         4 $expecting = 0;
164 2         4 my ($key,$value) = ($1,$2);
165 2 100       13 unless (defined $options{$key}) {
166 1         30 $options{$key} = MooseX::App::ParsedArgv::Element->new(
167             key => $key,
168             type => 'option',
169             raw => $element,
170             );
171 1         3 push(@elements,$options{$key});
172             }
173 2         6 $options{$key}->add_value(
174             $value,
175             $position,
176             $element,
177             );
178             }
179             # Ordinary key
180 235         548 when (m/^--?([^-].+)/) {
181 116         280 my $key = $1;
182              
183 116 100       408 unless (defined $options{$key} ) {
184 105         3527 $options{$key} = MooseX::App::ParsedArgv::Element->new(
185             key => $key,
186             type => 'option',
187             raw => $element,
188             );
189 105         323 push(@elements,$options{$key});
190             }
191             # This is a boolean or counter key that does not expect a value
192 116 100       3353 if ($key ~~ $self->hints_novalue) {
193             $options{$key}->add_value(
194 32   100     966 ($self->hints_fixedvalue->{$key} // 1),
195             $position,
196             $element
197             );
198 32         95 $expecting = 0;
199             # We are expecting a value
200             } else {
201 84         193 $expecting = 1;
202 84         148 $lastelement = $element;
203 84         270 $lastkey = $options{$key};
204             }
205             }
206             # Extra values - stop processing after this token
207 119         287 when ('--') {
208 2         5 undef $lastkey;
209 2         3 undef $lastelement;
210 2         5 $stopprocessing = 1;
211 2         10 $expecting = 0;
212             }
213             # Value
214 117         199 default {
215 117 100       248 if (defined $lastkey) {
216             # This is a parameter - last key was a flag
217 82 50       2503 if ($lastkey->key ~~ $self->hints_novalue) {
    100          
218 0         0 push(@elements,MooseX::App::ParsedArgv::Element->new( key => $element, type => 'parameter' ));
219 0         0 undef $lastkey;
220 0         0 undef $lastelement;
221 0         0 $expecting = 0;
222             # Permute values
223             } elsif ($lastkey->key ~~ $self->hints_permute) {
224 18         35 $expecting = 0;
225 18         61 $lastkey->add_value(
226             $element,
227             $position,
228             $lastelement
229             );
230             # Has value
231             } else {
232 64         135 $expecting = 0;
233 64         289 $lastkey->add_value($element,$position);
234 64         125 undef $lastkey;
235 64         180 undef $lastelement;
236             }
237             } else {
238 35         1174 push(@elements,MooseX::App::ParsedArgv::Element->new( key => $element, type => 'parameter' ));
239             }
240             }
241             }
242             }
243 245         470 $position++;
244             }
245              
246             # Fill up last value
247 70 100 100     303 if (defined $lastkey
248             && $expecting) {
249 3         29 $lastkey->add_value(undef,$position,$lastelement);
250 3         6 $position++;
251             }
252              
253 70         2083 return \@elements;
254             }
255              
256             sub available {
257 378     378 1 947 my ($self,$type) = @_;
258              
259 378         571 my @elements;
260 378         541 foreach my $element (@{$self->elements}) {
  378         10221  
261             next
262 721 100       20443 if $element->consumed;
263             next
264 479 100 66     13396 if defined $type
265             && $element->type ne $type;
266 310         715 push(@elements,$element);
267             }
268 378         1391 return @elements;
269             }
270              
271             sub consume {
272 36     36 1 91 my ($self,$type) = @_;
273              
274 36         54 foreach my $element (@{$self->elements}) {
  36         1007  
275             next
276 76 100       2456 if $element->consumed;
277             next
278 24 100 66     707 if defined $type
279             && $element->type ne $type;
280 22         96 $element->consume;
281 22         60 return $element;
282             }
283 14         53 return;
284             }
285              
286             sub extra {
287 44     44 1 127 my ($self) = @_;
288              
289 44         92 my @extra;
290 44         89 foreach my $element (@{$self->elements}) {
  44         1246  
291             next
292 106 100       3057 if $element->consumed;
293             next
294 9 50 66     258 unless $element->type eq 'parameter'
295             || $element->type eq 'extra';
296 9         256 push(@extra,$element->key);
297             }
298              
299 44         663 return @extra;
300             }
301              
302             __PACKAGE__->meta->make_immutable;
303             1;
304              
305             __END__
306              
307             =pod
308              
309             =head1 NAME
310              
311             MooseX::App::ParsedArgv - Parses @ARGV
312              
313             =head1 SYNOPSIS
314              
315             use MooseX::App::ParsedArgv;
316             my $argv = MooseX::App::ParsedArgv->instance;
317            
318             foreach my $option ($argv->available('option')) {
319             say "Parsed ".$option->key;
320             }
321              
322             =head1 DESCRIPTION
323              
324             This is a helper class that holds all options parsed from @ARGV. It is
325             implemented as a singleton. Unless you are developing a MooseX::App plugin
326             you usually do not need to interact with this class.
327              
328             =head1 METHODS
329              
330             =head2 new
331              
332             Create a new MooseX::App::ParsedArgv instance. Needs to be called as soon
333             as possible.
334              
335             =head2 instance
336              
337             Get the current MooseX::App::ParsedArgv instance. If there is no instance
338             a new one will be created.
339              
340             =head2 argv
341              
342             Accessor for the initinal @ARGV.
343              
344             =head2 hints
345              
346             ArrayRef of attributes that tells the parser which attributes should be
347             regarded as flags without values.
348              
349             =head2 first_argv
350              
351             Shifts the current first element from @ARGV.
352              
353             =head2 available
354              
355             my @options = $self->available($type);
356             OR
357             my @options = $self->available();
358              
359             Returns an array of all parsed options or parameters that have not yet been consumed.
360             The array elements will be L<MooseX::App::ParsedArgv::Element> objects.
361              
362             =head2 consume
363              
364             my $option = $self->consume($type);
365             OR
366             my $option = $self->consume();
367              
368             Returns the first option/parameter of the local @ARGV that has not yet been
369             consumed as a L<MooseX::App::ParsedArgv::Element> object.
370              
371             =head2 elements
372              
373             Returns all parsed options and parameters.
374              
375             =head2 extra
376              
377             Returns an array reference of unconsumed positional parameters and
378             extra values.
379              
380             =cut