openkylin
/
lintian
mirror of https://gitee.com/openkylin/lintian.git
9
0
Fork 0
Code Issues Projects Releases Wiki Activity
lintian/commands/reporting-lintian-harness.pm

604 lines
20 KiB
Perl
Raw Blame History

#!/usr/bin/perl -w
# Lintian reporting harness -- Run lintian against an archive mirror
#
# Copyright (C) 2015 Niels Thykier
# Copyright (C) 2018 Chris Lamb <lamby@debian.org>
#
# Based on "reporting/harness", which was:
# Copyright (C) 1998 Christian Schwarz and Richard Braakman
#
# This program is free software. It is distributed 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, you can find it on the World Wide
# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.
package reporting_lintian_harness;
use v5.20;
use warnings;
use utf8;
use autodie;
use constant BACKLOG_PROCESSING_TIME_LIMIT => 4 * 3600; # 4hours
use Fcntl qw(F_GETFD F_SETFD FD_CLOEXEC SEEK_END);
use File::Basename qw(basename);
use File::Temp qw(tempfile);
use Getopt::Long();
use IO::Async::Loop;
use IO::Async::Process;
use List::MoreUtils qw(first_index);
use POSIX qw(strftime);
use Lintian::IO::Async qw(safe_qx);
use Lintian::Reporting::Util
qw(find_backlog load_state_cache save_state_cache);
use constant EMPTY => q{};
use constant COLON => q{:};
use constant NEWLINE => qq{\n};
my (@LINTIAN_CMD, $LINTIAN_VERSION);
my @REQUIRED_PARAMETERS = qw(
lintian-log-dir
schedule-chunk-size
schedule-limit-groups
state-dir
);
my %OPT = ('lintian-frontend' => 'lintian',);
my %OPT_HASH = (
'schedule-chunk-size=i' => \$OPT{'schedule-chunk-size'},
'schedule-limit-groups=i' => \$OPT{'schedule-limit-groups'},
'state-dir=s' => \$OPT{'state-dir'},
'lintian-frontend=s' => \$OPT{'lintian-frontend'},
'lintian-log-dir=s' => \$OPT{'lintian-log-dir'},
'lintian-scratch-space=s' => \$OPT{'lintian-scratch-space'},
'help|h' => \&usage,
);
sub main {
STDOUT->autoflush;
Getopt::Long::config('bundling', 'no_getopt_compat', 'no_auto_abbrev');
Getopt::Long::GetOptions(%OPT_HASH) or die("error parsing options\n");
check_parameters();
$LINTIAN_VERSION= safe_qx($OPT{'lintian-frontend'}, '--print-version');
chomp($LINTIAN_VERSION);
prepare_lintian_environment_and_cmdline();
exit(harness_lintian());
}
### END OF SCRIPT -- below are helper subroutines ###
=item untaint(VALUE)
Untaint VALUE
=cut
sub untaint {
return $_[0] = $1 if $_[0] =~ m/^(.*)$/;
return;
}
sub check_parameters {
for my $parameter (@REQUIRED_PARAMETERS) {
if (not defined($OPT{$parameter})) {
die( "Missing required parameter \"--${parameter}\""
. "(use --help for more info)\n");
}
}
if (-d $OPT{'state-dir'}) {
untaint($OPT{'state-dir'});
} else {
die("The --state-dir parameter must point to an existing directory\n");
}
die("The argument for --schedule-limit-groups must be an > 0\n")
if $OPT{'schedule-limit-groups'} < 1;
return;
}
sub prepare_lintian_environment_and_cmdline {
my $frontend = 'lintian';
my $eoa_marker_index = first_index { $_ eq '--' } @ARGV;
my $logs_dir = $OPT{'lintian-log-dir'};
my @overridable_args = (qw(-EL +>=classification --show-overrides));
my @args = (
qw(--verbose), # We rely on this for filtering the log
qw(--exp-output=format=fullewi --packages-from-file -),
qw(--perf-debug --perf-output),
"+${logs_dir}/lintian-perf.log",
);
$frontend = $OPT{'lintian-frontend'} if ($OPT{'lintian-frontend'});
if ($eoa_marker_index > -1) {
# Move known "non-parameters" and the "--" behind our arguments.
# It is a misfeature, but at least it does not break
# our code. NB: It requires *two* "--" on the command-line to
# trigger this case.
push(@args, splice(@ARGV, $eoa_marker_index));
}
# Put "our" arguments after user supplied ones
@LINTIAN_CMD = ($frontend, @overridable_args, @ARGV, @args);
# The environment part
for my $key (keys(%ENV)) {
delete($ENV{$key}) if $key =~ m/^LINTIAN_/;
}
if ($OPT{'lintian-scratch-space'}) {
$ENV{'TMPDIR'} = $OPT{'lintian-scratch-space'};
log_msg("Setting TMPDIR to $ENV{'TMPDIR'}");
} else {
log_msg('Leaving TMPDIR unset (no --lintian-scratch-space');
}
return;
}
sub log_msg {
my ($msg) = @_;
my $ts = strftime('[%FT%T]: ', localtime());
print $ts, $msg, "\n";
return;
}
sub harness_lintian {
my (@worklist);
my $exit_code = 0;
my $state = load_state_cache($OPT{'state-dir'});
my $lintian_log_dir = $OPT{'lintian-log-dir'};
my $lintian_log = "${lintian_log_dir}/lintian.log";
log_msg('Update complete, loading current state information');
@worklist = find_backlog($LINTIAN_VERSION, $state);
# Always update the log if it exists, as we may have removed
# some entries.
if (-f $lintian_log) {
my $filter = generate_log_filter($state, {});
# update lintian.log
log_msg('Updating lintian.log...');
rewrite_lintian_log($filter);
}
log_msg('');
if (not @worklist) {
log_msg('Skipping Lintian run - nothing to do...');
} else {
log_msg('Processing backlog...');
if (@worklist > $OPT{'schedule-limit-groups'}) {
log_msg(
"Truncating worklist to size $OPT{'schedule-limit-groups'}"
. ' from '
. (scalar(@worklist)));
@worklist = splice(@worklist, 0, $OPT{'schedule-limit-groups'});
}
$exit_code= process_worklist(\@worklist, $state, $lintian_log_dir);
}
return $exit_code;
}
sub process_worklist {
my ($worklist_ref, $state, $lintian_log_dir) = @_;
my $round = 0;
my $rounds = 1;
my @worklist = @{$worklist_ref};
my $exit_code = 0;
my $schedule_chunk_size = $OPT{'schedule-chunk-size'};
my $start_time = time();
if ($schedule_chunk_size > 0) {
# compute the number of rounds needed.
my $size_up = scalar @worklist + ($schedule_chunk_size - 1);
$rounds = int($size_up / $schedule_chunk_size);
}
log_msg(
sprintf(
'Groups to process %d will take %d round(s) [round limit: %s]',
scalar @worklist,
$rounds,$schedule_chunk_size > 0 ? $schedule_chunk_size : 'none'
));
log_msg('Command line used: ' . join(q{ }, @LINTIAN_CMD));
while (@worklist) {
my $len = scalar @worklist;
my (@work_splice, @completed, %processed, %errors);
my ($status_fd, $lint_status_out);
my $got_alarm = 0;
# Bail if there is less than 5 minutes left
if (time() >= $start_time + BACKLOG_PROCESSING_TIME_LIMIT - 300) {
log_msg('No more time for processing backlogs');
$exit_code = 2;
last;
}
$round++;
# correct bounds to fit chunk size
if ($schedule_chunk_size > 0 and $len > $schedule_chunk_size) {
$len = $schedule_chunk_size;
}
# Sort @work_splice to have the "Range:"-line below produce
# reasonable output.
@work_splice = sort(splice(@worklist, 0, $len));
log_msg("Running Lintian (round $round/$rounds) ...");
if ($len == 1) {
log_msg(' - Single group: ' . $work_splice[0]);
} else {
log_msg(' - Range: GROUP:'
. $work_splice[0]
. q{ ... GROUP:}
. $work_splice[-1]);
}
next if ($OPT{'dry-run'});
pipe($status_fd, $lint_status_out);
my ($nfd, $new_lintian_log)
= tempfile('lintian.log-XXXXXXX', DIR => $lintian_log_dir);
# We do not mind if anyone reads the lintian log as it is being written
chmod(0644, $nfd);
log_msg("New lintian log at $new_lintian_log");
my $loop = IO::Async::Loop->new;
my $future = $loop->new_future;
my $signalled_lintian = 0;
push(@LINTIAN_CMD, '--status-log', '&3');
my $process = IO::Async::Process->new(
command => [@LINTIAN_CMD],
stdin => { via => 'pipe_write' },
stdout => { via => 'pipe_read' },
stderr => { via => 'pipe_read' },
fd3 => { via => 'pipe_read' },
on_finish => sub {
my ($self, $exitcode) = @_;
my $status = ($exitcode >> 8);
my $signal = ($exitcode & 0xff);
if ($signal) {
log_msg("Lintian terminated by signal: $signal");
# If someone is sending us signals (e.g. SIGINT/Ctrl-C)
# don't start the next round.
log_msg(' - skipping the rest of the worklist');
@worklist = ();
$future->fail(
"Command @LINTIAN_CMD received signal $signal");
return;
}
if ($status == 0 || $status == 1) {
# exit 1 (policy violations) happens all the time (sadly)
# exit 2 (broken packages) also happens all the time...
log_msg('Lintian finished successfully');
$future->done("Done with @LINTIAN_CMD");
return;
}
log_msg("warning: executing lintian returned status $status");
if ($got_alarm) {
# Ideally, lintian would always die by the signal
# but some times it catches it and terminates
# "normally"
log_msg('Stopped by a signal or time out');
log_msg(' - skipping the rest of the worklist');
@worklist = ();
}
$future->fail("Error status $status from @LINTIAN_CMD");
return;
});
$process->stdout->configure(
on_read => sub {
my ($stream, $buffref, $eof) = @_;
if (length $$buffref) {
print {$nfd} $$buffref;
$$buffref = EMPTY;
}
close($nfd)
if $eof;
return 0;
},
);
$process->stderr->configure(
on_read => sub {
my ($stream, $buffref, $eof) = @_;
if (length $$buffref) {
print STDOUT $$buffref;
$$buffref = EMPTY;
}
return 0;
},
);
$process->fd3->configure(
on_read => sub {
my ($stream, $buffref, $eof) = @_;
while($$buffref =~ s/^(.*)\n//) {
my $line = $1;
# listen to status updates from lintian
if ($line =~ m/^complete ([^ ]+) \(([^\)]+)\)$/) {
my ($group_id, $runtime) = ($1, $2);
push(@completed, $group_id);
$processed{$group_id} = 1;
log_msg(" [lintian] processed $group_id"
. " successfully (time: $runtime)");
} elsif ($line =~ m/^error ([^ ]+) \(([^\)]+)\)$/) {
my ($group_id, $runtime) = ($1, $2);
log_msg(" [lintian] error processing $group_id "
. "(time: $runtime)");
$processed{$group_id} = 1;
# We ignore errors if we sent lintian a signal to avoid
# *some* false-positives.
$errors{$group_id} = 1 if not $signalled_lintian;
} elsif ($line =~ m/^ack-signal (SIG\S+)$/) {
my $signal = $1;
log_msg(
"Signal $signal acknowledged: disabled timed alarms"
);
alarm(0);
}
}
alarm(0)
if $eof;
return 0;
},
);
$loop->add($process);
my $groups = $state->{'groups'};
# Submit the tasks to Lintian
foreach my $group_id (@work_splice) {
my $members;
if (not exists($groups->{$group_id})) {
# Sanity check (can in theory happen if an external process
# modifies the state cache and we have reloaded it)
log_msg(
"Group ${group_id} disappeared before we could schedule it"
);
next;
}
$members = $groups->{$group_id}{'members'};
for my $member_id (sort(keys(%{${members}}))) {
my $path = $members->{$member_id}{'path'};
$process->stdin->write($path . NEWLINE);
}
}
$process->stdin->close_when_empty;
eval {
my $time_limit
= $start_time + BACKLOG_PROCESSING_TIME_LIMIT - time();
my $count = 0;
my $sig_handler = sub {
my ($signal_name) = @_;
$signalled_lintian = 1;
$count++;
if ($signal_name eq 'ALRM') {
$got_alarm = 1 if $got_alarm >= 0;
} else {
$got_alarm = -1;
}
if ($count < 3) {
my $pid = $process->pid;
log_msg("Received SIG${signal_name}, "
. "sending SIGTERM to $pid [${count}/3]");
$process->kill('TERM');
if ($signal_name eq 'ALRM') {
log_msg(
'Scheduling another alarm in 5 minutes from now...'
);
alarm(300);
}
} else {
my $pid = $process->pid;
log_msg("Received SIG${signal_name} as the third one, "
. "sending SIGKILL to $pid");
log_msg('You may have to clean up some '
. 'temporary directories manually');
$process->kill('KILL');
}
};
local $SIG{'TERM'} = $sig_handler;
local $SIG{'INT'} = $sig_handler;
local $SIG{'ALRM'} = $sig_handler;
alarm($time_limit);
};
# Wait for lintian to terminate
$future->await;
if ($got_alarm) {
if ($got_alarm == 1) {
# Lintian was (presumably) killed due to a
# time-out from this process
$exit_code = 2;
} else {
# Lintian was killed by another signal; notify
# harness that it should skip the rest as well.
$exit_code = 3;
}
}
log_msg('Updating the lintian log used for reporting');
my $filter = generate_log_filter($state, \%processed);
seek($nfd, 0, SEEK_END);
update_lintian_log($filter, $nfd, $new_lintian_log);
log_msg('Updating harness state cache');
# Reload the state cache, just in case it was modified by an external
# process during the lintian run.
$state = load_state_cache($OPT{'state-dir'});
for my $group_id (@completed) {
my $group_data;
# In theory, they can disappear - in practise, that requires
# an external call to (e.g.) lintian reporting-sync-state.
next if not exists($state->{'groups'}{$group_id});
$group_data = $state->{'groups'}{$group_id};
$group_data->{'last-processed-by'} = $LINTIAN_VERSION;
delete($group_data->{'out-of-date'});
# Always clear the error counter after a successful run.
delete($group_data->{'processing-errors'});
delete($group_data->{'last-error-by'});
}
for my $group_id (sort(keys(%errors))) {
my $group_data;
# In theory, they can disappear - in practise, that requires
# an external call to (e.g.) lintian reporting-sync-state.
next if not exists($state->{'groups'}{$group_id});
$group_data = $state->{'groups'}{$group_id};
if ($errors{$group_id}) {
if (not exists($group_data->{'last-error-by'})
or $group_data->{'last-error-by'} ne $LINTIAN_VERSION) {
# If it is a new lintian version then (re)set the counter
# to 1. Case also triggers for the very first issue.
$group_data->{'processing-errors'} = 1;
} else {
# Repeated error with the same version
++$group_data->{'processing-errors'};
}
# Set the "last-error-by" flag so we can clear the
# error if there is a new version of lintian.
$group_data->{'last-error-by'} = $LINTIAN_VERSION;
} else {
delete($group_data->{'processing-errors'});
}
}
save_state_cache($OPT{'state-dir'}, $state);
last if $exit_code;
}
return $exit_code;
}
sub generate_log_filter {
my ($state, $exclude) = @_;
my %filter;
my $group_map = $state->{'groups'};
for my $group_id (keys(%{${group_map}})) {
my $members;
next if exists($exclude->{$group_id});
$members = $group_map->{$group_id}{'members'};
for my $member_id (keys(%{$members})) {
$filter{$member_id} = 1;
}
}
return \%filter;
}
sub update_lintian_log {
my ($keep_filter, $new_fd, $tmp_path) = @_;
my $lintian_log_dir = $OPT{'lintian-log-dir'};
my $lintian_log = "${lintian_log_dir}/lintian.log";
my $copy_mode = 0;
my $first = 1;
eval {
open(my $input, '<', $lintian_log);
while (<$input>) {
if (
m/^N: [ ] Processing [ ] (binary|udeb|source) [ ]
package [ ] (\S+) [ ] \(version [ ] (\S+), [ ]
arch [ ] (\S+)\)[ ]\.\.\./xsm
) {
my ($type, $pkg, $ver, $arch) = ($1,$2, $3, $4);
my $k = "$type:$pkg/$ver";
$k .= "/$arch" if $type ne 'source';
$copy_mode = 0;
$copy_mode = 1 if exists($keep_filter->{$k});
}
if ($copy_mode) {
if ($first) {
print {$new_fd} "N: ---start-of-old-lintian-log-file---\n";
$first = 0;
}
print {$new_fd} $_;
}
}
close($input);
close($new_fd);
rename($tmp_path, $lintian_log);
};
if (my $err = $@) {
# Unlink $new_lintian_log, we ignore errors as the one we
# already got is more important/interesting.
no autodie qw(unlink);
unlink($tmp_path) or warn("Cannot unlink $tmp_path: $!");
die($err);
}
return;
}
sub rewrite_lintian_log {
my ($keep_filter) = @_;
my $lintian_log_dir = $OPT{'lintian-log-dir'};
my ($nfd, $new_lintian_log);
($nfd, $new_lintian_log)
= tempfile('lintian.log-XXXXXXX', DIR => $lintian_log_dir);
chmod(0644, $nfd);
update_lintian_log($keep_filter, $nfd, $new_lintian_log);
return 1;
}
sub usage {
my $cmd = basename($0);
my $me = "lintian $cmd";
print <<EOF;
Internal command for the Lintian reporting framework
Usage: $me <args> -- <extra lintian args>
--help Show this text and exit
--lintian-frontend PROG Use PROG as frontend for lintian (defaults to "lintian")
--lintian-log-dir DIR Path to the harness log dir. [!]
--lintian-scratch-space DIR Use DIR for temporary files (notably temp labs)
--schedule-chunk-size N Run at most N groups in a given lintian run.
--schedule-limit-groups N Schedule at most N groups in total. [!]
--state-dir DIR Directory containing the state cache (must be
writable). [!]
Arguments marked with [!] are required for a successful run.
EOF
exit(0);
}
1;
# Local Variables:
# indent-tabs-mode: nil
# cperl-indent-level: 4
# End:
# vim: syntax=perl sw=4 sts=4 sr et
Reference in New Issue View Git Blame Copy Permalink