Commit | Line | Data |
52d358e2 |
1 | package MooseX::Types::Base; |
e211870f |
2 | |
3 | =head1 NAME |
4 | |
52d358e2 |
5 | MooseX::Types::Base - Type library base class |
e211870f |
6 | |
7 | =cut |
8 | |
3df5416a |
9 | #use warnings; |
10 | #use strict; |
8af0a70d |
11 | |
e211870f |
12 | use Sub::Install qw( install_sub ); |
9563f55e |
13 | use Carp::Clan qw( ^MooseX::Types ); |
9616cebc |
14 | use MooseX::Types::Util qw( filter_tags ); |
8af0a70d |
15 | use Moose::Util::TypeConstraints; |
3df5416a |
16 | use Moose; |
9616cebc |
17 | |
18 | use namespace::clean -except => [qw( meta )]; |
8af0a70d |
19 | |
e211870f |
20 | =head1 DESCRIPTION |
21 | |
22 | You normally won't need to interact with this class by yourself. It is |
23 | merely a collection of functionality that type libraries need to |
52d358e2 |
24 | interact with moose and the rest of the L<MooseX::Types> module. |
e211870f |
25 | |
26 | =cut |
27 | |
8af0a70d |
28 | my $UndefMsg = q{Unable to find type '%s' in library '%s'}; |
29 | |
e211870f |
30 | =head1 METHODS |
31 | |
32 | =cut |
33 | |
34 | =head2 import |
35 | |
36 | Provides the import mechanism for your library. See |
52d358e2 |
37 | L<MooseX::Types/"LIBRARY USAGE"> for syntax details on this. |
e211870f |
38 | |
39 | =cut |
40 | |
8af0a70d |
41 | sub import { |
c20dc98b |
42 | my ($class, @args) = @_; |
e211870f |
43 | |
c20dc98b |
44 | # separate tags from types and possible options |
45 | my ($options) = grep { ref $_ eq 'HASH' } @args; |
46 | my ($tags, $types) |
47 | = filter_tags |
48 | grep { ref $_ ne 'HASH' } |
49 | @args; |
50 | my $callee = ($options && $options->{ -into } || scalar(caller)); |
8af0a70d |
51 | |
e211870f |
52 | # :all replaces types with full list |
53 | @$types = $class->type_names if $tags->{all}; |
8af0a70d |
54 | |
55 | TYPE: |
56 | # export all requested types |
e211870f |
57 | for my $type (@$types) { |
8af0a70d |
58 | $class->export_type_into( |
c20dc98b |
59 | $callee, |
e211870f |
60 | $type, |
61 | sprintf($UndefMsg, $type, $class), |
c20dc98b |
62 | ($options ? %$options : ()), |
e211870f |
63 | ); |
8af0a70d |
64 | } |
65 | return 1; |
66 | } |
67 | |
e211870f |
68 | =head2 export_type_into |
69 | |
70 | Exports one specific type into a target package. |
71 | |
72 | =cut |
73 | |
8af0a70d |
74 | sub export_type_into { |
75 | my ($class, $target, $type, $undef_msg, %args) = @_; |
76 | |
77 | # the real type name and its type object |
9563f55e |
78 | my $full = $class->get_type($type) |
79 | or croak "No fully qualified type name stored for '$type'"; |
8af0a70d |
80 | my $tobj = find_type_constraint($full); |
c20dc98b |
81 | |
82 | # a possible wrapper around library functionality |
52d358e2 |
83 | my $wrap = $args{ -wrapper } || 'MooseX::Types'; |
8af0a70d |
84 | |
85 | # install Type name constant |
86 | install_sub({ |
c20dc98b |
87 | code => $wrap->type_export_generator($type, $full), |
8af0a70d |
88 | into => $target, |
89 | as => $type, |
90 | }); |
91 | |
92 | # install is_Type test function |
93 | install_sub({ |
c20dc98b |
94 | code => $wrap->check_export_generator($type, $full, $undef_msg), |
8af0a70d |
95 | into => $target, |
96 | as => "is_$type", |
97 | }); |
98 | |
99 | # only install to_Type coercion handler if type can coerce |
e211870f |
100 | # or if we want to provide them anyway, e.g. declarations |
9563f55e |
101 | if ($args{ -full } or $tobj and $tobj->has_coercion) { |
8af0a70d |
102 | |
e211870f |
103 | # install to_Type coercion handler |
104 | install_sub({ |
c20dc98b |
105 | code => $wrap->coercion_export_generator($type, $full, $undef_msg), |
e211870f |
106 | into => $target, |
107 | as => "to_$type", |
108 | }); |
109 | } |
8af0a70d |
110 | |
111 | return 1; |
112 | } |
113 | |
e211870f |
114 | =head2 get_type |
115 | |
116 | This returns a type from the library's store by its name. |
117 | |
118 | =cut |
119 | |
8af0a70d |
120 | sub get_type { |
121 | my ($class, $type) = @_; |
122 | |
123 | # useful message if the type couldn't be found |
124 | croak "Unknown type '$type' in library '$class'" |
125 | unless $class->has_type($type); |
126 | |
127 | # return real name of the type |
128 | return $class->type_storage->{ $type }; |
129 | } |
130 | |
e211870f |
131 | =head2 type_names |
132 | |
133 | Returns a list of all known types by their name. |
134 | |
135 | =cut |
136 | |
8af0a70d |
137 | sub type_names { |
138 | my ($class) = @_; |
139 | |
140 | # return short names of all stored types |
141 | return keys %{ $class->type_storage }; |
142 | } |
143 | |
e211870f |
144 | =head2 add_type |
145 | |
146 | Adds a new type to the library. |
147 | |
148 | =cut |
149 | |
8af0a70d |
150 | sub add_type { |
151 | my ($class, $type) = @_; |
152 | |
153 | # store type with library prefix as real name |
154 | $class->type_storage->{ $type } = "${class}::${type}"; |
155 | } |
156 | |
e211870f |
157 | =head2 has_type |
158 | |
159 | Returns true or false depending on if this library knows a type by that |
160 | name. |
161 | |
162 | =cut |
163 | |
8af0a70d |
164 | sub has_type { |
165 | my ($class, $type) = @_; |
166 | |
167 | # check if we stored a type under that name |
168 | return ! ! $class->type_storage->{ $type }; |
169 | } |
170 | |
e211870f |
171 | =head2 type_storage |
172 | |
173 | Returns the library's type storage hash reference. You shouldn't use this |
174 | method directly unless you know what you are doing. It is not an internal |
175 | method because overriding it makes virtual libraries very easy. |
176 | |
177 | =cut |
178 | |
8af0a70d |
179 | sub type_storage { |
180 | my ($class) = @_; |
181 | |
182 | # return a reference to the storage in ourself |
183 | { no strict 'refs'; |
184 | return \%{ $class . '::__MOOSEX_TYPELIBRARY_STORAGE' }; |
185 | } |
186 | } |
187 | |
e211870f |
188 | =head1 SEE ALSO |
189 | |
52d358e2 |
190 | L<MooseX::Types::Moose> |
e211870f |
191 | |
192 | =head1 AUTHOR AND COPYRIGHT |
193 | |
194 | Robert 'phaylon' Sedlacek C<E<lt>rs@474.atE<gt>>, with many thanks to |
195 | the C<#moose> cabal on C<irc.perl.org>. |
196 | |
197 | =head1 LICENSE |
198 | |
199 | This program is free software; you can redistribute it and/or modify |
200 | it under the same terms as perl itself. |
201 | |
202 | =cut |
203 | |
8af0a70d |
204 | 1; |