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