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 ); |
13 | use Carp qw( croak ); |
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 |
78 | my $full = $class->get_type($type); |
79 | my $tobj = find_type_constraint($full); |
c20dc98b |
80 | |
81 | # a possible wrapper around library functionality |
52d358e2 |
82 | my $wrap = $args{ -wrapper } || 'MooseX::Types'; |
8af0a70d |
83 | |
84 | # install Type name constant |
85 | install_sub({ |
c20dc98b |
86 | code => $wrap->type_export_generator($type, $full), |
8af0a70d |
87 | into => $target, |
88 | as => $type, |
89 | }); |
90 | |
91 | # install is_Type test function |
92 | install_sub({ |
c20dc98b |
93 | code => $wrap->check_export_generator($type, $full, $undef_msg), |
8af0a70d |
94 | into => $target, |
95 | as => "is_$type", |
96 | }); |
97 | |
98 | # only install to_Type coercion handler if type can coerce |
e211870f |
99 | # or if we want to provide them anyway, e.g. declarations |
100 | if ($args{ -full } or $tobj->has_coercion) { |
8af0a70d |
101 | |
e211870f |
102 | # install to_Type coercion handler |
103 | install_sub({ |
c20dc98b |
104 | code => $wrap->coercion_export_generator($type, $full, $undef_msg), |
e211870f |
105 | into => $target, |
106 | as => "to_$type", |
107 | }); |
108 | } |
8af0a70d |
109 | |
110 | return 1; |
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 | |
e211870f |
187 | =head1 SEE ALSO |
188 | |
52d358e2 |
189 | L<MooseX::Types::Moose> |
e211870f |
190 | |
191 | =head1 AUTHOR AND COPYRIGHT |
192 | |
193 | Robert 'phaylon' Sedlacek C<E<lt>rs@474.atE<gt>>, with many thanks to |
194 | the C<#moose> cabal on C<irc.perl.org>. |
195 | |
196 | =head1 LICENSE |
197 | |
198 | This program is free software; you can redistribute it and/or modify |
199 | it under the same terms as perl itself. |
200 | |
201 | =cut |
202 | |
8af0a70d |
203 | 1; |