devscripts/test/test_debi

#!/usr/bin/perl

# Copyright 2019 Simon McVittie
# SPDX-License-Identifier: GPL-2.0-or-later
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <https://www.gnu.org/licenses/>.

=head1 NAME

test_debi - unit test for debi

=head1 WARNING

This test requires root privileges, and installs and removes packages.
Please run it in an expendable environment, such as via
one of the B<autopkgtest-virt-*> autopkgtest backends.

=head1 DESCRIPTION

This test verifies that debi's B<--with-depends> and B<--upgrade> interact
as expected.

=cut

use autodie;
use strict;
use warnings;

use Cwd qw(getcwd);
use Digest::MD5;
use Digest::SHA;
use Dpkg::IPC;
use File::Temp qw(tempdir);
use Test::More;

use Dpkg::Control;

my $srcdir     = getcwd;
my $top_srcdir = getcwd . '/..';
my @debi       = ("$top_srcdir/scripts/debi.pl", '--no-conf');
my $tmp;

if (defined $ARGV[0] && $ARGV[0] eq '--installed') {
    $debi[0] = 'debi';
}
else {
    $ENV{PATH} = "$top_srcdir/scripts:$ENV{PATH}";
}

sub run {
    my ($argv, %opts) = @_;
    diag("Running: @{$argv}") if $opts{verbose};
    delete $opts{verbose};
    spawn(
        %opts,
        exec       => $argv,
        wait_child => 1,
        nocheck    => 1,
    );
    my $ret = $? == 0;
    if ($ret) {
        diag("=> success");
    } else {
        diag("=> exit status $?");
    }
    return $ret;
}

sub verbose_run {
    my ($argv, %opts) = @_;
    return run($argv, verbose => 1, %opts);
}

sub capture {
    my $output;
    my $argv = shift;
    ok(verbose_run($argv, to_string => \$output), "@{$argv}");
    chomp $output;
    return $output;
}

sub make_deb {
    my ($name, $version, $depends) = @_;
    mkdir "$tmp/deb"        unless -d "$tmp/deb";
    mkdir "$tmp/deb/DEBIAN" unless -d "$tmp/deb/DEBIAN";
    open my $fh, '>', "$tmp/deb/DEBIAN/control";
    print {$fh} "Package: devscripts-test-$name\n";
    print {$fh} "Section: misc\n";
    print {$fh} "Priority: optional\n";
    print {$fh} "Maintainer: nobody\n";
    print {$fh} "Version: $version\n";
    print {$fh} "Architecture: all\n";
    print {$fh} "Depends: $depends\n";
    print {$fh} "Description: a package\n";
    close $fh;

    my $deb = "$tmp/devscripts-test-${name}_${version}_all.deb";
    if (!run(['dpkg-deb', '-b', "$tmp/deb", $deb])) {
        BAIL_OUT("Failed to build $name package from $tmp/deb");
    }
}

sub make_changes {
    my @packages = @_;
    my $changes  = "$tmp/foo.changes";
    my $ctrl     = Dpkg::Control->new(type => CTRL_FILE_CHANGES);
    $ctrl->{Format}             = '1.8';
    $ctrl->{Source}             = 'devscripts-test';
    $ctrl->{Files}              = "\n";
    $ctrl->{'Checksums-Sha256'} = "\n";

    foreach my $name (@packages) {
        my $md5    = Digest::MD5->new;
        my $sha256 = Digest::SHA->new(256);
        open my $fh, '<', "$tmp/devscripts-test-${name}_1_all.deb";
        binmode $fh;
        $md5->addfile($fh);
        seek $fh, 0, 0;
        $sha256->addfile(*$fh);
        close $fh;
        my $hash = $md5->hexdigest;
        my @stat = stat "$tmp/devscripts-test-${name}_1_all.deb";
        my $size = $stat[7];

        $ctrl->{Files}
          .= "$hash $size misc optional devscripts-test-${name}_1_all.deb\n";
        $hash = $sha256->hexdigest;
        $ctrl->{'Checksums-Sha256'}
          .= "$hash $size devscripts-test-${name}_1_all.deb\n";
    }
    diag $ctrl;
    $ctrl->save($changes);
}

sub purge_packages {
    ok(
        verbose_run([
                'dpkg',
                '--purge',
                'devscripts-test-already-installed',
                'devscripts-test-dependency',
                'devscripts-test-gains-dependency',
                'devscripts-test-gains-local-dependency',
                'devscripts-test-not-installed',
                'hello',
            ]));
}

sub version_of {
    my $output;
    my $ignored;
    run(['dpkg-query', '-W', '-f', '${Version}', shift],
        to_string => \$output, error_to_string => \$ignored);
    chomp $output;
    return $output;
}

sub status_of {
    my $output;
    my $ignored;
    run(['dpkg-query', '-W', '-f', '${Status}', shift],
        to_string => \$output, error_to_string => \$ignored);
    chomp $output;
    return $output;
}

plan skip_all => 'not root' unless $< == 0 && $> == 0;

$tmp = tempdir(CLEANUP => 1);
open my $fh, '>', "$tmp/yes.conf";
print {$fh} qq{Apt::Get::Assume-Yes "true";\n};
print {$fh} qq{Apt::Get::allow-downgrades "true";\n};
close $fh;
$ENV{APT_CONFIG} = "$tmp/yes.conf";

make_deb('already-installed',      '0', 'base-files');
make_deb('already-installed',      '1', 'base-files');
make_deb('already-installed',      '2', 'base-files');
make_deb('not-installed',          '1', 'base-files');
make_deb('gains-local-dependency', '0', 'base-files');
make_deb('gains-local-dependency', '1', 'devscripts-test-dependency');
make_deb('dependency',             '1', 'base-files');
make_deb('gains-dependency',       '0', 'base-files');
make_deb('gains-dependency',       '1', 'hello');

diag('debi foo.changes will upgrade existing packages and install new ones');
purge_packages();
ok(
    verbose_run(
        ['dpkg', '-i', "$tmp/devscripts-test-already-installed_0_all.deb",]));
make_changes(qw(already-installed not-installed));
ok(verbose_run([@debi, "$tmp/foo.changes",]), 'plain debi succeeds');
is(version_of('devscripts-test-already-installed'),
    '1', 'already installed package was upgraded');
is(version_of('devscripts-test-not-installed'),
    '1', 'not-installed package was installed (regressed in #932640)');

diag('debi foo.changes will also downgrade existing packages');
purge_packages();
ok(
    verbose_run(
        ['dpkg', '-i', "$tmp/devscripts-test-already-installed_2_all.deb",]));
make_changes(qw(already-installed));
ok(verbose_run([@debi, "$tmp/foo.changes",]), 'plain debi succeeds');
is(version_of('devscripts-test-already-installed'),
    '1', 'already installed package was downgraded');

diag('debi --upgrade will upgrade/downgrade existing packages, only');
purge_packages();
ok(
    verbose_run(
        ['dpkg', '-i', "$tmp/devscripts-test-already-installed_2_all.deb",]));
make_changes(qw(already-installed not-installed));
ok(verbose_run([@debi, '--upgrade', "$tmp/foo.changes",]),
    'debi --upgrade succeeds');
is(version_of('devscripts-test-already-installed'),
    '1', 'already installed package was downgraded');
is(version_of('devscripts-test-not-installed'),
    '', 'not-installed package was not installed');

diag('it is OK if debi --upgrade does nothing');
purge_packages();
make_changes(qw(not-installed));
ok(verbose_run([@debi, '--upgrade', "$tmp/foo.changes",]),
    'debi --upgrade succeeds');
is(version_of('devscripts-test-not-installed'),
    '', 'not-installed package was not installed');

diag('debi without --with-depends does not try to satisfy dependencies');
purge_packages();
ok(
    verbose_run(
        ['dpkg', '-i', "$tmp/devscripts-test-gains-dependency_0_all.deb",]));
make_changes(qw(gains-dependency));
ok(!verbose_run([@debi, "$tmp/foo.changes",]),
    'debi without --with-depends does not install dependency');
# It's OK for it to either be unpacked but fail to configure, or be
# left at version 0.
isnt(
    version_of('devscripts-test-gains-dependency') . "::"
      . status_of('devscripts-test-gains-dependency'),
    '1::install ok installed',
    'package with a dependency was not installed'
);
is(version_of('hello'), '', 'third party dependency was not installed');

diag('debi --with-depends does satisfy dependencies');
purge_packages();
make_changes(qw(gains-dependency));
ok(verbose_run([@debi, '--with-depends', "$tmp/foo.changes",]),
    'debi --with-depends succeeds');
is(version_of('devscripts-test-gains-dependency'),
    '1', 'package with a dependency was installed');
isnt(version_of('hello'), '', 'third party dependency was installed');

diag('debi --upgrade --with-depends does satisfy new dependencies');
purge_packages();
ok(
    verbose_run(
        ['dpkg', '-i', "$tmp/devscripts-test-gains-dependency_0_all.deb",]));
make_changes(qw(gains-dependency not-installed));
ok(verbose_run([@debi, '--with-depends', '--upgrade', "$tmp/foo.changes",]),
    'debi --with-depends --upgrade succeeds');
is(version_of('devscripts-test-gains-dependency'),
    '1', 'package with a dependency was installed');
isnt(version_of('hello'), '', 'third party dependency was installed');
is(version_of('devscripts-test-not-installed'),
    '', 'not-installed package was not installed (#932963)');

purge_packages();
verbose_run(
    ['dpkg', '-i', "$tmp/devscripts-test-gains-local-dependency_0_all.deb",]);
make_changes(qw(dependency gains-local-dependency));
ok(
    verbose_run([@debi, '--upgrade', '--with-depends', "$tmp/foo.changes",]),
    'corner case from #932963: debi --upgrade --with-depends can cope with '
      . 'a new dependency on a binary from the same source'
);
is(version_of('devscripts-test-gains-local-dependency'),
    '1', 'the package we wanted to upgrade is upgraded');
is(version_of('devscripts-test-dependency'),
    '1',
    'the new dependency of the package we wanted to upgrade is installed');

purge_packages();
done_testing;