File Coverage

blib/lib/Class/Load.pm
Criterion Covered Total %
statement 95 95 100.0
branch 32 34 94.1
condition 15 21 71.4
subroutine 20 20 100.0
pod 4 4 100.0
total 166 174 95.4


line stmt bran cond sub pod time code
1 13     13   5012 use strict;
  13         19  
  13         318  
2 13     13   43 use warnings;
  13         17  
  13         494  
3             package Class::Load; # git description: v0.23-8-ge399b9c
4             # ABSTRACT: A working (require "Class::Name") and more
5             # KEYWORDS: class module load require use runtime
6              
7             our $VERSION = '0.24';
8              
9 13     13   44 use base 'Exporter';
  13         104  
  13         1123  
10 13     13   4635 use Data::OptList ();
  13         85661  
  13         250  
11 13     13   72 use Module::Implementation 0.04;
  13         163  
  13         246  
12 13     13   39 use Module::Runtime 0.012 ();
  13         118  
  13         178  
13 13     13   38 use Try::Tiny;
  13         12  
  13         10667  
14              
15             {
16             my $loader = Module::Implementation::build_loader_sub(
17             implementations => [ 'XS', 'PP' ],
18             symbols => ['is_class_loaded'],
19             );
20              
21             $loader->();
22             }
23              
24             our @EXPORT_OK = qw/load_class load_optional_class try_load_class is_class_loaded load_first_existing_class/;
25             our %EXPORT_TAGS = (
26             all => \@EXPORT_OK,
27             );
28              
29             our $ERROR;
30              
31             sub load_class {
32 21     21 1 4446 my $class = shift;
33 21         25 my $options = shift;
34              
35 21         39 my ($res, $e) = try_load_class($class, $options);
36 15 100       155 return $class if $res;
37              
38 8         16 _croak($e);
39             }
40              
41             sub load_first_existing_class {
42 14 50   14 1 4115 my $classes = Data::OptList::mkopt(\@_)
43             or return;
44              
45 14         353 foreach my $class (@{$classes}) {
  14         19  
46 29         169 Module::Runtime::check_module_name($class->[0]);
47             }
48              
49 13         86 for my $class (@{$classes}) {
  13         14  
50 25         21 my ($name, $options) = @{$class};
  25         31  
51              
52             # We need to be careful not to pass an undef $options to this sub,
53             # since the XS version will blow up if that happens.
54 25 100       72 return $name if is_class_loaded($name, ($options ? $options : ()));
    100          
55              
56 22         50 my ($res, $e) = try_load_class($name, $options);
57              
58 22 100       102 return $name if $res;
59              
60 21         40 my $file = Module::Runtime::module_notional_filename($name);
61              
62 21 100       504 next if $e =~ /^Can't locate \Q$file\E in \@INC/;
63             next
64             if $options
65             && defined $options->{-version}
66 11 100 66     62 && $e =~ _version_fail_re($name, $options->{-version});
      100        
67              
68 2         9 _croak("Couldn't load class ($name) because: $e");
69             }
70              
71             my @list = map {
72             $_->[0]
73             . ( $_->[1] && defined $_->[1]{-version}
74 13 100 66     57 ? " (version >= $_->[1]{-version})"
75             : q{} )
76 7         9 } @{$classes};
  7         14  
77              
78 7         17 my $err
79             .= q{Can't locate }
80             . _or_list(@list)
81             . " in \@INC (\@INC contains: @INC).";
82 7         13 _croak($err);
83             }
84              
85             sub _version_fail_re {
86 11     11   9 my $name = shift;
87 11         10 my $vers = shift;
88              
89 11         164 return qr/\Q$name\E version \Q$vers\E required--this is only version/;
90             }
91              
92             sub _nonexistent_fail_re {
93 8     8   9 my $name = shift;
94              
95 8         13 my $file = Module::Runtime::module_notional_filename($name);
96 8         249 return qr/Can't locate \Q$file\E in \@INC/;
97             }
98              
99             sub _or_list {
100 7 100   7   25 return $_[0] if @_ == 1;
101              
102 4 100       17 return join ' or ', @_ if @_ ==2;
103              
104 2         3 my $last = pop;
105              
106 2         3 my $list = join ', ', @_;
107 2         5 $list .= ', or ' . $last;
108              
109 2         8 return $list;
110             }
111              
112             sub load_optional_class {
113 15     15 1 3494 my $class = shift;
114 15         13 my $options = shift;
115              
116 15         40 Module::Runtime::check_module_name($class);
117              
118 15         167 my ($res, $e) = try_load_class($class, $options);
119 15 100       104 return 1 if $res;
120              
121             return 0
122             if $options
123             && defined $options->{-version}
124 9 50 66     30 && $e =~ _version_fail_re($class, $options->{-version});
      66        
125              
126 8 100       15 return 0
127             if $e =~ _nonexistent_fail_re($class);
128              
129 6         13 _croak($e);
130             }
131              
132             sub try_load_class {
133 78     78 1 3278 my $class = shift;
134 78         68 my $options = shift;
135              
136 78         152 Module::Runtime::check_module_name($class);
137              
138 72         602 local $@;
139 72         77 undef $ERROR;
140              
141 72 100       220 if (is_class_loaded($class)) {
142             # We need to check this here rather than in is_class_loaded() because
143             # we want to return the error message for a failed version check, but
144             # is_class_loaded just returns true/false.
145 24 100 66     102 return 1 unless $options && defined $options->{-version};
146             return try {
147 13     13   388 $class->VERSION($options->{-version});
148 3         9 1;
149             }
150             catch {
151 10     10   80 _error($_);
152 13         63 };
153             }
154              
155 48         85 my $file = Module::Runtime::module_notional_filename($class);
156             # This says "our diagnostics of the package
157             # say perl's INC status about the file being loaded are
158             # wrong", so we delete it from %INC, so when we call require(),
159             # perl will *actually* try reloading the file.
160             #
161             # If the file is already in %INC, it won't retry,
162             # And on 5.8, it won't fail either!
163             #
164             # The extra benefit of this trick, is it helps even on
165             # 5.10, as instead of dying with "Compilation failed",
166             # it will die with the actual error, and that's a win-win.
167 48         627 delete $INC{$file};
168             return try {
169 48     48   1246 local $SIG{__DIE__} = 'DEFAULT';
170 48 100 66     139 if ($options && defined $options->{-version}) {
171 7         20 Module::Runtime::use_module($class, $options->{-version});
172             }
173             else {
174 41         83 Module::Runtime::require_module($class);
175             }
176 10         4378 1;
177             }
178             catch {
179 38     38   9263 _error($_);
180 48         258 };
181             }
182              
183             sub _error {
184 48     48   67 my $e = shift;
185              
186 48         276 $e =~ s/ at .+?Runtime\.pm line [0-9]+\.$//;
187 48         70 chomp $e;
188              
189 48         47 $ERROR = $e;
190 48 100       127 return 0 unless wantarray;
191 41         177 return 0, $ERROR;
192             }
193              
194             sub _croak {
195 23     23   109 require Carp;
196 23         31 local $Carp::CarpLevel = $Carp::CarpLevel + 2;
197 23         3134 Carp::croak(shift);
198             }
199              
200             1;
201              
202             __END__