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>, but assumes every class is C<"$class::$comp">.
  77
  78 =cut
  79
  80 sub load_own_components {
  81   my $class = shift;
  82   $class->_load_components( map { "${class}::$_" } grep { $_ !~ /^#/ } @_ );
  83 }
  84
  85 sub _load_components {
  86   my $class = shift;
  87   return unless @_;
  88
  89   $class->ensure_class_loaded($_) for @_;
  90   $class->inject_base($class => @_);
  91   Class::C3::reinitialize();
  92 }
  93
  94 =head2 load_optional_components
  95
  96 As L<load_components>, but will silently ignore any components that cannot be
  97 found.
  98
  99 =cut
 100
 101 sub load_optional_components {
 102   my $class = shift;
 103   $class->_load_components( grep
 104     { $class->load_optional_class( $_ ) }
 105     ( map
 106       { /^\+(.*)$/
 107           ? $1
 108           : join ('::', $class->component_base_class, $_)
 109       }
 110       grep { $_ !~ /^#/ } @_
 111     )
 112   );
 113 }
 114
 115 =head2 ensure_class_loaded
 116
 117 Given a class name, tests to see if it is already loaded or otherwise
 118 defined. If it is not yet loaded, the package is require'd, and an exception
 119 is thrown if the class is still not loaded.
 120
 121  BUG: For some reason, packages with syntax errors are added to %INC on
 122       require
 123 =cut
 124
 125 sub ensure_class_loaded {
 126   my ($class, $f_class) = @_;
 127
 128   no strict 'refs';
 129
 130   # ripped from Class::Inspector for speed
 131   # note that the order is important (faster items are first)
 132   return if ${"${f_class}::VERSION"};
 133
 134   return if @{"${f_class}::ISA"};
 135
 136   my $file = (join ('/', split ('::', $f_class) ) ) . '.pm';
 137   return if $INC{$file};
 138
 139   for ( keys %{"${f_class}::"} ) {
 140     return if ( *{"${f_class}::$_"}{CODE} );
 141   }
 142
 143   # require always returns true on success
 144   # ill-behaved modules might very well obliterate $_
 145   eval { local $_; require($file) } or do {
 146
 147     $@ = "Invalid class name '$f_class'" if $f_class =~ $invalid_class;
 148
 149     if ($class->can('throw_exception')) {
 150       $class->throw_exception($@);
 151     } else {
 152       Carp::croak $@;
 153     }
 154   };
 155
 156   return;
 157 }
 158
 159 =head2 ensure_class_found
 160
 161 Returns true if the specified class is installed or already loaded, false
 162 otherwise.
 163
 164 Note that the underlying mechanism (Class::Inspector->installed()) used by this
 165 sub will not, at the time of writing, correctly function when @INC includes
 166 coderefs. Since PAR relies upon coderefs in @INC, this function should be
 167 avoided in modules that are likely to be included within a PAR.
 168
 169 =cut
 170
 171 sub ensure_class_found {
 172   #my ($class, $f_class) = @_;
 173   require Class::Inspector;
 174   return Class::Inspector->loaded($_[1]) ||
 175          Class::Inspector->installed($_[1]);
 176 }
 177
 178
 179 =head2 inject_base
 180
 181 Does the actual magic of adjusting @ISA on the target module.
 182
 183 =cut
 184
 185 sub inject_base {
 186   my $class = shift;
 187   my $target = shift;
 188
 189   mro::set_mro($target, 'c3');
 190
 191   for my $comp (reverse @_) {
 192     my $apply = do {
 193       no strict 'refs';
 194       sub { unshift ( @{"${target}::ISA"}, $comp ) };
 195     };
 196     unless ($target eq $comp || $target->isa($comp)) {
 197       our %APPLICATOR_FOR;
 198       if (my $apply_class
 199             = List::Util::first { $APPLICATOR_FOR{$_} } @{mro::get_linear_isa($comp)}
 200       ) {
 201         $APPLICATOR_FOR{$apply_class}->_apply_component_to_class($comp,$target,$apply);
 202       } else {
 203         $apply->();
 204       }
 205     }
 206   }
 207 }
 208
 209 =head2 load_optional_class
 210
 211 Returns a true value if the specified class is installed and loaded
 212 successfully, throws an exception if the class is found but not loaded
 213 successfully, and false if the class is not installed
 214
 215 =cut
 216
 217 sub load_optional_class {
 218   my ($class, $f_class) = @_;
 219
 220   # ensure_class_loaded either returns a () (*not* true)  or throws
 221   eval {
 222    $class->ensure_class_loaded($f_class);
 223    1;
 224   } && return 1;
 225
 226   my $err = $@;   # so we don't lose it
 227
 228   if ($f_class =~ $invalid_class) {
 229     $err = "Invalid class name '$f_class'";
 230   }
 231   else {
 232     my $fn = quotemeta( (join ('/', split ('::', $f_class) ) ) . '.pm' );
 233     return 0 if ($err =~ /Can't locate ${fn} in \@INC/ );
 234   }
 235
 236   if ($class->can('throw_exception')) {
 237     $class->throw_exception($err);
 238   }
 239   else {
 240     die $err;
 241   }
 242 }
 243
 244 =head1 AUTHORS
 245
 246 Matt S. Trout and the L<DBIx::Class team|DBIx::Class/CONTRIBUTORS>
 247
 248 Pulled out into separate module by Ash Berlin C<< <ash@cpan.org> >>
 249
 250 Optimizations and overall bolt-tightening by Peter "ribasushi" Rabbitson
 251 C<< <ribasushi@cpan.org> >>
 252
 253 =head1 COPYRIGHT
 254
 255 Copyright (c) 2006 - 2011 the Class::C3::Componentised L</AUTHORS> as listed
 256 above.
 257
 258 =head1 LICENSE
 259
 260 You may distribute this code under the same terms as Perl itself.
 261
 262 =cut
 263
 264 1;