Commit | Line | Data |
d288ce53 |
1 | package Class::C3::Componentised; |
2 | |
20169807 |
3 | =head1 NAME |
4 | |
5 | Class::C3::Componentised |
6 | |
7 | =head1 DESCRIPTION |
8 | |
9 | Load mix-ins or components to your C3-based class. |
10 | |
11 | =head1 SYNOPSIS |
12 | |
13 | package MyModule; |
14 | |
15 | use strict; |
16 | use warnings; |
17 | |
18 | use base 'Class::C3::Componentised'; |
19 | |
0c205e9c |
20 | sub component_base_class { "MyModule::Component" } |
20169807 |
21 | |
22 | package main; |
23 | |
0c205e9c |
24 | MyModule->load_components( qw/Foo Bar/ ); |
25 | # Will load MyModule::Component::Foo an MyModule::Component::Bar |
26 | |
27 | =head1 DESCRIPTION |
28 | |
29 | This will inject base classes to your module using the L<Class::C3> method |
30 | resolution order. |
31 | |
32 | Please note: these are not plugins that can take precedence over methods |
33 | declared in MyModule. If you want something like that, consider |
34 | L<MooseX::Object::Pluggable>. |
20169807 |
35 | |
36 | =head1 METHODS |
37 | |
38 | =cut |
39 | |
d288ce53 |
40 | use strict; |
41 | use warnings; |
42 | |
d2b0e111 |
43 | # see Makefile.PL for discussion on why we load both Class::C3 and MRO::Compat |
d2b0e111 |
44 | use Class::C3 (); |
0b8e135a |
45 | use MRO::Compat; |
20169807 |
46 | use Class::Inspector; |
47 | use Carp; |
d288ce53 |
48 | |
593953c0 |
49 | our $VERSION = 1.0004; |
d288ce53 |
50 | |
20169807 |
51 | =head2 load_components( @comps ) |
d288ce53 |
52 | |
20169807 |
53 | Loads the given components into the current module. If a module begins with a |
54 | C<+> character, it is taken to be a fully qualified class name, otherwise |
55 | C<< $class->component_base_class >> is prepended to it. |
d288ce53 |
56 | |
20169807 |
57 | Calling this will call C<Class::C3::reinitialize>. |
58 | |
59 | =cut |
d288ce53 |
60 | |
61 | sub load_components { |
62 | my $class = shift; |
63 | my $base = $class->component_base_class; |
64 | my @comp = map { /^\+(.*)$/ ? $1 : "${base}::$_" } grep { $_ !~ /^#/ } @_; |
65 | $class->_load_components(@comp); |
d288ce53 |
66 | } |
67 | |
20169807 |
68 | =head2 load_own_components( @comps ) |
69 | |
5e54b45d |
70 | Similar to L<load_components>, but assumes every class is C<"$class::$comp">. |
20169807 |
71 | |
72 | =cut |
73 | |
d288ce53 |
74 | sub load_own_components { |
75 | my $class = shift; |
76 | my @comp = map { "${class}::$_" } grep { $_ !~ /^#/ } @_; |
77 | $class->_load_components(@comp); |
78 | } |
79 | |
80 | sub _load_components { |
81 | my ($class, @comp) = @_; |
82 | foreach my $comp (@comp) { |
20169807 |
83 | $class->ensure_class_loaded($comp); |
d288ce53 |
84 | } |
85 | $class->inject_base($class => @comp); |
20169807 |
86 | Class::C3::reinitialize(); |
d288ce53 |
87 | } |
88 | |
20169807 |
89 | =head2 load_optional_components |
d288ce53 |
90 | |
20169807 |
91 | As L<load_components>, but will silently ignore any components that cannot be |
92 | found. |
d288ce53 |
93 | |
20169807 |
94 | =cut |
d288ce53 |
95 | |
20169807 |
96 | sub load_optional_components { |
97 | my $class = shift; |
98 | my $base = $class->component_base_class; |
99 | my @comp = grep { $class->load_optional_class( $_ ) } |
100 | map { /^\+(.*)$/ ? $1 : "${base}::$_" } |
101 | grep { $_ !~ /^#/ } @_; |
d288ce53 |
102 | |
20169807 |
103 | $class->_load_components( @comp ) if scalar @comp; |
104 | } |
d288ce53 |
105 | |
20169807 |
106 | =head2 ensure_class_loaded |
107 | |
108 | Given a class name, tests to see if it is already loaded or otherwise |
109 | defined. If it is not yet loaded, the package is require'd, and an exception |
110 | is thrown if the class is still not loaded. |
111 | |
112 | BUG: For some reason, packages with syntax errors are added to %INC on |
113 | require |
114 | =cut |
115 | |
116 | # |
117 | # TODO: handle ->has_many('rel', 'Class'...) instead of |
118 | # ->has_many('rel', 'Some::Schema::Class'...) |
119 | # |
120 | sub ensure_class_loaded { |
121 | my ($class, $f_class) = @_; |
122 | |
123 | croak "Invalid class name $f_class" |
124 | if ($f_class=~m/(?:\b:\b|\:{3,})/); |
125 | return if Class::Inspector->loaded($f_class); |
c2bfa58a |
126 | my $file = $f_class . '.pm'; |
127 | $file =~ s{::}{/}g; |
128 | eval { CORE::require($file) }; # require needs a bareword or filename |
20169807 |
129 | if ($@) { |
130 | if ($class->can('throw_exception')) { |
131 | $class->throw_exception($@); |
132 | } else { |
133 | croak $@; |
134 | } |
135 | } |
136 | } |
d288ce53 |
137 | |
20169807 |
138 | =head2 ensure_class_found |
d288ce53 |
139 | |
20169807 |
140 | Returns true if the specified class is installed or already loaded, false |
141 | otherwise |
d288ce53 |
142 | |
20169807 |
143 | =cut |
d288ce53 |
144 | |
20169807 |
145 | sub ensure_class_found { |
146 | my ($class, $f_class) = @_; |
147 | return Class::Inspector->loaded($f_class) || |
148 | Class::Inspector->installed($f_class); |
149 | } |
d288ce53 |
150 | |
d288ce53 |
151 | |
152 | =head2 inject_base |
153 | |
20169807 |
154 | Does the actual magic of adjusting @ISA on the target module. |
155 | |
156 | =cut |
d288ce53 |
157 | |
20169807 |
158 | sub inject_base { |
159 | my ($class, $target, @to_inject) = @_; |
160 | { |
161 | no strict 'refs'; |
162 | foreach my $to (reverse @to_inject) { |
0c205e9c |
163 | unshift ( @{"${target}::ISA"}, $to ) |
20169807 |
164 | unless ($target eq $to || $target->isa($to)); |
165 | } |
166 | } |
167 | |
d91a39a9 |
168 | mro::set_mro($target, 'c3'); |
20169807 |
169 | } |
d288ce53 |
170 | |
171 | =head1 AUTHOR |
172 | |
20169807 |
173 | Matt S. Trout and the DBIx::Class team |
174 | |
175 | Pulled out into seperate module by Ash Berlin C<< <ash@cpan.org> >> |
d288ce53 |
176 | |
177 | =head1 LICENSE |
178 | |
179 | You may distribute this code under the same terms as Perl itself. |
20169807 |
180 | |
181 | =cut |
182 | |
183 | 1; |