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