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   18506 use strict;
  7         8  
  7         197  
4 7     7   24 use warnings;
  7         8  
  7         142  
5 7     7   28 use Carp;
  7         11  
  7         407  
6 7     7   2809 use String::CamelCase qw( camelize );
  7         2900  
  7         2253  
7            
8             sub new {
9 33     33 1 2883 my ($class, @base) = @_;
10 33 50       59 unless ( grep { $_ eq 'Module::New' } @base ) {
  30         118  
11 33         52 push @base, 'Module::New';
12             }
13 33         132 bless { _base => \@base }, $class;
14             }
15            
16 146     146   150 sub _base { @{ shift->{_base} } }
  146         364  
17            
18             sub load_class {
19 146     146 1 237 my ($self, @parts) = @_;
20            
21 206         708 @parts = map { tr/a-zA-Z0-9_://cd; camelize( $_ ); }
  206         415  
  264         340  
22 146         191 grep { defined } @parts;
23            
24 146         1443 foreach my $base ( $self->_base ) {
25 266         430 my $package = join '::', $base, @parts;
26            
27 266 100       532 if ( $self->{_reload} ) {
28 118         374 (my $file = $package) =~ s|::|/|g;
29 118         258 delete $INC{"$file.pm"};
30             }
31            
32 266         218 local $@;
33 266         12798 eval "require $package; $package->import;";
34 266 100       1010 if ( $@ ) {
35 120 50       563 next if $@ =~ /^Can't locate/;
36 0         0 croak $@;
37             }
38 146         719 return $package;
39             }
40 0         0 croak "Can't locate ".(join '::', @parts);
41             }
42            
43             sub reload_class {
44 59     59 1 54 my $self = shift;
45            
46 59         114 local $self->{_reload} = 1;
47            
48 59         95 $self->load_class(@_);
49             }
50            
51             sub load {
52 59     59 1 105 my ($self, $type, $name, @args) = @_;
53            
54 59         120 $self->load_class($type, $name)->new(@args);
55             }
56            
57             1;
58            
59             __END__