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

   1 package MooseX::Meta::TypeConstraint::Structured::Named;
   2
   3 use Moose;
   4 use Moose::Meta::TypeConstraint ();
   5
   6 extends 'Moose::Meta::TypeConstraint';
   7 with 'MooseX::Meta::TypeConstraint::Role::Structured';
   8
   9 =head1 NAME
  10
  11 MooseX::Meta::TypeConstraint::Structured::Named - Structured Type Constraints
  12
  13 =head1 DESCRIPTION
  14
  15 Structured type constraints let you assign an internal pattern of type
  16 constraints to a 'container' constraint.  The goal is to make it easier to
  17 declare constraints like "ArrayRef[Int, Int, Str]" where the constraint is an
  18 ArrayRef of three elements and the internal constraint on the three is Int, Int
  19 and Str.
  20
  21 To accomplish this, we add an attribute to the base L<Moose::Meta::TypeConstraint>
  22 to hold a L</signature>, which is a reference to a pattern of type constraints.
  23 We then override L</constraint> to check our incoming value to the attribute
  24 against this signature pattern.
  25
  26 Named structured Constraints expect the internal constraints to be in keys or
  27 fields similar to what we expect in a HashRef.
  28
  29 =head1 ATTRIBUTES
  30
  31 This class defines the following attributes.
  32
  33 =head2 signature
  34
  35 This is a signature of internal contraints for the contents of the outer
  36 contraint container.
  37
  38 =cut
  39
  40 has '+signature' => (isa=>'HashRef[Moose::Meta::TypeConstraint]');
  41
  42 =head2 optional_signature
  43
  44 This is a signature of internal contraints for the contents of the outer
  45 contraint container.  These are optional constraints.
  46
  47 =cut
  48
  49 has '+optional_signature' => (isa=>'HashRef[Moose::Meta::TypeConstraint]');
  50
  51 =head1 METHODS
  52
  53 This class defines the following methods.
  54
  55 =head2 _normalize_args
  56
  57 Get arguments into a known state or die trying.  Ideally we try to make this
  58 into a HashRef so we can match it up with the L</signature> HashRef.
  59
  60 =cut
  61
  62 sub _normalize_args {
  63     my ($self, $args) = @_;
  64     if(defined $args) {
  65         if(ref $args eq 'HASH') {
  66             %$args
  67         } else {
  68             confess 'Signature must be an HashRef type';
  69         }
  70     } else {
  71         confess 'Signature cannot be empty';
  72     }
  73 }
  74
  75 =head2 constraint
  76
  77 The constraint is basically validating the L</signature> against the incoming
  78
  79 =cut
  80
  81 sub constraint {
  82     my $self = shift;
  83     return sub {
  84         my %args = $self->_normalize_args(shift);
  85         my @signature = keys %{$self->signature};
  86         my @ptional_signature = keys %{$self->optional_signature}
  87          if $self->has_optional_signature;
  88
  89         ## First make sure all the required type constraints match
  90         while( my $type_constraint_key = shift @signature) {
  91             my $type_constraint = $self->signature->{$type_constraint_key};
  92             if(my $error = $type_constraint->validate($args{$type_constraint_key})) {
  93                 confess $error;
  94             }
  95             delete $args{$type_constraint_key};
  96         }
  97
  98         ## Now test the option type constraints.
  99         while( my $arg_key = keys %args) {
 100             my $optional_type_constraint = $self->signature->{$arg_key};
 101             if(my $error = $optional_type_constraint->validate($args{$arg_key})) {
 102                 confess $error;
 103             }
 104         }
 105
 106         ## If we got this far we passed!
 107         return 1;
 108     };
 109 }
 110
 111 =head2 signature_equals
 112
 113 Check that the signature equals another signature.
 114
 115 =cut
 116
 117 sub signature_equals {
 118     my ($self, $compared_type_constraint) = @_;
 119
 120     foreach my $idx (keys %{$self->signature}) {
 121         my $this = $self->signature->{$idx};
 122         my $that = $compared_type_constraint->signature->{$idx};
 123         return unless $this->equals($that);
 124     }
 125
 126     if($self->has_optional_signature) {
 127         foreach my $idx (keys %{$self->optional_signature}) {
 128             my $this = $self->optional_signature->{$idx};
 129             my $that = $compared_type_constraint->optional_signature->{$idx};
 130             return unless $this->equals($that);
 131         }
 132     }
 133
 134     return 1;
 135 }
 136
 137
 138
 139 =head1 AUTHOR
 140
 141 John James Napiorkowski <jjnapiork@cpan.org>
 142
 143 =head1 LICENSE
 144
 145 You may distribute this code under the same terms as Perl itself.
 146
 147 =cut
 148
 149 no Moose; 1;