File Coverage

blib/lib/CPAN/Plugin/Sysdeps.pm

Criterion	Covered	Total	%
statement	254	409	62.1
branch	151	286	52.8
condition	40	66	60.6
subroutine	31	38	81.5
pod	2	2	100.0
total	478	801	59.6

package CPAN::Plugin::Sysdeps;

use strict;
use warnings;

our $VERSION = '0.71';

use List::Util 'first';

our $TRAVERSE_ONLY; # only for testing

use constant SUPPORTED_NUMERICAL_OPS => ['<','<=','==','>','>='];
use constant SUPPORTED_NUMERICAL_OPS_RX => do {
    my $rx = '^(' . join('|', map { quotemeta } @{SUPPORTED_NUMERICAL_OPS()}) . ')$';
    qr{$rx};
};

sub new {
    my($class, @args) = @_;

    my $installer;
    my $batch = 0;
    my $dryrun = 0;
    my $debug = 0;
    my @additional_mappings;
    my @args_errors;
    my $options;
    for my $arg (@args) {
	if (ref $arg eq 'HASH') {
	    if ($options) {
		die "Cannot handle multiple option hashes";
	    } else {
		$options = $arg;
	    }
	} elsif ($arg =~ m{^(apt-get|aptitude|pkg|pkg_add|yum|dnf|chocolatey|homebrew)$}) { # XXX are there more package installers?
	    $installer = $1;
	} elsif ($arg eq 'batch') {
	    $batch = 1;
	} elsif ($arg eq 'interactive') {
	    $batch = 0;
	} elsif ($arg eq 'dryrun') {
	    $dryrun = 1;
	} elsif ($arg =~ m{^mapping=(.*)$}) {
	    push @additional_mappings, $1;
	} elsif ($arg =~ m{^debug(?:=(\d+))?$}) {
	    $debug = defined $1 ? $1 : 1;
	} else {
	    push @args_errors, $arg;
	}
    }
    if (@args_errors) {
	die 'Unrecognized ' . __PACKAGE__ . ' argument' . (@args_errors != 1 ? 's' : '') . ": @args_errors\n";
    }

    if (exists $ENV{CPAN_PLUGIN_SYSDEPS_DEBUG}) {
	$debug = $ENV{CPAN_PLUGIN_SYSDEPS_DEBUG};
    }
    if ($debug) {
	require Data::Dumper; # we'll need it
    }

    my $os                  = $options->{os} || $^O;
    my $osvers              = '';
    my $linuxdistro         = '';
    my $linuxdistroversion  = 0;
    my $linuxdistrocodename = '';
    if ($os eq 'linux') {
	my $linux_info;
	my $get_linux_info = sub {
	    return $linux_info if $linux_info;
	    return $linux_info = _detect_linux_distribution();
	};
	if (defined $options->{linuxdistro}) {
	    $linuxdistro = $options->{linuxdistro};
	} else {
	    $linuxdistro = lc $get_linux_info->()->{linuxdistro};
	}

	if (defined $options->{linuxdistroversion}) {
	    $linuxdistroversion = $options->{linuxdistroversion};
	} else {
	    $linuxdistroversion = $get_linux_info->()->{linuxdistroversion}; # XXX make it a version object? or make sure it's just X.Y?
	}

	if (defined $options->{linuxdistrocodename}) {
	    $linuxdistrocodename = $options->{linuxdistrocodename};
	} else {
	    $linuxdistrocodename = $get_linux_info->()->{linuxdistrocodename};
	}
    } elsif (($os eq 'freebsd') || ($os eq 'openbsd') || ($os eq 'dragonfly')) {
	# Note: don't use $Config{osvers}, as this is just the OS
	# version of the system which built the current perl, not the
	# actually running OS version.
	if (defined $options->{osvers}) {
	    $osvers = $options->{osvers};
	} else {
	    chomp($osvers = `/sbin/sysctl -n kern.osrelease`);
	}
    }

    if (!$installer) {
	if      ($os eq 'freebsd' || $os eq 'dragonfly') {
	    $installer = 'pkg';
	} elsif ($os eq 'gnukfreebsd') {
	    $installer = 'apt-get';
	} elsif ($os eq 'openbsd') {
	    $installer = 'pkg_add';
	} elsif ($os eq 'linux') {
	    if      (__PACKAGE__->_is_linux_debian_like($linuxdistro)) {
		$installer = 'apt-get';
	    } elsif (__PACKAGE__->_is_linux_fedora_like($linuxdistro)) {
                if (_detect_dnf()) {
                    $installer = 'dnf';
		} else {
		    $installer = 'yum';
		}
	    } else {
		die __PACKAGE__ . " has no support for linux distribution $linuxdistro $linuxdistroversion\n";
	    }
	} elsif( $os eq 'MSWin32' ) {
	    $installer = 'chocolatey';
	} elsif ($os eq 'darwin') {
	    $installer = 'homebrew';
	} else {
	    die __PACKAGE__ . " has no support for operating system $os\n";
	}
    }

    my @mapping;
    for my $mapping (@additional_mappings, 'CPAN::Plugin::Sysdeps::Mapping') {
	if (-r $mapping) {
	    open my $fh, '<', $mapping
		or die "Can't load $mapping: $!";
	    local $/;
	    my $buf = <$fh>;
	    push @mapping, eval $buf;
	    die "Error while loading $mapping: $@" if $@;
	} else {
	    eval "require $mapping"; die "Can't load $mapping: $@" if $@;
	    push @mapping, $mapping->mapping;
	}
    }

    my %config =
	(
	 installer           => $installer,
	 batch               => $batch,
	 dryrun              => $dryrun,
	 debug               => $debug,
	 os                  => $os,
	 osvers              => $osvers,
	 linuxdistro         => $linuxdistro,
	 linuxdistroversion  => $linuxdistroversion,
	 linuxdistrocodename => $linuxdistrocodename,
	 mapping             => \@mapping,
	);
    my $self = bless \%config, $class;
    if (eval { require Hash::Util; 1 }) {
	Hash::Util::lock_keys($self);
    }
    $self;
}

# CPAN.pm plugin hook method
sub post_get {
    my($self, $dist) = @_;

    my @packages = $self->_map_cpandist($dist);
    if (@packages) {
	my @uninstalled_packages = $self->_filter_uninstalled_packages(@packages);
	if (@uninstalled_packages) {
	    my @cmds = $self->_install_packages_commands(@uninstalled_packages);
	    for my $cmd (@cmds) {
		if ($self->{dryrun}) {
		    warn "DRYRUN: @$cmd\n";
		} else {
		    warn "INFO: run @$cmd...\n";

		    system @$cmd;
		    if ($? != 0) {
		    	die "@$cmd failed, stop installation";
		    }
		}
	    }
	}
    }
}

# Helpers/Internal functions/methods
sub _detect_linux_distribution {
    if (-x '/usr/bin/lsb_release') {
	_detect_linux_distribution_lsb_release();
    } else {
	_detect_linux_distribution_fallback();
    }
}

sub _detect_linux_distribution_lsb_release {
    my %info;
    my @cmd = ('lsb_release', '-irc');
    open my $fh, '-|', @cmd
	or die "Error while running '@cmd': $!";
    while(<$fh>) {
	chomp;
	if      (m{^Distributor ID:\s+(.*)}) {
	    $info{linuxdistro} = $1;
	} elsif (m{^Release:\s+(.*)}) {
	    $info{linuxdistroversion} = $1;
	} elsif (m{^Codename:\s+(.*)}) {
	    $info{linuxdistrocodename} = $1;
	} else {
	    warn "WARNING: unexpected '@cmd' output '$_'";
	}
    }
    close $fh
	or die "Error while running '@cmd': $!";
    \%info;
}

sub _detect_linux_distribution_fallback {
    if (open my $fh, '<', '/etc/redhat-release') {
	my $contents = <$fh>;
	if ($contents =~ m{^(CentOS|Rocky|RedHat|Fedora) (?:Linux )?release (\d+)\S*( \((.*?)\))?}) {
	    return {linuxdistro => $1, linuxdistroversion => $2, linuxdistrocodename => defined $3 ? $3 : ''};
	}
    }
    if (open my $fh, '<', '/etc/issue') {
	chomp(my $line = <$fh>);
	if      ($line =~ m{^Linux Mint (\d+) (\S+)}) {
	    return {linuxdistro => 'LinuxMint', linuxdistroversion => $1, linuxdistrocodename => $2};
	} elsif ($line =~ m{^(Debian) GNU/Linux (\d+)}) {
	    my %info = (linuxdistro => $1, linuxdistroversion => $2);
	    $info{linuxdistrocodename} =
		{
		 6  => 'squeeze',
		 7  => 'wheezy',
		 8  => 'jessie',
		 9  => 'stretch',
		 10 => 'buster',
		 11 => 'bullseye',
		 12 => 'bookworm',
		}->{$info{linuxdistroversion}};
	    return \%info;
	} elsif ($line =~ m{^(Ubuntu) (\d+\.\d+)}) {
	    my %info = (linuxdistro => $1, linuxdistroversion => $2);
	    $info{linuxdistrocodename} =
		{
		 '12.04' => 'precise',
		 '14.04' => 'trusty',
		 '16.04' => 'xenial',
		 '18.04' => 'bionic',
		 '20.04' => 'focal',
		 '22.04' => 'jammy',
		}->{$info{linuxdistroversion}};
	    return \%info;
	} else {
	    warn "WARNING: don't know how to handle '$line'";
	}
    } else {
	warn "WARNING: no /etc/issue available";
    }
    return {};
}

sub _is_linux_debian_like {
    my(undef, $linuxdistro) = @_;
    $linuxdistro =~ m{^(debian|ubuntu|linuxmint)$};
}

sub _is_linux_fedora_like {
    my(undef, $linuxdistro) = @_;
    $linuxdistro =~ m{^(fedora|redhat|centos|rocky)$};
}

sub _is_apt_installer { shift->{installer} =~m{^(apt-get|aptitude)$} }

# Run a process in an elevated window, wait for its exit
sub _win32_run_elevated {
    my($exe, @args) = @_;

    my $args = join " ", map { if(/[ "]/) { s!"!\\"!g; qq{"$_"} } else { $_ }} @args;

    my $ps1 = sprintf q{powershell -NonInteractive -NoProfile -Command "$process = Start-Process '%s' -PassThru -ErrorAction Stop -ArgumentList '%s' -Verb RunAs -Wait; Exit $process.ExitCode"},
        $exe, $args;

    $ps1;
}

sub _debug {
    my $self = shift;
    if ($self->{debug}) {
	print STDERR 'DEBUG: ';
	print STDERR join('', map {
	    if (ref $_) {
		Data::Dumper->new([$_])->Terse(1)->Indent(0)->Dump;
	    } else {
		$_;
	    }
	} @_);
	print STDERR "\n";
    }
}

sub _map_cpandist {
    my($self, $dist) = @_;

    # compat for older CPAN.pm (1.76)
    if (!$dist->can('base_id')) {
	no warnings 'once';
	*CPAN::Distribution::base_id = sub {
	    my $self = shift;
	    my $id = $self->id();
	    my $base_id = File::Basename::basename($id);
	    $base_id =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i;
	    return $base_id;
	};
    }

    # smartmatch for regexp/string/array without ~~, 5.8.x compat!
    # also add support for numerical comparisons
    my $smartmatch = sub ($$) {
	my($left, $right) = @_;
	if (ref $right eq 'Regexp') {
	    return 1 if $left =~ $right;
	} elsif (ref $right eq 'ARRAY') {
	    return 1 if first { $_ eq $left } @$right;
	} elsif (ref $right eq 'HASH') {
	    for my $op (keys %$right) {
		if ($op !~ SUPPORTED_NUMERICAL_OPS_RX) {
		    die "Unsupported operator '$op', only supported: @{SUPPORTED_NUMERICAL_OPS()}";
		}
		my $val = $right->{$op};
		my $code = 'no warnings q(numeric); $left '.$op.' $val';
		my $res = eval $code;
		die "Evaluation of '$code' failed: $@" if $@;
		return 0 if !$res;
	    }
	    return 1;
	} else {
	    return 1 if $left eq $right;
	}
    };

    my $handle_mapping_entry; $handle_mapping_entry = sub {
	my($entry, $level) = @_;
	for(my $map_i=0; $map_i <= $#$entry; $map_i++) {
	    my $key_or_subentry = $entry->[$map_i];
	    if (ref $key_or_subentry eq 'ARRAY') {
		$self->_debug(' ' x $level . ' traverse another tree level');
		my $res = $handle_mapping_entry->($key_or_subentry, $level+1);
		return $res if $res && !$TRAVERSE_ONLY;
	    } elsif (ref $key_or_subentry eq 'CODE') {
		my $res = $key_or_subentry->($self, $dist);
		return $res if $res && !$TRAVERSE_ONLY;
	    } else {
		my $key = $key_or_subentry;
		my $match = $entry->[++$map_i];
		$self->_debug(' ' x $level . " match '$key' against '", $match, "'");
		if ($key eq 'cpandist') {
		    return 0 if !$smartmatch->($dist->base_id, $match) && !$TRAVERSE_ONLY;
		} elsif ($key eq 'cpanmod') {
		    my $found = 0;
		    for my $mod ($dist->containsmods) {
			$self->_debug(' ' x $level . "  found module '$mod' in dist, check now against '", $match, "'");
			if ($smartmatch->($mod, $match)) {
			    $found = 1;
			    last;
			}
		    }
		    return 0 if !$found && !$TRAVERSE_ONLY;
		} elsif ($key eq 'os') {
		    return 0 if !$smartmatch->($self->{os}, $match) && !$TRAVERSE_ONLY;
		} elsif ($key eq 'osvers') {
		    return 0 if !$smartmatch->($self->{osvers}, $match) && !$TRAVERSE_ONLY;
		} elsif ($key eq 'linuxdistro') {
		    if ($match =~ m{^~(debian|fedora)$}) {
			my $method = "_is_linux_$1_like";
			$self->_debug(' ' x $level . " translate $match to $method");
			return 0 if !$self->$method($self->{linuxdistro}) && !$TRAVERSE_ONLY;
		    } elsif ($match =~ m{^~}) {
			die "'like' matches only for debian and fedora";
		    } else {
			return 0 if !$smartmatch->($self->{linuxdistro}, $match) && !$TRAVERSE_ONLY;
		    }
		} elsif ($key eq 'linuxdistroversion') {
		    return 0 if !$smartmatch->($self->{linuxdistroversion}, $match) && !$TRAVERSE_ONLY;
		} elsif ($key eq 'linuxdistrocodename') {
		    return 0 if !$smartmatch->($self->{linuxdistrocodename}, $match) && !$TRAVERSE_ONLY; # XXX should also do a smart codename comparison additionally!
		} elsif ($key eq 'package') {
		    $self->_debug(' ' x $level . " found $match"); # XXX array?
		    return { package => $match };
		} else {
		    die "Invalid key '$key'"; # XXX context/position?
		}
	    }
	}
    };

    for my $entry (@{ $self->{mapping} || [] }) {
	my $res = $handle_mapping_entry->($entry, 0);
	if ($res && !$TRAVERSE_ONLY) {
	    return ref $res->{package} eq 'ARRAY' ? @{ $res->{package} } : $res->{package};
	}
    }

    ();
}

sub _detect_dnf {
    my @cmd = ('dnf', '--help');
    require IPC::Open3;
    require Symbol;
    my $err = Symbol::gensym();
    my $fh;
    return eval {
	    if (my $pid = IPC::Open3::open3(undef, $fh, $err, @cmd)) {
		    waitpid $pid, 0;
		    return $? == 0;
		}
    };
}

sub _find_missing_deb_packages {
    my($self, @packages) = @_;
    return () if !@packages;

    # taken from ~/devel/deb-install.pl
    my %seen_packages;
    my @missing_packages;

    my @cmd = ('dpkg-query', '-W', '-f=${Package} ${Status}\n', @packages);
    require IPC::Open3;
    require Symbol;
    my $err = Symbol::gensym();
    my $fh;
    my $pid = IPC::Open3::open3(undef, $fh, $err, @cmd)
	or die "Error running '@cmd': $!";
    while(<$fh>) {
	chomp;
	if (m{^(\S+) (.*)}) {
	    if ($2 ne 'install ok installed') {
		push @missing_packages, $1;
	    }
	    $seen_packages{$1} = 1;
	} else {
	    warn "ERROR: cannot parse $_, ignore line...\n";
	}
    }
    waitpid $pid, 0;
    for my $package (@packages) {
	if (!$seen_packages{$package}) {
	    push @missing_packages, $package;
	}
    }
    @missing_packages;
}

sub _find_missing_rpm_packages {
    my($self, @packages) = @_;
    return () if !@packages;

    my @missing_packages;

    {
	my %packages = map{($_,1)} @packages;

	local $ENV{LC_ALL} = 'C';
	my @cmd = ('rpm', '-q', @packages);
	open my $fh, '-|', @cmd
	    or die "Error running '@cmd': $!";
	while(<$fh>) {
	    if (m{^package (\S+) is not installed}) {
		my $package = $1;
		if (!exists $packages{$package}) {
		    die "Unexpected: package $package listed as non-installed, but not queries in '@cmd'?!";
		}
		push @missing_packages, $package;
	    }
	}
    }

    @missing_packages;
}

sub _find_missing_freebsd_pkg_packages {
    my($self, @packages) = @_;
    return () if !@packages;

    my @missing_packages;
    for my $package (@packages) {
	my @cmd = ('pkg', 'info', '--exists', $package);
	system @cmd;
	if ($? != 0) {
	    push @missing_packages, $package;
	}
    }

    @missing_packages;
}

sub _find_missing_openbsd_pkg_packages {
    my($self, @packages) = @_;
    return () if !@packages;

    require IPC::Open3;
    require Symbol;

    my @missing_packages;
    for my $package (@packages) {
        my $err = Symbol::gensym();
        my $fh;
        my $package_in_repository;
        eval {
            if (my $pid = IPC::Open3::open3(undef, $fh, $err, 'pkg_info', $package)) {
                waitpid $pid, 0;
                if ($? == 0) {
                    $package_in_repository = 1;
                }
            }
        };
        if ($package_in_repository) {
            my @cmd = ('pkg_info', '-q', '-e', "${package}->=0");
            system @cmd;
            if ($? != 0) {
                push @missing_packages, $package;
            }
        }
    }

    @missing_packages;
}

sub _find_missing_homebrew_packages {
    my($self, @packages) = @_;
    return () if !@packages;

    my @missing_packages;
    for my $package (@packages) {
	my @cmd = ('brew', 'ls', '--versions', $package);
	open my $fh, '-|', @cmd
	    or die "Error running @cmd: $!";
	my $has_package;
	while(<$fh>) {
	    $has_package = 1;
	    last;
	}
	close $fh; # earlier homebrew versions returned always 0,
                   # newer (since Oct 2016) return 1 if the package is
                   # missing
	if (!$has_package) {
	    push @missing_packages, $package;
	}
    }
    @missing_packages;
}

sub _find_missing_chocolatey_packages {
    my($self, @packages) = @_;
    return () if !@packages;

    my %installed_packages = map {
	    /^(.*)\|(.*)$/
		or next;
	    $1 => $2
	} grep {
	    /^(.*)\|(.*)$/
	} `$self->{installer} list --localonly --limit-output`;
    my @missing_packages = grep { ! $installed_packages{ $_ }} @packages;
    @missing_packages;
}

sub _filter_uninstalled_packages {
    my($self, @packages) = @_;
    my $find_missing_packages;
    if      ($self->_is_apt_installer) {
	$find_missing_packages = '_find_missing_deb_packages';
    } elsif (($self->{installer} eq 'yum') || ($self->{installer} eq 'dnf')) {
	$find_missing_packages = '_find_missing_rpm_packages';
    } elsif ($self->{os} eq 'freebsd' || $self->{os} eq 'dragonfly') {
	$find_missing_packages = '_find_missing_freebsd_pkg_packages';
    } elsif ($self->{os} eq 'openbsd') {
	$find_missing_packages = '_find_missing_openbsd_pkg_packages';
    } elsif ($self->{os} eq 'MSWin32') {
	$find_missing_packages = '_find_missing_chocolatey_packages';
    } elsif ($self->{installer} eq 'homebrew') {
	$find_missing_packages = '_find_missing_homebrew_packages';
    } else {
	warn "check for installed packages is NYI for $self->{os}/$self->{linuxdistro}";
    }
    if ($find_missing_packages) {
	my @plain_packages;
	my @missing_packages;
	for my $package_spec (@packages) {
	    if ($package_spec =~ m{\|}) { # has alternatives
		my @single_packages = split /\s*\|\s*/, $package_spec;
		my @missing_in_packages_spec = $self->$find_missing_packages(@single_packages);
		if (@missing_in_packages_spec == @single_packages) {
		    push @missing_packages, $single_packages[0];
		}
	    } else {
		push @plain_packages, $package_spec;
	    }
	}
	push @missing_packages, $self->$find_missing_packages(@plain_packages);
	@packages = @missing_packages;
    }
    @packages;
}

sub _install_packages_commands {
    my($self, @packages) = @_;
    my @pre_cmd;
    my @install_cmd;

    # sudo or not?
    if ($self->{installer} eq 'homebrew') {
	# may run as unprivileged user
    } elsif ($self->{installer} eq 'chocolatey') {
	# no sudo on Windows systems?
    } else {
	if ($< != 0) {
	    push @install_cmd, 'sudo';
	}
    }

    # the installer executable
    if ($self->{installer} eq 'homebrew') {
	push @install_cmd, 'brew';
    } else {
	push @install_cmd, $self->{installer};
    }

    # batch, default or interactive
    if ($self->{batch}) {
	if ($self->_is_apt_installer) {
	    push @install_cmd, '-y';
	} elsif (($self->{installer} eq 'yum') || ($self->{installer} eq 'dnf')) {
	    push @install_cmd, '-y';
	} elsif ($self->{installer} eq 'pkg') { # FreeBSD's pkg
	    # see below
	} elsif ($self->{installer} eq 'homebrew') {
	    # batch by default
	} else {
	    warn "batch=1 NYI for $self->{installer}";
	}
    } else {
	if ($self->_is_apt_installer) {
	    @pre_cmd = ('sh', '-c', 'echo -n "Install package(s) '."@packages".'? (y/N) "; read yn; [ "$yn" = "y" ]');
	} elsif (($self->{installer} eq 'yum') || ($self->{installer} eq 'dnf')) {
	    # interactive by default
	} elsif ($self->{installer} eq 'pkg') { # FreeBSD's pkg
	    # see below
	} elsif ($self->{installer} =~ m{^(chocolatey)$}) {
	    # Nothing to do here
	} elsif ($self->{installer} eq 'homebrew') {
	    # the sh builtin echo does not understand -n -> use printf
	    @pre_cmd = ('sh', '-c', 'printf %s "Install package(s) '."@packages".'? (y/N) "; read yn; [ "$yn" = "y" ]');
	} else {
	    warn "batch=0 NYI for $self->{installer}";
	}
    }

    # special options
    if ($self->{installer} eq 'pkg') { # FreeBSD's pkg
	push @install_cmd, '--option', 'LOCK_RETRIES=86400'; # wait quite long in case there are concurrent pkg runs
    }

    # the installer subcommand
    if ($self->{installer} ne 'pkg_add') {
        push @install_cmd, 'install';
    }

    # post options
    if ($self->{batch} && $self->{installer} eq 'pkg') {
	push @install_cmd, '-y';
    }
    if ($self->{batch} && $self->{installer} eq 'chocolatey') {
	push @install_cmd, '-y';
    }
    if ($self->{batch} && $self->{installer} eq 'pkg_add') {
	push @install_cmd, '-I';
    }

    push @install_cmd, @packages;

    if ($self->{os} eq 'MSWin32') {
        # Wrap the thing in our small powershell program
        @install_cmd = _win32_run_elevated(@install_cmd);
    };

    ((@pre_cmd ? \@pre_cmd : ()), \@install_cmd);
}

1;

__END__