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