# ============================================================================
package MooseX::App::Meta::Role::Attribute::Option;
# ============================================================================
use utf8;
use 5.010;
use namespace::autoclean;
use Moose::Role;
has 'cmd_type' => (
is => 'rw',
isa => 'MooseX::App::Types::CmdTypes',
predicate => 'has_cmd_type',
);
has 'cmd_tags' => (
is => 'rw',
isa => 'ArrayRef[Str]',
predicate => 'has_cmd_tags',
);
has 'cmd_flag' => (
is => 'rw',
isa => 'Str',
predicate => 'has_cmd_flag',
);
has 'cmd_aliases' => (
is => 'rw',
isa => 'MooseX::App::Types::List',
predicate => 'has_cmd_aliases',
coerce => 1,
);
has 'cmd_split' => (
is => 'rw',
isa => Moose::Util::TypeConstraints::union([qw(Str RegexpRef)]),
predicate => 'has_cmd_split',
);
has 'cmd_count' => (
is => 'rw',
isa => 'Bool',
default => sub { 0 },
);
has 'cmd_env' => (
is => 'rw',
isa => 'MooseX::App::Types::Env',
predicate => 'has_cmd_env',
);
has 'cmd_position' => (
is => 'rw',
isa => 'Int',
default => sub { 0 },
);
my $GLOBAL_COUNTER = 1;
around 'new' => sub {
my $orig = shift;
my $class = shift;
my $self = $class->$orig(@_);
if ($self->has_cmd_type) {
if ($self->cmd_position == 0) {
$GLOBAL_COUNTER++;
$self->cmd_position($GLOBAL_COUNTER);
}
}
return $self;
};
sub cmd_has_value {
my ($self) = @_;
if ($self->has_type_constraint
&& $self->type_constraint->is_a_type_of('Bool')) {
# Bool and defaults to true
#if ($self->has_default
# && ! $self->is_default_a_coderef
# && $self->default == 1) {
# return 0;
## Bool and is required
#} elsif (! $self->has_default
# && $self->is_required) {
# return 0;
#}
# Ordinary bool
return 0;
}
if ($self->cmd_count) {
return 0;
}
return 1;
}
sub cmd_type_constraint_description {
my ($self,$type_constraint,$singular) = @_;
$type_constraint //= $self->type_constraint;
$singular //= 1;
if ($type_constraint->isa('Moose::Meta::TypeConstraint::Enum')) {
return 'one of these values: '.join(', ',@{$type_constraint->values});
} elsif ($type_constraint->isa('Moose::Meta::TypeConstraint::Parameterized')) {
my $from = $type_constraint->parameterized_from;
if ($from->is_a_type_of('ArrayRef')) {
return $self->cmd_type_constraint_description($type_constraint->type_parameter);
} elsif ($from->is_a_type_of('HashRef')) {
return 'key-value pairs of '.$self->cmd_type_constraint_description($type_constraint->type_parameter,0);
}
# TODO union
} elsif ($type_constraint->equals('Int')) {
return $singular ? 'an integer':'integers'; # LOCALIZE
} elsif ($type_constraint->equals('Num')) {
return $singular ? 'a number':'numbers'; # LOCALIZE
} elsif ($type_constraint->equals('Str')) {
return $singular ? 'a string':'strings';
} elsif ($type_constraint->equals('HashRef')) {
return 'key-value pairs'; # LOCALIZE
}
if ($type_constraint->has_parent) {
return $self->cmd_type_constraint_description($type_constraint->parent);
}
return;
}
sub cmd_type_constraint_check {
my ($self,$value) = @_;
return
unless ($self->has_type_constraint);
my $type_constraint = $self->type_constraint;
if ($type_constraint->has_coercion) {
$value = $type_constraint->coerce($value)
}
# Check type constraints
unless ($type_constraint->check($value)) {
if (ref($value) eq 'ARRAY') {
$value = join(', ',grep { defined } @$value);
} elsif (ref($value) eq 'HASH') {
$value = join(', ',map { $_.'='.$value->{$_} } keys %$value)
}
# We have a custom message
if ($type_constraint->has_message) {
return $type_constraint->get_message($value);
# No message
} else {
my $message_human = $self->cmd_type_constraint_description($type_constraint);
if (defined $message_human) {
return "Value must be ". $message_human ." (not '$value')";
} else {
return $type_constraint->get_message($value);
}
}
}
return;
}
sub cmd_usage_description {
my ($self) = @_;
my $description = ($self->has_documentation) ? $self->documentation : '';
my @tags = $self->cmd_tags_list();
if (scalar @tags) {
$description .= ' '
if $description;
$description .= '['.join('; ',@tags).']';
}
return $description
}
sub cmd_usage_name {
my ($self) = @_;
if ($self->cmd_type eq 'parameter') {
return $self->cmd_name_primary;
} else {
return join(' ',
map { (length($_) == 1) ? "-$_":"--$_" }
$self->cmd_name_possible);
}
}
sub cmd_name_primary {
my ($self) = @_;
if ($self->has_cmd_flag) {
return $self->cmd_flag;
} else {
return $self->name;
}
}
sub cmd_name_possible {
my ($self) = @_;
my @names = ($self->cmd_name_primary);
if ($self->has_cmd_aliases) {
push(@names, @{$self->cmd_aliases});
}
return @names;
}
sub cmd_tags_list {
my ($self) = @_;
my @tags;
if ($self->is_required
&& ! $self->is_lazy_build
&& ! $self->has_default) {
push(@tags,'Required')
}
if ($self->has_default && ! $self->is_default_a_coderef) {
if ($self->has_type_constraint
&& $self->type_constraint->is_a_type_of('Bool')) {
# if ($attribute->default) {
# push(@tags,'Default:Enabled');
# } else {
# push(@tags,'Default:Disabled');
# }
} else {
push(@tags,'Default:"'.$self->default.'"');
}
}
if ($self->has_cmd_split) {
my $split = $self->cmd_split;
if (ref($split) eq 'Regexp') {
$split = "$split";
$split =~ s/^\(\?\^\w*:(.+)\)$/$1/x;
}
push(@tags,'Multiple','Split by "'.$split.'"');
}
if ($self->has_type_constraint) {
my $type_constraint = $self->type_constraint;
if ($type_constraint->is_a_type_of('ArrayRef')) {
if (! $self->has_cmd_split) {
push(@tags,'Multiple');
}
} elsif ($type_constraint->is_a_type_of('HashRef')) {
push(@tags,'Key-Value');
}
unless ($self->should_coerce) {
if ($type_constraint->is_a_type_of('Int')) {
push(@tags,'Integer');
} elsif ($type_constraint->is_a_type_of('Num')) {
push(@tags ,'Number');
} elsif ($type_constraint->is_a_type_of('Bool')) {
push(@tags ,'Flag');
} elsif ($type_constraint->isa('Moose::Meta::TypeConstraint::Enum')) {
push(@tags ,'Possible values: '.join(', ',@{$type_constraint->values}));
}
}
}
if ($self->can('has_cmd_env')
&& $self->has_cmd_env) {
push(@tags,'Env: '.$self->cmd_env)
}
if ($self->can('cmd_tags')
&& $self->can('cmd_tags')
&& $self->has_cmd_tags) {
push(@tags,@{$self->cmd_tags});
}
return @tags;
}
{
package Moose::Meta::Attribute::Custom::Trait::AppOption;
use strict;
use warnings;
sub register_implementation { return 'MooseX::App::Meta::Role::Attribute::Option' }
}
1;
=pod
=encoding utf8
=head1 NAME
MooseX::App::Meta::Role::Attribute::Option - Meta attribute role for options
=head1 DESCRIPTION
This meta attribute role will automatically be applied to all attributes
that should be used as options.
=head1 ACCESSORS
In your app and command classes you can
use the following attributes in option or parameter definitions.
option 'myoption' => (
is => 'rw',
isa => 'ArrayRef[Str]',
documentation => 'My special option',
cmd_flag => 'myopt',
cmd_aliases => [qw(mopt localopt)],
cmd_tags => [qw(Important!)],
cmd_env => 'MY_OPTION',
cmd_position => 1,
cmd_split => qr/,/,
);
=head2 cmd_flag
Use this name instead of the attribute name as the option name
=head2 cmd_type
Option to mark if this attribute should be used as an option or parameter value.
Allowed values are:
=over
=item * option - Command line option
=item * proto - Command line option that should be processed prior to other
options (eg. a config-file option that sets other attribues) Usually only
used for plugin developmemt
=item * parameter - Positional parameter command line value
=back
=head2 cmd_env
Environment variable name (only uppercase letters, numeric and underscores
allowed). If variable was not specified otherwise the value will be
taken from %ENV.
=head2 cmd_aliases
Arrayref of alternative option names
=head2 cmd_tags
Extra option tags displayed in the usage information (in brackets)
=head2 cmd_position
Override the order of the parameters in the usage message.
=head2 cmd_split
Splits multiple values at the given separator string or regular expression.
Only works in conjunction with an 'ArrayRef[*]' type constraint (isa).
ie. '--myattr value1,value2' with cmd_split set to ',' would produce an
arrayref with to elements.
=head2 cmd_count
Similar to the Getopt::Long '+' modifier, cmd_count turns the attribute into
a counter. Every occurrence of the attribute in @ARGV (without any value)
would increment the resulting value by one
=head1 METHODS
These methods are only of interest to plugin authors.
=head2 cmd_name_possible
my @names = $attribute->cmd_name_possible();
Returns a list of all possible option names.
=head2 cmd_name_primary
my $name = $attribute->cmd_name_primary();
Returns the primary option name
=head2 cmd_usage_name
my $name = $attribute->cmd_usage_name();
Returns the name as used by the usage text
=head2 cmd_usage_description
my $name = $attribute->cmd_usage_description();
Returns the description as used by the usage text
=head2 cmd_tags_list
my @tags = $attribute->cmd_tags_list();
Returns a list of tags
=head2 cmd_has_value
my $has_value = $attribute->cmd_has_value();
Indicates if an commandline attribute has a value. Usually attributes with a
boolean type constraint or counters don't have values.
=over
=item * undef: Does not have a boolean type constraint
=item * true: Has a boolean type constraint
=item * false: Has a boolean type constraint, and a true default value
=back
=head2 cmd_type_constraint_check
$attribute->cmd_type_constraint_check($value)
Checks the type constraint. Returns an error message if the check fails
=head2 cmd_type_constraint_description
$attribute->cmd_type_constraint_description($type_constraint,$singular)
Creates a description of the selected type constraint.
=cut