Commit | Line | Data |
9a491c80 |
1 | package MooseX::Meta::TypeConstraint::Structured::Named; |
2 | |
3 | use Moose; |
4 | use Moose::Meta::TypeConstraint (); |
9a491c80 |
5 | |
6 | extends 'Moose::Meta::TypeConstraint'; |
bc5c0758 |
7 | with 'MooseX::Meta::TypeConstraint::Role::Structured'; |
9a491c80 |
8 | |
9 | =head1 NAME |
10 | |
11 | MooseX::Meta::TypeConstraint::Structured::Named - Structured Type Constraints |
12 | |
309c8a6c |
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 | ); |
9a491c80 |
34 | |
309c8a6c |
35 | =head1 DESCRIPTION |
9a491c80 |
36 | |
37 | Named structured Constraints expect the internal constraints to be in keys or |
309c8a6c |
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. |
9a491c80 |
41 | |
9a491c80 |
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 | |
24dd1d2e |
53 | has '+signature' => (isa=>'HashRef[Moose::Meta::TypeConstraint]'); |
9a491c80 |
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 | |
24dd1d2e |
62 | has '+optional_signature' => (isa=>'HashRef[Moose::Meta::TypeConstraint]'); |
9a491c80 |
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); |
9a491c80 |
98 | |
99 | ## First make sure all the required type constraints match |
6479ca33 |
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})) { |
9a491c80 |
103 | confess $error; |
6479ca33 |
104 | } else { |
105 | delete $args{$sig_key}; |
9a491c80 |
106 | } |
9a491c80 |
107 | } |
108 | |
109 | ## Now test the option type constraints. |
6479ca33 |
110 | foreach my $arg_key (keys %args) { |
111 | my $optional_type_constraint = $self->optional_signature->{$arg_key}; |
9a491c80 |
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 | |
9a491c80 |
148 | |
9a491c80 |
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; |