File Coverage

blib/lib/Acme/require/case.pm
Criterion Covered Total %
statement 70 85 82.3
branch 18 28 64.2
condition n/a
subroutine 13 13 100.0
pod 0 1 0.0
total 101 127 79.5


line stmt bran cond sub pod time code
1 1     1   41877 use 5.008001;
  1         4  
2 1     1   4 use strict;
  1         2  
  1         15  
3 1     1   4 use warnings;
  1         2  
  1         30  
4 1     1   4 no warnings qw/once redefine/;
  1         2  
  1         52  
5              
6             package Acme::require::case;
7             # ABSTRACT: Make Perl's require case-sensitive
8              
9             our $VERSION = '0.013';
10              
11 1     1   5 use B;
  1         2  
  1         30  
12 1     1   4 use Carp qw/croak/;
  1         2  
  1         30  
13 1     1   604 use Path::Tiny qw/path/;
  1         8449  
  1         46  
14 1     1   7 use Scalar::Util qw/isvstring/;
  1         2  
  1         33  
15 1     1   398 use Sub::Uplevel qw/uplevel/;
  1         859  
  1         7  
16 1     1   432 use version 0.87;
  1         1435  
  1         7  
17              
18             sub require_casely {
19 45     45 0 11731 my ($filename) = @_;
20 45         67 my ( $realfilename, $result, $valid, $actual );
21              
22             # Are we checking a version number?
23 45 100       91 if ( _looks_like_version($filename) ) {
24 1         3 my $v = eval { version->new($filename) };
  1         70  
25 1 50       5 croak $@ if $@;
26 1 50       9 croak "Perl @{[$v->normal]} required--this is only $^V, stopped"
  0         0  
27             if $v > $^V;
28 1         7 return 1;
29             }
30              
31             # Is it already loaded?
32 44 100       113 if ( exists $INC{$filename} ) {
33 40 50       134 return 1 if $INC{$filename};
34 0         0 croak "Compilation failed in require";
35             }
36              
37             # Absolute or relative?
38 4 50       16 if ( path($filename)->is_absolute ) {
39 0         0 ( $valid, $actual ) = ( 1, $filename );
40 0         0 $realfilename = path($filename);
41             }
42             else {
43 4         339 foreach my $inc (@INC) {
44 36 50       558 if ( ref $inc ) {
45 0         0 croak "Acme::require::case does not support refs in \@INC";
46             }
47             else {
48 36         73 my $prefix = path($inc);
49 36         865 $realfilename = $prefix->child($filename);
50 36 100       1056 if ( $realfilename->is_file ) {
51 3         92 ( $valid, $actual ) = _case_correct( $prefix, $filename );
52 3         616 last;
53             }
54             }
55             }
56 4 100       92 croak "Can't locate $filename in \@INC (\@INC contains @INC)"
57             unless $actual;
58             }
59              
60             # Valid case or invalid?
61 3 50       12 if ($valid) {
62 3         7 $INC{$filename} = $realfilename;
63             # uplevel so calling package looks right
64 3         11 my $caller = caller(0);
65             # deletes $realfilename from %INC after loading it since that's
66             # just a proxy for $filename, which is already set above
67 3         81 my $code = qq{
68             package $caller; sub { local %^H; my \$r = do \$_[0]; delete \$INC{\$_[0]}; \$r }
69             };
70 3         278 my $packaged_do = eval $code; ## no critic
71 3         14 $result = uplevel( 2, $packaged_do, $realfilename );
72             }
73             else {
74 0         0 croak "$filename has incorrect case (maybe you want $actual instead?)";
75             }
76              
77             # Loaded correctly or not?
78 3 50       14 if ($@) {
    50          
79 0         0 $INC{$filename} = undef;
80 0         0 croak $@;
81             }
82             elsif ( !$result ) {
83 0         0 delete $INC{$filename};
84 0         0 croak "$filename did not return a true value";
85             }
86             else {
87 3         7 $! = 0;
88 3         25 return $result;
89             }
90             }
91              
92             sub _case_correct {
93 3     3   7 my ( $prefix, $filename ) = @_;
94 3         8 my $search = path($prefix); # clone
95 3         65 my @parts = split qr{/}, $filename;
96 3         9 my $valid = 1;
97 3         11 while ( my $p = shift @parts ) {
98 6 50       157 if ( grep { $p eq $_ } map { $_->basename } $search->children ) {
  303         625  
  303         13266  
99 6         17 $search = $search->child($p);
100             }
101             else {
102 0         0 $valid = 0;
103 0         0 my ($actual) = grep { lc $p eq lc $_ } map { $_->basename } $search->children;
  0         0  
  0         0  
104 0         0 $search = $search->child($actual);
105             }
106             }
107 3         137 return ( $valid, $search->relative($prefix) );
108             }
109              
110             sub _looks_like_version {
111 45     45   67 my ($v) = @_;
112 45 50       133 return 1 if isvstring($v);
113 45         262 return B::svref_2object( \$v )->FLAGS & ( B::SVp_NOK | B::SVp_IOK );
114             }
115              
116             *CORE::GLOBAL::require = \&require_casely;
117              
118             1;
119              
120              
121             # vim: ts=4 sts=4 sw=4 et:
122              
123             __END__