File Coverage

blib/lib/Module/XSOrPP.pm

Criterion	Covered	Total	%
statement	64	85	75.2
branch	28	60	46.6
condition	3	6	50.0
subroutine	9	9	100.0
pod	3	3	100.0
total	107	163	65.6

package Module::XSOrPP;

our $DATE = '2015-05-22'; # DATE
our $VERSION = '0.09'; # VERSION

use 5.010001;
use strict;
use warnings;

use Dist::Util qw(packlist_for);
use Module::Path::More qw(module_path);

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(
                       is_xs
                       is_pp
                       xs_or_pp
               );

our @XS_OR_PP_MODULES = qw(
                              Params::Util
                              List::MoreUtils
);

our @XS_MODULES = qw(
                        Scalar::Util
                );

our @PP_MODULES = qw(
                );

sub xs_or_pp {
    use experimental 'smartmatch';

    my ($mod, $opts) = @_;
    die "Please specify module\n" unless $mod;

    if ($mod =~ m!/!) {
        $mod =~ s!/!::!g;
        $mod =~ s/\.pm$//;
    }

    $opts //= {};
    $opts->{warn}  //= 0;
    my $warn = $opts->{warn};
    $opts->{debug} //= 0;
    my $debug = $opts->{debug};

    if ($mod ~~ @XS_OR_PP_MODULES) {
        warn "$mod is xs_or_pp (from list)\n" if $debug;
        return "xs_or_pp";
    }

    if ($mod ~~ @XS_MODULES) {
        warn "$mod is xs (from list)\n" if $debug;
        return "xs";
    }

    if ($mod ~~ @PP_MODULES) {
        warn "$mod is pp (from list)\n" if $debug;
        return "pp";
    }

    my $path = packlist_for($mod);
    {
        last unless $path;
        my $fh;
        unless (open $fh, '<', $path) {
            warn "Can't open .packlist $path: $!\n" if $warn;
            last;
        }
        while (my $line = <$fh>) {
            chomp $line;
            if ($line =~ /\.(bs|so|[Dd][Ll][Ll])\z/) {
                warn "$mod is XS because the .packlist contains .{bs,so,dll} files\n" if $debug;
                return "xs";
            }
        }
        warn "$mod is PP because the .packlist doesn't contain any .{bs,so,dll} files\n" if $debug;
        return "pp";
    }

    $path = module_path(module=>$mod);
    {
        last unless $path;
        local $/;
        my $fh;
        unless (open $fh, '<', $path) {
            warn "Can't open module file $path: $!" if $warn;
            last;
        }
        while (my $content = <$fh>) {
            if ($content =~ m!^\s*(use|require) \s+ (DynaLoader|XSLoader)\b!mx) {
                warn "$mod is XS because the source contains 'use {DynaLoader,XSLoader}' statement\n" if $debug;
                return "xs";
            }
        }
        warn "$mod is PP because the source code doesn't contain any 'use {DynaLoader,XSLoader}' statement\n" if $debug;
        return "pp";
    }

    {
        my $mod = $mod;
        unless ($mod =~ /\.pm\z/) { $mod =~ s!::!/!g; $mod .= ".pm" }

        if ($mod =~ m!/XS\.pm\z|/[^/]+_(xs|XS)\.pm\z!) {
            warn "$mod is probably XS because its name contains XS" if $debug;
            return "xs";
        } elsif ($mod =~ m!/PP\.pm\z|/[^/]+_(pp|PP)\.pm\z!) {
            warn "$mod is probably PP because its name contains PP" if $debug;
            return "pp";
        }
    }

    warn "Can't determine whether $mod is XS: all methods tried\n" if $warn;
    undef;
}

sub is_xs {
    my ($mod, $opts) = @_;
    my $res = xs_or_pp($mod, $opts);
    return undef unless defined($res);
    $res eq 'xs' || $res eq 'xs_or_pp';
}

sub is_pp {
    my ($mod, $opts) = @_;
    my $res = xs_or_pp($mod, $opts);
    return undef unless defined($res);
    $res eq 'pp' || $res eq 'xs_or_pp';
}

1;
# ABSTRACT: Determine if an installed module is XS or pure-perl

__END__