lib/MooseX/Getopt/Session.pm

   1
   2 package MooseX::Getopt::Session;
   3
   4 use Moose;
   5
   6 use MooseX::Getopt::Parser::Long;
   7 use maybe 'MooseX::Getopt::Parser::Descriptive';
   8
   9 #use Smart::Comments;
  10
  11 # Pluggined MooseX::Getopt::Parser parser
  12 has 'parser' => (
  13     is => 'rw',
  14     does => 'MooseX::Getopt::Parser',
  15     default => sub {
  16         maybe::HAVE_MOOSEX_GETOPT_PARSER_DESCRIPTIVE
  17         ? MooseX::Getopt::Parser::Descriptive->new
  18         : MooseX::Getopt::Parser::Long->new
  19     },
  20 );
  21
  22 # Filter for classes which are searched for getopt trait
  23 has 'classes_filter' => (
  24     is => 'rw',
  25     isa => 'CodeRef',
  26     default => sub { sub { 1 } },
  27 );
  28
  29 # Original @ARGV values
  30 has 'argv' => (
  31     is => 'rw',
  32     isa => 'ArrayRef[Str]',
  33     auto_deref => 1,
  34     default => sub { [ @ARGV ] },
  35 );
  36
  37 # Unrecognized @ARGV values
  38 has 'extra_argv' => (
  39     is => 'rw',
  40     isa => 'ArrayRef[Str]',
  41     auto_deref => 1,
  42     default => sub { [] },
  43 );
  44
  45 # Hash with options parsed from argv
  46 has 'options' => (
  47     is => 'rw',
  48     isa => 'HashRef',
  49     auto_deref => 1,
  50     default => sub { {} },
  51 );
  52
  53 # Status of parser
  54 has 'status' => (
  55     is => 'rw',
  56     isa => 'Bool',
  57 );
  58
  59 # Warnings collected by parser
  60 has 'warning' => (
  61     is => 'rw',
  62     isa => 'Str',
  63     predicate => 'has_warning',
  64 );
  65
  66 # Die if warnings was occured
  67 sub BUILD {
  68     ### MooseX::Getopt::Session::BUILD : @_
  69     my ($self, $args) = @_;
  70
  71     $self->build_options;
  72 };
  73
  74
  75 sub build_options {
  76     my ($self) = @_;
  77
  78     my @attrs = map { $_->_compute_getopt_attrs } $self->_compute_getopt_classes;
  79     ### MooseX::Getopt::Session::build_options @attrs -> name : map { $_->name } @attrs
  80
  81     return $self->parser->build_options( $self, @attrs );
  82 }
  83
  84
  85 sub _compute_getopt_classes {
  86     my $self = shift;
  87
  88     return grep {
  89         $self->classes_filter->()
  90     } grep {
  91         $_->isa('Moose::Object') && $_->does('MooseX::Getopt')
  92     } Class::MOP->get_all_metaclasses;
  93 };
  94
  95
  96 sub _get_cmd_flags_for_attr {
  97     my ($self, $attr) = @_;
  98
  99     my $flag = $attr->name;
 100
 101     my @aliases;
 102
 103     if ($attr->does('MooseX::Getopt::Meta::Attribute::Trait')) {
 104         $flag = $attr->cmd_flag if $attr->has_cmd_flag;
 105         @aliases = @{ $attr->cmd_aliases } if $attr->has_cmd_aliases;
 106     };
 107
 108     return ($flag, @aliases);
 109 };
 110
 111
 112 sub _get_cmd_type_for_attr {
 113     my ($self, $attr) = @_;
 114
 115     my $type;
 116
 117     $type = $attr->type_constraint if $attr->has_type_constraint;
 118
 119     if ($attr->does('MooseX::Getopt::Meta::Attribute::Trait')) {
 120         $type = $attr->cmd_type if $attr->has_cmd_type;
 121     };
 122
 123     return $type;
 124 };
 125
 126
 127 sub strcat_warning {
 128     my ($self, $string) = @_;
 129
 130     return $self->warning( ($self->has_warning ? $self->warning : '') . $string );
 131 };
 132
 133
 134 1;