#!/usr/bin/perl
#
# Lintian reporting harness -- Create and maintain Lintian reports automatically
#
# 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 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 Getopt::Std;

use vars qw($opt_c $opt_f $opt_i $opt_r);
unless (getopts('cfir')) {
  print <<END;
Lintian reporting harness
Create and maintain Lintian reports automatically

Usage: harness [ -i | -c [-f] ] [ -r ]

Options:
  -c    clean mode, erase everything and start from scratch
  -f    full mode, blithely overwrite lintian.log
  -i    incremental mode, use old lintian.log data, process changes only
  -r    generate HTML reports only

Incremental mode is the default if you have a lintian.log;
otherwise, it's full.

Report bugs to <lintian-maint\@debian.org>.
END
#'# for cperl-mode
  exit;
}

die 'Cannot use both incremental and full/clean.' if ($opt_i && ($opt_f || $opt_c));
$opt_f = 1 if $opt_c;
die 'Cannot use other modes with reports only.' if ($opt_r && ($opt_i || $opt_f || $opt_c));

# read configuration
require './config';
use vars qw($LINTIAN_ROOT $LINTIAN_LAB $LINTIAN_ARCHIVEDIR $LINTIAN_DIST
            $LINTIAN_ARCH $LINTIAN_CFG
            $lintian_cmd $html_reports_cmd
            $log_file $lintian_log $old_lintian_log
            $changes_file $list_file $html_reports_log
            $LOG_DIR $statistics_file
            $HTML_DIR $HTML_TMP_DIR $LINTIAN_BIN_DIR $LINTIAN_GPG_CHECK
            $LINTIAN_AREA);

# import perl libraries
unshift @INC, "$LINTIAN_ROOT/lib";
require Util;
require Lintian::Lab;
require Lintian::Lab::Manifest;
require Lintian::Processable::Package;

# turn file buffering off
$| = 1;

# rotate log files
system("savelog $log_file $changes_file $list_file $html_reports_log >/dev/null") == 0
    or Die('cannot rotate log files');

# create new log file
open(LOG, '>', $log_file)
    or Die("cannot open log file $log_file for writing: $!");

system("mkdir -p -m 775 $LINTIAN_BIN_DIR") == 0 || die "$!";

# export Lintian's configuration
$ENV{'LINTIAN_ROOT'} = $LINTIAN_ROOT;
$ENV{'LINTIAN_CFG'} = $LINTIAN_CFG;
$ENV{'LINTIAN_LAB'} = $LINTIAN_LAB;
$ENV{'LINTIAN_ARCHIVEDIR'} = $LINTIAN_ARCHIVEDIR;
$ENV{'LINTIAN_DIST'} = $LINTIAN_DIST;
$ENV{'LINTIAN_AREA'} = $LINTIAN_AREA;
$ENV{'LINTIAN_ARCH'} = $LINTIAN_ARCH;
$ENV{'PATH'} = $LINTIAN_BIN_DIR . ':' . $ENV{'PATH'};

if ($LINTIAN_GPG_CHECK) {
  if (-l $LINTIAN_BIN_DIR . '/gpg') {
    unlink($LINTIAN_BIN_DIR . '/gpg');
  } else {
    rename($LINTIAN_BIN_DIR . '/gpg', $LINTIAN_BIN_DIR . '/gpg.bkp');
  }
} else {
  symlink '/bin/true', $LINTIAN_BIN_DIR . '/gpg'
    unless(-f $LINTIAN_BIN_DIR . '/gpg');
}

my $LAB = Lintian::Lab->new ($LINTIAN_LAB);

# purge the old packages
$LAB->remove if $opt_c;

$LAB->create ({ 'mode' => 02775}) unless $LAB->exists;

unless ($opt_f || $opt_c) {
  unless ($opt_r) {
    if (-f $lintian_log) {
      $opt_i = 1;
    } else {
      $opt_f = 1;
    }
  }
}

unless ($opt_r) {
    $LAB->open;
    my @manifests = local_mirror_manifests ($LINTIAN_ARCHIVEDIR, [_trim_split ($LINTIAN_DIST)],
                                            [_trim_split ($LINTIAN_AREA)], [_trim_split ($LINTIAN_ARCH)]);
    my @diffs = $LAB->generate_diffs (@manifests);
    my %skip = ();
    my @inc;
    # Use the FullEWI output as it is less ambiguous for html_reports - it shouldn't make a difference
    # but still...
    my $cmd ="$lintian_cmd -I -E --pedantic -v --show-overrides -U changelog-file".
        " --exp-output=format=fullewi";
    # Remove old/stale packages from the lab
    foreach my $diff (@diffs) {
        my $type = $diff->type;
        Log ("Removing old or changed $type packages from the lab");
        foreach my $removed (@{ $diff->removed }, @{ $diff->changed }) {
            my ($pkg_name, $pkg_version, $pkg_arch) = @$removed;
            my $entry = $LAB->get_package ($pkg_name, $type, $pkg_version, $pkg_arch);
            my $sk = "$type:$pkg_name/$pkg_version";
            $sk .= "/$pkg_arch" if $pkg_arch;
            $skip{$sk} = 1; # For log-cleaning (incremental runs)
            if ($entry) {
                my $arch = '';
                $arch = " [$pkg_arch]" if $pkg_arch;
                if ($entry->remove) {
                    Log ("Removed $type $pkg_name ($pkg_version)$arch");
                } else {
                    Log ("Removing $type $pkg_name ($pkg_version)$arch failed.");
                }
            }
        }
        Log ("Adding new and changed $type packages to the lab");
        foreach my $added (@{ $diff->added }, @{ $diff->changed }) {
            my ($pkg_name, $pkg_version, $pkg_arch) = @$added;
            my $man = $diff->nlist;
            my $me = $man->get (@$added);
            my $file = $me->{'file'};
            my $proc;
            eval {
                $proc = Lintian::Processable::Package->new ($type, $file);
            };
            unless ($proc) {
                my $name = "$type:$pkg_name/$pkg_version";
                $name .= "/$pkg_arch" if $pkg_arch;
                Log ("Skipping $name due to errors ($@)");
                next;
            }

            my $entry = $LAB->get_package ($proc);
            if ($entry) {
                my $ok = 0;
                my $arch = '';
                $arch = " [$pkg_arch]" if $pkg_arch;
                eval {
                    $entry->create;
                    $entry->update_status_file or
                        die "creating status file: $!";
                    $ok = 1;
                };
                if ($ok) {
                    my $query = "$type:$pkg_name/$pkg_version";
                    $query .= "/$pkg_arch" if $pkg_arch;
                    Log ("Added $type $pkg_name ($pkg_version)$arch");
                    push @inc, $query;
                } else {
                    Log ("Adding $type $pkg_name ($pkg_version)$arch failed: $@");
                }
            }
        }
    }

    # Flushes the changed manifest to the file system - croaks on error
    $LAB->close;

    if ($opt_i) {
        # Extra work for the incremental run

        die "Old Lintian log file $lintian_log not found!\n" unless -f $lintian_log;

        # update lintian.log
        Log('Updating lintian.log...');
        rename $lintian_log, $old_lintian_log;
        open my $ofd, '<', $old_lintian_log
            or Die ("cannot open old lintian.log $old_lintian_log for reading: $!");
        open my $nfd, '>', $lintian_log
            or Die ("cannot open lintian.log $lintian_log for writing: $!");
        my $copy_mode = 1;
        while (<$ofd>) {
            if (/^N: Processing (binary|udeb|source) package (\S+) \(version (\S+), arch (\S+)\) \.\.\./o) {
                my ($type, $pkg, $ver, $arch) = ($1,$2, $3, $4);
                my $k = "$type:$pkg/$ver";
                $k .= "/$arch" if $type ne 'source';
                $copy_mode = 1;
                $copy_mode = 0 if exists $skip{$k};
            }
            if ($copy_mode) {
                print $nfd $_;
            }
        }
        print $nfd "N: ---end-of-old-lintian-log-file---\n";
        close $nfd;
        close $ofd;
        Log ('');
        if (@inc) {
            Log ('Creating work list for lintian');
            open my $lfd, '>', $list_file
                or Die ("opening $list_file: $!");
            foreach my $query (@inc) {
                Log (" - TODO - !query: $query\n");
                print $lfd "!query: $query\n";
            }
            close $lfd;
            Log ('');

            # incremental run cmd changes
            Log ('Running Lintian over newly introduced and changed packages...');
            $cmd .= " --packages-from-file $list_file >>$lintian_log 2>&1";
        } else {
            $cmd = undef;
            Log ('Skipping Lintian run - nothing to do...');
        }
    } else {
        # full run cmd changes
        Log('Running Lintian over all packages...');
        $cmd .= " -a >$lintian_log 2>&1";
    }

    if ($cmd) {
        Log("Executing $cmd");
        my $res = (system($cmd) >> 8);
        (($res == 0) or ($res == 1))
            or Log("warning: executing lintian returned $res");
        Log('');
    }
}

# create html reports
Log('Creating HTML reports...');
run("$html_reports_cmd $lintian_log >$html_reports_log 2>&1")
    or Log("warning: executing $html_reports_cmd returned " . (($? >> 8) & 0xff));
Log('');

# rotate the statistics file updated by $html_reports_cmd
if (-f $statistics_file) {
    system("cp $statistics_file $LOG_DIR/stats/statistics-`date +%Y%m%d`") == 0
        or Log('warning: could not rotate the statistics file');
}

# install new html directory
Log('Installing HTML reports...');
system("rm -rf $HTML_DIR") == 0
    or Die("error removing $HTML_DIR");
# a tiny bit of race right here
rename($HTML_TMP_DIR,$HTML_DIR)
    or Die("error renaming $HTML_TMP_DIR into $HTML_DIR");
Log('');

# ready!!! :-)
Log('All done.');
exit 0;

# -------------------------------

sub Log {
    print LOG $_[0],"\n";
}

sub run {
    Log("Executing $_[0]");
    return (system($_[0]) == 0);
}

sub Die {
    Log("fatal error: $_[0]");
    exit 1;
}

sub _trim_split {
    my ($val) = @_;
    return () unless $val;
    $val =~ s/^\s++//o;
    $val =~ s/\s++$//o;
    return split m/\s*+,\s*+/o, $val;
}

# local_mirror_manifests ($mirdir, $dists, $areas, $archs)
#
# Returns a list of manifests that represents what is on the local mirror
# at $mirdir.  3 manifests will be returned, one for "source", one for "binary"
# and one for "udeb" packages.  They are populated based on the "Sources" and
# "Packages" files.
#
# $mirdir - the path to the local mirror
# $dists  - listref of dists to consider (i.e. ['unstable'])
# $areas  - listref of areas to consider (i.e. ['main', 'contrib', 'non-free'])
# $archs  - listref of archs to consider (i.e. ['i386', 'amd64'])
#
sub local_mirror_manifests {
    my ($mirdir, $dists, $areas, $archs) = @_;
    my $srcman = Lintian::Lab::Manifest->new ('source');
    my $binman = Lintian::Lab::Manifest->new ('binary');
    my $udebman = Lintian::Lab::Manifest->new ('udeb');
    foreach my $dist (@$dists) {
        foreach my $area (@$areas) {
            my $srcs = "$mirdir/dists/$dist/$area/source/Sources";
            my $srcfd = _open_data_file ($srcs);
            my $srcsub = sub { _parse_srcs_pg ($srcman, $mirdir, $area, @_) };
            Util::_parse_dpkg_control_iterative ($srcsub, $srcfd);
            close $srcfd;
            # Binaries have a "per arch" file.
            foreach my $arch (@$archs) {
                my $pkgs = "$mirdir/dists/$dist/$area/binary-$arch/Packages";
                my $upkgs = "$mirdir/dists/$dist/$area/debian-installer/" .
                    "binary-$arch/Packages";
                my $pkgfd = _open_data_file ($pkgs);
                my $binsub = sub { _parse_pkgs_pg ($binman, $mirdir, $area, @_) };
                my $upkgfd = _open_data_file ($upkgs);
                my $udebsub = sub { _parse_pkgs_pg ($udebman, $mirdir, $area, @_) };
                Util::_parse_dpkg_control_iterative ($binsub, $pkgfd);
                Util::_parse_dpkg_control_iterative ($udebsub, $upkgfd);
                close $pkgfd;
                close $upkgfd;
            }
        }
    }
    return ($srcman, $binman, $udebman);
}

# _open_data_file ($file)
#
# Opens $file if it exists, otherwise it tries common extensions (i.e. .gz) and opens
# that instead.  It may pipe the file through a external decompressor, so the returned
# file descriptor cannot be assumed to be a file.
#
# If $file does not exists and no common extensions are found, this dies.  It may also
# die if it finds a file, but is unable to open it.
sub _open_data_file {
    my ($file) = @_;
    if (-e $file) {
        open my $fd, '<', $file or Die "opening $file: $!";
        return $fd;
    }
    foreach my $com (['gz', ['gzip', '-dc']] ){
        my ($ext, $cmd) = @$com;
        if ( -e "$file.$ext") {
            open my $c, '-|', @$cmd, "$file.$ext" or Die "running @$cmd $file.$ext";
            return $c;
        }
    }
    Die "Cannot find $file";
}

# Helper for local_mirror_manifests - it parses a paragraph from Packages file
sub _parse_pkgs_pg {
    my ($manifest, $mirdir, $area, $data) = @_;
    my $ts = 0;
    unless ($data->{'source'}) {
        $data->{'source'} = $data->{'package'};
    } elsif ($data->{'source'} =~ /^([-+\.\w]+)\s+\((.+)\)$/) {
        $data->{'source'} = $1;
        $data->{'source-version'} = $2;
    } else {
        $data->{'source-version'} = $data->{'version'};
    }
    unless (defined $data->{'source-version'}) {
        $data->{'source-version'} = $data->{'version'};
    }
    $data->{'file'} = $mirdir . '/' . $data->{'filename'};
    $data->{'area'} = $area;
    # $manifest strips redundant fields for us.  But for clarity and to
    # avoid "hard to debug" cases $manifest renames the fields, we explicitly
    # remove the "filename" field.
    delete $data->{'filename'};

    if (my @stat = stat $data->{'file'}) {
        $ts = $stat[9];
    }
    $data->{'timestamp'} = $ts;

    $manifest->set ($data);
}

# Helper for local_mirror_manifests - it parses a paragraph from Sources file
sub _parse_srcs_pg {
    my ($manifest, $mirdir, $area, $data) = @_;
    my $ts = 0;
    my $dir = $data->{'directory'}//'';
    $dir .= '/' if $dir;
    foreach my $f (split m/\n/, $data->{'files'}) {
        $f =~ s/^\s++//o;
        next unless $f && $f =~ m/\.dsc$/;
        my (undef, undef, $file) = split m/\s++/, $f;
        # $dir should end with a slash if it is non-empty.
        $data->{'file'} = $mirdir . "/$dir" . $file;
        last;
    }
    $data->{'area'} = $area;
    # Rename a field :)
    $data->{'source'} = $data->{'package'};

    if (my @stat = stat $data->{'file'}) {
        $ts = $stat[9];
    }
    $data->{'timestamp'} = $ts;

    # $manifest strips redundant fields for us.
    $manifest->set ($data);
}

# Local Variables:
# indent-tabs-mode: nil
# cperl-indent-level: 4
# End:
# vim: syntax=perl sw=4 sts=4 sr et
