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 SYNOPSIS
  14
  15 The follow is example usage:
  16
  17     use Moose::Util::TypeConstraints;
  18     use MooseX::Meta::TypeConstraint::Structured::Named;
  19
  20     my %required = (key1='Str', key2=>'Int');
  21     my %optional = (key3=>'Object');
  22
  23     my $tc = MooseX::Meta::TypeConstraint::Structured::Named->new(
  24         name => 'Dict',
  25         parent => find_type_constraint('HashRef'),
  26         package_defined_in => __PACKAGE__,
  27         signature => {map {
  28             $_ => find_type_constraint($required{$_});
  29         } keys %required},
  30         optional_signature => {map {
  31             $_ => find_type_constraint($optional{$_});
  32         } keys %optional},
  33     );
  34
  35 =head1 DESCRIPTION
  36
  37 Named structured Constraints expect the internal constraints to be in keys or
  38 fields similar to what we expect in a HashRef.  Basically, this allows you to
  39 easily add type constraint checks against values in the wrapping HashRef
  40 identified by the key name.
  41
  42 =head1 ATTRIBUTES
  43
  44 This class defines the following attributes.
  45
  46 =head2 signature
  47
  48 This is a signature of internal contraints for the contents of the outer
  49 contraint container.
  50
  51 =cut
  52
  53 has '+signature' => (isa=>'HashRef[Moose::Meta::TypeConstraint]');
  54
  55 =head2 optional_signature
  56
  57 This is a signature of internal contraints for the contents of the outer
  58 contraint container.  These are optional constraints.
  59
  60 =cut
  61
  62 has '+optional_signature' => (isa=>'HashRef[Moose::Meta::TypeConstraint]');
  63
  64 =head1 METHODS
  65
  66 This class defines the following methods.
  67
  68 =head2 _normalize_args
  69
  70 Get arguments into a known state or die trying.  Ideally we try to make this
  71 into a HashRef so we can match it up with the L</signature> HashRef.
  72
  73 =cut
  74
  75 sub _normalize_args {
  76     my ($self, $args) = @_;
  77     if(defined $args) {
  78         if(ref $args eq 'HASH') {
  79             %$args
  80         } else {
  81             confess 'Signature must be an HashRef type';
  82         }
  83     } else {
  84         confess 'Signature cannot be empty';
  85     }
  86 }
  87
  88 =head2 constraint
  89
  90 The constraint is basically validating the L</signature> against the incoming
  91
  92 =cut
  93
  94 sub constraint {
  95     my $self = shift;
  96     return sub {
  97         my %args = $self->_normalize_args(shift);
  98         my @optional_signature;
  99
 100         if($signature[-1]->isa('MooseX::Meta::TypeConstraint::Structured::Optional')) {
 101             my $optional = pop @signature;
 102             @optional_signature = @{$optional->signature};
 103         }
 104
 105         ## First make sure all the required type constraints match
 106         foreach my $sig_key (keys %{$self->signature}) {
 107             my $type_constraint = $self->signature->{$sig_key};
 108             if(my $error = $type_constraint->validate($args{$sig_key})) {
 109                 confess $error;
 110             } else {
 111                 delete $args{$sig_key};
 112             }
 113         }
 114
 115         ## Now test the option type constraints.
 116         foreach my $arg_key (keys %args) {
 117             my $optional_type_constraint = $self->optional_signature->{$arg_key};
 118             if(my $error = $optional_type_constraint->validate($args{$arg_key})) {
 119                 confess $error;
 120             }
 121         }
 122
 123         ## If we got this far we passed!
 124         return 1;
 125     };
 126 }
 127
 128 =head2 signature_equals
 129
 130 Check that the signature equals another signature.
 131
 132 =cut
 133
 134 sub signature_equals {
 135     my ($self, $compared_type_constraint) = @_;
 136
 137     foreach my $idx (keys %{$self->signature}) {
 138         my $this = $self->signature->{$idx};
 139         my $that = $compared_type_constraint->signature->{$idx};
 140         return unless $this->equals($that);
 141     }
 142
 143     if($self->has_optional_signature) {
 144         foreach my $idx (keys %{$self->optional_signature}) {
 145             my $this = $self->optional_signature->{$idx};
 146             my $that = $compared_type_constraint->optional_signature->{$idx};
 147             return unless $this->equals($that);
 148         }
 149     }
 150
 151     return 1;
 152 }
 153
 154
 155
 156 =head1 AUTHOR
 157
 158 John James Napiorkowski <jjnapiork@cpan.org>
 159
 160 =head1 LICENSE
 161
 162 You may distribute this code under the same terms as Perl itself.
 163
 164 =cut
 165
 166 no Moose; 1;