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 # This will prime the Class::C3 namespace (either by loading it proper on 5.8
  44 # or by installing compat shims on 5.10+). A user might have a reasonable
  45 # expectation that using Class::C3::<something> will give him access to
  46 # Class::C3 itself, and this module has been providing this historically.
  47 # Therefore leaving it in indefinitely.
  48 use MRO::Compat;
  49
  50 use Carp ();
  51
  52 our $VERSION = 1.0009;
  53
  54 my $invalid_class = qr/(?: \b:\b | \:{3,} | \:\:$ )/x;
  55
  56 =head2 load_components( @comps )
  57
  58 Loads the given components into the current module. If a module begins with a
  59 C<+> character, it is taken to be a fully qualified class name, otherwise
  60 C<< $class->component_base_class >> is prepended to it.
  61
  62 Calling this will call C<Class::C3::reinitialize>.
  63
  64 =cut
  65
  66 sub load_components {
  67   my $class = shift;
  68   $class->_load_components( map {
  69     /^\+(.*)$/
  70       ? $1
  71       : join ('::', $class->component_base_class, $_)
  72     } grep { $_ !~ /^#/ } @_
  73   );
  74 }
  75
  76 =head2 load_own_components( @comps )
  77
  78 Similar to L<load_components>, but assumes every class is C<"$class::$comp">.
  79
  80 =cut
  81
  82 sub load_own_components {
  83   my $class = shift;
  84   $class->_load_components( map { "${class}::$_" } grep { $_ !~ /^#/ } @_ );
  85 }
  86
  87 sub _load_components {
  88   my $class = shift;
  89   return unless @_;
  90
  91   $class->ensure_class_loaded($_) for @_;
  92   $class->inject_base($class => @_);
  93   Class::C3::reinitialize();
  94 }
  95
  96 =head2 load_optional_components
  97
  98 As L<load_components>, but will silently ignore any components that cannot be
  99 found.
 100
 101 =cut
 102
 103 sub load_optional_components {
 104   my $class = shift;
 105   $class->_load_components( grep
 106     { $class->load_optional_class( $_ ) }
 107     ( map
 108       { /^\+(.*)$/
 109           ? $1
 110           : join ('::', $class->component_base_class, $_)
 111       }
 112       grep { $_ !~ /^#/ } @_
 113     )
 114   );
 115 }
 116
 117 =head2 ensure_class_loaded
 118
 119 Given a class name, tests to see if it is already loaded or otherwise
 120 defined. If it is not yet loaded, the package is require'd, and an exception
 121 is thrown if the class is still not loaded.
 122
 123  BUG: For some reason, packages with syntax errors are added to %INC on
 124       require
 125 =cut
 126
 127 sub ensure_class_loaded {
 128   my ($class, $f_class) = @_;
 129
 130   no strict 'refs';
 131
 132   # ripped from Class::Inspector for speed
 133   # note that the order is important (faster items are first)
 134   return if ${"${f_class}::VERSION"};
 135
 136   return if @{"${f_class}::ISA"};
 137
 138   my $file = (join ('/', split ('::', $f_class) ) ) . '.pm';
 139   return if $INC{$file};
 140
 141   for ( keys %{"${f_class}::"} ) {
 142     return if ( *{"${f_class}::$_"}{CODE} );
 143   }
 144
 145   # require always returns true on success
 146   # ill-behaved modules might very well obliterate $_
 147   eval { local $_; require($file) } or do {
 148
 149     $@ = "Invalid class name '$f_class'" if $f_class =~ $invalid_class;
 150
 151     if ($class->can('throw_exception')) {
 152       $class->throw_exception($@);
 153     } else {
 154       Carp::croak $@;
 155     }
 156   };
 157
 158   return;
 159 }
 160
 161 =head2 ensure_class_found
 162
 163 Returns true if the specified class is installed or already loaded, false
 164 otherwise.
 165
 166 Note that the underlying mechanism (Class::Inspector->installed()) used by this
 167 sub will not, at the time of writing, correctly function when @INC includes
 168 coderefs. Since PAR relies upon coderefs in @INC, this function should be
 169 avoided in modules that are likely to be included within a PAR.
 170
 171 =cut
 172
 173 sub ensure_class_found {
 174   #my ($class, $f_class) = @_;
 175   require Class::Inspector;
 176   return Class::Inspector->loaded($_[1]) ||
 177          Class::Inspector->installed($_[1]);
 178 }
 179
 180
 181 =head2 inject_base
 182
 183 Does the actual magic of adjusting @ISA on the target module.
 184
 185 =cut
 186
 187 sub inject_base {
 188   my $class = shift;
 189   my $target = shift;
 190
 191   mro::set_mro($target, 'c3');
 192
 193   for my $comp (reverse @_) {
 194     no strict 'refs';
 195     unless ($target eq $comp || $target->isa($comp)) {
 196       my @heritage = @{mro::get_linear_isa($comp)};
 197
 198       my @before = map {
 199          my $to_run = $Class::C3::Componentised::ApplyHooks::Before{$_};
 200          ($to_run?[$_,$to_run]:())
 201       } @heritage;
 202
 203       for my $todo (@before) {
 204          my ($parent, $fn)  = @$todo;
 205          for my $f (reverse @$fn) {
 206             $target->$f($parent)
 207          }
 208       }
 209
 210       unshift ( @{"${target}::ISA"}, $comp );
 211
 212       my @after = map {
 213          my $to_run = $Class::C3::Componentised::ApplyHooks::After{$_};
 214          ($to_run?[$_,$to_run]:())
 215       } @heritage;
 216
 217       for my $todo (reverse @after) {
 218          my ($parent, $fn)  = @$todo;
 219          for my $f (@$fn) {
 220             $target->$f($parent)
 221          }
 222       }
 223     }
 224   }
 225 }
 226
 227 =head2 load_optional_class
 228
 229 Returns a true value if the specified class is installed and loaded
 230 successfully, throws an exception if the class is found but not loaded
 231 successfully, and false if the class is not installed
 232
 233 =cut
 234
 235 sub load_optional_class {
 236   my ($class, $f_class) = @_;
 237
 238   # ensure_class_loaded either returns a () (*not* true)  or throws
 239   eval {
 240    $class->ensure_class_loaded($f_class);
 241    1;
 242   } && return 1;
 243
 244   my $err = $@;   # so we don't lose it
 245
 246   if ($f_class =~ $invalid_class) {
 247     $err = "Invalid class name '$f_class'";
 248   }
 249   else {
 250     my $fn = quotemeta( (join ('/', split ('::', $f_class) ) ) . '.pm' );
 251     return 0 if ($err =~ /Can't locate ${fn} in \@INC/ );
 252   }
 253
 254   if ($class->can('throw_exception')) {
 255     $class->throw_exception($err);
 256   }
 257   else {
 258     die $err;
 259   }
 260 }
 261
 262 =head1 AUTHORS
 263
 264 Matt S. Trout and the L<DBIx::Class team|DBIx::Class/CONTRIBUTORS>
 265
 266 Pulled out into seperate module by Ash Berlin C<< <ash@cpan.org> >>
 267
 268 Optimizations and overall bolt-tightening by Peter "ribasushi" Rabbitson
 269 C<< <ribasushi@cpan.org> >>
 270
 271 =head1 COPYRIGHT
 272
 273 Copyright (c) 2006 - 2011 the Class::C3::Componentised L</AUTHORS> as listed
 274 above.
 275
 276 =head1 LICENSE
 277
 278 You may distribute this code under the same terms as Perl itself.
 279
 280 =cut
 281
 282 1;