lib/Class/C3/Componentised.pm

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