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