File Coverage

blib/lib/Module/Installed.pm

Criterion	Covered	Total	%
statement	51	99	51.5
branch	27	66	40.9
condition			n/a
subroutine	9	10	90.0
pod	2	2	100.0
total	89	177	50.2

package Module::Installed;

our $VERSION = '1.02';

use strict;
use warnings;

use Carp qw(croak);
use Data::Dumper;
use Exporter qw(import);
our @EXPORT_OK = qw(
    includes_installed
    module_installed
);

my $SEPARATOR;

BEGIN {
    if ($^O =~ /^(dos|os2)/i) {
        $SEPARATOR = '\\';
    } elsif ($^O =~ /^MacOS/i) {
        $SEPARATOR = ':';
    } else {
        $SEPARATOR = '/';
    }
}

sub includes_installed {
    my ($file, $cb) = @_;

    my $PPI = $ENV{MI_TEST_PPI} ? $ENV{MI_TEST_PPI} : 'PPI';

    if (! -f $file) {
        croak("includes_installed() requires a valid Perl file as a parameter...");
    }

    if (! module_installed($PPI)) {
        croak("includes_installed() requires PPI, which isn't installed...");
    }

    require PPI;
    PPI->import;

    my $doc = PPI::Document->new($file);
    my $includes = $doc->find('PPI::Statement::Include');

    my %includes;

    for (@$includes) {
        $includes{$_->module} = module_installed($_->module, $cb) ? 1 : 0;
    }

    return \%includes;
}
sub module_installed {
    my ($name, $sub) = @_;

    # convert Foo::Bar -> Foo/Bar.pm
    my $name_pm;
    if ($name =~ /\A\w+(?:::\w+)*\z/) {
        ($name_pm = "$name.pm") =~ s!::!$SEPARATOR!g;
    } else {
        $name_pm = $name;
    }

    my $installed = 0;

    if (exists $INC{$name_pm}) {
        $installed = 1;
    }
    elsif (eval {_module_source($name_pm); 1 } ? 1 : 0) {
        $installed = 1;
    }

    if (defined $sub) {
        if (ref $sub ne 'CODE') {
            croak("Callback parameter to module_installed() must be a code ref")
        }
        $sub->($name, $name_pm, $installed);
    }

    return $installed;
}
sub _get_module_source {
    my $name = shift;

    # convert Foo::Bar -> Foo/Bar.pm
    my $name_pm;
    if ($name =~ /\A\w+(?:::\w+)*\z/) {
        ($name_pm = "$name.pm") =~ s!::!$SEPARATOR!g;
    } else {
        $name_pm = $name;
    }

    return _module_source $name_pm;
}
sub _module_source {
    my $name_pm = shift;

    for my $entry (@INC) {
        next unless defined $entry;
        my $ref = ref($entry);
        my ($is_hook, @hook_res);
        if ($ref eq 'ARRAY') {
            $is_hook++;
            @hook_res = $entry->[0]->($entry, $name_pm);
        } elsif (UNIVERSAL::can($entry, 'INC')) {
            $is_hook++;
            @hook_res = $entry->INC($name_pm);
        } elsif ($ref eq 'CODE') {
            $is_hook++;
            @hook_res = $entry->($entry, $name_pm);
        } else {
            my $path = "$entry$SEPARATOR$name_pm";
            if (-f $path) {
                open my($fh), "<", $path
                    or die "Can't locate $name_pm: $path: $!";
                local $/;
                return wantarray ? (scalar <$fh>, $path) : scalar <$fh>;
            }
        }

        if ($is_hook) {
            next unless @hook_res;
            my $prepend_ref; $prepend_ref = shift @hook_res if ref($hook_res[0]) eq 'SCALAR';
            my $fh         ; $fh          = shift @hook_res if ref($hook_res[0]) eq 'GLOB';
            my $code       ; $code        = shift @hook_res if ref($hook_res[0]) eq 'CODE';
            my $code_state ; $code_state  = shift @hook_res if @hook_res;
            if ($fh) {
                my $src = "";
                local $_;
                while (!eof($fh)) {
                    $_ = <$fh>;
                    if ($code) {
                        $code->($code, $code_state);
                    }
                    $src .= $_;
                }
                $src = $$prepend_ref . $src if $prepend_ref;
                return wantarray ? ($src, $entry) : $src;
            } elsif ($code) {
                my $src = "";
                local $_;
                while ($code->($code, $code_state)) {
                    $src .= $_;
                }
                $src = $$prepend_ref . $src if $prepend_ref;
                return wantarray ? ($src, $entry) : $src;
            }
        }
    }

    die "Can't locate $name_pm in \@INC (\@INC contains: ".join(" ", @INC).")";
}
1;

# ABSTRACT: Check if modules are installed

__END__