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             my $optional_type_constraint = shift @optional_signature;
 110             if(my $error = $optional_type_constraint->validate($arg)) {
 111                 confess $error;
 112             }
 113         }
 114
 115         ## If we got this far we passed!
 116         return 1;
 117     };
 118 }
 119
 120 =head2 signature_equals
 121
 122 Check that the signature equals another signature.
 123
 124 =cut
 125
 126 sub signature_equals {
 127     my ($self, $compared_type_constraint) = @_;
 128
 129     foreach my $idx (0..$#{$self->signature}) {
 130         my $this = $self->signature->[$idx];
 131         my $that = $compared_type_constraint->signature->[$idx];
 132         return unless $this->equals($that);
 133     }
 134
 135     if($self->has_optional_signature) {
 136         foreach my $idx (0..$#{$self->optional_signature}) {
 137             my $this = $self->optional_signature->[$idx];
 138             my $that = $compared_type_constraint->optional_signature->[$idx];
 139             return unless $this->equals($that);
 140         }
 141     }
 142
 143     return 1;
 144 }
 145
 146 =head1 AUTHOR
 147
 148 John James Napiorkowski <jjnapiork@cpan.org>
 149
 150 =head1 LICENSE
 151
 152 You may distribute this code under the same terms as Perl itself.
 153
 154 =cut
 155
 156 no Moose; 1;