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

   1 package MooseX::Meta::TypeConstraint::Structured::Positional;
   2
   3 use Moose;
   4 use Moose::Meta::TypeConstraint ();
   5 use Moose::Util::TypeConstraints;
   6
   7 extends 'Moose::Meta::TypeConstraint';
   8 with 'MooseX::Meta::TypeConstraint::Role::Structured';
   9
  10 =head1 NAME
  11
  12 MooseX::Meta::TypeConstraint::Structured::Positional - Structured Type Constraints
  13
  14 =head1 VERSION
  15
  16 0.01
  17
  18 =cut
  19
  20 our $VERSION = '0.01';
  21
  22 =head1 DESCRIPTION
  23
  24 Structured type constraints let you assign an internal pattern of type
  25 constraints to a 'container' constraint.  The goal is to make it easier to
  26 declare constraints like "ArrayRef[Int, Int, Str]" where the constraint is an
  27 ArrayRef of three elements and the internal constraint on the three is Int, Int
  28 and Str.
  29
  30 To accomplish this, we add an attribute to the base L<Moose::Meta::TypeConstraint>
  31 to hold a L</signature>, which is a reference to a pattern of type constraints.
  32 We then override L</constraint> to check our incoming value to the attribute
  33 against this signature pattern.
  34
  35 Positionally structured Constraints expect the internal constraints to be in
  36 'positioned' or ArrayRef style order.
  37
  38 =head1 TYPES
  39
  40 The following types are defined in this class.
  41
  42 =head2 Moose::Meta::TypeConstraint
  43
  44 Used to make sure we can properly validate incoming signatures.
  45
  46 =cut
  47
  48 class_type 'Moose::Meta::TypeConstraint';
  49
  50 =head1 ATTRIBUTES
  51
  52 This class defines the following attributes.
  53
  54 =head2 signature
  55
  56 This is a signature of internal contraints for the contents of the outer
  57 contraint container.
  58
  59 =cut
  60
  61 has '+signature' => (isa=>'ArrayRef[Moose::Meta::TypeConstraint]');
  62
  63 =head2 optional_signature
  64
  65 This is a signature of internal contraints for the contents of the outer
  66 contraint container.  These are optional constraints.
  67
  68 =cut
  69
  70 has '+optional_signature' => (isa=>'ArrayRef[Moose::Meta::TypeConstraint]');
  71
  72 =head1 METHODS
  73
  74 This class defines the following methods.
  75
  76 =head2 _normalize_args
  77
  78 Get arguments into a known state or die trying.  Ideally we try to make this
  79 into a HashRef so we can match it up with the L</signature> HashRef.
  80
  81 =cut
  82
  83 sub _normalize_args {
  84     my ($self, $args) = @_;
  85     if(defined $args) {
  86         if(ref $args eq 'ARRAY') {
  87             @$args
  88         } else {
  89             confess 'Signature must be an ArrayRef type';
  90         }
  91     } else {
  92         confess 'Signature cannot be empty';
  93     }
  94 }
  95
  96 =head2 constraint
  97
  98 The constraint is basically validating the L</signature> against the incoming
  99
 100 =cut
 101
 102 sub constraint {
 103     my $self = shift;
 104     return sub {
 105         my @args = $self->_normalize_args(shift);
 106         my @signature = @{$self->signature};
 107         my @optional_signature = @{$self->optional_signature}
 108          if $self->has_optional_signature;
 109
 110         ## First make sure all the required type constraints match
 111         while( my $type_constraint = shift @signature) {
 112             if(my $error = $type_constraint->validate(shift @args)) {
 113                 confess $error;
 114             }
 115         }
 116
 117         ## Now test the option type constraints.
 118         while( my $arg = shift @args) {
 119             my $optional_type_constraint = shift @optional_signature;
 120             if(my $error = $optional_type_constraint->validate($arg)) {
 121                 confess $error;
 122             }
 123         }
 124
 125         ## If we got this far we passed!
 126         return 1;
 127     };
 128 }
 129
 130 =head2 signature_equals
 131
 132 Check that the signature equals another signature.
 133
 134 =cut
 135
 136 sub signature_equals {
 137     my ($self, $compared_type_constraint) = @_;
 138
 139     foreach my $idx (0..$#{$self->signature}) {
 140         my $this = $self->signature->[$idx];
 141         my $that = $compared_type_constraint->signature->[$idx];
 142         return unless $this->equals($that);
 143     }
 144
 145     if($self->has_optional_signature) {
 146         foreach my $idx (0..$#{$self->optional_signature}) {
 147             my $this = $self->optional_signature->[$idx];
 148             my $that = $compared_type_constraint->optional_signature->[$idx];
 149             return unless $this->equals($that);
 150         }
 151     }
 152
 153     return 1;
 154 }
 155
 156 =head2 equals
 157
 158 modifier to make sure equals descends into the L</signature>
 159
 160 =cut
 161
 162 around 'equals' => sub {
 163     my ($equals, $self, $compared_type_constraint) = @_;
 164
 165     ## Make sure we are comparing typeconstraints of the same base class
 166     return unless $compared_type_constraint->isa(__PACKAGE__);
 167
 168     ## Make sure the base equals is also good
 169     return unless $self->$equals($compared_type_constraint);
 170
 171     ## Make sure the signatures match
 172     return unless $self->signature_equals($compared_type_constraint);
 173
 174     ## If we get this far, the two are equal
 175     return 1;
 176 };
 177
 178 =head1 AUTHOR
 179
 180 John James Napiorkowski <jjnapiork@cpan.org>
 181
 182 =head1 LICENSE
 183
 184 You may distribute this code under the same terms as Perl itself.
 185
 186 =cut
 187
 188 no Moose; 1;