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 'getopt_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 has 'die_on_warning' => (
  68     is => 'rw',
  69     isa => 'Bool',
  70     default => 1,
  71 );
  72
  73
  74 sub BUILD {
  75     ### MooseX::Getopt::Session::BUILD : @_
  76     my ($self, $args) = @_;
  77
  78     $self->build_options;
  79 };
  80
  81
  82 sub build_options {
  83     my ($self) = @_;
  84
  85     my @attrs = map { $_->_compute_getopt_attrs } $self->_compute_getopt_classes;
  86     ### MooseX::Getopt::Session::build_options @attrs -> name : map { $_->name } @attrs
  87
  88     return $self->getopt_parser->build_options( $self, @attrs );
  89 }
  90
  91
  92 sub _compute_getopt_classes {
  93     my $self = shift;
  94
  95     return grep {
  96         $self->classes_filter->()
  97     } grep {
  98         $_->isa('Moose::Object') && $_->does('MooseX::Getopt')
  99     } Class::MOP->get_all_metaclasses;
 100 };
 101
 102
 103 sub _get_cmd_flags_for_attr {
 104     my ($self, $attr) = @_;
 105
 106     my $flag = $attr->name;
 107
 108     my @aliases;
 109
 110     if ($attr->does('MooseX::Getopt::Meta::Attribute::Trait')) {
 111         $flag = $attr->cmd_flag if $attr->has_cmd_flag;
 112         @aliases = @{ $attr->cmd_aliases } if $attr->has_cmd_aliases;
 113     };
 114
 115     return ($flag, @aliases);
 116 };
 117
 118
 119 sub _get_cmd_type_for_attr {
 120     my ($self, $attr) = @_;
 121
 122     my $type;
 123
 124     $type = $attr->type_constraint if $attr->has_type_constraint;
 125
 126     if ($attr->does('MooseX::Getopt::Meta::Attribute::Trait')) {
 127         $type = $attr->cmd_type if $attr->has_cmd_type;
 128     };
 129
 130     return $type;
 131 };
 132
 133
 134 sub strcat_warning {
 135     my ($self, $string) = @_;
 136
 137     return $self->warning( ($self->has_warning ? $self->warning : '') . $string );
 138 };
 139
 140
 141 1;