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