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
  99         ## First make sure all the required type constraints match
 100         foreach my $sig_key (keys %{$self->signature}) {
 101             my $type_constraint = $self->signature->{$sig_key};
 102             if(my $error = $type_constraint->validate($args{$sig_key})) {
 103                 confess $error;
 104             } else {
 105                 delete $args{$sig_key};
 106             }
 107         }
 108
 109         ## Now test the option type constraints.
 110         foreach my $arg_key (keys %args) {
 111             my $optional_type_constraint = $self->optional_signature->{$arg_key};
 112             if(my $error = $optional_type_constraint->validate($args{$arg_key})) {
 113                 confess $error;
 114             }
 115         }
 116
 117         ## If we got this far we passed!
 118         return 1;
 119     };
 120 }
 121
 122 =head2 signature_equals
 123
 124 Check that the signature equals another signature.
 125
 126 =cut
 127
 128 sub signature_equals {
 129     my ($self, $compared_type_constraint) = @_;
 130
 131     foreach my $idx (keys %{$self->signature}) {
 132         my $this = $self->signature->{$idx};
 133         my $that = $compared_type_constraint->signature->{$idx};
 134         return unless $this->equals($that);
 135     }
 136
 137     if($self->has_optional_signature) {
 138         foreach my $idx (keys %{$self->optional_signature}) {
 139             my $this = $self->optional_signature->{$idx};
 140             my $that = $compared_type_constraint->optional_signature->{$idx};
 141             return unless $this->equals($that);
 142         }
 143     }
 144
 145     return 1;
 146 }
 147
 148
 149
 150 =head1 AUTHOR
 151
 152 John James Napiorkowski <jjnapiork@cpan.org>
 153
 154 =head1 LICENSE
 155
 156 You may distribute this code under the same terms as Perl itself.
 157
 158 =cut
 159
 160 no Moose; 1;