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' => (
  62     isa=>'ArrayRef[Moose::Meta::TypeConstraint]',
  63 );
  64
  65 =head2 optional_signature
  66
  67 This is a signature of internal contraints for the contents of the outer
  68 contraint container.  These are optional constraints.
  69
  70 =cut
  71
  72 has 'optional_signature' => (
  73     is=>'ro',
  74     isa=>'ArrayRef[Moose::Meta::TypeConstraint]',
  75     predicate=>'has_optional_signature',
  76 );
  77
  78 =head1 METHODS
  79
  80 This class defines the following methods.
  81
  82 =head2 _normalize_args
  83
  84 Get arguments into a known state or die trying.  Ideally we try to make this
  85 into a HashRef so we can match it up with the L</signature> HashRef.
  86
  87 =cut
  88
  89 sub _normalize_args {
  90     my ($self, $args) = @_;
  91     if(defined $args) {
  92         if(ref $args eq 'ARRAY') {
  93             @$args
  94         } else {
  95             confess 'Signature must be an ArrayRef type';
  96         }
  97     } else {
  98         confess 'Signature cannot be empty';
  99     }
 100 }
 101
 102 =head2 constraint
 103
 104 The constraint is basically validating the L</signature> against the incoming
 105
 106 =cut
 107
 108 sub constraint {
 109     my $self = shift;
 110     return sub {
 111         my @args = $self->_normalize_args(shift);
 112         my @signature = @{$self->signature};
 113         my @optional_signature = @{$self->optional_signature}
 114          if $self->has_optional_signature;
 115
 116         ## First make sure all the required type constraints match
 117         while( my $type_constraint = shift @signature) {
 118             if(my $error = $type_constraint->validate(shift @args)) {
 119                 confess $error;
 120             }
 121         }
 122
 123         ## Now test the option type constraints.
 124         while( my $arg = shift @args) {
 125             my $optional_type_constraint = shift @optional_signature;
 126             if(my $error = $optional_type_constraint->validate($arg)) {
 127                 confess $error;
 128             }
 129         }
 130
 131         ## If we got this far we passed!
 132         return 1;
 133     };
 134 }
 135
 136 =head2 signature_equals
 137
 138 Check that the signature equals another signature.
 139
 140 =cut
 141
 142 sub signature_equals {
 143     my ($self, $compared_type_constraint) = @_;
 144
 145     foreach my $idx (0..$#{$self->signature}) {
 146         my $this = $self->signature->[$idx];
 147         my $that = $compared_type_constraint->signature->[$idx];
 148         return unless $this->equals($that);
 149     }
 150
 151     if($self->has_optional_signature) {
 152         foreach my $idx (0..$#{$self->optional_signature}) {
 153             my $this = $self->optional_signature->[$idx];
 154             my $that = $compared_type_constraint->optional_signature->[$idx];
 155             return unless $this->equals($that);
 156         }
 157     }
 158
 159     return 1;
 160 }
 161
 162 =head2 equals
 163
 164 modifier to make sure equals descends into the L</signature>
 165
 166 =cut
 167
 168 around 'equals' => sub {
 169     my ($equals, $self, $compared_type_constraint) = @_;
 170
 171     ## Make sure we are comparing typeconstraints of the same base class
 172     return unless $compared_type_constraint->isa(__PACKAGE__);
 173
 174     ## Make sure the base equals is also good
 175     return unless $self->$equals($compared_type_constraint);
 176
 177     ## Make sure the signatures match
 178     return unless $self->signature_equals($compared_type_constraint);
 179
 180     ## If we get this far, the two are equal
 181     return 1;
 182 };
 183
 184 =head1 AUTHOR
 185
 186 John James Napiorkowski <jjnapiork@cpan.org>
 187
 188 =head1 LICENSE
 189
 190 You may distribute this code under the same terms as Perl itself.
 191
 192 =cut
 193
 194 no Moose; 1;