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'; ...@@ -25,10 +25,14 @@ use parent 'Class::Accessor::Fast';
use Carp qw(croak); use Carp qw(croak);
use File::Basename qw(dirname); use File::Basename qw(dirname);
use IO::Async::Loop;
use Lintian::Deb822Parser qw(read_dpkg_control_utf8); use Lintian::Deb822Parser qw(read_dpkg_control_utf8);
use Lintian::Util qw(internal_error); use Lintian::Util qw(internal_error);
use constant EMPTY => q{};
use constant SPACE => q{ };
=head1 NAME =head1 NAME
Lintian::CollScript - Collection script handle Lintian::CollScript - Collection script handle
...@@ -222,14 +226,44 @@ sub is_type { ...@@ -222,14 +226,44 @@ sub is_type {
sub collect { sub collect {
my ($self, $pkg_name, $task, $dir) = @_; my ($self, $pkg_name, $task, $dir) = @_;
my $iface = $self->interface; 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; my $cs_path = $self->script_path;
require $cs_path; require $cs_path;
my $collector = $self->{'collector_class'}; my $collector = $self->{'collector_class'};
$collector->can('collect')->($pkg_name, $task, $dir); $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 { } else {
internal_error("Unknown interface: $iface"); internal_error("Unknown interface: $iface");
} }
......
...@@ -376,37 +376,15 @@ sub process_tasks { ...@@ -376,37 +376,15 @@ sub process_tasks {
my $pkg_name = $lpkg->pkg_name; my $pkg_name = $lpkg->pkg_name;
my $pkg_type = $lpkg->pkg_type; my $pkg_type = $lpkg->pkg_type;
my $base = $lpkg->base_dir; my $base = $lpkg->base_dir;
if ($cs->interface ne 'exec'
and not $ENV{'LINTIAN_COVERAGE'}) { # exec changes the process name; otherwise do it manually
# With a non-exec interface, let L::CollScript $0 = "$coll (processing $procid)"
# handle it. Note that when run under unless $cs->interface eq 'exec';
# Devel::Cover, we never take this route.
# This is because Devel::Cover relies on the eval {$cs->collect($pkg_name, $pkg_type, $base);};
# END handler so all collections would get if ($@) {
# (more or less) 0 coverage in this case. print STDERR $@;
$ret = 2;
# 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: $!";
} }
POSIX::_exit($ret); 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