File Coverage

blib/lib/Doit/Deb.pm

Criterion	Covered	Total	%
statement	82	181	45.3
branch	26	106	24.5
condition	3	33	9.0
subroutine	9	13	69.2
pod	5	7	71.4
total	125	340	36.7

# -*- perl -*-

#
# Author: Slaven Rezic
#
# Copyright (C) 2017,2018,2020,2025,2026 Slaven Rezic. All rights reserved.
# This package is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# WWW:  https://github.com/eserte/Doit
#

package Doit::Deb; # Convention: all commands here should be prefixed with 'deb_'

use strict;
use warnings;
our $VERSION = '0.031';

use Doit::Log;
use Doit::Util 'get_sudo_cmd', 'get_os_release';

sub new { bless {}, shift }
sub functions { qw(deb_install_packages deb_missing_packages deb_install_key deb_add_repository deb_upgradeable_packages) }

sub deb_install_packages {
    my($self, @packages) = @_;
    my @missing_packages = $self->deb_missing_packages(@packages); # XXX cmd vs. info???
    if (@missing_packages) {
	$self->system(get_sudo_cmd(), 'apt-get', '-y', 'install', @missing_packages);
    }
    @missing_packages;
}


sub deb_missing_packages {
    my($self, @packages) = @_;

    my @missing_packages;

    if (@packages) {
	require IPC::Open3;
	require Symbol;

	my %seen_packages;
	my %required_version;
	for my $package (@packages) {
	    if (ref $package eq 'ARRAY') {
		my($package_name, $package_version) = @$package;
		$required_version{$package_name} = $package_version;
		$package = $package_name;
	    }
	}
	my @cmd = ('dpkg-query', '-W', '-f=${Package}\t${Status}\t${Version}\n', @packages);
	my $err = Symbol::gensym();
	my $fh;
	my $pid = IPC::Open3::open3(undef, $fh, $err, @cmd)
	    or error "Error running '@cmd': $!";
	while(<$fh>) {
	    chomp;
	    if (m{^([^\t]+)\t([^\t]+)\t([^\t]*)$}) {
		if ($2 ne 'install ok installed') {
		    push @missing_packages, $1;
		}
		if ($required_version{$1} && $required_version{$1} ne $3) {
		    push @missing_packages, $1;
		}
		$seen_packages{$1} = 1;
	    } else {
		warning "cannot parse '$_', ignore line...";
	    }
	}
	waitpid $pid, 0;
	for my $package (@packages) {
	    if (!$seen_packages{$package}) {
		push @missing_packages, $package;
	    }
	}
    }
    @missing_packages;
}

sub deb_upgradeable_packages {
    my($self) = @_;

    my @upgradeable_packages;

    require IPC::Open3;
    require Symbol;

    my @cmd = ('apt-get', '-s', 'upgrade');
    my $err = Symbol::gensym();
    my $fh;
    my $pid = IPC::Open3::open3(undef, $fh, $err, @cmd)
        or error "Error running '@cmd': $!";
    while(<$fh>) {
        chomp;
        # Parse lines like: Inst package_name [old_version] (new_version ...)
        if (m{^Inst\s+(\S+)}) {
            push @upgradeable_packages, $1;
        }
    }
    waitpid $pid, 0;
    my $exit_code = $? >> 8;
    if ($exit_code != 0) {
        error "Command '@cmd' failed with exit code $exit_code";
    }

    @upgradeable_packages;
}

sub deb_install_key {
    my($self, %opts) = @_;
    my $url       = delete $opts{url};
    my $keyserver = delete $opts{keyserver};
    my $key       = delete $opts{key};
    my $file      = delete $opts{file};
    error "Unhandled options: " . join(" ", %opts) if %opts;

    if (!$url) {
	if (!$keyserver) {
	    error "keyserver is missing";
	}
	if (!$key) {
	    error "key is missing";
	}
    } else {
	if ($keyserver) {
	    error "Don't define both url and keyserver";
	}
    }

    my $is_modern = _missing_apt_key();

    if ($is_modern) {
	if (!defined $file) {
	    error "For Debian >= 13 and Ubuntu >= 24.04 the 'file' option must be set (to something like /etc/apt/keyrings/...gpg)";
	}
    }

    my $found_key;
    if ($key) {
	$key =~ s{\s}{}g; # convenience: strip spaces from key ('apt-key finger' returns them with spaces)
	local $ENV{LC_ALL} = 'C';
	# XXX If run with $sudo, then this will emit warnings in the form
	#   gpg: WARNING: unsafe ownership on configuration file `$HOME/.gnupg/gpg.conf'
	# Annoying, but harmless. Could be workarounded by specifying
	# '--homedir=/root/.gpg', but this would create gpg files under ~root. Similar
	# if using something like
	#   local $ENV{HOME} = (getpwuid($<))[7];
	# Probably better would be to work with privilege escalation and run
	# this command as normal user (to be implemented).
	#
	# Older Debian (jessie and older?) have only /etc/apt/trusted.gpg,
	# newer ones (stretch and newer?) have /etc/apt/trusted.gpg.d/*.gpg
    SEARCH_FOR_KEY: {
	    my @gpg_files;
	    if (defined $file) {
		@gpg_files = $file;
	    } else {
		require File::Glob;
		@gpg_files = ('/etc/apt/trusted.gpg', File::Glob::bsd_glob('/etc/apt/trusted.gpg.d/*.gpg'));
	    }
	    for my $keyfile (@gpg_files) {
		if (-r $keyfile) {
		    my @cmd = ('gpg', '--keyring', $keyfile, '--list-keys', '--fingerprint', '--with-colons');
		    open my $fh, '-|', @cmd
			or error "Running '@cmd' failed: $!";
		    while(<$fh>) {
			if (m{^fpr:::::::::\Q$key\E:$}) {
			    $found_key = 1;
			    last SEARCH_FOR_KEY;
			}
		    }
		    close $fh
			or error "Running '@cmd' failed: $!";
		}
	    }
	}
    }

    my $changed = 0;

    if (!$found_key) {
	if ($keyserver) {
	    $self->system(get_sudo_cmd(), 'apt-key', 'adv', '--keyserver', $keyserver, '--recv-keys', $key);
	} elsif ($url) {
	    my @fetch_cmd;
	    if ($self->which('curl')) {
		@fetch_cmd = ('curl', '-fsSL', $url);
	    } else {
		@fetch_cmd = ('wget', '-O-', $url); # other alternative would be lwp-request
	    }
	    my @add_cmd;
	    if ($is_modern) {
		@add_cmd = (get_sudo_cmd(), 'gpg', '--dearmor', '-o', $file);
	    } else {
		@add_cmd = (get_sudo_cmd(), 'apt-key', 'add', '-');
	    }
	    if ($self->is_dry_run) {
		info "Fetch key using '@fetch_cmd' and add using '@add_cmd' (dry-run)";
	    } else {
		open my $ifh, '-|', @fetch_cmd
		    or error "Failed to start '@fetch_cmd': $!";
		open my $ofh, '|-', @add_cmd
		    or error "Failed to start '@add_cmd': $!";
		local $/ = \1024;
		while(<$ifh>) {
		    print $ofh $_;
		}
		close $ofh
		    or error "Running '@add_cmd' failed: $!";
		close $ifh
		    or error "Running '@fetch_cmd' failed: $!";
	    }
	} else {
	    error "Shouldn't happen (either url or keyserver has to be specified)";
	}
	$changed = 1;
    }
    $changed;
}

sub _missing_apt_key {
    my $os_release = get_os_release();
    if (($os_release->{ID} eq 'debian' && (($os_release->{VERSION_ID}||0) >= 13 || $os_release->{VERSION_CODENAME} =~ m{^(trixie|sid)$})) ||
        ($os_release->{ID} eq 'ubuntu' && $os_release->{VERSION_ID} >= 24.04)) {
        return 1;
    } else {
	return 0;
    }
}

sub deb_add_repository {
    my($self, $name, $contents, %opts) = @_;
    my $update = delete $opts{update};
    error "Unhandled options: " . join(" ", %opts) if %opts;

    my $os_release   = get_os_release();
    my $debian_ver   = $os_release->{ID} eq 'debian' ? $os_release->{VERSION_ID} : undef;
    my $ubuntu_ver   = $os_release->{ID} eq 'ubuntu' ? $os_release->{VERSION_ID} : undef;

    my $sources_file = "/etc/apt/sources.list.d/$name.sources";
    my $list_file    = "/etc/apt/sources.list.d/$name.list";

    my ($target_file, $final_contents);

    if (($debian_ver && $debian_ver >= 13) ||
        ($ubuntu_ver && $ubuntu_ver >= 24.04)) {
        # Use new deb822 format directly
        $target_file    = $sources_file;
        $final_contents = $contents;

        # If a legacy .list file exists, remove it
        if (-e $list_file) {
            $self->unlink($list_file);
        }
    } else {
        # Convert to old-style .list format
        $target_file    = $list_file;
        $final_contents = _convert_sources_to_list($contents);

        # If a .sources file exists, remove it
        if (-e $sources_file) {
            $self->unlink($sources_file);
        }
    }

    my $changed = $self->write_binary($target_file, $final_contents);
    if ($changed && $update) {
	$self->system('apt-get', 'update', '-qq');
    }
    $changed;
}

sub _convert_sources_to_list {
    my($contents) = @_;

    my %stanza;
    my $current_key;

    for my $line (split /\n/, $contents) {
        next if $line =~ /^\s*#/ || $line =~ /^\s*$/;

        if ($line =~ /^(\S+):\s*(.*)$/) {
            $current_key = lc $1;
            push @{ $stanza{$current_key} }, split /\s+/, $2 if $2 ne '';
        }
        elsif ($line =~ /^\s+(\S.*)$/ && $current_key) {
            push @{ $stanza{$current_key} }, split /\s+/, $1;
        }
    }

    my @lines;
    for my $type (@{ $stanza{types} || ['deb'] }) {
        for my $uri (@{ $stanza{uris} || [] }) {
            for my $suite (@{ $stanza{suites} || [] }) {
                my $components = join " ", @{ $stanza{components} || [] };
                my @opts;

                if ($stanza{architectures}) {
                    push @opts, "arch=" . join(",", @{ $stanza{architectures} });
                }
                if ($stanza{'signed-by'}) {
                    push @opts, map { "signed-by=$_"} @{ $stanza{'signed-by'} };
                }

                my $options = @opts ? "[" . join(" ", @opts) . "] " : "";
                push @lines, "$type ${options}$uri $suite $components";
            }
        }
    }

    return join("\n", @lines) . "\n";
}

1;

__END__