Commit | Line | Data |
d288ce53 |
1 | package Class::C3::Componentised; |
2 | |
20169807 |
3 | =head1 NAME |
4 | |
6ea99b11 |
5 | Class::C3::Componentised - Load mix-ins or components to your C3-based class |
20169807 |
6 | |
7 | =head1 SYNOPSIS |
8 | |
9 | package MyModule; |
10 | |
11 | use strict; |
12 | use warnings; |
13 | |
14 | use base 'Class::C3::Componentised'; |
15 | |
0c205e9c |
16 | sub component_base_class { "MyModule::Component" } |
20169807 |
17 | |
18 | package main; |
19 | |
3a23b721 |
20 | MyModule->load_components( qw/Foo Bar/ ); |
b34a4025 |
21 | # Will load MyModule::Component::Foo and MyModule::Component::Bar |
0c205e9c |
22 | |
23 | =head1 DESCRIPTION |
24 | |
25 | This will inject base classes to your module using the L<Class::C3> method |
26 | resolution order. |
27 | |
3a23b721 |
28 | Please note: these are not plugins that can take precedence over methods |
0c205e9c |
29 | declared in MyModule. If you want something like that, consider |
30 | L<MooseX::Object::Pluggable>. |
20169807 |
31 | |
32 | =head1 METHODS |
33 | |
34 | =cut |
35 | |
d288ce53 |
36 | use strict; |
37 | use warnings; |
38 | |
3a4635fb |
39 | # This will prime the Class::C3 namespace (either by loading it proper on 5.8 |
40 | # or by installing compat shims on 5.10+). A user might have a reasonable |
41 | # expectation that using Class::C3::<something> will give him access to |
42 | # Class::C3 itself, and this module has been providing this historically. |
43 | # Therefore leaving it in indefinitely. |
0b8e135a |
44 | use MRO::Compat; |
3a4635fb |
45 | |
f8b4872f |
46 | use Carp (); |
91e80be9 |
47 | use List::Util (); |
d288ce53 |
48 | |
c17e86b8 |
49 | our $VERSION = '1.001000'; |
a7808c8e |
50 | $VERSION =~ tr/_//d; |
d288ce53 |
51 | |
eac9b176 |
52 | my $invalid_class = qr/(?: \b:\b | \:{3,} | \:\:$ )/x; |
53 | |
20169807 |
54 | =head2 load_components( @comps ) |
d288ce53 |
55 | |
3a23b721 |
56 | Loads the given components into the current module. If a module begins with a |
20169807 |
57 | C<+> character, it is taken to be a fully qualified class name, otherwise |
58 | C<< $class->component_base_class >> is prepended to it. |
d288ce53 |
59 | |
20169807 |
60 | Calling this will call C<Class::C3::reinitialize>. |
61 | |
62 | =cut |
d288ce53 |
63 | |
64 | sub load_components { |
65 | my $class = shift; |
3a4635fb |
66 | $class->_load_components( map { |
67 | /^\+(.*)$/ |
68 | ? $1 |
69 | : join ('::', $class->component_base_class, $_) |
70 | } grep { $_ !~ /^#/ } @_ |
71 | ); |
d288ce53 |
72 | } |
73 | |
20169807 |
74 | =head2 load_own_components( @comps ) |
75 | |
5e54b45d |
76 | Similar to L<load_components>, but assumes every class is C<"$class::$comp">. |
20169807 |
77 | |
78 | =cut |
79 | |
d288ce53 |
80 | sub load_own_components { |
81 | my $class = shift; |
3a4635fb |
82 | $class->_load_components( map { "${class}::$_" } grep { $_ !~ /^#/ } @_ ); |
d288ce53 |
83 | } |
84 | |
85 | sub _load_components { |
3a4635fb |
86 | my $class = shift; |
87 | return unless @_; |
88 | |
89 | $class->ensure_class_loaded($_) for @_; |
90 | $class->inject_base($class => @_); |
20169807 |
91 | Class::C3::reinitialize(); |
d288ce53 |
92 | } |
93 | |
20169807 |
94 | =head2 load_optional_components |
d288ce53 |
95 | |
3a23b721 |
96 | As L<load_components>, but will silently ignore any components that cannot be |
20169807 |
97 | found. |
d288ce53 |
98 | |
20169807 |
99 | =cut |
d288ce53 |
100 | |
20169807 |
101 | sub load_optional_components { |
102 | my $class = shift; |
3a4635fb |
103 | $class->_load_components( grep |
104 | { $class->load_optional_class( $_ ) } |
105 | ( map |
106 | { /^\+(.*)$/ |
107 | ? $1 |
108 | : join ('::', $class->component_base_class, $_) |
109 | } |
110 | grep { $_ !~ /^#/ } @_ |
111 | ) |
112 | ); |
20169807 |
113 | } |
d288ce53 |
114 | |
20169807 |
115 | =head2 ensure_class_loaded |
116 | |
117 | Given a class name, tests to see if it is already loaded or otherwise |
118 | defined. If it is not yet loaded, the package is require'd, and an exception |
119 | is thrown if the class is still not loaded. |
120 | |
121 | BUG: For some reason, packages with syntax errors are added to %INC on |
122 | require |
123 | =cut |
124 | |
20169807 |
125 | sub ensure_class_loaded { |
126 | my ($class, $f_class) = @_; |
127 | |
3a4635fb |
128 | no strict 'refs'; |
129 | |
130 | # ripped from Class::Inspector for speed |
131 | # note that the order is important (faster items are first) |
132 | return if ${"${f_class}::VERSION"}; |
133 | |
134 | return if @{"${f_class}::ISA"}; |
135 | |
136 | my $file = (join ('/', split ('::', $f_class) ) ) . '.pm'; |
137 | return if $INC{$file}; |
138 | |
139 | for ( keys %{"${f_class}::"} ) { |
140 | return if ( *{"${f_class}::$_"}{CODE} ); |
141 | } |
142 | |
3a4635fb |
143 | # require always returns true on success |
15b7d164 |
144 | # ill-behaved modules might very well obliterate $_ |
145 | eval { local $_; require($file) } or do { |
3a4635fb |
146 | |
eac9b176 |
147 | $@ = "Invalid class name '$f_class'" if $f_class =~ $invalid_class; |
3a4635fb |
148 | |
20169807 |
149 | if ($class->can('throw_exception')) { |
150 | $class->throw_exception($@); |
151 | } else { |
f8b4872f |
152 | Carp::croak $@; |
20169807 |
153 | } |
3a4635fb |
154 | }; |
155 | |
156 | return; |
20169807 |
157 | } |
d288ce53 |
158 | |
20169807 |
159 | =head2 ensure_class_found |
d288ce53 |
160 | |
20169807 |
161 | Returns true if the specified class is installed or already loaded, false |
b34a4025 |
162 | otherwise. |
163 | |
164 | Note that the underlying mechanism (Class::Inspector->installed()) used by this |
165 | sub will not, at the time of writing, correctly function when @INC includes |
166 | coderefs. Since PAR relies upon coderefs in @INC, this function should be |
167 | avoided in modules that are likely to be included within a PAR. |
d288ce53 |
168 | |
20169807 |
169 | =cut |
d288ce53 |
170 | |
20169807 |
171 | sub ensure_class_found { |
3a4635fb |
172 | #my ($class, $f_class) = @_; |
173 | require Class::Inspector; |
174 | return Class::Inspector->loaded($_[1]) || |
175 | Class::Inspector->installed($_[1]); |
20169807 |
176 | } |
d288ce53 |
177 | |
d288ce53 |
178 | |
179 | =head2 inject_base |
180 | |
20169807 |
181 | Does the actual magic of adjusting @ISA on the target module. |
182 | |
183 | =cut |
d288ce53 |
184 | |
20169807 |
185 | sub inject_base { |
3a4635fb |
186 | my $class = shift; |
187 | my $target = shift; |
188 | |
e6b8b400 |
189 | mro::set_mro($target, 'c3'); |
190 | |
191 | for my $comp (reverse @_) { |
91e80be9 |
192 | my $apply = do { |
193 | no strict 'refs'; |
194 | sub { unshift ( @{"${target}::ISA"}, $comp ) }; |
195 | }; |
e6b8b400 |
196 | unless ($target eq $comp || $target->isa($comp)) { |
91e80be9 |
197 | our %APPLICATOR_FOR; |
198 | if (my $apply_class |
199 | = List::Util::first { $APPLICATOR_FOR{$_} } @{mro::get_linear_isa($comp)} |
200 | ) { |
201 | $APPLICATOR_FOR{$apply_class}->_apply_component_to_class($comp,$target,$apply); |
202 | } else { |
203 | $apply->(); |
e6b8b400 |
204 | } |
205 | } |
206 | } |
20169807 |
207 | } |
d288ce53 |
208 | |
078742b1 |
209 | =head2 load_optional_class |
210 | |
211 | Returns a true value if the specified class is installed and loaded |
212 | successfully, throws an exception if the class is found but not loaded |
213 | successfully, and false if the class is not installed |
214 | |
215 | =cut |
216 | |
217 | sub load_optional_class { |
218 | my ($class, $f_class) = @_; |
3a4635fb |
219 | |
220 | # ensure_class_loaded either returns a () (*not* true) or throws |
221 | eval { |
222 | $class->ensure_class_loaded($f_class); |
223 | 1; |
224 | } && return 1; |
225 | |
dfb3a821 |
226 | my $err = $@; # so we don't lose it |
3a4635fb |
227 | |
eac9b176 |
228 | if ($f_class =~ $invalid_class) { |
229 | $err = "Invalid class name '$f_class'"; |
230 | } |
231 | else { |
232 | my $fn = quotemeta( (join ('/', split ('::', $f_class) ) ) . '.pm' ); |
233 | return 0 if ($err =~ /Can't locate ${fn} in \@INC/ ); |
3a4635fb |
234 | } |
eac9b176 |
235 | |
236 | if ($class->can('throw_exception')) { |
3a4635fb |
237 | $class->throw_exception($err); |
078742b1 |
238 | } |
dfb3a821 |
239 | else { |
3a4635fb |
240 | die $err; |
dfb3a821 |
241 | } |
078742b1 |
242 | } |
243 | |
025a7b58 |
244 | =head1 AUTHORS |
d288ce53 |
245 | |
025a7b58 |
246 | Matt S. Trout and the L<DBIx::Class team|DBIx::Class/CONTRIBUTORS> |
20169807 |
247 | |
248 | Pulled out into seperate module by Ash Berlin C<< <ash@cpan.org> >> |
d288ce53 |
249 | |
025a7b58 |
250 | Optimizations and overall bolt-tightening by Peter "ribasushi" Rabbitson |
251 | C<< <ribasushi@cpan.org> >> |
252 | |
253 | =head1 COPYRIGHT |
254 | |
255 | Copyright (c) 2006 - 2011 the Class::C3::Componentised L</AUTHORS> as listed |
256 | above. |
257 | |
d288ce53 |
258 | =head1 LICENSE |
259 | |
260 | You may distribute this code under the same terms as Perl itself. |
20169807 |
261 | |
262 | =cut |
263 | |
264 | 1; |