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