Commit bd043a28 authored by Felix Lechner's avatar Felix Lechner

Delegate interface processing for collection scripts to existing facility in CollScript.

Unpacker processed the collection interface independently even though
that facility already existed inside CollScript. Uses the existing
facility instead, except it replaces the call to system with
equivalent IO::Async code instead.

Gbp-Dch: ignore
parent 040a7a40
......@@ -25,10 +25,14 @@ use parent 'Class::Accessor::Fast';
use Carp qw(croak);
use File::Basename qw(dirname);
use IO::Async::Loop;
use Lintian::Deb822Parser qw(read_dpkg_control_utf8);
use Lintian::Util qw(internal_error);
use constant EMPTY => q{};
use constant SPACE => q{ };
=head1 NAME
Lintian::CollScript - Collection script handle
......@@ -222,14 +226,44 @@ sub is_type {
sub collect {
my ($self, $pkg_name, $task, $dir) = @_;
my $iface = $self->interface;
if ($iface eq 'perl-coll') {
# always use 'exec' under Devel::Cover, which relies on the END handler
# otherwise coverage would always be zero (or close to it)
if ($iface eq 'exec' || exists $ENV{'LINTIAN_COVERAGE'}) {
if (exists $ENV{'LINTIAN_COVERAGE'}) {
$ENV{'PERL5OPT'} //= EMPTY;
$ENV{'PERL5OPT'} .= SPACE . $ENV{'LINTIAN_COVERAGE'};
}
my $loop = IO::Async::Loop->new;
my $future = $loop->new_future;
my @command = ($self->script_path, $pkg_name, $task, $dir);
$loop->run_child(
command => [@command],
on_finish => sub {
my ($pid, $exitcode, $stdout, $stderr) = @_;
my $status = ($exitcode >> 8);
if ($status) {
my $message= "Command @command exited with status $status";
$message .= ": $stderr" if length $stderr;
$future->fail($message);
return;
}
$future->done($stdout);
});
# will raise an exception in case of failure
$future->get;
} elsif ($iface eq 'perl-coll') {
my $cs_path = $self->script_path;
require $cs_path;
my $collector = $self->{'collector_class'};
$collector->can('collect')->($pkg_name, $task, $dir);
} elsif ($iface eq 'exec') {
system($self->script_path, $pkg_name, $task, $dir) == 0
or die 'Collection ' . $self->name . " for $pkg_name failed\n";
} else {
internal_error("Unknown interface: $iface");
}
......
......@@ -376,37 +376,15 @@ sub process_tasks {
my $pkg_name = $lpkg->pkg_name;
my $pkg_type = $lpkg->pkg_type;
my $base = $lpkg->base_dir;
if ($cs->interface ne 'exec'
and not $ENV{'LINTIAN_COVERAGE'}) {
# With a non-exec interface, let L::CollScript
# handle it. Note that when run under
# Devel::Cover, we never take this route.
# This is because Devel::Cover relies on the
# END handler so all collections would get
# (more or less) 0 coverage in this case.
# For platforms that support it, try to change
# our name to the collection being run (like
# how it would be with the exec case below).
# For platforms that do not support, the child
# process will just keep its name as
# "lintian".
$0 = "${coll} (processing ${procid})";
eval {$cs->collect($pkg_name, $pkg_type, $base);};
if ($@) {
print STDERR $@;
$ret = 2;
}
} else {
if (my $coverage_arg = $ENV{'LINTIAN_COVERAGE'}) {
my $p5opt = $ENV{'PERL5OPT'} // q{};
$p5opt .= ' ' if $p5opt ne q{};
$ENV{'PERL5OPT'} = "${p5opt} ${coverage_arg}";
}
# Its fork + exec - invoke that directly (saves a fork)
exec $cs->script_path, $pkg_name, $pkg_type, $base
or die "exec $cs->script_path: $!";
# exec changes the process name; otherwise do it manually
$0 = "$coll (processing $procid)"
unless $cs->interface eq 'exec';
eval {$cs->collect($pkg_name, $pkg_type, $base);};
if ($@) {
print STDERR $@;
$ret = 2;
}
POSIX::_exit($ret);
},
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment