File Coverage

blib/lib/Module/EnforceLoad.pm

Criterion	Covered	Total	%
statement	79	81	97.5
branch	15	18	83.3
condition	2	3	66.6
subroutine	15	15	100.0
pod	0	3	0.0
total	111	120	92.5

package Module::EnforceLoad;

my %LOAD_TREE;
my %RELOADS;
our $DEBUG = 0;

BEGIN {
    our $MOD;

    sub file_to_mod {
        my $mod = shift;
        $mod =~ s{/}{::}g;
        $mod =~ s{.pm$}{};
        return $mod;
    }

    *CORE::GLOBAL::require = sub {
        my $file = shift;
        return CORE::require($file) if $file =~ m/^[0-9\.]+$/;

        my $mod = file_to_mod($file);

        my @stack = ($mod);
        while (my $m = shift @stack) {
            $RELOADS{$m}++;
            push @stack => keys %{$LOAD_TREE{$m}};
        }
        $LOAD_TREE{$mod} = {};
        $LOAD_TREE{$MOD}->{$mod} = $LOAD_TREE{$mod} if $MOD;
        local $MOD = $mod;
        CORE::require($file);
    };
}

use strict;
use warnings;
use Sub::Util qw/prototype set_prototype subname/;
use List::Util qw/first/;

our $VERSION = '0.000002';

our $ENFORCE = 0;
my %OVERRIDE = (
    __PACKAGE__,      1,
    'UNIVERSAL'    => 1,
    'CORE'         => 1,
    'CORE::GLOBAL' => 1,
);

sub import {
    my $class = shift;
    my $caller = caller;
    no strict 'refs';
    *{"$caller\::enforce"} = \&enforce;
}

sub enforce {
    %RELOADS = ();
    replace_subs(scalar caller);
    replace_subs(file_to_mod($_)) for keys %LOAD_TREE;
    $ENFORCE = 1;
}

sub replace_subs {
    my $mod = shift;
    return if $OVERRIDE{$mod}++;
    local $ENFORCE = 0;

    my $stash;
    {
        no strict 'refs';
        $stash = \%{"$mod\::"};
    }

    for my $i (keys %$stash) {
        my $orig = $mod->can($i) or next;
        next if $OVERRIDE{"$mod\::$i"}++;
        next if $i eq 'DESTROY';
        next if $i eq 'can';
        my $prototype = prototype($orig);

        my $new = sub {
            if ($ENFORCE && !$RELOADS{$mod}) {
                $ENFORCE = 0;

                my ($pkg, $file, $line) = caller;
                my $name = subname($orig);
                my $pname = $name =~ s/::[^:]+$//r;
                my $str = "Tried to use $name without loading $pname at $file line $line.\n";
                my $l = 1;
                while (my @caller = caller($l++)) {
                    $str .= "    $caller[3] called at $caller[1] line $caller[2].\n";
                }

                if ($DEBUG) {
                    require Data::Dumper;
                    $str .= Data::Dumper::Dumper({
                        LOAD_TREE => \%LOAD_TREE,
                        RELOADS   => \%RELOADS,
                    });
                }

                die $str;
            }
            goto &$orig;
        };
        set_prototype($prototype, $new);

        no strict 'refs';
        no warnings 'redefine';
        *{"$mod\::$i"} = $new;
    }
}

1;

__END__