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