testing security issues

#!/usr/bin/perl
# Must run on a machine with madison.
# 
# To check for un-updated binary kernel packages, also needs grep-dctrl 
# and a Sources file for the distribution. Set the location of the Sources
# file in SOURCES_FILE in the environment.
# 
use URI::Escape;

my $html=0;
if ($ARGV[0] eq 'html') {
	shift;
	$html=1;
}

if (! @ARGV) {
	die "usage: $0 [html] list\n";
}


my %data;
my %needkernel=qw/2.4.27 0 2.6.8 0/;
my $list_unknown=0; #set to 1 to display kernel images with unknown source version
my $sources=$ENV{SOURCES_FILE};
my $need_rebuild=0;

my $unprop = my $unfixed = my $todos = 0;

sub record {
	my ($package, $condition, $item)=@_;
		
	if ($html) {
		$condition=~s{bug #(\d+)}{<a href="http://bugs.debian.org/$1">bug #$1</a>}g;
		$condition=~s{unfixed}{<b>unfixed</b>}g;
		$item=~s#((?:CAN|CVE)-\d+-\d+)#<a href="http://www.cve.mitre.org/cgi-bin/cvename.cgi?name=$1">$1</a>#g;
	}

	push @{$data{$package}{$condition}}, $item;
}

foreach my $list (@ARGV) {
	if (-d $list) {
		$list="$list/list";
	}
	
	open (IN, $list) || die "open $list: $!";
	while (<IN>) {
		chomp;
		if (/^\[/) {
			($id)=m/((?:DSA|CAN|CVE)-[^\s]+) /;
		}
		elsif (/^((?:DSA|CAN|CVE)-[^\s]+)/) {
			$id=$1;
		}
		elsif (/^\s+[!-]\s+(\S+)\s+(.*?)\s*$/) {
			my $package=$1;
			my $version=$2;
			
			if ($package=~/kernel-source-([0-9.]+)/) {
			 	my $kernversion=$1;
				if (exists $needkernel{$kernversion} &&
						$version!~/\(/ ) {
					$needkernel{$kernversion}=$version if !system("dpkg --compare-versions $needkernel{$kernversion} lt $version");
				}
			}

			my $maddy=`madison -s testing '$package'`;
			if ($? & 128) {
				# good old newraff..
				record($package, "madison segfaulted", $id);
			}
			elsif ($? >> 8 != 0 && $? >> 8 != 1) {
				record($package, "<em>madison exited with ".($? >> 8)."</em>", $id);
			}
			if (! length $maddy) {
				next;
			}
			
			if ($version=~/unfixed/ || $version=~/pending/) {
				record($package, $version, $id);
				$unfixed++;
			}
			else {
				my @fields = split(/\s*\|\s*/, $maddy);
				my $havver=$fields[1];
				my $cmp=system("dpkg --compare-versions '$havver' '>=' '$version'");
				if ($cmp != 0) {
					if ($html) {
						$havver='<a href="http://bjorn.haxx.se/debian/testing.pl?package='.uri_escape($package).'">'.$havver.'</a>';
					}
					record($package, "$version needed, have $havver", $id);
					$unprop++;
				}
			}
		}
		elsif (/\s+TODO/) {
			$todos++;
		}
	}
}


if ($html) {
	print "<html><title>testing security issues</title>\n";
	print "<ul>\n";
}

foreach my $package (sort keys %data) {
	foreach my $condition (sort keys %{$data{$package}}) {
		print "<li>" if $html;
		print "$package $condition for ";
		my $items=0;
		foreach my $item (sort @{$data{$package}{$condition}}) {
			print ", " if $items > 0;
			print $item;
			$items++;
		}
		print "\n";
	}
}

foreach my $version (sort keys %needkernel) {
	my %images;
	
	if ($needkern{$version} eq "0") {
		next;
	}

	my @dctrl;
	if (defined $sources && length $sources) {
		@dctrl=`grep-dctrl -F Binary kernel-image-$version -s Package,Build-Depends $sources`;
	}

	my $package="";
	my $haveversion;
	
	foreach my $line (@dctrl) {
		chomp;
		if ($line=~/Package:\s*(\S+)/) {
			$package=$1;
			$haveversion="0";
		} elsif ($line=~/Build-Depends/) {
			if ($line=~/kernel-tree-$version-([^,\s]+)/) {
				$haveversion="$version-$1";
			} elsif ($line=~/kernel-source-$version\s+\(>=\s*([^\s\)])\)/) {
				$haveversion="$1";
			}
		} else {
			if ($package=~/linux-kernel-di/ || $package eq "") {
				next;
			}
			$images{$package}=$haveversion;
			$package="";
		}
	}

	foreach $package (sort keys %images) {
		if ($images{$package} eq "0") {
			print "<li>" if ($html && $list_unknown);
			print "$package built from kernel-source-$version $needkernel{$version} needed, current version unknown\n" if $list_unknown;
		} elsif (!system("dpkg --compare-versions $needkernel{$version} gt $images{$package}")) {
		print "<li>" if $html;
			print "$package built from kernel-source-$version $needkernel{$version} needed, have $images{$package}\n";
			$need_rebuild++;
		}
	}


}


if ($html) {
	print "</ul>\n";
	print "<hr>\n";
	print "Total holes unfixed: $unfixed<br>\n";
	print "Total holes fixed in unstable but not testing: $unprop<br>\n";
	print "Total number of kernel image source packages not up to date: $need_rebuild<br>\n";
	print "Number of TODO lines in <a href=\"http://svn.debian.org/wsvn/secure-testing/sarge-checks/?rev=0&sc=0\">records</a>: $todos<br>\n";
	print "Maintained by the <a href=\"http://secure-testing.alioth.debian.org/\">testing security team</a><br>\n";
	print "Last update: ".`date`."<br>\n";
	print "</html>\n";
}