[SCM] Debian package checker branch, master, updated. 2.5.10-214-g527df0f
The following commit has been merged in the master branch:
commit 527df0f9802fe34f596d88f22e04e1c3b5ed1204
Author: Niels Thykier <niels@thykier.net>
Date: Sun Oct 21 11:25:12 2012 +0200
Test::Lintian: New module to assist test writing
Rename tags.t to check-descs.t and move all of its code into
Test::Lintian, so others may reuse our test code for their own checks.
Also correct two issues in the manual about the check desc file.
Signed-off-by: Niels Thykier <niels@thykier.net>
diff --git a/doc/lintian.xml b/doc/lintian.xml
index d2b4c4a..fbe490d 100644
--- a/doc/lintian.xml
+++ b/doc/lintian.xml
@@ -1276,7 +1276,7 @@ foo [!any-i386] binary: some-tag-not-for-i386 optional-extra
</listitem>
</varlistentry>
<varlistentry>
- <term><emphasis>Needs-Info</emphasis> (simple, mandatory)</term>
+ <term><emphasis>Needs-Info</emphasis> (simple, optional)</term>
<listitem>
<para>
Comma separated list of collections required for the
@@ -1327,6 +1327,7 @@ foo [!any-i386] binary: some-tag-not-for-i386 optional-extra
Name of the tag. It must consist entirely of the
lower or/and upper case characters ([a-zA-Z]),
digits ([0-9]), underscore (_), dash (-) and period (.).
+ The tag name should be at most 68 characters long.
</para>
</listitem>
</varlistentry>
diff --git a/lib/Test/Lintian.pm b/lib/Test/Lintian.pm
new file mode 100644
index 0000000..8d298a4
--- /dev/null
+++ b/lib/Test/Lintian.pm
@@ -0,0 +1,220 @@
+# Copyright (C) 1998 Richard Braakman
+# Copyright (C) 2012 Niels Thykier
+#
+# 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 Test::Lintian;
+
+=head1 NAME
+
+Test::Lintian -- Check Lintian files for issues
+
+=head1 SYNOPSIS
+
+ use Test::Lintian;
+ use Test::More import => ['done_testing'];
+
+ load_profile_for_test ('vendor/profile', 'some/path/', '/usr/share/lintian');
+ test_check_desc (<./checks/vendor/*.desc>);
+
+ done_testing;
+
+=head1 DESCRIPTION
+
+A testing framework for testing various Lintian files for common
+errors.
+
+=cut
+
+use strict;
+use warnings;
+
+my $CLASS = __PACKAGE__;
+my $PROFILE = undef;
+our @EXPORT = qw(load_profile_for_test test_check_desc);
+
+use base 'Test::Builder::Module';
+
+use Lintian::Check qw(check_spelling);
+use Lintian::Data;
+use Lintian::Profile;
+use Lintian::Tags;
+use Lintian::Util qw(read_dpkg_control);
+
+my %severities = map { $_ => 1 } @Lintian::Tags::SEVERITIES;
+my %certainties = map { $_ => 1 } @Lintian::Tags::CERTAINTIES;
+my %check_types = map { $_ => 1 } qw(binary changes source udeb);
+my %known_html_tags = map { $_ => 1 } qw(a em i tt);
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item test_check_desc ([OPTS, ]DESCFILES...)
+
+Test check desc files (and the tags in them) for common errors.
+
+OPTS is an optional HASHREF that determines if some of the tests
+are optional or not. Currently it is unused.
+
+DESCFILES is a list of paths to check desc files.
+
+As the number tests depend on the number of tags in desc, it is
+difficult to "plan ahead" when using this test. It is therefore
+recommended to not specify a plan and use done_testing().
+
+This sub uses a Data file (see L</load_profile_for_test ([PROFNAME[, INC...]])>).
+
+=cut
+
+sub test_check_desc {
+ my ($opts, @descs);
+ my $builder = $CLASS->builder;
+
+ if (ref $_[0] eq 'HASH') {
+ $opts = shift;
+ }
+ $opts //= {};
+ @descs = @_;
+ load_profile_for_test ();
+
+ foreach my $desc_file (@descs) {
+ my ($header, @tagpara) = read_dpkg_control ($desc_file);
+ my $cname = $header->{'check-script'}//'';
+ my $ctype = $header->{'type'} // '';
+ my $cinfo = $header->{'info'} // '';
+ my $i = 1; # paragraph counter.
+ $builder->isnt_eq ($cname, '', "Check has a name ($desc_file)");
+ $cname = '<missing>' if $cname eq '';
+
+ if ($cname eq 'lintian') {
+ # skip these two tests for this special case...
+ $builder->skip ('Special case, check "lintian" does not have a type');
+ $builder->skip ('Special case, check "lintian" does not have a type');
+ } elsif ($builder->isnt_eq ($ctype, '', "$cname has a type")) {
+ my @bad = ();
+ # new lines are not allowed, map them to "\\n" for readability.
+ $ctype =~ s/\n/\\n/go;
+ foreach my $type (split m/\s*+,\s*+/o, $ctype) {
+ push @bad, $type unless exists $check_types{$type};
+ }
+ $builder->is_eq (join (', ', @bad), '', "The type of $cname is valid");
+ } else {
+ $builder->skip ("Cannot check type of $cname is valid (field is empty/missing)");
+ }
+
+ $builder->is_eq (check_spelling (undef, $cinfo), 0,
+ "$cname Info has no spelling errors");
+
+ foreach my $tpara (@tagpara) {
+ my $tag = $tpara->{'tag'}//'';
+ my $severity = $tpara->{'severity'}//'';
+ my $certainty = $tpara->{'certainty'}//'';
+ my $info = $tpara->{'info'} // '';
+ my @htmltags = ();
+ my %seen = ();
+
+ $i++;
+
+ # Tag name
+ $builder->isnt_eq ($tag, '', "Tag in check $cname has a name")
+ or $builder->diag ("$cname: Paragraph number $i\n");
+ $tag = '<N/A>' if $tag eq '';
+ $builder->ok ($tag =~ /^[\w0-9.+-]+$/, 'Tag has valid characters')
+ or $builder->diag ("$cname: $tag\n");
+ $builder->cmp_ok (length $tag, '<=', 68, 'Tag is not too long')
+ or $builder->diag ("$cname: $tag\n");
+
+ # Severity / Certainty
+ $builder->ok (!$severity || exists $severities{$severity}, 'Tag has valid severity')
+ or $builder->diag ("$cname: $tag severity: $severity\n");
+ $builder->ok (!$certainty || exists $certainties{$certainty}, 'Tag has valid certainty')
+ or $builder->diag ("$cname: $tag certainty: $certainty\n");
+
+ # Info
+ $builder->is_eq (check_spelling (undef, $info), 0,
+ "$cname: $tag has no spelling errors");
+
+ # Check the tag info for unescaped <> or for unknown tags (which
+ # probably indicate the same thing).
+ while ($info =~ s,<([^\s>]+)(?:\s+href=\"[^\"]+\")?>.*?</\1>,,s) {
+ push @htmltags, $1;
+ }
+ @htmltags = grep { !exists $known_html_tags{$_} && !$seen{$_}++ } @htmltags;
+ $builder->is_eq (join (', ', @htmltags), '', 'Tag info has no unknown html tags')
+ or $builder->diag ("$cname: $tag\n");
+
+ $builder->ok ($info !~ /[<>]/, 'Tag info has no stray angle brackets')
+ or $builder->diag ("$cname: $tag\n");
+
+ # TODO: Implement check of Ref (?)
+ }
+ }
+}
+
+=item load_profile_for_test ([PROFNAME[, INC...]])
+
+Load a Lintian::Profile and ensure Data files can be used. This is
+needed if the test needs to access a data file or if a special profile
+is needed for the test. It does I<not> test the profile for issues.
+
+PROFNAME is the name of the profile to load. It can be omitted, in
+which case the sub ensures that a profile has been loaded. If no
+profile has been loaded, 'debian/main' will be loaded.
+
+INC is a list of extra "include dirs" (or Lintian "roots") to be used
+for finding the profile. If not specified, it defaults to
+I<$ENV{'LINTIAN_ROOT'}> and I</usr/share/lintian> (in order). INC
+is ignored if a profile has already been loaded.
+
+CAVEAT: Only one profile can be loaded in a given test. Once a
+profile has been loaded, it is not possible to replace it with another
+one. So if this is invoked multiple times, PROFNAME must be omitted
+or must match the name of the loaded profile.
+
+=cut
+
+sub load_profile_for_test {
+ my ($profname, @inc) = @_;
+
+ # We have loaded a profile and are not asked to
+ # load a specific one - then current one will do.
+ return if $PROFILE and not $profname;
+
+ die "Cannot load two profiles.\n"
+ if $PROFILE and $PROFILE->name ne $profname;
+
+ return if $PROFILE; # Already loaded? stop here
+ # We just need it for spell checking, so debian/main should
+ # do just fine...
+ $profname ||= 'debian/main';
+
+ unless (@inc) {
+ push @inc, $ENV{'LINTIAN_ROOT'} if $ENV{'LINTIAN_ROOT'};
+ push @inc, '/usr/share/lintian' if -d '/usr/share/lintian';
+ }
+
+ $PROFILE = Lintian::Profile->new ($profname, \@inc);
+ Lintian::Data->set_vendor ($PROFILE);
+}
+
+
+=back
+
+=cut
+
+1;
diff --git a/collection/init.d b/t/scripts/check-descs.t
similarity index 52%
copy from collection/init.d
copy to t/scripts/check-descs.t
index ddc27d2..28e6654 100755
--- a/collection/init.d
+++ b/t/scripts/check-descs.t
@@ -1,18 +1,17 @@
-#!/usr/bin/perl -w
-# init.d -- lintian collector script
+#!/usr/bin/perl
-# Copyright (C) 1998 Richard Braakman
-#
+# Copyright (C) 2012 Niels Thykier
+#
# 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
@@ -22,27 +21,11 @@
use strict;
use warnings;
-use lib "$ENV{'LINTIAN_ROOT'}/lib";
-use Lintian::Util qw(copy_dir delete_dir fail);
+use Test::More import => ['done_testing'];
+use Test::Lintian;
-($#ARGV == 2) or fail('syntax: init.d <pkg> <type> <dir>');
-my ($pkg, $type, $dir) = @ARGV;
+load_profile_for_test ('debian/main', $ENV{'LINTIAN_ROOT'});
-if (-e "$dir/init.d") {
- delete_dir ("$dir/init.d")
- or fail('cannot rm old init.d directory');
-}
+test_check_desc (<$ENV{'LINTIAN_ROOT'}/checks/*.desc>);
-if (-d "$dir/unpacked/etc/init.d") {
- copy_dir("$dir/unpacked/etc/init.d", "$dir/init.d")
- or fail('cannot copy init.d directory');
-} else {
- # no etc/init.d
- mkdir ("$dir/init.d", 0777) or fail "cannot mkdir init.d: $!";
-}
-
-# Local Variables:
-# indent-tabs-mode: nil
-# cperl-indent-level: 4
-# End:
-# vim: syntax=perl sw=4 sts=4 sr et
+done_testing;
diff --git a/t/scripts/tags.t b/t/scripts/tags.t
deleted file mode 100755
index 61d6574..0000000
--- a/t/scripts/tags.t
+++ /dev/null
@@ -1,84 +0,0 @@
-#!/usr/bin/perl
-
-# Copyright (C) 1998 Richard Braakman
-#
-# 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.
-
-use strict;
-use warnings;
-
-use Test::More qw(no_plan);
-
-use Lintian::Check qw(check_spelling);
-use Lintian::Data;
-use Lintian::Profile;
-use Lintian::Tags ();
-use Lintian::Util qw(read_dpkg_control);
-
-my $vendor = Lintian::Profile->new ('debian/main',
- [$ENV{'LINTIAN_ROOT'}]);
-my @DESCS = <$ENV{'LINTIAN_ROOT'}/checks/*.desc>;
-
-my %severities = map { $_ => 1 } 'pedantic', @Lintian::Tags::SEVERITIES;
-my %certainties = map { $_ => 1 } @Lintian::Tags::CERTAINTIES;
-
-Lintian::Data->set_vendor ($vendor);
-
-for my $desc_file (@DESCS) {
- for my $i (read_dpkg_control($desc_file)) {
- $desc_file =~ s#.*/##;
- if (exists $i->{'tag'}) {
- ok($i->{'tag'} =~ /^[\w0-9.+-]+$/, "Tag has valid characters")
- or diag("$desc_file: $i->{'tag'}\n");
- ok(exists $i->{'info'}, "Tag has info")
- or diag("$desc_file: $i->{'tag'}\n");
- cmp_ok(length($i->{'tag'}), '<=', 68, "Tag is not too long")
- or diag("$desc_file: $i->{'tag'}\n");
-
- my $info = $i->{'info'} || '';
-
- is(check_spelling(undef, $info), 0,
- "$desc_file: $i->{'tag'} has no spelling errors");
-
- # Check the tag info for unescaped <> or for unknown tags (which
- # probably indicate the same thing).
- my @tags;
- while ($info =~ s,<([^\s>]+)(?:\s+href=\"[^\"]+\")?>.*?</\1>,,s) {
- push (@tags, $1);
- }
- my %known = map { $_ => 1 } qw(a em i tt);
- my %seen;
- @tags = grep { !$known{$_} && !$seen{$_}++ } @tags;
- is(join(', ', @tags), '', 'Tag info has unknown html tags')
- or diag("$desc_file: $i->{'tag'}\n");
-
- ok($info !~ /[<>]/, "Tag info has no stray angle brackets")
- or diag("$desc_file: $i->{'tag'}\n");
-
- my $severity = $i->{'severity'};
- my $certainty = $i->{'certainty'};
- ok(!$severity || exists $severities{$severity}, "Tag has valid severity")
- or diag("$desc_file: $i->{'tag'} severity: $severity\n");
- ok(!$certainty || exists $certainties{$certainty}, "Tag has valid certainty")
- or diag("$desc_file: $i->{'tag'} certainty: $certainty\n");
- ok($severity, "Tag has severity")
- or diag("$desc_file: $i->{'tag'}");
- ok($certainty, "Tag has certainty")
- or diag("$desc_file: $i->{'tag'}");
- }
- }
-}
--
Debian package checker
Reply to: