File Coverage

blib/lib/Module/Case.pm

Criterion	Covered	Total	%
statement	15	34	44.1
branch	1	10	10.0
condition	1	9	11.1
subroutine	5	6	83.3
pod			n/a
total	22	59	37.2

package Module::Case;

use 5.008000;
use strict;
use warnings;

our $VERSION = '0.05';

our $sensitive_modules;

our $inc_sniffer = sub {
    # Special @INC hook to only load modules with exact case match.
    # This is particularly useful on case insensitive file systems.
    my ($self, $filename) = @_;
    # Ignore full path filenames
    return undef if $filename =~ m{^/};
    # Calculate package name
    my $pkg = $filename;
    $pkg =~ s/\.pm$//;
    $pkg =~ s{/+}{::}g;
    # For efficiency purposes, skip module unless it's one of the special case sensitive packages flagged to load case-sensitively.
    $sensitive_modules->{$pkg} or $sensitive_modules->{'-all'} or return undef;

    # Skip the directories before me since they've already been tried (and obviously didn't find the file already or else we wouldn't be here)
    my $keep = 0;
    # Only look through regular directories after myself but ignore CODEREFs (such as myself) in @INC
    my @scan = grep { $keep = 1 if $_ eq $self; !ref $_ and $keep; } @INC;
    # Now that @scan has been built, it's safe to disable $pkg from the list.
    __PACKAGE__->unimport($pkg);
    my $found_wrong_case = 0;
    foreach my $dir (@scan) {
        if (open my $fh, "<", "$dir/$filename") {
            # Found a matching file but might not have same case.
            # Take a quick peek to make sure the case matches too.
            my $contents = join "", <$fh>;
            if ($contents =~ /^\s*package\s+\Q$pkg\E\s*;/m) {
                 # Smells like a pretty good package.
                 # Case matches case exactly.
                 # So rewind and return this handle.
                 seek($fh, 0, 0);
                 $INC{$filename} = "$dir/$filename";
                 return $fh;
            }
            else {
                # Looks like we found a file with the wrong case, so ignore it.
                $found_wrong_case ||= "$dir/$filename";
            }
            close $fh;
        }
    }
    # Couldn't find the real module
    if ($found_wrong_case) {
        # Found a case insensitive match but did NOT find an exact match.
        # We need to block Perl from continuing along @INC or else it will find the bad guy too.
        my $error = "Can't locate $filename in \@INC except for decoy with wrong case [$found_wrong_case]";
        if (eval { require Carp }) {
            Carp::croak($error);
        }
        else {
            die "$error\n";
        }
    }
    # Can't even find a case-insensitive match, so just continue and let Perl try
    return undef;
};

our $sub_import = sub {
    my $class = shift;
    foreach (@_) {
        # Autovivify $sensitive_modules only as needed
        $sensitive_modules->{$_} = $_;
    }
    if (keys %$sensitive_modules and !grep { $_ eq $inc_sniffer } @INC) {
        # Only inject the sniffer if there is something to smell
        # and only if it's not already in the list.
        # Search for the first regular directory (non-ref string) @INC setting
        # Then jam the $inc_sniffer right before it.
        for (my $i = 0; $i < @INC; $i++) {
            if (!ref $INC[$i]) {
                splice @INC, $i, 0, $inc_sniffer;
                last;
            }
        }
    }
    return;
};

my $sub_unimport = sub {
    my $class = shift;
    my $wiped = undef;
    if ($sensitive_modules) {
        if (@_) {
            # Pick out module(s) to quit case sniffing for
            foreach (@_) {
                $wiped ||= delete $sensitive_modules->{$_};
            }
        }
        else {
            # No specific module provided, so just wipe everything
            ($wiped) = keys %$sensitive_modules;
            $sensitive_modules = undef;
        }
    }
    if (!$sensitive_modules or !keys %$sensitive_modules) {
        # No module case-sensitive modules left, so restore @INC without the sniffer
        $sensitive_modules = undef;
        @INC = grep { $_ ne $inc_sniffer } @INC;
    }
    # Return one of the modules that got wiped, if any.
    return $wiped;
};

{
    no strict 'refs';
    my $should_pkg = __PACKAGE__;
    defined &{"$should_pkg\::import"}   or *{"$should_pkg\::import"}   = $sub_import;
    defined &{"$should_pkg\::unimport"} or *{"$should_pkg\::unimport"} = $sub_unimport;
    (my $should_file = "$should_pkg.pm") =~ s%::%/%g;
    if (__FILE__ !~ m{\b\Q$should_file\E$} and
        __FILE__ =~ m{\b(\Q$should_file\E)$}i) {
        my $fake_file = $1;
        my $fake_pkg = $fake_file;
        $fake_pkg =~ s%/+%::%g;
        $fake_pkg =~ s/\.pm//;
        #if (eval { require Carp }) { Carp::carp("Case-ignorant filesystem exploited by loading module wrongly: $fake_pkg"); }
        defined &{"$fake_pkg\::import"}   or *{"$fake_pkg\::import"}   = *{"$should_pkg\::import"};
        defined &{"$fake_pkg\::unimport"} or *{"$fake_pkg\::unimport"} = *{"$should_pkg\::unimport"};
        # Fake Preload Real Module
        $INC{$should_file} = __FILE__;
    }
}

1;

__END__