Commit | Line | Data |
52d358e2 |
1 | package MooseX::Types::Base; |
16ddefbf |
2 | use Moose; |
e211870f |
3 | |
ef8b7b7a |
4 | # ABSTRACT: Type library base class |
e211870f |
5 | |
9563f55e |
6 | use Carp::Clan qw( ^MooseX::Types ); |
9616cebc |
7 | use MooseX::Types::Util qw( filter_tags ); |
16ddefbf |
8 | use Sub::Exporter qw( build_exporter ); |
8af0a70d |
9 | use Moose::Util::TypeConstraints; |
9616cebc |
10 | |
11 | use namespace::clean -except => [qw( meta )]; |
8af0a70d |
12 | |
e211870f |
13 | =head1 DESCRIPTION |
14 | |
15 | You normally won't need to interact with this class by yourself. It is |
16 | merely a collection of functionality that type libraries need to |
52d358e2 |
17 | interact with moose and the rest of the L<MooseX::Types> module. |
e211870f |
18 | |
19 | =cut |
20 | |
8af0a70d |
21 | my $UndefMsg = q{Unable to find type '%s' in library '%s'}; |
22 | |
e211870f |
23 | =head1 METHODS |
24 | |
25 | =cut |
26 | |
27 | =head2 import |
28 | |
29 | Provides the import mechanism for your library. See |
52d358e2 |
30 | L<MooseX::Types/"LIBRARY USAGE"> for syntax details on this. |
e211870f |
31 | |
32 | =cut |
33 | |
8af0a70d |
34 | sub import { |
c20dc98b |
35 | my ($class, @args) = @_; |
e211870f |
36 | |
16ddefbf |
37 | # filter or create options hash for S:E |
38 | my $options = (@args and (ref($args[0]) eq 'HASH')) ? $args[0] : undef; |
39 | unless ($options) { |
40 | $options = {foo => 23}; |
41 | unshift @args, $options; |
42 | } |
8af0a70d |
43 | |
16ddefbf |
44 | # all types known to us |
45 | my @types = $class->type_names; |
8af0a70d |
46 | |
16ddefbf |
47 | # determine the wrapper, -into is supported for compatibility reasons |
48 | my $wrapper = $options->{ -wrapper } || 'MooseX::Types'; |
49 | $args[0]->{into} = $options->{ -into } |
50 | if exists $options->{ -into }; |
51 | |
52 | my (%ex_spec, %ex_util); |
8af0a70d |
53 | TYPE: |
16ddefbf |
54 | for my $type_short (@types) { |
55 | |
56 | # find type name and object, create undefined message |
57 | my $type_full = $class->get_type($type_short) |
58 | or croak "No fully qualified type name stored for '$type_short'"; |
59 | my $type_cons = find_type_constraint($type_full); |
60 | my $undef_msg = sprintf($UndefMsg, $type_short, $class); |
61 | |
62 | # the type itself |
63 | push @{ $ex_spec{exports} }, |
64 | $type_short, |
5885c4f4 |
65 | sub { |
66 | bless $wrapper->type_export_generator($type_short, $type_full), |
67 | 'MooseX::Types::EXPORTED_TYPE_CONSTRAINT'; |
68 | }; |
16ddefbf |
69 | |
70 | # the check helper |
71 | push @{ $ex_spec{exports} }, |
72 | "is_${type_short}", |
73 | sub { $wrapper->check_export_generator($type_short, $type_full, $undef_msg) }; |
74 | |
75 | # only export coercion helper if full (for libraries) or coercion is defined |
76 | next TYPE |
77 | unless $options->{ -full } |
78 | or ($type_cons and $type_cons->has_coercion); |
79 | push @{ $ex_spec{exports} }, |
80 | "to_${type_short}", |
81 | sub { $wrapper->coercion_export_generator($type_short, $type_full, $undef_msg) }; |
82 | $ex_util{ $type_short }{to}++; # shortcut to remember this exists |
8af0a70d |
83 | } |
e211870f |
84 | |
16ddefbf |
85 | # create S:E exporter and increase export level unless specified explicitly |
86 | my $exporter = build_exporter \%ex_spec; |
87 | $options->{into_level}++ |
88 | unless $options->{into}; |
e211870f |
89 | |
16ddefbf |
90 | # remember requested symbols to determine what helpers to auto-export |
91 | my %was_requested = |
92 | map { ($_ => 1) } |
93 | grep { not ref } |
94 | @args; |
e211870f |
95 | |
16ddefbf |
96 | # determine which additional symbols (helpers) to export along |
97 | my %add; |
98 | EXPORT: |
99 | for my $type (grep { exists $was_requested{ $_ } } @types) { |
100 | $add{ "is_$type" }++ |
101 | unless $was_requested{ "is_$type" }; |
102 | next EXPORT |
103 | unless exists $ex_util{ $type }{to}; |
104 | $add{ "to_$type" }++ |
105 | unless $was_requested{ "to_$type" }; |
e211870f |
106 | } |
8af0a70d |
107 | |
16ddefbf |
108 | # and on to the real exporter |
109 | my @new_args = (@args, keys %add); |
110 | return $class->$exporter(@new_args); |
8af0a70d |
111 | } |
112 | |
e211870f |
113 | =head2 get_type |
114 | |
115 | This returns a type from the library's store by its name. |
116 | |
117 | =cut |
118 | |
8af0a70d |
119 | sub get_type { |
120 | my ($class, $type) = @_; |
121 | |
122 | # useful message if the type couldn't be found |
123 | croak "Unknown type '$type' in library '$class'" |
124 | unless $class->has_type($type); |
125 | |
126 | # return real name of the type |
127 | return $class->type_storage->{ $type }; |
128 | } |
129 | |
e211870f |
130 | =head2 type_names |
131 | |
132 | Returns a list of all known types by their name. |
133 | |
134 | =cut |
135 | |
8af0a70d |
136 | sub type_names { |
137 | my ($class) = @_; |
138 | |
139 | # return short names of all stored types |
140 | return keys %{ $class->type_storage }; |
141 | } |
142 | |
e211870f |
143 | =head2 add_type |
144 | |
145 | Adds a new type to the library. |
146 | |
147 | =cut |
148 | |
8af0a70d |
149 | sub add_type { |
150 | my ($class, $type) = @_; |
151 | |
152 | # store type with library prefix as real name |
153 | $class->type_storage->{ $type } = "${class}::${type}"; |
154 | } |
155 | |
e211870f |
156 | =head2 has_type |
157 | |
158 | Returns true or false depending on if this library knows a type by that |
159 | name. |
160 | |
161 | =cut |
162 | |
8af0a70d |
163 | sub has_type { |
164 | my ($class, $type) = @_; |
165 | |
166 | # check if we stored a type under that name |
167 | return ! ! $class->type_storage->{ $type }; |
168 | } |
169 | |
e211870f |
170 | =head2 type_storage |
171 | |
172 | Returns the library's type storage hash reference. You shouldn't use this |
173 | method directly unless you know what you are doing. It is not an internal |
174 | method because overriding it makes virtual libraries very easy. |
175 | |
176 | =cut |
177 | |
8af0a70d |
178 | sub type_storage { |
179 | my ($class) = @_; |
180 | |
181 | # return a reference to the storage in ourself |
182 | { no strict 'refs'; |
183 | return \%{ $class . '::__MOOSEX_TYPELIBRARY_STORAGE' }; |
184 | } |
185 | } |
186 | |
b0db42a9 |
187 | =head2 registered_class_types |
188 | |
189 | Returns the class types registered within this library. Don't use directly. |
190 | |
191 | =cut |
192 | |
193 | sub registered_class_types { |
194 | my ($class) = @_; |
195 | |
196 | { |
197 | no strict 'refs'; |
198 | return \%{ $class . '::__MOOSEX_TYPELIBRARY_CLASS_TYPES' }; |
199 | } |
200 | } |
201 | |
202 | =head2 register_class_type |
203 | |
204 | Register a C<class_type> for use in this library by class name. |
205 | |
206 | =cut |
207 | |
208 | sub register_class_type { |
209 | my ($class, $type) = @_; |
210 | |
211 | croak "Not a class_type" |
212 | unless $type->isa('Moose::Meta::TypeConstraint::Class'); |
213 | |
214 | $class->registered_class_types->{$type->class} = $type; |
215 | } |
216 | |
217 | =head2 get_registered_class_type |
218 | |
219 | Get a C<class_type> registered in this library by name. |
220 | |
221 | =cut |
222 | |
223 | sub get_registered_class_type { |
224 | my ($class, $name) = @_; |
225 | |
226 | $class->registered_class_types->{$name}; |
227 | } |
228 | |
229 | =head2 registered_role_types |
230 | |
231 | Returns the role types registered within this library. Don't use directly. |
232 | |
233 | =cut |
234 | |
235 | sub registered_role_types { |
236 | my ($class) = @_; |
237 | |
238 | { |
239 | no strict 'refs'; |
240 | return \%{ $class . '::__MOOSEX_TYPELIBRARY_ROLE_TYPES' }; |
241 | } |
242 | } |
243 | |
244 | =head2 register_role_type |
245 | |
246 | Register a C<role_type> for use in this library by role name. |
247 | |
248 | =cut |
249 | |
250 | sub register_role_type { |
251 | my ($class, $type) = @_; |
252 | |
253 | croak "Not a role_type" |
254 | unless $type->isa('Moose::Meta::TypeConstraint::Role'); |
255 | |
256 | $class->registered_role_types->{$type->role} = $type; |
257 | } |
258 | |
259 | =head2 get_registered_role_type |
260 | |
261 | Get a C<role_type> registered in this library by role name. |
262 | |
263 | =cut |
264 | |
265 | sub get_registered_role_type { |
266 | my ($class, $name) = @_; |
267 | |
268 | $class->registered_role_types->{$name}; |
269 | } |
270 | |
e211870f |
271 | =head1 SEE ALSO |
272 | |
52d358e2 |
273 | L<MooseX::Types::Moose> |
e211870f |
274 | |
e211870f |
275 | =head1 LICENSE |
276 | |
277 | This program is free software; you can redistribute it and/or modify |
278 | it under the same terms as perl itself. |
279 | |
280 | =cut |
281 | |
8af0a70d |
282 | 1; |