lib/Class/C3/Componentised.pm

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