Commit | Line | Data |
d24da8ec |
1 | package MooseX::Types::Structured; |
2 | |
6c2f284c |
3 | use Moose; |
4 | use Moose::Util::TypeConstraints; |
5 | use MooseX::Meta::TypeConstraint::Structured::Positional; |
6 | use MooseX::Meta::TypeConstraint::Structured::Named; |
011bacc6 |
7 | |
8 | use MooseX::Types -declare => [qw(Dict Tuple Optional)]; |
9 | #use Sub::Exporter |
10 | # -setup => { exports => [ qw( Optional) ] }; |
6c2f284c |
11 | |
d24da8ec |
12 | our $VERSION = '0.01'; |
13 | our $AUTHORITY = 'cpan:JJNAPIORK'; |
14 | |
15 | =head1 NAME |
16 | |
17 | MooseX::Types::Structured; Structured Type Constraints for Moose |
18 | |
19 | =head1 SYNOPSIS |
20 | |
6c2f284c |
21 | The following is example usage for this module. You can define a class that has |
22 | an attribute with a structured type like so: |
23 | |
24 | package MyApp::MyClass; |
25 | |
26 | use Moose; |
27 | use MooseX::Types::Moose qw(Str Int); |
28 | use MooseX::Types::Structured qw(Dict Tuple); |
29 | |
30 | has name => (isa=>Dict[first_name=>Str, last_name=>Str]); |
31 | |
32 | Then you can instantiate this class with something like: |
33 | |
34 | my $instance = MyApp::MyClass->new( |
35 | name=>{first_name=>'John', last_name=>'Napiorkowski'}, |
36 | ); |
d24da8ec |
37 | |
6c2f284c |
38 | But all of these would cause an error: |
39 | |
40 | my $instance = MyApp::MyClass->new(name=>'John'); |
41 | my $instance = MyApp::MyClass->new(name=>{first_name=>'John'}); |
42 | my $instance = MyApp::MyClass->new(name=>{first_name=>'John', age=>39}); |
43 | |
44 | Please see the test cases for more examples. |
d24da8ec |
45 | |
46 | =head1 DESCRIPTION |
47 | |
6c2f284c |
48 | This type library enables structured type constraints. Basically, this is very |
49 | similar to parameterized constraints that are built into the core Moose types, |
50 | except that you are allowed to define the container's entire structure. For |
51 | example, you could define a parameterized constraint like so: |
52 | |
53 | subtype HashOfInts, as Hashref[Int]; |
54 | |
55 | which would constraint a value to something like [1,2,3,...] and so one. A |
56 | structured constraint like so: |
57 | |
58 | subtype StringFollowedByInt, as Tuple[Str,Int]; |
59 | |
60 | would constrain it's value to something like ['hello', 111]; |
61 | |
62 | These structures can be as simple or elaborate as you wish. You can even |
63 | combine various structured, parameterized and simple constraints all together: |
64 | |
65 | subtype crazy, as Tuple[Int, Dict[name=>Str, age=>Int], ArrayRef[Int]]; |
66 | |
67 | Which would match "[1, {name=>'John', age=>25},[10,11,12]]". |
68 | |
69 | You should exercise some care as to whether or not your complex structured |
70 | constraints would be better off contained by a real object as in the following |
71 | example: |
72 | |
73 | { |
74 | package MyApp::MyStruct; |
75 | use Moose; |
76 | |
77 | has $_ for qw(name age); |
78 | |
79 | package MyApp::MyClass; |
80 | use Moose; |
81 | |
82 | has person => (isa=>'MyApp::MyStruct'); |
83 | } |
84 | |
85 | my $instance = MyApp::MyClass |
86 | ->new( person=>MyApp::MyStruct->new(name=>'John', age=>39) ); |
87 | |
88 | This method may take some additional time to setup but will give you more |
89 | flexibility. However, structured constraints are highly compatible with this |
90 | method, granting some interesting possibilities for coercion. Try: |
91 | |
92 | subtype 'MyStruct', |
93 | as 'MyApp::MyStruct'; |
94 | |
95 | coerce 'MyStruct', |
96 | from (Dict[name=>Str, age=>Int]), |
97 | via { |
98 | MyApp::MyStruct->new(%$_); |
99 | }, |
100 | from (Dict[last_name=>Str, first_name=>Str, dob=>DateTime]), |
101 | via { |
102 | my $name = _->{first_name} .' '. $_->{last_name}; |
103 | my $age = $_->{dob} - DateTime->now; |
104 | MyApp::MyStruct->new( |
105 | name=>$name, |
106 | age=>$age->years ); |
107 | }; |
108 | |
d24da8ec |
109 | |
110 | =head1 TYPES |
111 | |
112 | This class defines the following types and subtypes. |
113 | |
114 | =cut |
115 | |
011bacc6 |
116 | use MooseX::Meta::TypeConstraint::Structured::Positionable; |
117 | |
118 | my $tuple = MooseX::Meta::TypeConstraint::Structured::Positionable->new( |
119 | name => 'Tuple', |
120 | package_defined_in => __PACKAGE__, |
121 | parent => find_type_constraint('Ref'), |
122 | ); |
123 | |
124 | Moose::Util::TypeConstraints::register_type_constraint($tuple); |
125 | |
126 | subtype Tuple, as 'Tuple'; |
127 | |
128 | |
13cf7c3b |
129 | sub Optional($) { |
130 | return bless {args=>shift}, 'MooseX::Types::Optional'; |
131 | } |
132 | |
011bacc6 |
133 | sub TupleX($) { |
13cf7c3b |
134 | my ($args, $optional) = _normalize_args(@_); |
6c2f284c |
135 | my @args = @$args; |
136 | my @optional = ref $optional eq 'ARRAY' ? @$optional : (); |
137 | |
138 | return MooseX::Meta::TypeConstraint::Structured::Positional->new( |
139 | name => 'Tuple', |
140 | parent => find_type_constraint('ArrayRef'), |
141 | package_defined_in => __PACKAGE__, |
142 | signature => [map { |
143 | _normalize_type_constraint($_); |
144 | } @args], |
145 | optional_signature => [map { |
146 | _normalize_type_constraint($_); |
147 | } @optional], |
148 | ); |
149 | } |
150 | |
011bacc6 |
151 | sub DictX($) { |
13cf7c3b |
152 | my ($args, $optional) = _normalize_args(@_); |
6c2f284c |
153 | my %args = @$args; |
154 | my %optional = ref $optional eq 'ARRAY' ? @$optional : (); |
155 | |
156 | return MooseX::Meta::TypeConstraint::Structured::Named->new( |
157 | name => 'Dict', |
158 | parent => find_type_constraint('HashRef'), |
159 | package_defined_in => __PACKAGE__, |
160 | signature => {map { |
161 | $_ => _normalize_type_constraint($args{$_}); |
162 | } keys %args}, |
163 | optional_signature => {map { |
164 | $_ => _normalize_type_constraint($optional{$_}); |
165 | } keys %optional}, |
166 | ); |
167 | } |
168 | |
13cf7c3b |
169 | sub _normalize_args { |
170 | my $args = shift @_; |
171 | confess "Structured Type Constraints can only accept an ArrayRef as arguments" |
172 | unless ref $args eq 'ARRAY'; |
173 | |
174 | my @args = @$args; |
175 | my $last = pop @args; |
176 | |
177 | if(blessed $last && $last->isa('MooseX::Types::Optional')) { |
178 | return ([@args], $last->{args}); |
179 | } else { |
180 | return ([@args, $last]); |
181 | } |
182 | |
183 | } |
6c2f284c |
184 | sub _normalize_type_constraint { |
185 | my $tc = shift @_; |
424215da |
186 | |
187 | ## If incoming is an object, we will assume it's something that implements |
188 | ## what a type constraint is. We should probably have a Role for this... |
189 | if(defined $tc && blessed $tc) { |
6c2f284c |
190 | return $tc; |
191 | } elsif($tc) { |
192 | return Moose::Util::TypeConstraints::find_or_parse_type_constraint($tc); |
193 | } |
194 | } |
d24da8ec |
195 | |
196 | =head1 SEE ALSO |
197 | |
198 | The following modules or resources may be of interest. |
199 | |
200 | L<Moose>, L<MooseX::TypeLibrary>, L<Moose::Meta::TypeConstraint> |
201 | |
202 | =head1 BUGS |
203 | |
204 | No known or reported bugs. |
205 | |
206 | =head1 AUTHOR |
207 | |
208 | John Napiorkowski, C<< <jjnapiork@cpan.org> >> |
209 | |
210 | =head1 COPYRIGHT & LICENSE |
211 | |
212 | This program is free software; you can redistribute it and/or modify |
213 | it under the same terms as Perl itself. |
214 | |
215 | =cut |
216 | |
6c2f284c |
217 | 1; |