#!/usr/bin/perl -w
# Keep track of Linux kernel versions and ABI bumps
use strict;
use File::Slurp;
use Email::MIME;
use Email::Sender::Simple qw(sendmail);
use List::MoreUtils qw(uniq);
use Sort::Versions;
use LWP::UserAgent;
use XML::LibXML;
sub colorize_flavours {
my ($arch, $abi, $lastabi, %v) = @_;
my $cell;
if ($v{$arch}{$abi}) {
foreach my $flavour (@{$v{$arch}{$abi}}) {
my $color;
if (($abi ne $lastabi) && $v{$arch}{$lastabi}) {
if (grep { $_ eq $flavour } @{$v{$arch}{$lastabi}}) {
# Available in a newer ABI, can be decrufted:
$color='darkorange';
}
else {
# Not available in newer ABI, possibly dropped:
$color='purple';
}
}
if (($abi ne $lastabi) && !$v{$arch}{$lastabi}) {
# Not built yet:
$color='red';
}
if ($color) {
$cell .= "$flavour ";
}
else {
$cell .= "$flavour ";
}
}
}
$cell ||= " ";
return "
$cell
\n";
}
sub compare_and_mail {
my ($dist, $lastabi, $summary, $url) = @_;
if (-f $summary) {
foreach my $line (read_file($summary)) {
if ($line =~ //) {
my $previous_lastabi = $1;
my $previous_dist = $2;
if (($dist eq $previous_dist) and ($lastabi ne $previous_lastabi)) {
my $subject = "Linux kernel ABI bump in $dist: from $previous_lastabi to $lastabi";
my $body = "Linux kernel ABI bump in $dist: from $previous_lastabi to $lastabi\n\nFull summary: $url#$dist\n";
my $message = Email::MIME->create(
header_str => [
From => 'Linux kernel watcher ',
To => 'kibi@debian.org',
Subject => $subject,
],
attributes => {
encoding => "quoted-printable",
charset => "UTF-8",
},
body_str => $body,
);
sendmail($message);
print STDERR "Sending a notification: $subject\n";
}
}
}
}
# Beware: keep in sync with the match above
return "";
}
sub build_status {
my ($dist, @allarchs) = @_;
my $buildurl = "https://buildd.debian.org/status/package.php?p=linux&suite=$dist";
# Only look at build logs for those distributions:
return ''
if ! grep { $dist eq $_ } qw(unstable experimental);
my $html;
my $ua = LWP::UserAgent->new;
my $response = $ua->get($buildurl);
my %builds;
if ($response->is_success) {
# Avoid hardcoding column id:
my $xml = XML::LibXML->load_html(string => $response->content);
my @columns = $xml->findnodes('//table[@class="data"]/tr/th/text()');
my %col_lookup;
foreach my $i (0 .. $#columns) {
$col_lookup{$columns[$i]} = $i;
}
foreach my $line ($xml->findnodes('//table[@class="data"]/tr')) {
my @cells = $line->findnodes('./td');
next if ! @cells;
next if $#cells < 2;
my $arch = $cells[ $col_lookup{Architecture} ]->textContent();
my $status = $cells[ $col_lookup{Status} ]->textContent();
my $time = $cells[ $col_lookup{For} ]->textContent();
$arch =~ s/^\s+|\s+$//g;
$time =~ s/\s+\d+m$//;
my %color = ( Installed => 'darkgreen', Building => 'darkorange', 'Needs-Build' => 'darkorange', 'Failed' => 'red', 'Build-Attempted' => 'red' );
my $c = $color{$status} || 'black';
$builds{$arch} = "$status ($time)";
}
$html .= "
Failed to retrieve build status: " . $response->status_line . "
";
}
return $html;
}
my $summary = shift @ARGV || "kernel-summary.html";
my $url = "http://d-i.debian.org/kernel-summary.html";
my $html = << 'EOS';
Linux kernel status across distributions
EOS
# Make this cumulative across dists as builds can be disappearing from
# experimental (decruft), and we would miss Build-Attempted/Failed
# cases:
my @allarchs;
foreach my $dist (qw(testing unstable experimental)) {
# FIXME: A few hours can happen until a built package can be seen
# here. Another option would be ssh {ftp-master,release}.d.o dak ls
my @lines = `rmadison -S linux -s $dist 2>/dev/null`;
# Abort if rmadison fails (e.g. qa.debian.org fails to reply):
exit 1
if $? != 0;
my @allabis;
my %v;
foreach my $line (@lines) {
next
if $line !~ /linux-image-/;
chomp $line;
my ($package, $version, $dist, $archs) = split /\s*[|]\s*/, $line;
$package =~ s/\s*linux-image-//;
(my $abi = $package) =~ s/(-(?:rc\d+|\d+|trunk))-.*/$1/;
my $flavour = substr $package, 1+length($abi);
#print STDERR "$abi; $package; $version; $dist; $archs\n";
foreach my $arch (split /,\s*/, $archs) {
push @{$v{$arch}{$abi}}, $flavour;
push @allarchs, $arch;
}
push @allabis, $abi;
}
### Sort and uniquify:
@allarchs = uniq sort @allarchs;
@allabis = uniq sort { versioncmp($a,$b) } @allabis;
my $none = "(none)";
my $lastabi = $allabis[-1] || $none;
### Compare with previous ABI if relevant:
my $abi_comment = compare_and_mail($dist, $lastabi, $summary, $url);
### Output:
$html .= "