Commit | Line | Data |
a15dff8d |
1 | |
2 | package Moose::Util::TypeConstraints; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
7 | use Sub::Name 'subname'; |
8 | use Scalar::Util 'blessed'; |
9 | |
5569c072 |
10 | our $VERSION = '0.02'; |
a15dff8d |
11 | |
12 | sub import { |
13 | shift; |
14 | my $pkg = shift || caller(); |
15 | return if $pkg eq ':no_export'; |
16 | no strict 'refs'; |
17 | foreach my $export (qw( |
18 | type subtype as where |
19 | )) { |
20 | *{"${pkg}::${export}"} = \&{"${export}"}; |
21 | } |
22 | |
23 | foreach my $constraint (qw( |
24 | Any |
25 | Value Ref |
26 | Str Int |
27 | ScalarRef ArrayRef HashRef CodeRef RegexpRef |
28 | Object |
29 | )) { |
30 | *{"${pkg}::${constraint}"} = \&{"${constraint}"}; |
31 | } |
32 | |
33 | } |
34 | |
35 | my %TYPES; |
36 | |
a15dff8d |
37 | #sub find_type_constraint { $TYPES{$_[0]} } |
38 | |
39 | sub type ($$) { |
40 | my ($name, $check) = @_; |
41 | my $pkg = caller(); |
42 | my $full_name = "${pkg}::${name}"; |
43 | no strict 'refs'; |
44 | *{$full_name} = $TYPES{$name} = subname $full_name => sub { |
45 | return $TYPES{$name} unless defined $_[0]; |
46 | local $_ = $_[0]; |
47 | return undef unless $check->($_[0]); |
48 | $_[0]; |
49 | }; |
50 | } |
51 | |
52 | sub subtype ($$;$) { |
53 | my ($name, $parent, $check) = @_; |
54 | if (defined $check) { |
55 | my $pkg = caller(); |
56 | my $full_name = "${pkg}::${name}"; |
57 | no strict 'refs'; |
58 | $parent = $TYPES{$parent} unless $parent && ref($parent) eq 'CODE'; |
59 | *{$full_name} = $TYPES{$name} = subname $full_name => sub { |
60 | return $TYPES{$name} unless defined $_[0]; |
61 | local $_ = $_[0]; |
62 | return undef unless defined $parent->($_[0]) && $check->($_[0]); |
63 | $_[0]; |
64 | }; |
65 | } |
66 | else { |
67 | ($parent, $check) = ($name, $parent); |
68 | $parent = $TYPES{$parent} unless $parent && ref($parent) eq 'CODE'; |
5569c072 |
69 | return subname '__anon_subtype__' => sub { |
a15dff8d |
70 | return $TYPES{$name} unless defined $_[0]; |
71 | local $_ = $_[0]; |
72 | return undef unless defined $parent->($_[0]) && $check->($_[0]); |
73 | $_[0]; |
5569c072 |
74 | }; |
a15dff8d |
75 | } |
76 | } |
77 | |
78 | sub as ($) { $_[0] } |
79 | sub where (&) { $_[0] } |
80 | |
81 | # define some basic types |
82 | |
83 | type Any => where { 1 }; |
84 | |
85 | type Value => where { !ref($_) }; |
86 | type Ref => where { ref($_) }; |
87 | |
88 | subtype Int => as Value => where { Scalar::Util::looks_like_number($_) }; |
89 | subtype Str => as Value => where { !Scalar::Util::looks_like_number($_) }; |
90 | |
91 | subtype ScalarRef => as Ref => where { ref($_) eq 'SCALAR' }; |
92 | subtype ArrayRef => as Ref => where { ref($_) eq 'ARRAY' }; |
93 | subtype HashRef => as Ref => where { ref($_) eq 'HASH' }; |
94 | subtype CodeRef => as Ref => where { ref($_) eq 'CODE' }; |
95 | subtype RegexpRef => as Ref => where { ref($_) eq 'Regexp' }; |
96 | |
97 | # NOTE: |
98 | # blessed(qr/.../) returns true,.. how odd |
99 | subtype Object => as Ref => where { blessed($_) && blessed($_) ne 'Regexp' }; |
100 | |
101 | 1; |
102 | |
103 | __END__ |
104 | |
105 | =pod |
106 | |
107 | =head1 NAME |
108 | |
e522431d |
109 | Moose::Util::TypeConstraints - Type constraint system for Moose |
a15dff8d |
110 | |
111 | =head1 SYNOPSIS |
112 | |
113 | use Moose::Util::TypeConstraints; |
114 | |
115 | type Num => where { Scalar::Util::looks_like_number($_) }; |
116 | |
117 | subtype Natural |
118 | => as Num |
119 | => where { $_ > 0 }; |
120 | |
121 | subtype NaturalLessThanTen |
122 | => as Natural |
123 | => where { $_ < 10 }; |
124 | |
125 | =head1 DESCRIPTION |
126 | |
e522431d |
127 | This module provides Moose with the ability to create type contraints |
128 | to be are used in both attribute definitions and for method argument |
129 | validation. |
130 | |
131 | This is B<NOT> a type system for Perl 5. |
132 | |
133 | The type and subtype constraints are basically functions which will |
134 | validate their first argument. If called with no arguments, they will |
135 | return themselves (this is syntactic sugar for Moose attributes). |
136 | |
137 | This module also provides a simple hierarchy for Perl 5 types, this |
138 | could probably use some work, but it works for me at the moment. |
139 | |
140 | Any |
141 | Value |
142 | Int |
143 | Str |
144 | Ref |
145 | ScalarRef |
146 | ArrayRef |
147 | HashRef |
148 | CodeRef |
149 | RegexpRef |
150 | Object |
151 | |
152 | Suggestions for improvement are welcome. |
153 | |
a15dff8d |
154 | =head1 FUNCTIONS |
155 | |
156 | =head2 Type Constraint Constructors |
157 | |
158 | =over 4 |
159 | |
160 | =item B<type> |
161 | |
162 | =item B<subtype> |
163 | |
164 | =item B<as> |
165 | |
166 | =item B<where> |
167 | |
168 | =back |
169 | |
170 | =head2 Built-in Type Constraints |
171 | |
172 | =over 4 |
173 | |
174 | =item B<Any> |
175 | |
176 | =item B<Value> |
177 | |
178 | =item B<Int> |
179 | |
180 | =item B<Str> |
181 | |
182 | =item B<Ref> |
183 | |
184 | =item B<ArrayRef> |
185 | |
186 | =item B<CodeRef> |
187 | |
188 | =item B<HashRef> |
189 | |
190 | =item B<RegexpRef> |
191 | |
192 | =item B<ScalarRef> |
193 | |
194 | =item B<Object> |
195 | |
196 | =back |
197 | |
198 | =head1 BUGS |
199 | |
200 | All complex software has bugs lurking in it, and this module is no |
201 | exception. If you find a bug please either email me, or add the bug |
202 | to cpan-RT. |
203 | |
a15dff8d |
204 | =head1 AUTHOR |
205 | |
206 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
207 | |
208 | =head1 COPYRIGHT AND LICENSE |
209 | |
210 | Copyright 2006 by Infinity Interactive, Inc. |
211 | |
212 | L<http://www.iinteractive.com> |
213 | |
214 | This library is free software; you can redistribute it and/or modify |
215 | it under the same terms as Perl itself. |
216 | |
217 | =cut |