File Coverage

blib/lib/MooseX/App/Meta/Role/Attribute/Option.pm
Criterion Covered Total %
statement 118 149 79.1
branch 75 114 65.7
condition 29 62 46.7
subroutine 17 18 94.4
pod 9 9 100.0
total 248 352 70.4


line stmt bran cond sub pod time code
1             # ============================================================================
2             package MooseX::App::Meta::Role::Attribute::Option;
3             # ============================================================================
4              
5 15     15   107 use utf8;
  15         33  
  15         94  
6 15     15   637 use 5.010;
  15         62  
7              
8 15     15   6621 use namespace::autoclean;
  15         174784  
  15         55  
9 15     15   5562 use Moose::Role;
  15         2808906  
  15         109  
10              
11 15     15   85374 use List::Util qw(uniq first);
  15         40  
  15         32686  
12              
13             has 'cmd_type' => (
14             is => 'rw',
15             isa => 'MooseX::App::Types::CmdTypes',
16             predicate => 'has_cmd_type',
17             );
18              
19             has 'cmd_tags' => (
20             is => 'rw',
21             isa => 'MooseX::App::Types::List',
22             coerce => 1,
23             predicate => 'has_cmd_tags',
24             );
25              
26             has 'cmd_flag' => (
27             is => 'rw',
28             isa => 'MooseX::App::Types::Identifier',
29             predicate => 'has_cmd_flag',
30             );
31              
32             has 'cmd_aliases' => (
33             is => 'rw',
34             isa => 'MooseX::App::Types::IdentifierList',
35             predicate => 'has_cmd_aliases',
36             coerce => 1,
37             );
38              
39             has 'cmd_split' => (
40             is => 'rw',
41             isa => Moose::Util::TypeConstraints::union([qw(Str RegexpRef)]),
42             predicate => 'has_cmd_split',
43             );
44              
45             has 'cmd_count' => (
46             is => 'rw',
47             isa => 'Bool',
48             default => sub { 0 },
49             );
50              
51             has 'cmd_negate' => (
52             is => 'rw',
53             isa => 'MooseX::App::Types::IdentifierList',
54             coerce => 1,
55             predicate => 'has_cmd_negate',
56             );
57              
58             has 'cmd_env' => (
59             is => 'rw',
60             isa => 'MooseX::App::Types::Env',
61             predicate => 'has_cmd_env',
62             );
63              
64             has 'cmd_position' => (
65             is => 'rw',
66             isa => 'Int',
67             default => sub { 0 },
68             );
69              
70             my $GLOBAL_COUNTER = 1;
71              
72             around 'new' => sub {
73             my $orig = shift;
74             my $class = shift;
75              
76             my $self = $class->$orig(@_);
77              
78             if ($self->has_cmd_type) {
79             if ($self->cmd_position == 0) {
80             $GLOBAL_COUNTER++;
81             $self->cmd_position($GLOBAL_COUNTER);
82             }
83             }
84              
85             return $self;
86             };
87              
88             sub cmd_check {
89 201     201 1 514 my ($self) = @_;
90              
91 201         787 my $name = $self->name;
92 201         362 my $from_constraint;
93 201         6450 my $type_constraint = $self->type_constraint;
94 201 50 66     2495 $from_constraint = $type_constraint->parameterized_from
95             if $type_constraint && $type_constraint->isa('Moose::Meta::TypeConstraint::Parameterized');
96              
97 201         8244 my $cmd_type = ucfirst($self->cmd_type);
98              
99             # Check for useless flags
100 201 50       6088 if ($self->cmd_type eq 'parameter') {
101 0 0       0 if ($self->cmd_count) {
102 0         0 Moose->throw_error("Parameter $name has 'cmd_count'. This attribute only works with options");
103             }
104 0 0       0 if ($self->has_cmd_negate) {
105 0         0 Moose->throw_error("Parameter $name has 'cmd_negate'. This attribute only works with options");
106             }
107 0 0       0 if ($self->has_cmd_negate) {
108 0         0 Moose->throw_error("Parameter $name has 'cmd_negate'. This attribute only works with options");
109             }
110 0 0 0     0 if (defined $type_constraint
111             && $type_constraint->is_a_type_of('Bool')) {
112 0         0 Moose->throw_error("Parameter $name has 'cmd_negate'. This attribute only works with options");
113             }
114 0 0 0     0 if (($from_constraint && $from_constraint->is_a_type_of('Ref'))
      0        
      0        
115             || ($type_constraint && $type_constraint->is_a_type_of('Ref'))) {
116 0         0 Moose->throw_error("Parameter $name may not have Ref type constraints");
117             }
118             } else {
119 201 100 100     669 if ((!$type_constraint || ! $type_constraint->is_a_type_of('Bool'))
      100        
120 57     57   275 && first { length($_) == 1 } $self->cmd_name_list) {
121 1         13 Moose->throw_error("Option $name has a single letter flag but no Bool type constraint");
122             }
123              
124             # Check negate
125 200 50 33     25431 if ($self->has_cmd_negate
      66        
126             && (!$type_constraint || ! $type_constraint->is_a_type_of('Bool'))) {
127 0         0 Moose->throw_error("Option $name has 'cmd_negate' but has no Bool type constraint");
128             }
129             }
130              
131             # Check type constraints
132 200 100       1430 if (defined $type_constraint) {
133 177 50 33     5681 if ($self->cmd_count
134             && ! $type_constraint->is_a_type_of('Num')) {
135 0         0 Moose->throw_error("$cmd_type $name has 'cmd_count' but has no Num/Int type constraint");
136             }
137 177 50 0     6337 if ($self->has_cmd_split
      33        
138             && ! (
139             ($from_constraint && $from_constraint->is_a_type_of('ArrayRef'))
140             || $type_constraint->is_a_type_of('ArrayRef'))
141             ) {
142 0         0 Moose->throw_error("$cmd_type $name has 'cmd_split' but has no ArrayRef type constraint");
143             }
144             }
145              
146             # Check for uniqness
147 200         657 my @names = $self->cmd_name_possible;
148 200 50       1153 if (scalar(uniq(@names)) != scalar(@names)) {
149 0         0 Moose->throw_error("$cmd_type $name has duplicate names/aliases");
150             }
151              
152 200         810 return;
153             }
154              
155             sub cmd_type_constraint_description {
156 6     6 1 28 my ($self,$type_constraint,$singular) = @_;
157              
158 6   33     33 $type_constraint //= $self->type_constraint;
159 6   50     75 $singular //= 1;
160              
161 6 100       106 if ($type_constraint->isa('Moose::Meta::TypeConstraint::Enum')) {
    50          
    100          
    50          
    0          
    0          
162 1         4 return 'one of these values: '.join(', ',@{$type_constraint->values});
  1         41  
163             } elsif ($type_constraint->isa('Moose::Meta::TypeConstraint::Parameterized')) {
164 0         0 my $from = $type_constraint->parameterized_from;
165 0 0       0 if ($from->is_a_type_of('ArrayRef')) {
    0          
166 0         0 return $self->cmd_type_constraint_description($type_constraint->type_parameter);
167             } elsif ($from->is_a_type_of('HashRef')) {
168 0         0 return 'key-value pairs of '.$self->cmd_type_constraint_description($type_constraint->type_parameter,0);
169             }
170             # TODO union
171             } elsif ($type_constraint->equals('Int')) {
172 4 50       465 return $singular ? 'an integer':'integers'; # LOCALIZE
173             } elsif ($type_constraint->equals('Num')) {
174 1 50       246 return $singular ? 'a number':'numbers'; # LOCALIZE
175             } elsif ($type_constraint->equals('Str')) {
176 0 0       0 return $singular ? 'a string':'strings';
177             } elsif ($type_constraint->equals('HashRef')) {
178 0         0 return 'key-value pairs'; # LOCALIZE
179             }
180              
181 0 0       0 if ($type_constraint->has_parent) {
182 0         0 return $self->cmd_type_constraint_description($type_constraint->parent);
183             }
184              
185 0         0 return;
186             }
187              
188             sub cmd_type_constraint_check {
189 110     110 1 334 my ($self,$value) = @_;
190              
191             return
192 110 50       4067 unless ($self->has_type_constraint);
193 110         4034 my $type_constraint = $self->type_constraint;
194              
195 110 100       4386 if ($type_constraint->has_coercion) {
196 2         20 $value = $type_constraint->coerce($value)
197             }
198              
199             # Check type constraints
200 110 100       1373 unless ($type_constraint->check($value)) {
201 7 50       707 if (ref($value) eq 'ARRAY') {
    50          
202 0         0 $value = join(', ',grep { defined } @$value);
  0         0  
203             } elsif (ref($value) eq 'HASH') {
204 0         0 $value = join(', ',map { $_.'='.$value->{$_} } keys %$value)
  0         0  
205             }
206              
207             # We have a custom message
208 7 100       270 if ($type_constraint->has_message) {
209 1         9 return $type_constraint->get_message($value);
210             # No message
211             } else {
212 6         307 my $message_human = $self->cmd_type_constraint_description($type_constraint);
213 6 50       35 if (defined $message_human) {
214 6         41 return "Value must be ". $message_human ." (not '$value')";
215             } else {
216 0         0 return $type_constraint->get_message($value);
217             }
218             }
219             }
220              
221 103         8132 return;
222             }
223              
224             sub cmd_usage_description {
225 195     195 1 428 my ($self) = @_;
226              
227 195 100       7138 my $description = ($self->has_documentation) ? $self->documentation : '';
228 195         4877 my @tags = $self->cmd_tags_list();
229 195 100       505 if (scalar @tags) {
230 145 100       454 $description .= ' '
231             if $description;
232 145         490 $description .= '['.join('; ',@tags).']';
233             }
234 195         868 return $description
235             }
236              
237             sub cmd_usage_name {
238 251     251 1 1088 my ($self) = @_;
239              
240 251 100       7860 if ($self->cmd_type eq 'parameter') {
241 42         100 return $self->cmd_name_primary;
242             } else {
243             return join(' ',
244 209 100       614 map { (length($_) == 1) ? "-$_":"--$_" }
  340         1789  
245             $self->cmd_name_possible
246             );
247             }
248             }
249              
250             sub cmd_name_primary {
251 1242     1242 1 2372 my ($self) = @_;
252              
253 1242 100       42920 if ($self->has_cmd_flag) {
254 339         10481 return $self->cmd_flag;
255             } else {
256 903         3802 return $self->name;
257             }
258             }
259              
260             sub cmd_name_list {
261 1143     1143 1 26363 my ($self) = @_;
262              
263 1143         2454 my @names = ($self->cmd_name_primary);
264              
265 1143 100       40672 if ($self->has_cmd_aliases) {
266 273         562 push(@names, @{$self->cmd_aliases});
  273         8624  
267             }
268              
269 1143         3472 return @names;
270             }
271              
272             sub cmd_name_possible {
273 740     740 1 1459 my ($self) = @_;
274              
275 740 50       22881 if ($self->cmd_type eq 'parameter') {
276 0         0 return $self->cmd_name_primary;
277             }
278              
279 740         1875 my @names = $self->cmd_name_list();
280              
281             # TODO check boolean type constraint
282 740 100       26009 if ($self->has_cmd_negate) {
283 18         35 push(@names, @{$self->cmd_negate});
  18         582  
284             }
285              
286 740         2196 return @names;
287             }
288              
289             sub cmd_tags_list {
290 198     198 1 549 my ($self) = @_;
291              
292 198         308 my @tags;
293              
294 198 100 66     6460 if ($self->is_required
      100        
295             && ! $self->is_lazy_build
296             && ! $self->has_default) {
297 25         1826 push(@tags,'Required')
298             }
299              
300 198 100 100     2018 if ($self->has_default && ! $self->is_default_a_coderef) {
301 1 50 33     57 if ($self->has_type_constraint
302             && $self->type_constraint->is_a_type_of('Bool')) {
303             # if ($attribute->default) {
304             # push(@tags,'Default:Enabled');
305             # } else {
306             # push(@tags,'Default:Disabled');
307             # }
308             } else {
309 0         0 push(@tags,'Default:"'.$self->default.'"');
310             }
311             }
312              
313 198 100       7970 if ($self->has_cmd_split) {
314 5         165 my $split = $self->cmd_split;
315 5 50       20 if (ref($split) eq 'Regexp') {
316 5         14 $split = "$split";
317 5         29 $split =~ s/^\(\?\^\w*:(.+)\)$/$1/x;
318             }
319 5         23 push(@tags,'Multiple','Split by "'.$split.'"');
320             }
321              
322 198 100       7032 if ($self->has_type_constraint) {
323 171         5825 my $type_constraint = $self->type_constraint;
324 171 100       1640 if ($type_constraint->is_a_type_of('ArrayRef')) {
    100          
325 10 100       2316 if (! $self->has_cmd_split) {
326 5         17 push(@tags,'Multiple');
327             }
328             } elsif ($type_constraint->is_a_type_of('HashRef')) {
329 5         3506 push(@tags,'Key-Value');
330             }
331 171 100       170998 unless ($self->should_coerce) {
332 166 100       1520 if ($type_constraint->is_a_type_of('Int')) {
    100          
    100          
    100          
333 39         5213 push(@tags,'Integer');
334             } elsif ($type_constraint->is_a_type_of('Num')) {
335 5         3689 push(@tags ,'Number');
336             } elsif ($type_constraint->is_a_type_of('Bool')) {
337 60         49338 push(@tags ,'Flag');
338             } elsif ($type_constraint->isa('Moose::Meta::TypeConstraint::Enum')) {
339 9         15167 push(@tags ,'Possible values: '.join(', ',@{$type_constraint->values}));
  9         323  
340             }
341             }
342             }
343              
344 198 100 66     96440 if ($self->can('has_cmd_env')
345             && $self->has_cmd_env) {
346 14         484 push(@tags,'Env: '.$self->cmd_env)
347             }
348              
349 198 100 33     7840 if ($self->can('cmd_tags')
      66        
350             && $self->can('cmd_tags')
351             && $self->has_cmd_tags) {
352 29         71 push(@tags,@{$self->cmd_tags});
  29         1012  
353             }
354              
355 198         663 return @tags;
356             }
357              
358             {
359             package Moose::Meta::Attribute::Custom::Trait::AppOption;
360              
361 15     15   147 use strict;
  15         35  
  15         414  
362 15     15   112 use warnings;
  15         42  
  15         1391  
363              
364 0     0     sub register_implementation { return 'MooseX::App::Meta::Role::Attribute::Option' }
365             }
366              
367             1;
368              
369             =pod
370              
371             =encoding utf8
372              
373             =head1 NAME
374              
375             MooseX::App::Meta::Role::Attribute::Option - Meta attribute role for options
376              
377             =head1 DESCRIPTION
378              
379             This meta attribute role will automatically be applied to all attributes
380             that should be used as options.
381              
382             =head1 ACCESSORS
383              
384             In your app and command classes you can
385             use the following attributes in option or parameter definitions.
386              
387             option 'myoption' => (
388             is => 'rw',
389             isa => 'ArrayRef[Str]',
390             documentation => 'My special option',
391             cmd_flag => 'myopt',
392             cmd_aliases => [qw(mopt localopt)],
393             cmd_tags => [qw(Important!)],
394             cmd_env => 'MY_OPTION',
395             cmd_position => 1,
396             cmd_split => qr/,/,
397             cmd_negate => 'notoption'
398             );
399              
400             =head2 cmd_flag
401              
402             Use this name instead of the attribute name as the option name
403              
404             =head2 cmd_type
405              
406             Option to mark if this attribute should be used as an option or parameter value.
407              
408             Allowed values are:
409              
410             =over
411              
412             =item * option - Command line option
413              
414             =item * proto - Command line option that should be processed prior to other
415             options (eg. a config-file option that sets other attribues) Usually only
416             used for plugin developmemt
417              
418             =item * parameter - Positional parameter command line value
419              
420             =back
421              
422             =head2 cmd_env
423              
424             Environment variable name (only uppercase letters, numeric and underscores
425             allowed). If variable was not specified otherwise the value will be
426             taken from %ENV.
427              
428             =head2 cmd_aliases
429              
430             Arrayref of alternative option names
431              
432             =head2 cmd_tags
433              
434             Extra option tags displayed in the usage information (in brackets)
435              
436             =head2 cmd_position
437              
438             Override the order of the parameters in the usage message.
439              
440             =head2 cmd_split
441              
442             Splits multiple values at the given separator string or regular expression.
443             Only works in conjunction with an 'ArrayRef[*]' type constraint.
444             ie. '--myattr value1,value2' with cmd_split set to ',' would produce an
445             arrayref with to elements.
446              
447             =head2 cmd_count
448              
449             Similar to the Getopt::Long '+' modifier, cmd_count turns the attribute into
450             a counter. Every occurrence of the attribute in @ARGV (without any value)
451             would increment the resulting value by one
452              
453             =head2 cmd_negate
454              
455             Sets names for the negated variant of a boolean field. Only works in conjunction
456             with a 'Bool' type constraint.
457              
458             =head1 METHODS
459              
460             These methods are only of interest to plugin authors.
461              
462             =head2 cmd_check
463              
464             Runs sanity checks on options and parameters. Will usually only be executed if
465             either HARNESS_ACTIVE or APP_DEVELOPER environment are set.
466              
467             =head2 cmd_name_possible
468              
469             my @names = $attribute->cmd_name_possible();
470              
471             Returns a list of all possible option names.
472              
473             =head2 cmd_name_list
474              
475             my @names = $attribute->cmd_name_list();
476              
477             Similar to cmd_name_possible this method returns a list of option names,
478             except for names set via cmd_negate.
479              
480             =head2 cmd_name_primary
481              
482             my $name = $attribute->cmd_name_primary();
483              
484             Returns the primary option name
485              
486             =head2 cmd_usage_name
487              
488             my $name = $attribute->cmd_usage_name();
489              
490             Returns the name as used by the usage text
491              
492             =head2 cmd_usage_description
493              
494             my $name = $attribute->cmd_usage_description();
495              
496             Returns the description as used by the usage text
497              
498             =head2 cmd_tags_list
499              
500             my @tags = $attribute->cmd_tags_list();
501              
502             Returns a list of tags
503              
504             =head2 cmd_type_constraint_check
505              
506             $attribute->cmd_type_constraint_check($value)
507              
508             Checks the type constraint. Returns an error message if the check fails
509              
510             =head2 cmd_type_constraint_description
511              
512             $attribute->cmd_type_constraint_description($type_constraint,$singular)
513              
514             Creates a description of the selected type constraint.
515              
516             =cut
517