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

   1 package MooseX::Meta::TypeConstraint::Structured::Named;
   2
   3 use Moose;
   4 use Moose::Meta::TypeConstraint ();
   5 use Moose::Util::TypeConstraints;
   6
   7 extends 'Moose::Meta::TypeConstraint';
   8 with 'MooseX::Meta::TypeConstraint::Role::Structured';
   9
  10 =head1 NAME
  11
  12 MooseX::Meta::TypeConstraint::Structured::Named - Structured Type Constraints
  13
  14 =head1 VERSION
  15
  16 0.01
  17
  18 =cut
  19
  20 our $VERSION = '0.01';
  21
  22 =head1 DESCRIPTION
  23
  24 Structured type constraints let you assign an internal pattern of type
  25 constraints to a 'container' constraint.  The goal is to make it easier to
  26 declare constraints like "ArrayRef[Int, Int, Str]" where the constraint is an
  27 ArrayRef of three elements and the internal constraint on the three is Int, Int
  28 and Str.
  29
  30 To accomplish this, we add an attribute to the base L<Moose::Meta::TypeConstraint>
  31 to hold a L</signature>, which is a reference to a pattern of type constraints.
  32 We then override L</constraint> to check our incoming value to the attribute
  33 against this signature pattern.
  34
  35 Named structured Constraints expect the internal constraints to be in keys or
  36 fields similar to what we expect in a HashRef.
  37
  38 =head1 TYPES
  39
  40 The following types are defined in this class.
  41
  42 =head2 Moose::Meta::TypeConstraint
  43
  44 Used to make sure we can properly validate incoming signatures.
  45
  46 =cut
  47
  48 class_type 'Moose::Meta::TypeConstraint';
  49
  50 =head1 ATTRIBUTES
  51
  52 This class defines the following attributes.
  53
  54 =head2 signature
  55
  56 This is a signature of internal contraints for the contents of the outer
  57 contraint container.
  58
  59 =cut
  60
  61 has '+signature' => (isa=>'HashRef[Moose::Meta::TypeConstraint]');
  62
  63 =head2 optional_signature
  64
  65 This is a signature of internal contraints for the contents of the outer
  66 contraint container.  These are optional constraints.
  67
  68 =cut
  69
  70 has '+optional_signature' => (isa=>'HashRef[Moose::Meta::TypeConstraint]');
  71
  72 =head1 METHODS
  73
  74 This class defines the following methods.
  75
  76 =head2 _normalize_args
  77
  78 Get arguments into a known state or die trying.  Ideally we try to make this
  79 into a HashRef so we can match it up with the L</signature> HashRef.
  80
  81 =cut
  82
  83 sub _normalize_args {
  84     my ($self, $args) = @_;
  85     if(defined $args) {
  86         if(ref $args eq 'HASH') {
  87             %$args
  88         } else {
  89             confess 'Signature must be an HashRef type';
  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         my @signature = keys %{$self->signature};
 107         my @ptional_signature = keys %{$self->optional_signature}
 108          if $self->has_optional_signature;
 109
 110         ## First make sure all the required type constraints match
 111         while( my $type_constraint_key = shift @signature) {
 112             my $type_constraint = $self->signature->{$type_constraint_key};
 113             if(my $error = $type_constraint->validate($args{$type_constraint_key})) {
 114                 confess $error;
 115             }
 116             delete $args{$type_constraint_key};
 117         }
 118
 119         ## Now test the option type constraints.
 120         while( my $arg_key = keys %args) {
 121             my $optional_type_constraint = $self->signature->{$arg_key};
 122             if(my $error = $optional_type_constraint->validate($args{$arg_key})) {
 123                 confess $error;
 124             }
 125         }
 126
 127         ## If we got this far we passed!
 128         return 1;
 129     };
 130 }
 131
 132 =head2 signature_equals
 133
 134 Check that the signature equals another signature.
 135
 136 =cut
 137
 138 sub signature_equals {
 139     my ($self, $compared_type_constraint) = @_;
 140
 141     foreach my $idx (keys %{$self->signature}) {
 142         my $this = $self->signature->{$idx};
 143         my $that = $compared_type_constraint->signature->{$idx};
 144         return unless $this->equals($that);
 145     }
 146
 147     if($self->has_optional_signature) {
 148         foreach my $idx (keys %{$self->optional_signature}) {
 149             my $this = $self->optional_signature->{$idx};
 150             my $that = $compared_type_constraint->optional_signature->{$idx};
 151             return unless $this->equals($that);
 152         }
 153     }
 154
 155     return 1;
 156 }
 157
 158 =head2 equals
 159
 160 modifier to make sure equals descends into the L</signature>
 161
 162 =cut
 163
 164 around 'equals' => sub {
 165     my ($equals, $self, $compared_type_constraint) = @_;
 166
 167     ## Make sure we are comparing typeconstraints of the same base class
 168     return unless $compared_type_constraint->isa(__PACKAGE__);
 169
 170     ## Make sure the base equals is also good
 171     return unless $self->$equals($compared_type_constraint);
 172
 173     ## Make sure the signatures match
 174     return unless $self->signature_equals($compared_type_constraint);
 175
 176     ## If we get this far, the two are equal
 177     return 1;
 178 };
 179
 180 =head1 AUTHOR
 181
 182 John James Napiorkowski <jjnapiork@cpan.org>
 183
 184 =head1 LICENSE
 185
 186 You may distribute this code under the same terms as Perl itself.
 187
 188 =cut
 189
 190 no Moose; 1;