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