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 SUBTYPES
  32
  33 The following subtypes and coercions are defined in this class.
  34
  35 =head2 MooseX::Meta::TypeConstraint::Structured::Signature
  36
  37 This is a type constraint to normalize the incoming L</signature>.
  38
  39 =cut
  40
  41 subtype 'MooseX::Meta::TypeConstraint::Structured::Signature',
  42     as 'HashRef[Object]',
  43     where {
  44         my %signature = %$_;
  45         foreach my $key (keys %signature) {
  46             $signature{$key}->isa('Moose::Meta::TypeConstraint');
  47         } 1;
  48     };
  49
  50 coerce 'MooseX::Meta::TypeConstraint::Structured::Signature',
  51     from 'ArrayRef[Object]',
  52     via {
  53         my @signature = @$_;
  54         my %hashed_signature = map { $_ => $signature[$_] } 0..$#signature;
  55         \%hashed_signature;
  56     };
  57
  58 =head1 ATTRIBUTES
  59
  60 This class defines the following attributes.
  61
  62 =head2 signature
  63
  64 This is a signature of internal contraints for the contents of the outer
  65 contraint container.
  66
  67 =cut
  68
  69 has 'signature' => (
  70     is=>'ro',
  71     isa=>'MooseX::Meta::TypeConstraint::Structured::Signature',
  72     coerce=>1,
  73     required=>1,
  74 );
  75
  76 =head1 METHODS
  77
  78 This class defines the following methods.
  79
  80 =head2 _normalize_args
  81
  82 Get arguments into a known state or die trying.  Ideally we try to make this
  83 into a HashRef so we can match it up with the L</signature> HashRef.
  84
  85 =cut
  86
  87 sub _normalize_args {
  88     my ($self, $args) = @_;
  89     if(defined $args) {
  90         if(ref $args eq 'ARRAY') {
  91             return map { $_ => $args->[$_] } (0..$#$args);
  92         } elsif (ref $args eq 'HASH') {
  93             return %$args;
  94         } else {
  95             confess 'Signature must be a reference';
  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         foreach my $idx (keys %{$self->signature}) {
 113             my $type_constraint = $self->signature->{$idx};
 114             if(my $error = $type_constraint->validate($args{$idx})) {
 115                 confess $error;
 116             }
 117         } 1;
 118     };
 119 }
 120
 121 =head2 equals
 122
 123 modifier to make sure equals descends into the L</signature>
 124
 125 =cut
 126
 127 around 'equals' => sub {
 128     my ($equals, $self, $compared_type_constraint) = @_;
 129
 130     ## Make sure we are comparing typeconstraints of the same base class
 131     return unless $compared_type_constraint->isa(__PACKAGE__);
 132
 133     ## Make sure the base equals is also good
 134     return unless $self->$equals($compared_type_constraint);
 135
 136     ## Make sure the signatures match
 137     return unless $self->signature_equals($compared_type_constraint);
 138
 139     ## If we get this far, the two are equal
 140     return 1;
 141 };
 142
 143 =head2 signature_equals
 144
 145 Check that the signature equals another signature.
 146
 147 =cut
 148
 149 sub signature_equals {
 150     my ($self, $compared_type_constraint) = @_;
 151
 152    foreach my $idx (keys %{$self->signature}) {
 153         my $this = $self->signature->{$idx};
 154         my $that = $compared_type_constraint->signature->{$idx};
 155         return unless $this->equals($that);
 156     }
 157
 158     return 1;
 159 }
 160
 161 =head1 AUTHOR
 162
 163 John James Napiorkowski <jjnapiork@cpan.org>
 164
 165 =head1 LICENSE
 166
 167 You may distribute this code under the same terms as Perl itself.
 168
 169 =cut
 170
 171 no Moose; 1;