lib/MooseX/Meta/TypeConstraint/Role/Structured.pm

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