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