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 | |
16ddefbf |
10 | #use Data::Dump qw( dump ); |
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, |
70 | sub { $wrapper->type_export_generator($type_short, $type_full) }; |
71 | |
72 | # the check helper |
73 | push @{ $ex_spec{exports} }, |
74 | "is_${type_short}", |
75 | sub { $wrapper->check_export_generator($type_short, $type_full, $undef_msg) }; |
76 | |
77 | # only export coercion helper if full (for libraries) or coercion is defined |
78 | next TYPE |
79 | unless $options->{ -full } |
80 | or ($type_cons and $type_cons->has_coercion); |
81 | push @{ $ex_spec{exports} }, |
82 | "to_${type_short}", |
83 | sub { $wrapper->coercion_export_generator($type_short, $type_full, $undef_msg) }; |
84 | $ex_util{ $type_short }{to}++; # shortcut to remember this exists |
8af0a70d |
85 | } |
e211870f |
86 | |
16ddefbf |
87 | # create S:E exporter and increase export level unless specified explicitly |
88 | my $exporter = build_exporter \%ex_spec; |
89 | $options->{into_level}++ |
90 | unless $options->{into}; |
e211870f |
91 | |
16ddefbf |
92 | # remember requested symbols to determine what helpers to auto-export |
93 | my %was_requested = |
94 | map { ($_ => 1) } |
95 | grep { not ref } |
96 | @args; |
e211870f |
97 | |
16ddefbf |
98 | # determine which additional symbols (helpers) to export along |
99 | my %add; |
100 | EXPORT: |
101 | for my $type (grep { exists $was_requested{ $_ } } @types) { |
102 | $add{ "is_$type" }++ |
103 | unless $was_requested{ "is_$type" }; |
104 | next EXPORT |
105 | unless exists $ex_util{ $type }{to}; |
106 | $add{ "to_$type" }++ |
107 | unless $was_requested{ "to_$type" }; |
e211870f |
108 | } |
8af0a70d |
109 | |
16ddefbf |
110 | # and on to the real exporter |
111 | my @new_args = (@args, keys %add); |
112 | return $class->$exporter(@new_args); |
8af0a70d |
113 | } |
114 | |
e211870f |
115 | =head2 get_type |
116 | |
117 | This returns a type from the library's store by its name. |
118 | |
119 | =cut |
120 | |
8af0a70d |
121 | sub get_type { |
122 | my ($class, $type) = @_; |
123 | |
124 | # useful message if the type couldn't be found |
125 | croak "Unknown type '$type' in library '$class'" |
126 | unless $class->has_type($type); |
127 | |
128 | # return real name of the type |
129 | return $class->type_storage->{ $type }; |
130 | } |
131 | |
e211870f |
132 | =head2 type_names |
133 | |
134 | Returns a list of all known types by their name. |
135 | |
136 | =cut |
137 | |
8af0a70d |
138 | sub type_names { |
139 | my ($class) = @_; |
140 | |
141 | # return short names of all stored types |
142 | return keys %{ $class->type_storage }; |
143 | } |
144 | |
e211870f |
145 | =head2 add_type |
146 | |
147 | Adds a new type to the library. |
148 | |
149 | =cut |
150 | |
8af0a70d |
151 | sub add_type { |
152 | my ($class, $type) = @_; |
153 | |
154 | # store type with library prefix as real name |
155 | $class->type_storage->{ $type } = "${class}::${type}"; |
156 | } |
157 | |
e211870f |
158 | =head2 has_type |
159 | |
160 | Returns true or false depending on if this library knows a type by that |
161 | name. |
162 | |
163 | =cut |
164 | |
8af0a70d |
165 | sub has_type { |
166 | my ($class, $type) = @_; |
167 | |
168 | # check if we stored a type under that name |
169 | return ! ! $class->type_storage->{ $type }; |
170 | } |
171 | |
e211870f |
172 | =head2 type_storage |
173 | |
174 | Returns the library's type storage hash reference. You shouldn't use this |
175 | method directly unless you know what you are doing. It is not an internal |
176 | method because overriding it makes virtual libraries very easy. |
177 | |
178 | =cut |
179 | |
8af0a70d |
180 | sub type_storage { |
181 | my ($class) = @_; |
182 | |
183 | # return a reference to the storage in ourself |
184 | { no strict 'refs'; |
185 | return \%{ $class . '::__MOOSEX_TYPELIBRARY_STORAGE' }; |
186 | } |
187 | } |
188 | |
e211870f |
189 | =head1 SEE ALSO |
190 | |
52d358e2 |
191 | L<MooseX::Types::Moose> |
e211870f |
192 | |
193 | =head1 AUTHOR AND COPYRIGHT |
194 | |
195 | Robert 'phaylon' Sedlacek C<E<lt>rs@474.atE<gt>>, with many thanks to |
196 | the C<#moose> cabal on C<irc.perl.org>. |
197 | |
198 | =head1 LICENSE |
199 | |
200 | This program is free software; you can redistribute it and/or modify |
201 | it under the same terms as perl itself. |
202 | |
203 | =cut |
204 | |
8af0a70d |
205 | 1; |