[SCM] Debian package checker branch, master, updated. 2.2.10-81-gf594b61
The following commit has been merged in the master branch:
commit 48539d51c6e731ecc765d52cd3e4373932e35601
Author: Raphael Geissert <atomo64@gmail.com>
Date: Sat May 2 17:55:51 2009 -0500
Test that checks/* have Needs-info for used Lintian::Collect methods
Add a list of collection scripts needed for every Lintian::Collect::*
method so that it is possible to verify that check scripts using a given
method declare the required collection scripts.
diff --git a/lib/Lintian/Collect.pm b/lib/Lintian/Collect.pm
index 599c415..e9765d0 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 c3559dd..fbfe053 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 f362daa..20485e9 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.t b/t/scripts/needs-info-exists.t
similarity index 100%
rename from t/scripts/needs-info.t
rename to t/scripts/needs-info-exists.t
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 <atomo64@gmail.com>
+# Copyright (C) 2009 Russ Allbery <rra@debian.org>
+#
+# 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);
+}
--
Debian package checker
Reply to: