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