# patch-systems -- lintian check script -*- perl -*-
#
# Copyright (C) 2007 Marc Brockschmidt
# Copyright (C) 2008 Raphael Hertzog
#
# This program is free software; you can redistribute it and/or modify
# it 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.

package Lintian::patch_systems;
use strict;

use Lintian::Tags qw(tag);
use Util;
use Cwd qw(realpath);

sub run {
    my ($pkg, $type, $info) = @_;

    #Some (cruft) checks are valid for every patch system, so we need to record that:
    my $uses_patch_system = 0;

    #Get build deps so we can decide which build system the maintainer
    #meant to use:
    my $build_deps = $info->relation('build-depends-all');
    # Get source package format
    my $format = "";
    if (defined $info->field('format')) {
        $format = $info->field('format');
    }
    my $quilt_format = ($format =~ /3\.\d+ \(quilt\)/) ? 1 : 0;

    my $droot = realpath($info->debfiles);
    my $dpdir = "$droot/patches";

    #----- dpatch
    if ($build_deps->implies("dpatch")) {
        $uses_patch_system++;
        #check for a debian/patches file:
        if (! -r "$dpdir/00list") {
            tag 'dpatch-build-dep-but-no-patch-list';
        } else {
            my $list_uses_cpp = 0;
            if (open(OPTS, '<', "$dpdir/00options")) {
                while(<OPTS>) {
                    if (/DPATCH_OPTION_CPP=1/) {
                        $list_uses_cpp = 1;
                        last;
                    }
                }
                close(OPTS);
            }
            foreach my $listfile (glob("$dpdir/00list*")) {
                my @patches;
                if (open(IN, '<', $listfile)) {
                    while(<IN>) {
                        chomp;
                        next if (/^\#/); #ignore comments or CPP directive
                        s%//.*%% if $list_uses_cpp; # remove C++ style comments
                        if ($list_uses_cpp && m%/\*%) {
                            # remove C style comments
                            $_ .= <IN> while($_ !~ m%\*/%);
                            s%/\*[^*]*\*/%%g;
                        }
                        next if (/^\s*$/); #ignore blank lines
                        push @patches, split(' ', $_);
                    }
                    close(IN);
                }

                # Check each patch.
                foreach my $patch_file (@patches) {
                    $patch_file .= '.dpatch' if -e "$dpdir/$patch_file.dpatch"
                        and not -e "$dpdir/$patch_file";
                    next if ( -l "$dpdir/$patch_file" );
                    unless (realpath("$dpdir/$patch_file") =~ m,^\Q$droot/,) {
                        next;
                    }
                    if (! -r "$dpdir/$patch_file") {
                        tag 'dpatch-index-references-non-existent-patch', $patch_file;
                        next;
                    }
                    if (open(PATCH_FILE, '<', "$dpdir/$patch_file")) {
                        my $has_comment = 0;
                        while (<PATCH_FILE>) {
                            #stop if something looking like a patch starts:
                            last if /^---/;
                            #note comment if we find a proper one
                            $has_comment = 1 if (/^\#+\s*DP:\s*(\S.*)$/ && $1 !~ /^no description\.?$/i);
                            $has_comment = 1 if (/^\# (?:Description|Subject)/);
                        }
                        close(PATCH_FILE);
                        unless ($has_comment) {
                            tag "dpatch-missing-description", $patch_file;
                        }
                    }
                    check_patch($dpdir, $patch_file);
                }
            }
        }
    }

    #----- quilt
    if ($build_deps->implies("quilt") or $quilt_format) {
        $uses_patch_system++;
        if($quilt_format && $build_deps->implies("quilt")){
            tag "unneeded-build-dep-on-quilt";
        }
        #check for a debian/patches file:
        if (! -r "$dpdir/series") {
            tag 'quilt-build-dep-but-no-series-file' unless $quilt_format;
        } else {
            if (open(IN, '<', "$dpdir/series")) {
                my @patches;
                my @badopts;
                while(<IN>) {
                    chomp; s/^\s+//; s/\s+$//; # Strip leading/trailing spaces
                    s/(^|\s+)#.*$//; # Strip comment
                    next unless $_;
                    if (/^(\S+)\s+(\S.*)$/) {
                        $_ = $1;
                        if ($2 ne '-p1') {
                            push @badopts, $_;
                        }
                    }
                    push @patches, $_;
                }
                close(IN);
                if (scalar(@badopts)) {
                    tag "quilt-patch-with-non-standard-options", @badopts;
                }

                # Check each patch.
                foreach my $patch_file (@patches) {
                    next if ( -l "$dpdir/$patch_file" );
                    unless (realpath("$dpdir/$patch_file") =~ m,^\Q$droot\E/,) {
                        next;
                    }
                    if (! -r "$dpdir/$patch_file") {
                        tag 'quilt-series-references-non-existent-patch', $patch_file;
                        next;
                    }
                    if (open(PATCH_FILE, '<', "$dpdir/$patch_file")) {
                        my $has_description = 0;
                        while (<PATCH_FILE>) {
                            # stop if something looking like a patch starts:
                            last if /^---/;
                            next if /^\s*$/;
                            # Skip common "lead-in" lines
                            $has_description = 1 unless (/^(Index: |=+$|diff .+|index )/);
                        }
                        close(PATCH_FILE);
                        unless ($has_description) {
                            tag "quilt-patch-missing-description", $patch_file;
                        }
                    }
                    check_patch($dpdir, $patch_file);
                }
            }
        }
        if ($quilt_format) { # 3.0 (quilt) specific checks
            # Format 3.0 packages may generate a debian-changes-$version patch
            my $version = $info->field('version');
            if (-f "$dpdir/debian-changes-$version" &&
            ! -f "$droot/source/patch-header") {
            tag 'format-3.0-but-debian-changes-patch';
            }
        }
    } else {
        if (-r "$dpdir/series" and
            -f "$dpdir/series") {
            # 3.0 (quilt) sources don't need quilt as dpkg-source will do the work
            tag 'quilt-series-but-no-build-dep' unless $quilt_format;
        }
    }

    #----- look for README.source
    if ($uses_patch_system && ! $quilt_format && ! -f "$droot/README.source") {
        tag "patch-system-but-no-source-readme";
    }

    #----- general cruft checking:
    if ($uses_patch_system > 1) {
        tag "more-than-one-patch-system";
    }
    my @direct;
    open(STAT, '<', $info->diffstat) or fail("cannot open diffstat file: $!");
    while (<STAT>) {
        my ($file) = (m,^\s+(.*?)\s+\|,)
             or fail("syntax error in diffstat file: $_");
        push (@direct, $file) if ($file !~ m,^debian/,);
    }
    close (STAT) or fail("error reading diffstat file: $!");
    if (@direct) {
        my $files = (@direct > 1) ? "$direct[0] and $#direct more" : $direct[0];

        tag "patch-system-but-direct-changes-in-diff", $files
            if ($uses_patch_system);
        tag "direct-changes-in-diff-but-no-patch-system", $files
            if (not $uses_patch_system);
    }
}

# Checks on patches common to all build systems.
sub check_patch {
    my ($dpdir, $patch_file) = @_;

    # Use --strip=1 to strip off the first layer of directory in case the parent
    # directory in which the patches were generated was named "debian".
    # This will produce false negatives for --strip=0 patches that modify files
    # in the debian/* directory, but as of 2010-01-01, all cases where the
    # first level of the patch path is "debian/" in the archive are false
    # positives.
    open(my $fd, '-|', 'lsdiff', '--strip=1', "$dpdir/$patch_file")
      or fail('cannot fork lsdiff');
    while (<$fd>) {
        chomp;
        if (m|^(?:\./)?debian/|o) {
            tag 'patch-modifying-debian-files', $patch_file, $_;
        }
    }
    close($fd) or fail("cannot close pipe to lsdiff on $patch_file: $!");
}

1;

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