lib/MooseX/Meta/TypeConstraint/Structured.pm

   1 package MooseX::Meta::TypeConstraint::Structured;
   2
   3 use 5.8.8; ## Minimum tested Perl Version
   4 use Moose;
   5 use Moose::Util::TypeConstraints;
   6
   7 extends 'Moose::Meta::TypeConstraint';
   8
   9 our $AUTHORITY = 'cpan:JJNAPIORK';
  10
  11 =head1 NAME
  12
  13 MooseX::Meta::TypeConstraint::Structured - Structured Type Constraints
  14
  15 =head1 VERSION
  16
  17 0.01
  18
  19 =cut
  20
  21 our $VERSION = '0.01';
  22
  23 =head1 DESCRIPTION
  24
  25 Structured type constraints let you assign an internal pattern of type
  26 constraints to a 'container' constraint.  The goal is to make it easier to
  27 declare constraints like "ArrayRef[Int, Int, Str]" where the constraint is an
  28 ArrayRef of three elements and the internal constraint on the three is Int, Int
  29 and Str.
  30
  31 =head1 ATTRIBUTES
  32
  33 This class defines the following attributes.
  34
  35 =head2 parent
  36
  37 additional details on the inherited parent attribute
  38
  39 =head2 signature
  40
  41 This is a signature of internal contraints for the contents of the outer
  42 contraint container.
  43
  44 =cut
  45
  46 subtype 'MooseX::Meta::TypeConstraint::Structured::Signature',
  47     as 'HashRef[Object]',
  48     where {
  49         my %signature = %$_;
  50         foreach my $key (keys %signature) {
  51             $signature{$key}->isa('Moose::Meta::TypeConstraint');
  52         } 1;
  53     };
  54
  55 coerce 'MooseX::Meta::TypeConstraint::Structured::Signature',
  56     from 'ArrayRef[Object]',
  57     via {
  58         my @signature = @$_;
  59         my %hashed_signature = map { $_ => $signature[$_] } 0..$#signature;
  60         \%hashed_signature;
  61     };
  62
  63 has 'signature' => (
  64     is=>'ro',
  65     isa=>'MooseX::Meta::TypeConstraint::Structured::Signature',
  66     coerce=>1,
  67     required=>1,
  68 );
  69
  70 =head1 METHODS
  71
  72 This class defines the following methods.
  73
  74 =head2 _normalize_args
  75
  76 Get arguments into a known state or die trying.  Ideally we try to make this
  77 into a HashRef so we can match it up with the L</signature> HashRef.
  78
  79 =cut
  80
  81 sub _normalize_args {
  82     my ($self, $args) = @_;
  83     if(defined $args) {
  84         if(ref $args eq 'ARRAY') {
  85             return map { $_ => $args->[$_] } (0..$#$args);
  86         } elsif (ref $args eq 'HASH') {
  87             return %$args;
  88         } else {
  89             confess 'Signature must be a reference';
  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         foreach my $idx (keys %{$self->signature}) {
 107             my $type_constraint = $self->signature->{$idx};
 108             if(my $error = $type_constraint->validate($args{$idx})) {
 109                 confess $error;
 110             }
 111         } 1;
 112     };
 113 }
 114
 115 =head2 equals
 116
 117 modifier to make sure equals descends into the L</signature>
 118
 119 =cut
 120
 121 around 'equals' => sub {
 122     my ($equals, $self, $compared_type_constraint) = @_;
 123
 124     ## Make sure we are comparing typeconstraints of the same base class
 125     return unless $compared_type_constraint->isa(__PACKAGE__);
 126
 127     ## Make sure the base equals is also good
 128     return unless $self->$equals($compared_type_constraint);
 129
 130     ## Make sure the signatures match
 131     return unless $self->signature_equals($compared_type_constraint);
 132
 133     ## If we get this far, the two are equal
 134     return 1;
 135 };
 136
 137 =head2 signature_equals
 138
 139 Check that the signature equals another signature.
 140
 141 =cut
 142
 143 sub signature_equals {
 144     my ($self, $compared_type_constraint) = @_;
 145
 146    foreach my $idx (keys %{$self->signature}) {
 147         my $this = $self->signature->{$idx};
 148         my $that = $compared_type_constraint->signature->{$idx};
 149         return unless $this->equals($that);
 150     }
 151
 152     return 1;
 153 }
 154
 155 =head1 AUTHOR
 156
 157 John James Napiorkowski <jjnapiork@cpan.org>
 158
 159 =head1 LICENSE
 160
 161 You may distribute this code under the same terms as Perl itself.
 162
 163 =cut
 164
 165 no Moose; 1;