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 MRO::Compat;
  45 use Class::C3 ();
  46 use Class::Inspector;
  47 use Carp;
  48
  49 our $VERSION = 1.0003;
  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 $base = $class->component_base_class;
  64   my @comp = map { /^\+(.*)$/ ? $1 : "${base}::$_" } grep { $_ !~ /^#/ } @_;
  65   $class->_load_components(@comp);
  66 }
  67
  68 =head2 load_own_components( @comps )
  69
  70 Simialr to L<load_components>, but assumes every class is C<"$class::$comp">.
  71
  72 =cut
  73
  74 sub load_own_components {
  75   my $class = shift;
  76   my @comp = map { "${class}::$_" } grep { $_ !~ /^#/ } @_;
  77   $class->_load_components(@comp);
  78 }
  79
  80 sub _load_components {
  81   my ($class, @comp) = @_;
  82   foreach my $comp (@comp) {
  83     $class->ensure_class_loaded($comp);
  84   }
  85   $class->inject_base($class => @comp);
  86   Class::C3::reinitialize();
  87 }
  88
  89 =head2 load_optional_components
  90
  91 As L<load_components>, but will silently ignore any components that cannot be
  92 found.
  93
  94 =cut
  95
  96 sub load_optional_components {
  97   my $class = shift;
  98   my $base = $class->component_base_class;
  99   my @comp = grep { $class->load_optional_class( $_ ) }
 100              map { /^\+(.*)$/ ? $1 : "${base}::$_" }
 101              grep { $_ !~ /^#/ } @_;
 102
 103   $class->_load_components( @comp ) if scalar @comp;
 104 }
 105
 106 =head2 ensure_class_loaded
 107
 108 Given a class name, tests to see if it is already loaded or otherwise
 109 defined. If it is not yet loaded, the package is require'd, and an exception
 110 is thrown if the class is still not loaded.
 111
 112  BUG: For some reason, packages with syntax errors are added to %INC on
 113       require
 114 =cut
 115
 116 #
 117 # TODO: handle ->has_many('rel', 'Class'...) instead of
 118 #              ->has_many('rel', 'Some::Schema::Class'...)
 119 #
 120 sub ensure_class_loaded {
 121   my ($class, $f_class) = @_;
 122
 123   croak "Invalid class name $f_class"
 124       if ($f_class=~m/(?:\b:\b|\:{3,})/);
 125   return if Class::Inspector->loaded($f_class);
 126   my $file = $f_class . '.pm';
 127   $file =~ s{::}{/}g;
 128   eval { CORE::require($file) }; # require needs a bareword or filename
 129   if ($@) {
 130     if ($class->can('throw_exception')) {
 131       $class->throw_exception($@);
 132     } else {
 133       croak $@;
 134     }
 135   }
 136 }
 137
 138 =head2 ensure_class_found
 139
 140 Returns true if the specified class is installed or already loaded, false
 141 otherwise
 142
 143 =cut
 144
 145 sub ensure_class_found {
 146   my ($class, $f_class) = @_;
 147   return Class::Inspector->loaded($f_class) ||
 148          Class::Inspector->installed($f_class);
 149 }
 150
 151
 152 =head2 inject_base
 153
 154 Does the actual magic of adjusting @ISA on the target module.
 155
 156 =cut
 157
 158 sub inject_base {
 159   my ($class, $target, @to_inject) = @_;
 160   {
 161     no strict 'refs';
 162     foreach my $to (reverse @to_inject) {
 163       unshift ( @{"${target}::ISA"}, $to )
 164         unless ($target eq $to || $target->isa($to));
 165     }
 166   }
 167
 168   mro::set_mro($target, 'c3');
 169 }
 170
 171 =head1 AUTHOR
 172
 173 Matt S. Trout and the DBIx::Class team
 174
 175 Pulled out into seperate module by Ash Berlin C<< <ash@cpan.org> >>
 176
 177 =head1 LICENSE
 178
 179 You may distribute this code under the same terms as Perl itself.
 180
 181 =cut
 182
 183 1;