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.0006;
  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
 144   # require always returns true on success
 145   eval { require($file) } or do {
 146
 147     $@ = "Invalid class name $f_class"
 148       if ($f_class=~m/(?:\b:\b|\:{3,})/);
 149
 150     if ($class->can('throw_exception')) {
 151       $class->throw_exception($@);
 152     } else {
 153       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 Note that the underlying mechanism (Class::Inspector->installed()) used by this
 166 sub will not, at the time of writing, correctly function when @INC includes
 167 coderefs. Since PAR relies upon coderefs in @INC, this function should be
 168 avoided in modules that are likely to be included within a PAR.
 169
 170 =cut
 171
 172 sub ensure_class_found {
 173   #my ($class, $f_class) = @_;
 174   require Class::Inspector;
 175   return Class::Inspector->loaded($_[1]) ||
 176          Class::Inspector->installed($_[1]);
 177 }
 178
 179
 180 =head2 inject_base
 181
 182 Does the actual magic of adjusting @ISA on the target module.
 183
 184 =cut
 185
 186 sub inject_base {
 187   my $class = shift;
 188   my $target = shift;
 189
 190   my %isa = map { $_ => 1 } ($target, @{mro::get_linear_isa($target)} );
 191
 192   for (reverse @_) {
 193     no strict 'refs';
 194     unless ($isa{$_}++) {
 195       unshift ( @{"${target}::ISA"}, $_ );
 196     }
 197   }
 198
 199   mro::set_mro($target, 'c3');
 200 }
 201
 202 =head2 load_optional_class
 203
 204 Returns a true value if the specified class is installed and loaded
 205 successfully, throws an exception if the class is found but not loaded
 206 successfully, and false if the class is not installed
 207
 208 =cut
 209
 210 sub load_optional_class {
 211   my ($class, $f_class) = @_;
 212
 213   # ensure_class_loaded either returns a () (*not* true)  or throws
 214   eval {
 215    $class->ensure_class_loaded($f_class);
 216    1;
 217   } && return 1;
 218
 219   my $err = $@;   # so we don't lose it
 220
 221   my $fn = quotemeta( (join ('/', split ('::', $f_class) ) ) . '.pm' );
 222   if ($err =~ /Can't locate ${fn} in \@INC/ ) {
 223     return 0;
 224   }
 225   elsif ($class->can('throw_exception')) {
 226     $class->throw_exception($err);
 227   }
 228   else {
 229     die $err;
 230   }
 231 }
 232
 233 =head1 AUTHOR
 234
 235 Matt S. Trout and the DBIx::Class team
 236
 237 Pulled out into seperate module by Ash Berlin C<< <ash@cpan.org> >>
 238
 239 =head1 LICENSE
 240
 241 You may distribute this code under the same terms as Perl itself.
 242
 243 =cut
 244
 245 1;