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