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   19272 use strict;
  7         10  
  7         206  
4 7     7   22 use warnings;
  7         11  
  7         127  
5 7     7   34 use Carp;
  7         7  
  7         372  
6 7     7   2596 use String::CamelCase qw( camelize );
  7         2577  
  7         2449  
7              
8             sub new {
9 33     33 1 2938 my ($class, @base) = @_;
10 33 50       68 unless ( grep { $_ eq 'Module::New' } @base ) {
  30         132  
11 33         67 push @base, 'Module::New';
12             }
13 33         153 bless { _base => \@base }, $class;
14             }
15              
16 160     160   188 sub _base { @{ shift->{_base} } }
  160         691  
17              
18             sub load_class {
19 160     160 1 378 my ($self, @parts) = @_;
20              
21 220         1252 @parts = map { tr/a-zA-Z0-9_://cd; camelize( $_ ); }
  220         649  
  292         627  
22 160         409 grep { defined } @parts;
23              
24 160         2204 foreach my $base ( $self->_base ) {
25 294         679 my $package = join '::', $base, @parts;
26              
27 294 100       863 if ( $self->{_reload} ) {
28 118         559 (my $file = $package) =~ s|::|/|g;
29 118         387 delete $INC{"$file.pm"};
30             }
31              
32 294         286 local $@;
33 294         20680 eval "require $package; $package->import;";
34 294 100       2476 if ( $@ ) {
35 134 50       935 next if $@ =~ /^Can't locate/;
36 0         0 croak $@;
37             }
38 160         1147 return $package;
39             }
40 0         0 croak "Can't locate ".(join '::', @parts);
41             }
42              
43             sub reload_class {
44 59     59 1 75 my $self = shift;
45              
46 59         162 local $self->{_reload} = 1;
47              
48 59         215 $self->load_class(@_);
49             }
50              
51             sub load {
52 73     73 1 160 my ($self, $type, $name, @args) = @_;
53              
54 73         187 $self->load_class($type, $name)->new(@args);
55             }
56              
57             1;
58              
59             __END__