File Coverage

lib/Module/New/Loader.pm
Criterion Covered Total %
statement 39 41 95.1
branch 6 8 75.0
condition n/a
subroutine 9 9 100.0
pod 4 4 100.0
total 58 62 93.5


line stmt bran cond sub pod time code
1             package Module::New::Loader;
2            
3 7     7   15216 use strict;
  7         8  
  7         181  
4 7     7   25 use warnings;
  7         9  
  7         132  
5 7     7   32 use Carp;
  7         7  
  7         331  
6 7     7   2057 use String::CamelCase qw( camelize );
  7         2129  
  7         1995  
7            
8             sub new {
9 33     33 1 3925 my ($class, @base) = @_;
10 33 50       56 unless ( grep { $_ eq 'Module::New' } @base ) {
  30         112  
11 33         47 push @base, 'Module::New';
12             }
13 33         128 bless { _base => \@base }, $class;
14             }
15            
16 146     146   131 sub _base { @{ shift->{_base} } }
  146         362  
17            
18             sub load_class {
19 146     146 1 202 my ($self, @parts) = @_;
20            
21 206         782 @parts = map { tr/a-zA-Z0-9_://cd; camelize( $_ ); }
  206         397  
  264         387  
22 146         188 grep { defined } @parts;
23            
24 146         1512 foreach my $base ( $self->_base ) {
25 266         449 my $package = join '::', $base, @parts;
26            
27 266 100       502 if ( $self->{_reload} ) {
28 118         414 (my $file = $package) =~ s|::|/|g;
29 118         245 delete $INC{"$file.pm"};
30             }
31            
32 266         233 local $@;
33 266         13805 eval "require $package; $package->import;";
34 266 100       1129 if ( $@ ) {
35 120 50       559 next if $@ =~ /^Can't locate/;
36 0         0 croak $@;
37             }
38 146         772 return $package;
39             }
40 0         0 croak "Can't locate ".(join '::', @parts);
41             }
42            
43             sub reload_class {
44 59     59 1 59 my $self = shift;
45            
46 59         116 local $self->{_reload} = 1;
47            
48 59         110 $self->load_class(@_);
49             }
50            
51             sub load {
52 59     59 1 108 my ($self, $type, $name, @args) = @_;
53            
54 59         122 $self->load_class($type, $name)->new(@args);
55             }
56            
57             1;
58            
59             __END__