* MooseX::Getopt::Parser::Descriptive: fixed regression: does not require CLI param...

[gitmo/MooseX-Getopt.git] / lib / MooseX / Getopt / Session.pm

package MooseX::Getopt::Session;

use Moose;

use MooseX::Getopt::Parser::Long;
use maybe 'MooseX::Getopt::Parser::Descriptive';

#use Smart::Comments;

# Pluggined MooseX::Getopt::Parser parser
has 'parser' => (
    is => 'rw',
    does => 'MooseX::Getopt::Parser',
    default => sub {
        maybe::HAVE_MOOSEX_GETOPT_PARSER_DESCRIPTIVE
        ? MooseX::Getopt::Parser::Descriptive->new
        : MooseX::Getopt::Parser::Long->new
    },
);

# Filter for classes which are searched for getopt trait
has 'classes_filter' => (
    is => 'rw',
    isa => 'CodeRef',
    default => sub { sub { 1 } },
);

# Explicite parameters for new_with_options
has 'params' => (
    is => 'rw',
    isa => 'HashRef',
    default => sub { {} },
);

# Original @ARGV values
has 'argv' => (
    is => 'rw',
    isa => 'ArrayRef[Str]',
    auto_deref => 1,
    default => sub { [ @ARGV ] },
);

# Unrecognized @ARGV values
has 'extra_argv' => (
    is => 'rw',
    isa => 'ArrayRef[Str]',
    auto_deref => 1,
    default => sub { [] },
);

# Hash with options parsed from argv
has 'options' => (
    is => 'rw',
    isa => 'HashRef',
    auto_deref => 1,
    default => sub { {} },
);

# Status of parser
has 'status' => (
    is => 'rw',
    isa => 'Bool',
);

# Warnings collected by parser
has 'warning' => (
    is => 'rw',
    isa => 'Str',
    predicate => 'has_warning',
);

# Die if warnings was occured
sub BUILD {
    ### MooseX::Getopt::Session::BUILD : @_
    my ($self, $args) = @_;

    $self->build_options;
};


sub build_options {
    my ($self) = @_;

    my @attrs = map { $_->_compute_getopt_attrs } $self->_compute_getopt_classes;
    ### MooseX::Getopt::Session::build_options @attrs -> name : map { $_->name } @attrs

    return $self->parser->build_options( $self, @attrs );
}


sub _compute_getopt_classes {
    my $self = shift;

    return grep {
        $self->classes_filter->()
    } grep {
        $_->isa('Moose::Object') && $_->does('MooseX::Getopt')
    } Class::MOP->get_all_metaclasses;
};


sub _get_cmd_flags_for_attr {
    my ($self, $attr) = @_;

    my $flag = $attr->name;

    my @aliases;

    if ($attr->does('MooseX::Getopt::Meta::Attribute::Trait')) {
        $flag = $attr->cmd_flag if $attr->has_cmd_flag;
        @aliases = @{ $attr->cmd_aliases } if $attr->has_cmd_aliases;
    };

    return ($flag, @aliases);
};


sub _get_cmd_type_for_attr {
    my ($self, $attr) = @_;

    my $type;
    
    $type = $attr->type_constraint if $attr->has_type_constraint;

    if ($attr->does('MooseX::Getopt::Meta::Attribute::Trait')) {
        $type = $attr->cmd_type if $attr->has_cmd_type;
    };

    return $type;
};


sub strcat_warning {
    my ($self, $string) = @_;

    return $self->warning( ($self->has_warning ? $self->warning : '') . $string );
};


1;