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;
  98
  99         if($signature[-1]->isa('MooseX::Meta::TypeConstraint::Structured::Optional')) {
 100             my $optional = pop @signature;
 101             @optional_signature = @{$optional->signature};
 102         }
 103
 104         ## First make sure all the required type constraints match
 105         while( my $type_constraint = shift @signature) {
 106             if(my $error = $type_constraint->validate(shift @args)) {
 107                 confess $error;
 108             }
 109         }
 110
 111         ## Now test the option type constraints.
 112         while( my $arg = shift @args) {
 113             if(my $optional_type_constraint = shift @optional_signature) {
 114                 if(my $error = $optional_type_constraint->validate($arg)) {
 115                     confess $error;
 116                 }
 117             } else {
 118                 confess "Too Many arguments for the available type constraints";
 119             }
 120         }
 121
 122         ## If we got this far we passed!
 123         return 1;
 124     };
 125 }
 126
 127 =head2 _parse_type_parameter ($str)
 128
 129 Given a $string that is the parameter information part of a parameterized
 130 constraint, parses it for internal constraint information.  For example:
 131
 132         MyType[Int,Int,Str]
 133
 134 has a parameter string of "Int,Int,Str" (whitespace will automatically be
 135 removed during normalization that happens in L<Moose::Util::TypeConstraints>)
 136 and we need to convert that to ['Int','Int','Str'] which then has any type
 137 constraints converted to true objects.
 138
 139 =cut
 140
 141 {
 142     use re "eval";
 143
 144     my $any;
 145     my $valid_chars = qr{[\w:]};
 146     my $type_atom   = qr{ $valid_chars+ };
 147
 148     my $type                = qr{  $valid_chars+  (?: \[  (??{$any})  \] )? }x;
 149     my $type_capture_parts  = qr{ ($valid_chars+) (?: \[ ((??{$any})) \] )? }x;
 150     my $type_with_parameter = qr{  $valid_chars+      \[  (??{$any})  \]    }x;
 151
 152     my $op_union = qr{ \s* \| \s* }x;
 153     my $union    = qr{ $type (?: $op_union $type )+ }x;
 154
 155     ## New Stuff for structured types.
 156     my $comma = qr{,};
 157     my $indirection = qr{=>};
 158     my $divider_ops = qr{ $comma | $indirection }x;
 159     my $structure_divider = qr{\s* $divider_ops \s*}x;
 160     my $structure_elements = qr{ $valid_chars+ $structure_divider $type | $union }x;
 161
 162     $any = qr{  $union | $structure_elements+ | $type }x;
 163
 164         sub _parse_type_parameter {
 165                 my ($class, $type_str) = @_;
 166         {
 167             $any;
 168             my @type_strs = ($type_str=~m/$union | $type/gx);
 169             return map {
 170                 Moose::Util::TypeConstraints::find_or_create_type_constraint($_);
 171             } @type_strs;
 172         }
 173         }
 174 }
 175
 176 =head2 signature_equals
 177
 178 Check that the signature equals another signature.
 179
 180 =cut
 181
 182 sub signature_equals {
 183     my ($self, $compared_type_constraint) = @_;
 184
 185     foreach my $idx (0..$#{$self->signature}) {
 186         my $this = $self->signature->[$idx];
 187         my $that = $compared_type_constraint->signature->[$idx];
 188         return unless $this->equals($that);
 189     }
 190
 191     if($self->has_optional_signature) {
 192         foreach my $idx (0..$#{$self->optional_signature}) {
 193             my $this = $self->optional_signature->[$idx];
 194             my $that = $compared_type_constraint->optional_signature->[$idx];
 195             return unless $this->equals($that);
 196         }
 197     }
 198
 199     return 1;
 200 }
 201
 202 =head1 AUTHOR
 203
 204 John James Napiorkowski <jjnapiork@cpan.org>
 205
 206 =head1 LICENSE
 207
 208 You may distribute this code under the same terms as Perl itself.
 209
 210 =cut
 211
 212 no Moose; 1;