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 # see Makefile.PL for discussion on why we load both Class::C3 and MRO::Compat
  44 use Class::C3 ();
  45 use MRO::Compat;
  46 use Class::Inspector;
  47 use Carp;
  48
  49 our $VERSION = 1.0006;
  50
  51 =head2 load_components( @comps )
  52
  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.
  56
  57 Calling this will call C<Class::C3::reinitialize>.
  58
  59 =cut
  60
  61 sub 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
  74 Similar to L<load_components>, but assumes every class is C<"$class::$comp">.
  75
  76 =cut
  77
  78 sub load_own_components {
  79   my $class = shift;
  80   my @comp = map { "${class}::$_" } grep { $_ !~ /^#/ } @_;
  81   $class->_load_components(@comp);
  82 }
  83
  84 sub _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
  95 As L<load_components>, but will silently ignore any components that cannot be
  96 found.
  97
  98 =cut
  99
 100 sub 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
 115 Given a class name, tests to see if it is already loaded or otherwise
 116 defined. If it is not yet loaded, the package is require'd, and an exception
 117 is 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 #
 127 sub 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
 147 Returns true if the specified class is installed or already loaded, false
 148 otherwise.
 149
 150 Note that the underlying mechanism (Class::Inspector->installed()) used by this
 151 sub will not, at the time of writing, correctly function when @INC includes
 152 coderefs. Since PAR relies upon coderefs in @INC, this function should be
 153 avoided in modules that are likely to be included within a PAR.
 154
 155 =cut
 156
 157 sub 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
 166 Does the actual magic of adjusting @ISA on the target module.
 167
 168 =cut
 169
 170 sub 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
 185 Returns a true value if the specified class is installed and loaded
 186 successfully, throws an exception if the class is found but not loaded
 187 successfully, and false if the class is not installed
 188
 189 =cut
 190
 191 sub 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
 211 Matt S. Trout and the DBIx::Class team
 212
 213 Pulled out into seperate module by Ash Berlin C<< <ash@cpan.org> >>
 214
 215 =head1 LICENSE
 216
 217 You may distribute this code under the same terms as Perl itself.
 218
 219 =cut
 220
 221 1;