--- /dev/null
+#!/usr/bin/perl -w
+#
+# Lintian HTML reporting tool -- Create Lintian web reports
+#
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2007 Russ Allbery
+#
+# 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 http://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+use strict;
+use File::Copy qw(copy);
+use URI::Escape;
+use Text::Template ();
+
+# ------------------------------
+# Global variables and configuration
+
+# Maximum number of identical tags per package to display. Any remaining tags
+# will be compressed into a "... reported %d more times" line.
+our $MAX_TAGS = 8;
+
+# These have no default and must be set in the configuration file.
+# FIXME: $statistics_file should be in all caps as well.
+our ($LINTIAN_ROOT, $LINTIAN_LAB, $LINTIAN_ARCHIVEDIR, $LINTIAN_DIST,
+ $LINTIAN_SECTION, $LINTIAN_ARCH, $HTML_TMP_DIR, $statistics_file);
+
+# Read the configuration.
+require './config';
+
+# The path to the mirror timestamp.
+our $LINTIAN_TIMESTAMP
+ = "$LINTIAN_ARCHIVEDIR/project/trace/ftp-master.debian.org";
+
+# FIXME: At least the lab should be a parameter to Read_pkglists rather
+# than an environment variable.
+$ENV{'LINTIAN_LAB'} = $LINTIAN_LAB;
+$ENV{'LINTIAN_ROOT'} = $LINTIAN_ROOT;
+
+# Import Lintian Perl libraries.
+use lib "$ENV{LINTIAN_ROOT}/lib";
+use Read_pkglists;
+use Read_taginfo;
+use Util;
+
+# Global variables from Read_pkglists. Ugh.
+# FIXME: Read_pkglists should return this information instead.
+our (%binary_info, %source_info, %udeb_info, %bin_src_ref);
+
+# Get the tag information from the Lintian *.desc files.
+our %tag_info = %{ read_tag_info('html') };
+
+# Set the Lintian version, current timestamp, and archive timestamp.
+our $LINTIAN_VERSION = `$LINTIAN_ROOT/frontend/lintian --print-version`;
+our $timestamp = `date -u --rfc-822`;
+our $mirror_timestamp = slurp_entire_file($LINTIAN_TIMESTAMP);
+chomp ($LINTIAN_VERSION, $timestamp, $mirror_timestamp);
+
+
+# ------------------------------
+# Initialize templates
+
+# The path to our templates.
+our $TEMPLATES = "$LINTIAN_ROOT/reporting/templates";
+
+# This only has to be done once, so do it at the start and then reuse the same
+# templates throughout.
+our %templates;
+for my $template (qw/head foot clean index maintainer maintainers packages tag tags/) {
+ my %options = (TYPE => 'FILE', SOURCE => "$TEMPLATES/$template.tmpl");
+ $templates{$template} = Text::Template->new (%options)
+ or die "cannot load template $template: $Text::Template::ERROR\n";
+}
+
+
+# ------------------------------
+# Main routine
+
+# Read the package lists.
+#
+# FIXME: get_bin_src_ref runs read_src_list unconditionally so we can't call
+# it directly, which is confusing.
+read_bin_list;
+read_udeb_list;
+get_bin_src_ref;
+
+# Create output directories.
+mkdir($HTML_TMP_DIR, 0777)
+ or die "cannot create output directory $HTML_TMP_DIR: $!\n";
+mkdir("$HTML_TMP_DIR/full", 0777)
+ or die "cannot create output directory $HTML_TMP_DIR/full: $!\n";
+mkdir("$HTML_TMP_DIR/maintainer", 0777)
+ or die "cannot create output directory $HTML_TMP_DIR/maintainer: $!\n";
+mkdir("$HTML_TMP_DIR/tags", 0777)
+ or die "cannot create output directory $HTML_TMP_DIR/tags: $!\n";
+symlink(".", "$HTML_TMP_DIR/reports")
+ or die "cannot create symlink $HTML_TMP_DIR/reports: $!\n";
+symlink("$LINTIAN_ROOT/doc/lintian.html", "$HTML_TMP_DIR/manual")
+ or die "cannot create symlink $HTML_TMP_DIR/manual: $!\n";
+if ($ARGV[0]) {
+ symlink($ARGV[0], "$HTML_TMP_DIR/lintian.log")
+ or die "cannot create symlink $HTML_TMP_DIR/lintian.log: $!\n";
+}
+copy("$LINTIAN_ROOT/reporting/lintian.css", "$HTML_TMP_DIR/lintian.css")
+ or die "cannot copy lintian.css to $HTML_TMP_DIR: $!\n";
+for my $image (qw/ico.png l.png logo-small.png/) {
+ copy("$LINTIAN_ROOT/reporting/images/$image", "$HTML_TMP_DIR/$image")
+ or die "cannot copy images/$image to $HTML_TMP_DIR: $!\n";
+}
+
+# This variable will accumulate statistics. For tags: errors, warnings,
+# experimental, overridden, and info are the keys holding the count of tags of
+# that sort. For packages: binary, udeb, and source are the number of
+# packages of each type with Lintian errors or warnings. For maintainers:
+# maintainers is the number of maintainers with Lintian errors or warnings.
+my %statistics;
+
+# %by_maint holds a hash of maintainer names to packages and tags. Each
+# maintainer is a key. The value is a hash of package names to hashes. Each
+# package hash is in turn a hash of versions to an anonymous array of hashes,
+# with each hash having keys code, package, type, tag, extra, and xref. xref
+# gets the partial URL of the maintainer page for that source package.
+#
+# In other words, the lintian output line:
+#
+# W: gnubg source: substvar-source-version-is-deprecated gnubg-data
+#
+# for gnubg 0.15~20061120-1 maintained by Russ Allbery <rra@debian.org> is
+# turned into the following structure:
+#
+# { 'gnubg' => {
+# '0.15~20061120-1' => [
+# { code => 'W',
+# package => 'gnubg',
+# type => 'source',
+# tag => 'substvar-source-version-is-deprecated',
+# extra => 'gnubg-data'
+# xref => 'rra@debian.org.html#gnubg' } ] } }
+#
+# and then stored under the key 'Russ Allbery <rra@debian.org>'
+#
+# %by_uploader holds the same thing except for packages for which the person
+# is only an uploader.
+#
+# %by_tag is a hash of tag names to an anonymous array of tag information
+# hashes just like the inside-most data structure above.
+my (%by_maint, %by_uploader, %by_tag);
+
+# We take a lintian log file on either standard input or as the first
+# argument. This log file contains all the tags lintian found, plus N: tags
+# with informational messages. Ignore all the N: tags and load everything
+# else into the hashes we use for all web page generation.
+#
+# We keep track of a hash from maintainer page URLs to maintainer values so
+# that we don't have two maintainers who map to the same page and overwrite
+# each other's pages. If we find two maintainers who map to the same URL,
+# just assume that the second maintainer is the same as the first (but warn
+# about it).
+my (%seen, %saw_maintainer);
+while (<>) {
+ chomp;
+ next unless m/^([EWIXO]): (\S+)(?: (\S+))?: (\S+)(?:\s+(.*))?/;
+ my ($code, $package, $type, $tag, $extra) = ($1, $2, $3, $4, $5);
+ $type = 'binary' unless (defined $type);
+ next unless ($type eq 'source' || $type eq 'binary' || $type eq 'udeb');
+
+ # Update statistics.
+ my $key = {
+ E => 'errors',
+ W => 'warnings',
+ I => 'info',
+ X => 'experimental',
+ O => 'overridden'
+ }->{$code};
+ $statistics{$key}++;
+ unless ($seen{"$package $type"}) {
+ $statistics{"$type-packages"}++;
+ $seen{"$package $type"} = 1;
+ }
+
+ # Determine the source package for this package and warn if there appears
+ # to be no source package in the archive. Determine the maintainer and
+ # version. Work around a missing source package by pulling information
+ # from a binary package or udeb of the same name if there is any.
+ my ($source, $version, $maintainer, $uploaders);
+ if ($type eq 'source') {
+ $source = $package;
+ if (exists $source_info{$source}) {
+ $version = $source_info{$source}->{version};
+ $maintainer = $source_info{$source}->{maintainer};
+ $uploaders = $source_info{$source}->{uploaders};
+ } else {
+ warn "source package $package not listed!\n";
+ }
+ } else {
+ $source = $bin_src_ref{$package};
+ if ($source and exists $source_info{$source}) {
+ $maintainer = $source_info{$source}->{maintainer};
+ $uploaders = $source_info{$source}->{uploaders};
+ } else {
+ warn "source for package $package not found!\n";
+ $source = $package;
+ if ($type eq 'binary') {
+ $maintainer = $binary_info{$package}->{maintainer};
+ } elsif ($type eq 'udeb') {
+ $maintainer = $udeb_info{$package}->{maintainer};
+ }
+ }
+ if ($type eq 'binary') {
+ $version = $binary_info{$package}->{version};
+ } elsif ($type eq 'udeb') {
+ $version = $udeb_info{$package}->{version};
+ }
+ }
+ $maintainer ||= '(unknown)';
+ $version ||= 'unknown';
+
+ # Check if we've seen the URL for this maintainer before and, if so, map
+ # them to the same person as the previous one.
+ $maintainer = map_maintainer ($maintainer);
+ $saw_maintainer{$maintainer} = 1;
+
+ # Update maintainer statistics.
+ $statistics{maintainers}++ unless defined $by_maint{$maintainer};
+
+ # Sanitize, just out of paranoia.
+ $source =~ s/[^a-zA-Z0-9.+-]/_/g;
+ $version =~ s/[^a-zA-Z0-9.+:~-]/_/g;
+
+ # Add the tag information to our hashes. Share the data between the
+ # hashes to save space (which means we can't later do destructive tricks
+ # with it).
+ my $info = {
+ code => html_quote ($code),
+ package => html_quote ($package),
+ type => html_quote ($type),
+ tag => html_quote ($tag),
+ extra => html_quote ($extra),
+ xref => maintainer_url ($maintainer) . "#$source"
+ };
+ $by_maint{$maintainer}{$source}{$version} ||= [];
+ push(@{ $by_maint{$maintainer}{$source}{$version} }, $info);
+ $by_tag{$tag} ||= [];
+ push(@{ $by_tag{$tag} }, $info);
+
+ # If the package had uploaders listed, also add the information to
+ # %by_uploaders (still sharing the data between hashes).
+ if ($uploaders) {
+ my @uploaders = split (/\s*,\s*/, $uploaders);
+ for (@uploaders) {
+ my $uploader = map_maintainer ($_);
+ next if $uploader eq $maintainer;
+ $saw_maintainer{$uploader} = 1;
+ $by_uploader{$uploader}{$source}{$version} ||= [];
+ push(@{ $by_uploader{$uploader}{$source}{$version} }, $info);
+ }
+ }
+}
+
+# Build a hash of all maintainers, not just those with Lintian tags. We use
+# this later to generate stub pages for maintainers whose packages are all
+# Lintian-clean.
+my %clean;
+for my $source (keys %source_info) {
+ my $maintainer = $source_info{$source}->{maintainer};
+ my $id = maintainer_url ($maintainer);
+ $clean{$id} = $maintainer;
+}
+
+# Now, walk through the tags by source package (sorted by maintainer). Output
+# a summary page of errors and warnings for each maintainer, output a full
+# page that includes info, experimental, and overriden tags, and assemble the
+# maintainer index and the QA package list as we go.
+my (%qa, %maintainers, %packages);
+my @maintainers;
+{
+ my %seen;
+ @maintainers =
+ sort grep { !$seen{$_}++ } keys (%by_maint), keys (%by_uploader);
+}
+for my $maintainer (@maintainers) {
+ my $id = maintainer_url ($maintainer);
+ delete $clean{$id};
+
+ # For each of this maintainer's packages, add statistical information
+ # about warnings and errors to the QA list and build the packages hash
+ # used for the package index. We only do this for the maintainer
+ # packages, not the uploader packages, to avoid double-counting.
+ for my $source (keys %{ $by_maint{$maintainer} }) {
+ my ($errors, $warnings) = (0, 0);
+ for my $version (keys %{ $by_maint{$maintainer}{$source} }) {
+ my $tags = $by_maint{$maintainer}{$source}{$version};
+ for my $tag (@$tags) {
+ $errors++ if $tag->{code} eq 'E';
+ $warnings++ if $tag->{code} eq 'W';
+ $packages{$tag->{package}} = $tag->{xref};
+ }
+ }
+ $qa{$source} = [ $errors, $warnings ];
+ }
+
+ # Determine if the maintainer's page is clean. Check all packages for
+ # which they're either maintainer or uploader and set $error_clean if
+ # they have no errors or warnings.
+ my $error_clean = 1;
+ for my $source (keys %{ $by_maint{$maintainer} },
+ keys %{ $by_uploader{$maintainer} }) {
+ my $versions = $by_maint{$maintainer}{$source}
+ || $by_uploader{$maintainer}{$source};
+ for my $version (keys %$versions) {
+ my $tags = $versions->{$version};
+ for my $tag (@$tags) {
+ $error_clean = 0 if ($tag->{code} eq 'E');
+ $error_clean = 0 if ($tag->{code} eq 'W');
+ }
+ }
+ }
+
+ # Determine the parts of the maintainer and the file name for the
+ # maintainer page.
+ my ($name, $email) = ($maintainer =~ /^(.*) <([^>]+)>/);
+ $name = 'Unknown Maintainer' unless $name;
+ $email = 'unknown' unless $email;
+ my $regular = "maintainer/$id";
+ my $full = "full/$id";
+
+ # Create the regular maintainer page (only errors and warnings) and the
+ # full maintainer page (all tags, including overrides and info tags).
+ print "Generating page for $id\n";
+ my %data = (
+ email => html_quote (uri_escape ($email)),
+ errors => 1,
+ id => $id,
+ maintainer => html_quote ($maintainer),
+ name => html_quote ($name),
+ packages => $by_maint{$maintainer},
+ uploads => $by_uploader{$maintainer},
+ );
+ my $template;
+ if ($error_clean) {
+ $template = $templates{clean};
+ } else {
+ $template = $templates{maintainer};
+ }
+ output_template ($regular, $template, \%data);
+ $template = $templates{maintainer};
+ $data{errors} = 0;
+ output_template ($full, $template, \%data);
+
+ # Add this maintainer to the hash of maintainer to URL mappings.
+ $maintainers{$maintainer} = $id;
+}
+
+# Write out the maintainer index.
+my %data = (
+ maintainers => \%maintainers,
+);
+output_template ('maintainers.html', $templates{maintainers}, \%data);
+
+# Write out the QA package list.
+open (QA, '>', "$HTML_TMP_DIR/qa-list.txt")
+ or die "cannot create qa-list.txt: $!\n";
+for my $source (sort keys %qa) {
+ print QA "$source $qa{$source}[0] $qa{$source}[1]\n";
+}
+close QA or die "cannot write to qa-list: $!\n";
+
+# Now, generate stub pages for every maintainer who has only clean packages.
+for my $id (keys %clean) {
+ my $maintainer = $clean{$id};
+ my ($name, $email) = ($maintainer =~ /^(.*) <([^>]+)>/);
+ $email = 'unknown' unless $email;
+ my %data = (
+ email => html_quote (uri_escape ($email)),
+ maintainer => html_quote ($maintainer),
+ name => html_quote ($name),
+ );
+ print "Generating clean page for $id\n";
+ output_template ("maintainer/$id", $templates{clean}, \%data);
+ output_template ("full/$id", $templates{clean}, \%data);
+}
+
+# Create the pages for each tag. Each page shows the extended description for
+# the tag and all the packages for which that tag was issued.
+for my $tag (sort keys %by_tag) {
+ my $description;
+ if ($tag_info{$tag}) {
+ $description = wrap_paragraphs('HTML', ' ', $tag_info{$tag});
+ } else {
+ $description = " <p>Can't find description of tag $tag.</p>";
+ }
+ my $code = 'O';
+ foreach (@{$by_tag{$tag}}) {
+ if ($_->{code} ne 'O') {
+ $code = $_->{code};
+ last;
+ }
+ }
+ my %data = (
+ description => $description,
+ tag => html_quote ($tag),
+ code => $code,
+ tags => $by_tag{$tag},
+ );
+ output_template ("tags/$tag.html", $templates{tag}, \%data);
+}
+
+# Create the general tag index.
+%data = (
+ tags => \%by_tag,
+);
+output_template ('tags.html', $templates{tags}, \%data);
+
+# Generate the package lists. These are huge, so we break them into four
+# separate pages.
+#
+# FIXME: Does anyone actually use these pages? They're basically unreadable.
+my %list;
+$list{'0-9, A-F'} = [];
+$list{'G-L'} = [];
+$list{'M-R'} = [];
+$list{'S-Z'} = [];
+for my $package (sort keys %packages) {
+ my $first = uc substr($package, 0, 1);
+ if ($first le 'F') { push(@{ $list{'0-9, A-F'} }, $package) }
+ elsif ($first le 'L') { push(@{ $list{'G-L'} }, $package) }
+ elsif ($first le 'R') { push(@{ $list{'M-R'} }, $package) }
+ else { push(@{ $list{'S-Z'} }, $package) }
+}
+%data = (
+ packages => \%packages,
+);
+my $i = 1;
+for my $section (sort keys %list) {
+ $data{section} = $section;
+ $data{list} = $list{$section};
+ output_template ("packages_$i.html", $templates{packages}, \%data);
+ $i++;
+}
+
+# Finally, we can start creating the index page. First, read in the old
+# statistics file so that we can calculate deltas for all of our statistics.
+my $old_statistics;
+if (-f $statistics_file) {
+ ($old_statistics) = read_dpkg_control($statistics_file);
+}
+my %delta;
+my @attrs = qw(maintainers source-packages binary-packages udeb-packages
+ errors warnings info experimental overridden);
+for my $attr (@attrs) {
+ my $old = $old_statistics->{$attr} || 0;
+ $statistics{$attr} ||= 0;
+ $delta{$attr} = sprintf("%d (%+d)", $statistics{$attr},
+ $statistics{$attr} - $old);
+}
+
+# Update the statistics file.
+open (STATS, '>', $statistics_file)
+ or die "cannot open $statistics_file for writing: $!\n";
+print STATS "last-updated: $timestamp\n";
+print STATS "mirror-timestamp: $mirror_timestamp\n";
+for my $attr (@attrs) {
+ print STATS "$attr: $statistics{$attr}\n";
+}
+print STATS "lintian-version: $LINTIAN_VERSION\n";
+close STATS or die "cannot write to $statistics_file: $!\n";
+
+# Create the main page.
+%data = (
+ architecture => $LINTIAN_ARCH,
+ delta => \%delta,
+ dist => $LINTIAN_DIST,
+ mirror => $mirror_timestamp,
+ previous => $old_statistics->{'last-updated'},
+ section => $LINTIAN_SECTION,
+);
+output_template ('index.html', $templates{index}, \%data);
+exit 0;
+
+# ------------------------------
+# Utility functions
+
+# Determine the file name for the maintainer page given a maintainer. It
+# should be <email>.html where <email> is their email address with all
+# characters other than a-z A-Z 0-9 - _ . @ = + replaced with _. Don't change
+# this without coordinating with QA.
+sub maintainer_url {
+ my ($maintainer) = @_;
+ my ($email) = ($maintainer =~ /<([^>]+)>/);
+ my ($regular, $full);
+ if ($email) {
+ my $id = $email;
+ $id =~ tr/a-zA-Z0-9_.@=+-/_/c;
+ return "$id.html";
+ } else {
+ return 'unsorted.html';
+ }
+}
+
+# Deduplicate maintainers. Maintains a cache of the maintainers we've seen
+# with a given e-mail address, issues a warning if two maintainers have the
+# same e-mail address, and returns the maintainer string that we should use
+# (which is whatever maintainer we saw first with that e-mail).
+{
+ my (%urlmap, %warned);
+ sub map_maintainer {
+ my ($maintainer) = @_;
+ my $url = maintainer_url ($maintainer);
+ if ($urlmap{$url} && $urlmap{$url} ne $maintainer) {
+ warn "$maintainer has the same page as $urlmap{$url}\n"
+ unless ($warned{$maintainer}
+ || lc ($maintainer) eq lc ($urlmap{$url})
+ || $maintainer =~ /\@lists\.(alioth\.)?debian\.org>/);
+ $warned{$maintainer}++;
+ $maintainer = $urlmap{$url};
+ } else {
+ $urlmap{$url} = $maintainer;
+ }
+ return $maintainer;
+ }
+}
+
+# Quote special characters for HTML output.
+sub html_quote {
+ my ($text) = @_;
+ $text ||= '';
+ $text =~ s/&/\&/g;
+ $text =~ s/</\</g;
+ $text =~ s/>/\>/g;
+ return $text;
+}
+
+# Given a file name, a template, and a data hash, fill out the template with
+# that data hash and output the results to the file.
+sub output_template {
+ my ($file, $template, $data) = @_;
+ $data->{version} ||= $LINTIAN_VERSION;
+ $data->{timestamp} ||= $timestamp;
+ $data->{head} ||= sub { $templates{head}->fill_in (HASH => { page_title => $_[0],
+ path_prefix => '../' x ($_[1]||0),
+ %$data }) };
+ $data->{foot} ||= sub { $templates{foot}->fill_in (HASH => $data) };
+ open (OUTPUT, '>', "$HTML_TMP_DIR/$file")
+ or die "creating $HTML_TMP_DIR/$file falied: $!\n";
+ $template->fill_in (OUTPUT => \*OUTPUT, HASH => $data)
+ or die "filling out $file failed: $Text::Template::ERROR\n";
+ close OUTPUT;
+}
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 ts=4 et shiftround
projects / maemian / blobdiff