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 parse_parameter_str ($str)
 121
 122 Given a $string that is the parameter information part of a parameterized
 123 constraint, parses it for internal constraint information.  For example:
 124
 125         MyType[Int,Int,Str]
 126
 127 has a parameter string of "Int,Int,Str" (whitespace will automatically be
 128 removed during normalization that happens in L<Moose::Util::TypeConstraints>)
 129 and we need to convert that to ['Int','Int','Str'] which then has any type
 130 constraints converted to true objects.
 131
 132 =cut
 133
 134 {
 135     my $comma = qr{,};
 136     my $indirection = qr{=>};
 137     my $divider_ops = qr{ $comma | $indirection }x;
 138     my $structure_divider = qr{\s* $divider_ops \s*}x;
 139
 140         sub parse_parameter_str {
 141                 my ($class, $type_str) = @_;
 142                 my @type_strs = split($structure_divider, $type_str);
 143                 return map { Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($_) } @type_strs;
 144         }
 145 }
 146
 147 =head2 signature_equals
 148
 149 Check that the signature equals another signature.
 150
 151 =cut
 152
 153 sub signature_equals {
 154     my ($self, $compared_type_constraint) = @_;
 155
 156     foreach my $idx (0..$#{$self->signature}) {
 157         my $this = $self->signature->[$idx];
 158         my $that = $compared_type_constraint->signature->[$idx];
 159         return unless $this->equals($that);
 160     }
 161
 162     if($self->has_optional_signature) {
 163         foreach my $idx (0..$#{$self->optional_signature}) {
 164             my $this = $self->optional_signature->[$idx];
 165             my $that = $compared_type_constraint->optional_signature->[$idx];
 166             return unless $this->equals($that);
 167         }
 168     }
 169
 170     return 1;
 171 }
 172
 173 =head1 AUTHOR
 174
 175 John James Napiorkowski <jjnapiork@cpan.org>
 176
 177 =head1 LICENSE
 178
 179 You may distribute this code under the same terms as Perl itself.
 180
 181 =cut
 182
 183 no Moose; 1;