File Coverage

blib/lib/Perinci/Sub/DepChecker.pm

Criterion	Covered	Total	%
statement	124	142	87.3
branch	89	108	82.4
condition	10	11	90.9
subroutine	19	25	76.0
pod	3	16	18.7
total	245	302	81.1

package Perinci::Sub::DepChecker;

use 5.010001;
use strict;
use warnings;
use experimental 'smartmatch';
use Log::ger;

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(
                       check_deps
                       dep_satisfy_rel
                       list_mentioned_dep_clauses
               );

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2022-04-22'; # DATE
our $DIST = 'Perinci-Sub-DepChecker'; # DIST
our $VERSION = '0.125'; # VERSION

my $pa;

sub check_deps {
    my ($val) = @_;
    #say "D:check: ", dump($val);
    for my $dname (keys %$val) {
        my $dval = $val->{$dname};
        unless (defined &{"checkdep_$dname"}) {
            # give a chance to load from a module first
            eval { my $mod_pm = "Perinci/Sub/Dep/$dname.pm"; require $mod_pm };
            return "Unknown dependency type: $dname"
                unless defined &{"checkdep_$dname"};
        }
        my $check = \&{"checkdep_$dname"};
        my $res = $check->($dval);
        if ($res) {
            $res = "$dname: $res";
            return $res;
        }
    }
    "";
}

sub checkdep_all {
    my ($val) = @_;
    #say "D:check_all: ", dump($val);
    for (@$val) {
        my $res = check_deps($_);
        return "Some dependencies not met: $res" if $res;
    }
    "";
}

sub checkdep_any {
    my ($val) = @_;
    my $nfail = 0;
    for (@$val) {
        return "" unless check_deps($_);
        $nfail++;
    }
    $nfail ? "None of the dependencies are met" : "";
}

sub checkdep_none {
    my ($val) = @_;
    for (@$val) {
        my $res = check_deps($_);
        return "A dependency is met when it shouldn't: $res" unless $res;
    }
    "";
}

sub checkdep_env {
    my ($cval) = @_;
    $ENV{$cval} ? "" : "Environment variable $cval not set/true";
}

sub checkdep_code {
    my ($cval) = @_;
    $cval->() ? "" : "code doesn't return true value";
}

sub checkdep_prog {
    my ($cval) = @_;

    $cval = ref $cval eq 'HASH' ? $cval : {name=>$cval};
    my $prog_name = $cval->{name} or return "BUG: Program name not specified in dependency";

    if ($prog_name =~ m!/!) {
        return "Program $prog_name not executable" unless (-x $prog_name);
    } else {
        require File::Which;
        return "Program $prog_name not found in PATH (".
            join(":", File::Spec->path).")"
                unless File::Which::which($prog_name);
    }

    if (defined $cval->{min_version}) {
        require IPC::System::Options;
        require Version::Util;

        my (@ver_cmd, $ver_extract);
        my $prog_path = $cval->{path} // $prog_name;
        if ($prog_name eq 'git') {
            @ver_cmd = ($prog_path, "--version");
            $ver_extract = sub { $_[0] =~ /git version (.+)/ ? $1 : undef };
        } elsif ($prog_name eq 'perl') {
            @ver_cmd = ($prog_path, "-v");
            $ver_extract = sub { $_[0] =~ /\(v(.+?)\)/ ? $1 : undef };
        } else {
            return "ERR: Cannot check minimum version for program '$prog_name'";
        }

        my $ver = IPC::System::Options::readpipe({log=>1, shell=>0}, @ver_cmd);
        my ($exit_code, $signal, $core_dump) = ($? < 0 ? $? : $? >> 8, $? & 127, $? & 128);
        return "ERR: Cannot check version with '".join(" ", @ver_cmd)."': exit_code=$exit_code"
            if $exit_code;
        ($ver) = $ver_extract->($ver) or return "ERR: Cannot extract version from response '$ver'";
        return "Program '$prog_name' version ($ver) is less than required ($cval->{min_version})"
            if Version::Util::version_lt($ver, $cval->{min_version});
    }

    "";
}

sub riap_client {
    return $pa if $pa;
    require Perinci::Access;
    $pa = Perinci::Access->new;
    $pa;
}

sub checkdep_pkg {
    my ($cval) = @_;
    my $res = riap_client->request(info => $cval);
    $res->[0] == 200 or return "Can't perform 'info' Riap request on '$cval': ".
        "$res->[0] $res->[1]";
    $res->[2]{type} eq 'package' or return "$cval is not a Riap package";
    "";
}

sub checkdep_func {
    my ($cval) = @_;
    my $res = riap_client->request(info => $cval);
    $res->[0] == 200 or return "Can't perform 'info' Riap request on '$cval': ".
        "$res->[0] $res->[1]";
    $res->[2]{type} eq 'function' or return "$cval is not a Riap function";
    "";
}

# for backward-compatibility
sub checkdep_exec { checkdep_prog(@_) }

# we check this dep by checking arguments, so we'll let something like
# Perinci::Sub::Wrapper to do it
sub checkdep_tmp_dir { "" }

# we check this dep by checking arguments, so we'll let something like
# Perinci::Sub::Wrapper to do it
sub checkdep_trash_dir { "" }

# we check this dep by checking arguments, so we'll let something like
# Perinci::Sub::Wrapper to do it
sub checkdep_undo_trash_dir { "" }

sub _all_elems_is {
    my ($ary, $el) = @_;
    (grep {$_ eq $el} @$ary) && !(grep {$_ ne $el} @$ary);
}

sub _all_nonblank_elems_is {
    my ($ary, $el) = @_;
    (grep {$_ eq $el} @$ary) && !(grep {$_ && $_ ne $el} @$ary);
}

sub dep_satisfy_rel {
    my ($wanted, $deps) = @_;
    #$log->tracef("=> dep_satisfy_rel(%s, %s)", $wanted, $deps);

    my $res;
    for my $dname (keys %$deps) {
        my $dval = $deps->{$dname};

        if ($dname eq 'all') {
            my @r = map { dep_satisfy_rel($wanted, $_) } @$dval;
            #$log->tracef("all: %s", \@r);
            next unless @r;
            return "impossible" if "impossible" ~~ @r;
            return "impossible" if "must" ~~ @r && "must not" ~~ @r;
            return "must"       if "must" ~~ @r;
            return "must not"   if "must not" ~~ @r;
            return "might"      if _all_nonblank_elems_is(\@r, "might");
        } elsif ($dname eq 'any') {
            my @r = map { dep_satisfy_rel($wanted, $_) } @$dval;
            #$log->tracef("any: %s", \@r);
            next unless @r;
            return "impossible" if "impossible" ~~ @r;
            return "must"       if _all_elems_is(\@r, "must");
            return "must not"   if _all_elems_is(\@r, "must not");
            next                if _all_elems_is(\@r, "");
            return "might";
        } elsif ($dname eq 'none') {
            my @r = map { dep_satisfy_rel($wanted, $_) } @$dval;
            #$log->tracef("none: %s", \@r);
            next unless @r;
            return "impossible" if "impossible" ~~ @r;
            return "impossible" if "must" ~~ @r && "must not" ~~ @r;
            return "must not"   if "must" ~~ @r;
            return "must"       if "must not" ~~ @r;
            return "might"      if _all_nonblank_elems_is(\@r, "might");
        } else {
            return "must" if $dname eq $wanted;
        }
    }
    "";
}

sub list_mentioned_dep_clauses {
    my ($deps, $res) = @_;
    $res //= [];
    for my $dname (keys %$deps) {
        my $dval = $deps->{$dname};
        push @$res, $dname unless $dname ~~ @$res;
        if ($dname =~ /\A(?:all|any|none)\z/) {
            list_mentioned_dep_clauses($_, $res) for @$dval;
        }
    }
    $res;
}

1;
# ABSTRACT: Check dependencies from 'deps' property

__END__