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 an 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 # see Makefile.PL for discussion on why we load both Class::C3 and MRO::Compat
  44 use Class::C3 ();
  45 use MRO::Compat;
  46 use Class::Inspector;
  47 use Carp;
  48
  49 our $VERSION = 1.0005;
  50
  51 =head2 load_components( @comps )
  52
  53 Loads the given components into the current module. If a module begins with a
  54 C<+> character, it is taken to be a fully qualified class name, otherwise
  55 C<< $class->component_base_class >> is prepended to it.
  56
  57 Calling this will call C<Class::C3::reinitialize>.
  58
  59 =cut
  60
  61 sub load_components {
  62   my $class = shift;
  63   my @comp = map {
  64               /^\+(.*)$/
  65                 ? $1
  66                 : join ('::', $class->component_base_class, $_)
  67              }
  68              grep { $_ !~ /^#/ } @_;
  69   $class->_load_components(@comp);
  70 }
  71
  72 =head2 load_own_components( @comps )
  73
  74 Similar to L<load_components>, but assumes every class is C<"$class::$comp">.
  75
  76 =cut
  77
  78 sub load_own_components {
  79   my $class = shift;
  80   my @comp = map { "${class}::$_" } grep { $_ !~ /^#/ } @_;
  81   $class->_load_components(@comp);
  82 }
  83
  84 sub _load_components {
  85   my ($class, @comp) = @_;
  86   foreach my $comp (@comp) {
  87     $class->ensure_class_loaded($comp);
  88   }
  89   $class->inject_base($class => @comp);
  90   Class::C3::reinitialize();
  91 }
  92
  93 =head2 load_optional_components
  94
  95 As L<load_components>, but will silently ignore any components that cannot be
  96 found.
  97
  98 =cut
  99
 100 sub load_optional_components {
 101   my $class = shift;
 102   my @comp = grep { $class->load_optional_class( $_ ) }
 103              map {
 104               /^\+(.*)$/
 105                 ? $1
 106                 : join ('::', $class->component_base_class, $_)
 107              }
 108              grep { $_ !~ /^#/ } @_;
 109
 110   $class->_load_components( @comp ) if scalar @comp;
 111 }
 112
 113 =head2 ensure_class_loaded
 114
 115 Given a class name, tests to see if it is already loaded or otherwise
 116 defined. If it is not yet loaded, the package is require'd, and an exception
 117 is thrown if the class is still not loaded.
 118
 119  BUG: For some reason, packages with syntax errors are added to %INC on
 120       require
 121 =cut
 122
 123 #
 124 # TODO: handle ->has_many('rel', 'Class'...) instead of
 125 #              ->has_many('rel', 'Some::Schema::Class'...)
 126 #
 127 sub ensure_class_loaded {
 128   my ($class, $f_class) = @_;
 129
 130   croak "Invalid class name $f_class"
 131       if ($f_class=~m/(?:\b:\b|\:{3,})/);
 132   return if Class::Inspector->loaded($f_class);
 133   my $file = $f_class . '.pm';
 134   $file =~ s{::}{/}g;
 135   eval { CORE::require($file) }; # require needs a bareword or filename
 136   if ($@) {
 137     if ($class->can('throw_exception')) {
 138       $class->throw_exception($@);
 139     } else {
 140       croak $@;
 141     }
 142   }
 143 }
 144
 145 =head2 ensure_class_found
 146
 147 Returns true if the specified class is installed or already loaded, false
 148 otherwise
 149
 150 =cut
 151
 152 sub ensure_class_found {
 153   my ($class, $f_class) = @_;
 154   return Class::Inspector->loaded($f_class) ||
 155          Class::Inspector->installed($f_class);
 156 }
 157
 158
 159 =head2 inject_base
 160
 161 Does the actual magic of adjusting @ISA on the target module.
 162
 163 =cut
 164
 165 sub inject_base {
 166   my ($class, $target, @to_inject) = @_;
 167   {
 168     no strict 'refs';
 169     foreach my $to (reverse @to_inject) {
 170       unshift ( @{"${target}::ISA"}, $to )
 171         unless ($target eq $to || $target->isa($to));
 172     }
 173   }
 174
 175   mro::set_mro($target, 'c3');
 176 }
 177
 178 =head2 load_optional_class
 179
 180 Returns a true value if the specified class is installed and loaded
 181 successfully, throws an exception if the class is found but not loaded
 182 successfully, and false if the class is not installed
 183
 184 =cut
 185
 186 sub load_optional_class {
 187   my ($class, $f_class) = @_;
 188   eval { $class->ensure_class_loaded($f_class) };
 189   my $err = $@;   # so we don't lose it
 190   if (! $err) {
 191     return 1;
 192   }
 193   else {
 194     my $fn = (join ('/', split ('::', $f_class) ) ) . '.pm';
 195     if ($err =~ /Can't locate ${fn} in \@INC/ ) {
 196       return 0;
 197     }
 198     else {
 199       die $err;
 200     }
 201   }
 202 }
 203
 204 =head1 AUTHOR
 205
 206 Matt S. Trout and the DBIx::Class team
 207
 208 Pulled out into seperate module by Ash Berlin C<< <ash@cpan.org> >>
 209
 210 =head1 LICENSE
 211
 212 You may distribute this code under the same terms as Perl itself.
 213
 214 =cut
 215
 216 1;