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