Subject: [PATCH 5/5] Test that check scripts have Needs-info for each Lintian::Collect method it uses

From: Raphael Geissert <[email-masked]>
Date: Sat, 2 May 2009 17:55:51 -0500

Add a list of collection scripts needed on every Lintian::Collect::* method so
that it is possible to verify that check scripts using a given method do
declare the required collection scripts.
---
 lib/Lintian/Collect.pm         |    3 +
 lib/Lintian/Collect/Binary.pm  |    7 ++
 lib/Lintian/Collect/Source.pm  |    8 +++
 t/scripts/needs-info-exists.t  |   44 ++++++++++++++
 t/scripts/needs-info-missing.t |  125 ++++++++++++++++++++++++++++++++++++++++
 t/scripts/needs-info.t         |   44 --------------
 6 files changed, 187 insertions(+), 44 deletions(-)
 create mode 100755 t/scripts/needs-info-exists.t
 create mode 100755 t/scripts/needs-info-missing.t
 delete mode 100755 t/scripts/needs-info.t

diff --git a/lib/Lintian/Collect.pm b/lib/Lintian/Collect.pm
index 953d5a3..006f831 100644
--- a/lib/Lintian/Collect.pm
+++ b/lib/Lintian/Collect.pm
@@ -40,12 +40,14 @@ sub new {
 }
 
 # Return the package name.
+# sub name Needs-Info <>
 sub name {
     my ($self) = @_;
     return $self->{name};
 }
 
 # Return the package type.
+# sub type Needs-Info <>
 sub type {
     my ($self) = @_;
     return $self->{type};
@@ -55,6 +57,7 @@ sub type {
 # that field wasn't present in the control file for the package.  For source
 # packages, this is the *.dsc file; for binary packages, this is the control
 # file in the control section of the package.
+# sub field Needs-Info <>
 sub field {
     my ($self, $field) = @_;
     return $self->{field}{$field} if exists $self->{field}{$field};
diff --git a/lib/Lintian/Collect/Binary.pm b/lib/Lintian/Collect/Binary.pm
index 2e1ec38..144e45d 100644
--- a/lib/Lintian/Collect/Binary.pm
+++ b/lib/Lintian/Collect/Binary.pm
@@ -40,6 +40,7 @@ sub new {
 
 # Returns whether the package is a native package according to
 # its version number
+# sub native Needs-Info <>
 sub native {
     my ($self) = @_;
     return $self->{native} if exists $self->{native};
@@ -53,6 +54,7 @@ sub native {
 sub changelog {
     my ($self) = @_;
     return $self->{changelog} if exists $self->{changelog};
+    # sub changelog Needs-Info changelog-file
     if (-l 'changelog' || ! -f 'changelog') {
         $self->{changelog} = undef;
     } else {
@@ -64,6 +66,7 @@ sub changelog {
 
 # Returns the information from the indices
 # FIXME: should maybe return an object
+# sub index Needs-Info <>
 sub index {
     my ($self) = @_;
     return $self->{index} if exists $self->{index};
@@ -125,6 +128,7 @@ sub file_info {
     return $self->{file_info} if exists $self->{file_info};
 
     my %file_info;
+    # sub file_info Needs-Info file-info
     open(my $idx, '<', "file-info")
         or fail("cannot open file-info: $!");
     while (<$idx>) {
@@ -150,6 +154,7 @@ sub scripts {
     return $self->{scripts} if exists $self->{scripts};
 
     my %scripts;
+    # sub scripts Needs-Info scripts
     open(SCRIPTS, '<', "scripts")
 	or fail("cannot open scripts file: $!");
     while (<SCRIPTS>) {
@@ -179,6 +184,7 @@ sub objdump_info {
 
     my %objdump_info;
     my ($dynsyms, $file);
+    # sub objdump_info Needs-Info objdump-info
     open(my $idx, '<', "objdump-info")
         or fail("cannot open objdump-info: $!");
     while (<$idx>) {
@@ -261,6 +267,7 @@ sub objdump_info {
 # field names are supported: all (pre-depends, depends, recommends, and
 # suggests), strong (pre-depends and depends), and weak (recommends and
 # suggests).
+# sub relation Needs-Info <>
 sub relation {
     my ($self, $field) = @_;
     $field = lc $field;
diff --git a/lib/Lintian/Collect/Source.pm b/lib/Lintian/Collect/Source.pm
index e34789f..b381944 100644
--- a/lib/Lintian/Collect/Source.pm
+++ b/lib/Lintian/Collect/Source.pm
@@ -41,6 +41,7 @@ sub new {
 
 # Get the changelog file of a source package as a Parse::DebianChangelog
 # object.  Returns undef if the changelog file couldn't be found.
+# sub changelog Needs-Info <>
 sub changelog {
     my ($self) = @_;
     return $self->{changelog} if exists $self->{changelog};
@@ -57,6 +58,7 @@ sub changelog {
 # format 3.0 (quilt) packages, we base this on whether we have a Debian
 # *.diff.gz file.  3.0 (quilt) packages are always non-native.  Returns true
 # if the package is native and false otherwise.
+# sub native Needs-Info <>
 sub native {
     my ($self) = @_;
     return $self->{native} if exists $self->{native};
@@ -78,6 +80,7 @@ sub binaries {
     my ($self) = @_;
     return $self->{binaries} if exists $self->{binaries};
     my %binaries;
+    # sub binaries Needs-Info source-control-file
     opendir(BINPKGS, 'control') or fail("can't open control directory: $!");
     for my $package (readdir BINPKGS) {
         next if $package =~ /^\.\.?$/;
@@ -97,6 +100,7 @@ sub binary_field {
     return $self->{binary_field}{$package}{$field}
         if exists $self->{binary_field}{$package}{$field};
     my $value = '';
+    # sub binary_field Needs-Info source-control-file
     if (-f "control/$package/$field") {
         $value = slurp_entire_file("control/$package/$field");
         chomp $value;
@@ -123,6 +127,7 @@ sub binary_relation {
     if ($special{$field}) {
         my $merged;
         for my $f (@{ $special{$field} }) {
+	    # sub binary_relation Needs-Info :binary_field
             my $value = $self->binary_field($f);
             $merged .= ', ' if (defined($merged) and defined($value));
             $merged .= $value if defined($value);
@@ -147,6 +152,7 @@ sub file_info {
     return $self->{file_info} if exists $self->{file_info};
 
     my %file_info;
+    # sub file_info Needs-Info file-info
     open(my $idx, '<', "file-info") or fail("cannot open file-info: $!");
     while (<$idx>) {
         chomp;
@@ -166,6 +172,7 @@ sub file_info {
 # following special field names are supported:  build-depends-all
 # (build-depends and build-depends-indep) and build-conflicts-all
 # (build-conflicts and build-conflicts-indep).
+# sub relation Needs-Info <>
 sub relation {
     my ($self, $field) = @_;
     $field = lc $field;
@@ -194,6 +201,7 @@ sub relation {
 # Similar to relation(), return a Lintian::Relation object for the given build
 # relationship field, but ignore architecture restrictions.  It supports the
 # same special field names.
+# sub relation_noarch Needs-Info <>
 sub relation_noarch {
     my ($self, $field) = @_;
     $field = lc $field;
diff --git a/t/scripts/needs-info-exists.t b/t/scripts/needs-info-exists.t
new file mode 100755
index 0000000..104193f
--- /dev/null
+++ b/t/scripts/needs-info-exists.t
@@ -0,0 +1,44 @@
+#!/usr/bin/perl
+
+# Copyright (C) 2009 by Raphael Geissert <[email-masked]>
+# Copyright (C) 2009 Russ Allbery <[email-masked]>
+#
+# This file 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 file 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 file.  If not, see <http://www.gnu.org/licenses/>.
+
+use strict;
+
+use Test::More;
+use Util qw(read_dpkg_control);
+
+# Find all of the desc files in either collection or checks.  We'll do one
+# check per description.
+our @DESCS = (<$ENV{LINTIAN_ROOT}/collection/*.desc>,
+              <$ENV{LINTIAN_ROOT}/checks/*.desc>);
+plan tests => scalar(@DESCS);
+
+# For each desc file, load the first stanza of the file and check that all of
+# its Needs-Info script references exist.
+for my $desc (@DESCS) {
+    my ($header) = read_dpkg_control($desc);
+    my @needs = split(/\s*,\s*/, $header->{'needs-info'} || '');
+    my @missing;
+    for my $coll (@needs) {
+        unless (-f "$ENV{LINTIAN_ROOT}/collection/$coll") {
+            push(@missing, $coll);
+        }
+    }
+    my $short = $desc;
+    $short =~ s/^\Q$ENV{LINTIAN_ROOT}//;
+    is(join(', ', @missing), '', "$short has valid needs-info");
+}
diff --git a/t/scripts/needs-info-missing.t b/t/scripts/needs-info-missing.t
new file mode 100755
index 0000000..cd0a073
--- /dev/null
+++ b/t/scripts/needs-info-missing.t
@@ -0,0 +1,125 @@
+#!/usr/bin/perl
+
+# Copyright (C) 2009 by Raphael Geissert <[email-masked]>
+# Copyright (C) 2009 Russ Allbery <[email-masked]>
+#
+# This file 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 file 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 file.  If not, see <http://www.gnu.org/licenses/>.
+
+use strict;
+
+use Test::More;
+use Util qw(read_dpkg_control slurp_entire_file);
+
+# Find all of the desc files in checks.  We'll do one check per description.
+our @DESCS = (<$ENV{LINTIAN_ROOT}/checks/*.desc>);
+our @MODULES = (<$ENV{LINTIAN_ROOT}/lib/Lintian/Collect.pm>,
+		<$ENV{LINTIAN_ROOT}/lib/Lintian/Collect/*.pm>);
+
+plan tests => scalar(@DESCS)+scalar(@MODULES);
+
+my %needs_info;
+
+# Build the Needs-Info hash from the Collect modules
+for my $module (@MODULES) {
+    my $pretty_module = $module;
+    $pretty_module =~ s,^\Q$ENV{LINTIAN_ROOT}/lib/,,;
+    open(PM, '<', $module) or die("Could not open module $pretty_module");
+    my (%seen_subs, %seen_needsinfo, @errors, @warnings);
+    while (<PM>) {
+	if (m/^\s*sub\s+(\w+)/) {
+	    $seen_subs{$1} = 1;
+	}
+	if (m/^\s*#\s*sub\s+(\w+)\s+Needs-Info\s+(.*)$/) {
+	    my ($sub, $all_info) = ($1, $2);
+	    $seen_needsinfo{$sub} = 1;
+	    $all_info =~ s/\s//g;
+	    $all_info =~ s/,,/,/g;
+	    if (!$all_info) {
+		push @errors, "$sub has empty needs-info\n";
+		next;
+	    }
+	    $all_info =~ s/^<>$//;
+	    if (exists($needs_info{$sub})) {
+		if ($all_info ne $needs_info{$sub}) {
+		    push @warnings, "$sub already defined but values don't match:\n"
+				. "\t'$all_info' ($pretty_module) ne '$needs_info{$sub}'\n";
+		    $needs_info{$sub} .= " or $all_info";
+		}
+	    } else {
+		$needs_info{$sub} = $all_info;
+	    }
+	}
+    }
+    close(PM);
+    if (scalar(@errors)) {
+	ok(0, "$pretty_module has per-method needs-info") or diag(@errors);
+	diag("\n", @warnings) if (@warnings);
+	next;
+    }
+    for my $sub (keys %seen_subs) {
+	if (exists($seen_needsinfo{$sub})) {
+	    delete $seen_needsinfo{$sub};
+	    delete $seen_subs{$sub};
+	}
+    }
+
+    delete $seen_subs{'new'};
+
+    is(scalar(keys(%seen_subs)) + scalar(keys(%seen_needsinfo)), 0,
+	"$pretty_module has per-method needs-info") or
+	diag("Subs missing info: ", join(', ', keys(%seen_subs)), "\n",
+	     "Info for unknown subs: ", join(', ', keys(%seen_needsinfo)),"\n");
+
+    diag("\n", @warnings) if @warnings;
+}
+
+for my $desc (@DESCS) {
+    my ($header) = read_dpkg_control($desc);
+    my %needs = map { $_ => 1 } split(/\s*,\s*/, $header->{'needs-info'} || '');
+
+    if ($desc =~ m/lintian\.desc$/) {
+	pass("lintian.desc doesn't have missing needs-info for Lintian::Collect");
+	next;
+    }
+
+    my ($check) = split(/\.desc$/, $desc);
+    my $code =slurp_entire_file($check);
+    my %subs;
+    while ($code =~ s/\$info\s*->\s*(\w+)//) {
+	$subs{$1} = 1;
+    }
+
+    my @warnings;
+    my $missing = 0;
+
+    for my $sub (keys %subs) {
+	if (exists($needs_info{$sub})) {
+	    # TODO: try to satisfy either branch when an 'or' exists
+	    next if ($needs_info{$sub} =~ m/ or /);
+	    for my $needed (split(/,/, $needs_info{$sub})) {
+		unless (exists($needs{$needed})) {
+		    $missing++;
+		    push @warnings, "$sub needs $needed\n";
+		}
+	    }
+	} else {
+	    push @warnings, "Unknown method \$info->$sub\n";
+	}
+    }
+
+    my $short = $desc;
+    $short =~ s,^\Q$ENV{LINTIAN_ROOT}/checks/,,;
+    is($missing, 0, "$short doesn't have missing needs-info for Lintian::Collect") or
+	diag(@warnings);
+}
diff --git a/t/scripts/needs-info.t b/t/scripts/needs-info.t
deleted file mode 100755
index 104193f..0000000
--- a/t/scripts/needs-info.t
+++ /dev/null
@@ -1,44 +0,0 @@
-#!/usr/bin/perl
-
-# Copyright (C) 2009 by Raphael Geissert <[email-masked]>
-# Copyright (C) 2009 Russ Allbery <[email-masked]>
-#
-# This file 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 file 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 file.  If not, see <http://www.gnu.org/licenses/>.
-
-use strict;
-
-use Test::More;
-use Util qw(read_dpkg_control);
-
-# Find all of the desc files in either collection or checks.  We'll do one
-# check per description.
-our @DESCS = (<$ENV{LINTIAN_ROOT}/collection/*.desc>,
-              <$ENV{LINTIAN_ROOT}/checks/*.desc>);
-plan tests => scalar(@DESCS);
-
-# For each desc file, load the first stanza of the file and check that all of
-# its Needs-Info script references exist.
-for my $desc (@DESCS) {
-    my ($header) = read_dpkg_control($desc);
-    my @needs = split(/\s*,\s*/, $header->{'needs-info'} || '');
-    my @missing;
-    for my $coll (@needs) {
-        unless (-f "$ENV{LINTIAN_ROOT}/collection/$coll") {
-            push(@missing, $coll);
-        }
-    }
-    my $short = $desc;
-    $short =~ s/^\Q$ENV{LINTIAN_ROOT}//;
-    is(join(', ', @missing), '', "$short has valid needs-info");
-}