lib/MooseX/Meta/TypeConstraint/Structured/Positional.pm

   1 package MooseX::Meta::TypeConstraint::Structured::Positional;
   2
   3 use Moose;
   4 use Moose::Meta::TypeConstraint ();
   5
   6 extends 'Moose::Meta::TypeConstraint';
   7 with 'MooseX::Meta::TypeConstraint::Role::Structured';
   8
   9 =head1 NAME
  10
  11 MooseX::Meta::TypeConstraint::Structured::Positional - Structured Type Constraints
  12
  13 =head1 SYNOPSIS
  14
  15 The follow is example usage:
  16
  17     use Moose::Util::TypeConstraints;
  18     use MooseX::Meta::TypeConstraint::Structured::Positional;
  19
  20     my @required = ('Str', 'Int');
  21     my @optional = ('Object');
  22
  23     my $tc = MooseX::Meta::TypeConstraint::Structured::Positional->new(
  24         name => 'Dict',
  25         parent => find_type_constraint('ArrayRef'),
  26         signature => [map {
  27             find_type_constraint($_);
  28         } @required],
  29         optional_signature => [map {
  30             find_type_constraint($_);
  31         } @optional],
  32     );
  33
  34 =head1 DESCRIPTION
  35
  36 Positionally structured Constraints expect the internal constraints to be in
  37 'positioned' or ArrayRef style order.  This allows you to add type constraints
  38 to the internal values of the Arrayref.
  39
  40 =head1 ATTRIBUTES
  41
  42 This class defines the following attributes.
  43
  44 =head2 signature
  45
  46 This is a signature of internal contraints for the contents of the outer
  47 contraint container.
  48
  49 =cut
  50
  51 has '+signature' => (isa=>'ArrayRef[Moose::Meta::TypeConstraint]');
  52
  53 =head2 optional_signature
  54
  55 This is a signature of internal contraints for the contents of the outer
  56 contraint container.  These are optional constraints.
  57
  58 =cut
  59
  60 has '+optional_signature' => (isa=>'ArrayRef[Moose::Meta::TypeConstraint]');
  61
  62 =head1 METHODS
  63
  64 This class defines the following methods.
  65
  66 =head2 _normalize_args
  67
  68 Get arguments into a known state or die trying.  Ideally we try to make this
  69 into a HashRef so we can match it up with the L</signature> HashRef.
  70
  71 =cut
  72
  73 sub _normalize_args {
  74     my ($self, $args) = @_;
  75     if(defined $args) {
  76         if(ref $args eq 'ARRAY') {
  77             @$args
  78         } else {
  79             confess 'Signature must be an ArrayRef type';
  80         }
  81     } else {
  82         confess 'Signature cannot be empty';
  83     }
  84 }
  85
  86 =head2 constraint
  87
  88 The constraint is basically validating the L</signature> against the incoming
  89
  90 =cut
  91
  92 sub constraint {
  93     my $self = shift;
  94     return sub {
  95         my @args = $self->_normalize_args(shift);
  96         my @signature = @{$self->signature};
  97                 my @optional_signature = @{$self->optional_signature}
  98                 if $self->has_optional_signature;
  99
 100         ## First make sure all the required type constraints match
 101         while( my $type_constraint = shift @signature) {
 102             if(my $error = $type_constraint->validate(shift @args)) {
 103                 confess $error;
 104             }
 105         }
 106
 107         ## Now test the option type constraints.
 108         while( my $arg = shift @args) {
 109             if(my $optional_type_constraint = shift @optional_signature) {
 110                 if(my $error = $optional_type_constraint->validate($arg)) {
 111                     confess $error;
 112                 }
 113             } else {
 114                 confess "Too Many arguments for the available type constraints";
 115             }
 116         }
 117
 118         ## If we got this far we passed!
 119         return 1;
 120     };
 121 }
 122
 123 =head2 signature_equals
 124
 125 Check that the signature equals another signature.
 126
 127 =cut
 128
 129 sub signature_equals {
 130     my ($self, $compared_type_constraint) = @_;
 131
 132     foreach my $idx (0..$#{$self->signature}) {
 133         my $this = $self->signature->[$idx];
 134         my $that = $compared_type_constraint->signature->[$idx];
 135         return unless $this->equals($that);
 136     }
 137
 138     if($self->has_optional_signature) {
 139         foreach my $idx (0..$#{$self->optional_signature}) {
 140             my $this = $self->optional_signature->[$idx];
 141             my $that = $compared_type_constraint->optional_signature->[$idx];
 142             return unless $this->equals($that);
 143         }
 144     }
 145
 146     return 1;
 147 }
 148
 149 =head1 AUTHOR
 150
 151 John James Napiorkowski <jjnapiork@cpan.org>
 152
 153 =head1 LICENSE
 154
 155 You may distribute this code under the same terms as Perl itself.
 156
 157 =cut
 158
 159 no Moose; 1;