Lintian: On using perltidy
Hi,
I believe Russ mentioned perltidy (way) earlier in the thread we had on
changing the code style of Lintian. Today, I was asked by Michael
Stapelberg why we didn't use perltidy and be done with most of the style
issues.
In light of that, I have prepared a perltidyrc (attached) based on the
one from Russ Allbery's rra-c-util repository - with the addition of
"-bar", which I think (but I might be wrong) is closer to the style
proposed.
I have also attached the changes to some checks as done by perltidy with
the aforementioned perltidyrc file. Comments greatly appreciated (also,
my experience with perltidy can be measured in minutes, so if you have
more experience, suggestions are very welcome).
~Niels
# -*- conf -*-
#
# Default options for perltidy for proper Perl code reformatting.
#
# The canonical version of this file is maintained in the rra-c-util package,
# which can be found at <http://www.eyrie.org/~eagle/software/rra-c-util/>.
-bbao # put line breaks before any operator
-nbbc # don't force blank lines before comments (bad for else blocks)
-ce # cuddle braces around else
-l=79 # usually use 78, but don't want 79-long lines reformatted
-pt=2 # don't add extra whitespace around parentheses
-sbt=2 # ...or square brackets
-sfs # no space before semicolon in for (not that I use this form)
-bar # opening-brace-always-on-right
-sot # avoid lines with isolated opening tokens
diff --git a/checks/apache2.pm b/checks/apache2.pm
index a1e030b..42b46d9 100644
--- a/checks/apache2.pm
+++ b/checks/apache2.pm
@@ -37,7 +37,8 @@ sub run {
# the web server itself
return if $pkg =~ m/^apache2(:?\.2)?(?:-\w+)?$/;
- # whether the package appears to be an Apache2 module/web application
+ # whether the package appears to be an Apache2 module/web
+ # application
my $seen_apache2_special_file = 0;
if ($type eq 'binary') {
@@ -47,45 +48,53 @@ sub run {
next if $file->is_dir;
next if $file !~ m#^(?:usr/lib/apache2/modules/|etc/apache2/)#;
-
- # Package installs an unrecognized file - check this for all files
- if ($file !~ m#\.conf$# and $file =~ m#^etc/apache2/(conf|site|mods)-available/(.*)$#) {
+ # Package installs an unrecognized file - check this for
+ # all files
+ if ( $file !~ m#\.conf$#
+ and $file =~ m#^etc/apache2/(conf|site|mods)-available/(.*)$#)
+ {
my $temp_type = $1;
my $temp_file = $2;
- # ... except modules which are allowed to ship .load files
+ # ... except modules which are allowed to ship .load
+ # files
tag 'apache2-configuration-files-need-conf-suffix', $file
- unless $temp_type eq 'mods' and $temp_file =~ m#\.load#;
+ unless $temp_type eq 'mods' and $temp_file =~ m#\.load#;
}
# Package appears to be a binary module
if ($file =~ m#^usr/lib/apache2/modules/(.*)\.so#) {
- check_module_package ($pkg, $info, $1);
+ check_module_package($pkg, $info, $1);
$seen_apache2_special_file++;
}
# Package appears to be a web application
elsif ($file =~ m#^etc/apache2/(conf|site)-available/(.*)$#) {
- check_web_application_package ($pkg, $type, $info, $file, $1, $2);
+ check_web_application_package($pkg, $type, $info, $file, $1,
+ $2);
$seen_apache2_special_file++;
}
# Package appears to be a legacy web application
elsif ($file =~ m#^etc/apache2/conf\.d/(.*)$#) {
- tag 'apache2-reverse-dependency-uses-obsolete-directory', $file;
- check_web_application_package ($pkg, $type, $info, $file, 'conf', $1);
+ tag 'apache2-reverse-dependency-uses-obsolete-directory',
+ $file;
+ check_web_application_package($pkg, $type, $info, $file,
+ 'conf', $1);
$seen_apache2_special_file++;
}
# Package does scary things
elsif ($file =~ m#^etc/apache2/(?:conf|sites|mods)-enabled/.*$#) {
- tag 'apache2-reverse-dependency-ships-file-in-not-allowed-directory', $file;
+ tag
+'apache2-reverse-dependency-ships-file-in-not-allowed-directory',
+ $file;
$seen_apache2_special_file++;
}
}
if ($seen_apache2_special_file) {
- check_maintainer_scripts ($info);
+ check_maintainer_scripts($info);
}
}
return;
@@ -95,10 +104,11 @@ sub check_web_application_package {
my ($pkg, $type, $info, $file, $pkgtype, $webapp) = @_;
tag 'non-standard-apache2-configuration-name', $webapp, '!=', "$pkg.conf"
- if $webapp ne "$pkg.conf" or $webapp =~ m/^local-./;
+ if $webapp ne "$pkg.conf"
+ or $webapp =~ m/^local-./;
- my $rel = Lintian::Relation->and ($info->relation ('strong'),
- $info->relation ('recommends'));
+ my $rel = Lintian::Relation->and($info->relation('strong'),
+ $info->relation('recommends'));
# A web application must not depend on apache2-whatever
my $visit = sub {
@@ -108,17 +118,17 @@ sub check_web_application_package {
}
return 0;
};
- $rel->visit ($visit, VISIT_STOP_FIRST_MATCH);
+ $rel->visit($visit, VISIT_STOP_FIRST_MATCH);
# ... nor on apache2 only. Moreover, it should be in the form
# apache2 | httpd but don't worry about versions, virtual package
# don't support that
- if ($rel->implies ('apache2')) {
+ if ($rel->implies('apache2')) {
tag 'web-application-should-not-depend-unconditionally-on-apache2';
}
- if (defined $info->index ($file)) {
- inspect_conf_file ($info, $pkgtype, $file);
+ if (defined $info->index($file)) {
+ inspect_conf_file($info, $pkgtype, $file);
}
return;
}
@@ -126,8 +136,8 @@ sub check_web_application_package {
sub check_module_package {
my ($pkg, $info, $module) = @_;
- # We want packages to be follow our naming scheme. Modules should be named
- # libapache2-mod-<foo> if it ships a mod_foo.so
+ # We want packages to be follow our naming scheme. Modules should
+ # be named libapache2-mod-<foo> if it ships a mod_foo.so
my $expected_name = 'libapache2-' . $module;
# Package depends on apache2-api-YYYYMMDD
@@ -142,14 +152,15 @@ sub check_module_package {
};
$expected_name =~ tr/_/-/;
- if ( $expected_name ne $pkg ) {
- tag 'non-standard-apache2-module-package-name', $pkg, '!=', $expected_name;
+ if ($expected_name ne $pkg) {
+ tag 'non-standard-apache2-module-package-name', $pkg, '!=',
+ $expected_name;
}
- $info->relation ('strong')->visit ($visit, VISIT_STOP_FIRST_MATCH);
- $rel = Lintian::Relation->and ($info->relation ('strong'),
- $info->relation ('recommends'));
- if (! $rel->matches (qr/^apache2-api-\d+$/o)) {
+ $info->relation('strong')->visit($visit, VISIT_STOP_FIRST_MATCH);
+ $rel = Lintian::Relation->and($info->relation('strong'),
+ $info->relation('recommends'));
+ if (!$rel->matches(qr/^apache2-api-\d+$/o)) {
tag 'apache2-module-does-not-depend-on-apache2-api';
}
@@ -160,56 +171,56 @@ sub check_module_package {
$load_file =~ s#^mod.(.*)$#etc/apache2/mods-available/$1.load#;
$conf_file =~ s#^mod.(.*)$#etc/apache2/mods-available/$1.conf#;
- if (defined $info->index ($load_file)) {
- inspect_conf_file ($info, 'mods', $load_file);
+ if (defined $info->index($load_file)) {
+ inspect_conf_file($info, 'mods', $load_file);
} else {
tag 'apache2-module-does-not-ship-load-file', $load_file;
}
- if (defined $info->index ($conf_file)) {
- inspect_conf_file ($info, 'mods', $conf_file);
+ if (defined $info->index($conf_file)) {
+ inspect_conf_file($info, 'mods', $conf_file);
}
return;
}
-
sub check_maintainer_scripts {
my ($info) = @_;
open(my $fd, '<', $info->lab_data_path('control-scripts'));
- while (<$fd>)
- {
+ while (<$fd>) {
m/^(\S*) (.*)$/ or fail("bad line in control-scripts file: $_");
my $interpreter = $1;
- my $file = $2;
- my $filename = $info->control ($file);
+ my $file = $2;
+ my $filename = $info->control($file);
# Don't follow links
next if -l $filename;
- # Don't try to parse the file if it does not appear to be a shell script
+ # Don't try to parse the file if it does not appear to be a shell script
next if $interpreter !~ m/sh\b/;
open(my $sfd, '<', $filename);
while (<$sfd>) {
# skip comments
- next if substr ($_, 0, $-[0]) =~ /#/;
+ next if substr($_, 0, $-[0]) =~ /#/;
- # Do not allow reverse dependencies to call "a2enmod" and friends
- # directly
+ # Do not allow reverse dependencies to call "a2enmod" and
+ # friends directly
if (m/\b(a2(?:en|dis)(?:conf|site|mod))\b/) {
- tag 'apache2-reverse-dependency-calls-wrapper-script', $file, $1;
+ tag 'apache2-reverse-dependency-calls-wrapper-script', $file,
+ $1;
}
- # Do not allow reverse dependencies to call "invoke-rc.d apache2
+ # Do not allow reverse dependencies to call "invoke-rc.d
+ # apache2
if (m/invoke-rc\.d\s+apache2/) {
tag 'apache2-reverse-dependency-calls-invoke-rc.d', $file;
}
# XXX: Check whether apache2-maintscript-helper is used
- # unconditionally e.g. not protected by a [ -e ], [ -x ] or so.
- # That's going to be complicated. Or not possible without grammar
- # parser.
+ # unconditionally e.g. not protected by a [ -e ], [ -x ]
+ # or so. That's going to be complicated. Or not possible
+ # without grammar parser.
}
close($sfd);
}
@@ -218,19 +229,17 @@ sub check_maintainer_scripts {
return;
}
-
sub inspect_conf_file {
my ($info, $conftype, $file) = @_;
-
- my $filename = $info->unpacked ($file);
+ my $filename = $info->unpacked($file);
# Don't follow links
return if -l $filename;
open(my $fd, '<', $filename);
- while (<$fd>) {
+ while (<$fd>) {
for my $directive ('Order', 'Satisfy', 'Allow', 'Deny',
- qr{</?Limit.*?>}xsm, qr{</?LimitExcept.*?>}xsm) {
+ qr{</?Limit.*?>}xsm, qr{</?LimitExcept.*?>}xsm) {
if (m{\A \s* ($directive) (?:\s+|\Z)}xsm) {
tag 'apache2-deprecated-auth-config', $1;
}
@@ -239,13 +248,13 @@ sub inspect_conf_file {
if (m/^#\s*(Depends|Conflicts):\s+(.*?)\s*$/) {
my ($field, $value) = ($1, $2);
tag 'apache2-unsupported-dependency', $file, $field
- if $field eq 'Conflicts' and $conftype ne 'mods';
- my @dependencies = split( /[\n\s]+/, $value );
+ if $field eq 'Conflicts' and $conftype ne 'mods';
+ my @dependencies = split(/[\n\s]+/, $value);
foreach my $dep (@dependencies) {
tag 'apache2-unparseable-dependency', $file, $dep
- if $dep =~ m/\W/ or
- $dep =~ /^mod\_/ or
- $dep =~ m/\.(?:conf|load)/;
+ if $dep =~ m/\W/
+ or $dep =~ /^mod\_/
+ or $dep =~ m/\.(?:conf|load)/;
}
}
diff --git a/checks/binaries.pm b/checks/binaries.pm
index f26e809..c6dfa74 100644
--- a/checks/binaries.pm
+++ b/checks/binaries.pm
@@ -33,20 +33,20 @@ use Lintian::Util qw(fail slurp_entire_file strip);
use File::Spec;
-my $ARCH_REGEX = Lintian::Data->new ('binaries/arch-regex', qr/\s*\~\~/o, sub { return qr/$_[1]/ } );
-my $ARCH_64BIT_EQUIVS = Lintian::Data->new ('binaries/arch-64bit-equivs', qr/\s*\=\>\s*/);
+my $ARCH_REGEX = Lintian::Data->new('binaries/arch-regex', qr/\s*\~\~/o,
+ sub { return qr/$_[1]/ });
+my $ARCH_64BIT_EQUIVS
+ = Lintian::Data->new('binaries/arch-64bit-equivs', qr/\s*\=\>\s*/);
sub _embedded_libs {
my ($key, $val, undef) = @_;
- my $result = {
- 'libname' => $key,
- };
+ my $result = { 'libname' => $key, };
my ($opts, $regex) = split m/\|\|/, $val, 2;
if (!$regex) {
$regex = $opts;
- $opts = '';
+ $opts = '';
} else {
- strip ($opts);
+ strip($opts);
foreach my $optstr (split m/\s++/, $opts) {
my ($opt, $val) = split m/=/, $optstr, 2;
if ($opt eq 'source' or $opt eq 'libname') {
@@ -54,13 +54,15 @@ sub _embedded_libs {
} elsif ($opt eq 'source-regex') {
$result->{$opt} = qr/$val/;
} else {
- fail "Unknown option $opt used for $key (in binaries/embedded-libs)";
+ fail
+"Unknown option $opt used for $key (in binaries/embedded-libs)";
}
}
}
if (defined $result->{'source'} and $result->{'source-regex'}) {
- fail "Both source and source-regex used for $key (in binaries/embedded-libs)";
+ fail
+"Both source and source-regex used for $key (in binaries/embedded-libs)";
} else {
$result->{'source'} = $key unless defined $result->{'source'};
}
@@ -70,7 +72,9 @@ sub _embedded_libs {
return $result;
}
-our $EMBEDDED_LIBRARIES = Lintian::Data->new ('binaries/embedded-libs', qr/\s*+\|\|/, \&_embedded_libs);
+our $EMBEDDED_LIBRARIES
+ = Lintian::Data->new('binaries/embedded-libs', qr/\s*+\|\|/,
+ \&_embedded_libs);
our $MULTIARCH_DIRS = Lintian::Data->new('binaries/multiarch-dirs', '\s+');
@@ -81,425 +85,477 @@ sub _split_hash {
return $hash;
}
-our $HARDENING = Lintian::Data->new ('binaries/hardening-tags', qr/\s*\|\|\s*/o, \&_split_hash);
-our $LFS_SYMBOLS = Lintian::Data->new ('binaries/lfs-symbols');
+our $HARDENING = Lintian::Data->new('binaries/hardening-tags', qr/\s*\|\|\s*/o,
+ \&_split_hash);
+our $LFS_SYMBOLS = Lintian::Data->new('binaries/lfs-symbols');
our $ARCH_32_REGEX;
sub run {
-my ($pkg, $type, $info, $proc, $group) = @_;
-
-my $arch;
-my $multiarch;
-my $madir;
-my $gnu_triplet_re;
-my $ruby_triplet_re;
-my $dynsyms = 0;
-my $needs_libc = '';
-my $needs_libc_file;
-my $needs_libc_count = 0;
-my $needs_depends_line = 0;
-my $has_perl_lib = 0;
-my $has_php_ext = 0;
-my $uses_numpy_c_abi = 0;
-
-my %SONAME;
-
-$arch = $info->field ('architecture', '');
-$multiarch = $info->field ('multi-arch', 'no');
-my $srcpkg = $proc->pkg_src;
-
-foreach my $file (sort keys %{$info->objdump_info}) {
- my $objdump = $info->objdump_info->{$file};
- my $has_lfs = undef;
- my $is_profiled = 0;
- # Only 32bit ELF binaries can lack LFS.
- $ARCH_32_REGEX = $ARCH_REGEX->value ('32') unless defined $ARCH_32_REGEX;
- $has_lfs = 1 unless $info->file_info ($file) =~ m/$ARCH_32_REGEX/o;
- # We don't care if it is a debug file
- $has_lfs = 1 if $file =~ m,^usr/lib/debug/,;
-
- if (defined $objdump->{SONAME}) {
- foreach my $soname (@{$objdump->{SONAME}}) {
- $SONAME{$soname} ||= [];
- push @{$SONAME{$soname}}, $file;
- }
- }
- foreach my $symbol (@{$objdump->{SYMBOLS}}) {
- my ($foo, $sec, $sym) = @{$symbol};
-
- unless (defined $has_lfs) {
- if ($LFS_SYMBOLS->known ($sym)) {
- # Using a 32bit only interface call, some parts of the
- # binary are built without LFS.
- $has_lfs = 0;
+ my ($pkg, $type, $info, $proc, $group) = @_;
+
+ my $arch;
+ my $multiarch;
+ my $madir;
+ my $gnu_triplet_re;
+ my $ruby_triplet_re;
+ my $dynsyms = 0;
+ my $needs_libc = '';
+ my $needs_libc_file;
+ my $needs_libc_count = 0;
+ my $needs_depends_line = 0;
+ my $has_perl_lib = 0;
+ my $has_php_ext = 0;
+ my $uses_numpy_c_abi = 0;
+
+ my %SONAME;
+
+ $arch = $info->field('architecture', '');
+ $multiarch = $info->field('multi-arch', 'no');
+ my $srcpkg = $proc->pkg_src;
+
+ foreach my $file (sort keys %{ $info->objdump_info }) {
+ my $objdump = $info->objdump_info->{$file};
+ my $has_lfs = undef;
+ my $is_profiled = 0;
+ # Only 32bit ELF binaries can lack LFS.
+ $ARCH_32_REGEX = $ARCH_REGEX->value('32')
+ unless defined $ARCH_32_REGEX;
+ $has_lfs = 1 unless $info->file_info($file) =~ m/$ARCH_32_REGEX/o;
+ # We don't care if it is a debug file
+ $has_lfs = 1 if $file =~ m,^usr/lib/debug/,;
+
+ if (defined $objdump->{SONAME}) {
+ foreach my $soname (@{ $objdump->{SONAME} }) {
+ $SONAME{$soname} ||= [];
+ push @{ $SONAME{$soname} }, $file;
}
}
- next if $is_profiled;
- # According to the binutils documentation[1], the profiling symbol
- # can be named "mcount", "_mcount" or even "__mcount".
- # [1] http://sourceware.org/binutils/docs/gprof/Implementation.html
- if ( $sec =~ /^GLIBC_.*/ and $sym =~ m{\A _?+ _?+ mcount \Z}xsm ) {
- $is_profiled = 1;
- } elsif ($arch ne 'hppa') {
- # This code was used to detect profiled code in Wheezy (and earlier)
- if ($foo eq '.text' and $sec eq 'Base' and
- $sym eq '__gmon_start__') {
+ foreach my $symbol (@{ $objdump->{SYMBOLS} }) {
+ my ($foo, $sec, $sym) = @{$symbol};
+
+ unless (defined $has_lfs) {
+ if ($LFS_SYMBOLS->known($sym)) {
+ # Using a 32bit only interface call, some parts of the
+ # binary are built without LFS.
+ $has_lfs = 0;
+ }
+ }
+ next if $is_profiled;
+ # According to the binutils documentation[1], the profiling symbol
+ # can be named "mcount", "_mcount" or even "__mcount".
+ # [1] http://sourceware.org/binutils/docs/gprof/Implementation.html
+ if ($sec =~ /^GLIBC_.*/ and $sym =~ m{\A _?+ _?+ mcount \Z}xsm) {
$is_profiled = 1;
+ } elsif ($arch ne 'hppa') {
+ # This code was used to detect profiled code in Wheezy (and earlier)
+ if ( $foo eq '.text'
+ and $sec eq 'Base'
+ and $sym eq '__gmon_start__') {
+ $is_profiled = 1;
+ }
}
+ tag 'binary-compiled-with-profiling-enabled', $file
+ if $is_profiled;
+ }
+ tag 'binary-file-compressed-with-upx', $file if $objdump->{'UPX'};
+ tag 'apparently-corrupted-elf-binary', $file if $objdump->{'ERRORS'};
+ tag 'binary-file-built-without-LFS-support', $file
+ if defined $has_lfs and not $has_lfs;
+ if ($objdump->{'BAD-DYNAMIC-TABLE'}) {
+ tag 'binary-with-bad-dynamic-table', $file
+ unless $file =~ m%^usr/lib/debug/%;
}
- tag 'binary-compiled-with-profiling-enabled', $file if $is_profiled;
- }
- tag 'binary-file-compressed-with-upx', $file if $objdump->{'UPX'};
- tag 'apparently-corrupted-elf-binary', $file if $objdump->{'ERRORS'};
- tag 'binary-file-built-without-LFS-support', $file
- if defined $has_lfs and not $has_lfs;
- if ($objdump->{'BAD-DYNAMIC-TABLE'}) {
- tag 'binary-with-bad-dynamic-table', $file unless $file =~ m%^usr/lib/debug/%;
}
-}
-# For the package naming check, filter out SONAMEs where all the files are at
-# paths other than /lib, /usr/lib, or /usr/X11R6/lib. This avoids false
-# positives with plugins like Apache modules, which may have their own SONAMEs
-# but which don't matter for the purposes of this check. Also filter out
-# nsswitch modules
-$madir = $MULTIARCH_DIRS->value($arch);
-
-# In the case that the architecture is "all" or unknown (or we do
-# not know the multi-arch path for a known architecture) , we assume
-# it the multi-arch path to be this (hopefully!) non-existent path to
-# avoid warnings about uninitialized variables.
-$madir = './!non-existant-path!/./' unless defined $madir;
-
-$gnu_triplet_re = quotemeta $madir;
-$gnu_triplet_re =~ s,^i386,i[3-6]86,;
-$ruby_triplet_re = $gnu_triplet_re;
-$ruby_triplet_re =~ s,linux\\-gnu$,linux,;
-$ruby_triplet_re =~ s,linux\\-gnu,linux\\-,;
-
-sub lib_soname_path {
- my ($dir, @paths) = @_;
- foreach my $path (@paths) {
- next if $path =~ m%^(?:usr/)?lib(?:32|64)?/libnss_[^.]+\.so(?:\.[0-9]+)$%;
- return 1 if $path =~ m%^lib/[^/]+$%;
- return 1 if $path =~ m%^usr/lib/[^/]+$%;
- return 1 if defined $dir && $path =~ m%lib/$dir/[^/]++$%;
- return 1 if defined $dir && $path =~ m%usr/lib/$dir/[^/]++$%;
+ # For the package naming check, filter out SONAMEs where all the
+ # files are at paths other than /lib, /usr/lib, or /usr/X11R6/lib.
+ # This avoids false positives with plugins like Apache modules,
+ # which may have their own SONAMEs but which don't matter for the
+ # purposes of this check. Also filter out nsswitch modules
+ $madir = $MULTIARCH_DIRS->value($arch);
+
+ # In the case that the architecture is "all" or unknown (or we do
+ # not know the multi-arch path for a known architecture) , we
+ # assume it the multi-arch path to be this (hopefully!)
+ # non-existent path to avoid warnings about uninitialized
+ # variables.
+ $madir = './!non-existant-path!/./' unless defined $madir;
+
+ $gnu_triplet_re = quotemeta $madir;
+ $gnu_triplet_re =~ s,^i386,i[3-6]86,;
+ $ruby_triplet_re = $gnu_triplet_re;
+ $ruby_triplet_re =~ s,linux\\-gnu$,linux,;
+ $ruby_triplet_re =~ s,linux\\-gnu,linux\\-,;
+
+ sub lib_soname_path {
+ my ($dir, @paths) = @_;
+ foreach my $path (@paths) {
+ next
+ if $path
+ =~ m%^(?:usr/)?lib(?:32|64)?/libnss_[^.]+\.so(?:\.[0-9]+)$%;
+ return 1 if $path =~ m%^lib/[^/]+$%;
+ return 1 if $path =~ m%^usr/lib/[^/]+$%;
+ return 1 if defined $dir && $path =~ m%lib/$dir/[^/]++$%;
+ return 1 if defined $dir && $path =~ m%usr/lib/$dir/[^/]++$%;
+ }
+ return 0;
}
- return 0;
-}
-my @sonames = sort grep { lib_soname_path($madir, @{$SONAME{$_}}) } keys %SONAME;
-
-# try to identify transition strings
-my $base_pkg = $pkg;
-$base_pkg =~ s/c102\b//o;
-$base_pkg =~ s/c2a?\b//o;
-$base_pkg =~ s/\dg$//o;
-$base_pkg =~ s/gf$//o;
-$base_pkg =~ s/-udeb$//o;
-$base_pkg =~ s/^lib64/lib/o;
-
-my $match_found = 0;
-foreach my $expected_name (@sonames) {
- $expected_name =~ s/([0-9])\.so\./$1-/;
- $expected_name =~ s/\.so(?:\.|\z)//;
- $expected_name =~ s/_/-/g;
-
- if ((lc($expected_name) eq $pkg)
- || (lc($expected_name) eq $base_pkg)) {
- $match_found = 1;
- last;
+ my @sonames
+ = sort grep { lib_soname_path($madir, @{ $SONAME{$_} }) } keys %SONAME;
+
+ # try to identify transition strings
+ my $base_pkg = $pkg;
+ $base_pkg =~ s/c102\b//o;
+ $base_pkg =~ s/c2a?\b//o;
+ $base_pkg =~ s/\dg$//o;
+ $base_pkg =~ s/gf$//o;
+ $base_pkg =~ s/-udeb$//o;
+ $base_pkg =~ s/^lib64/lib/o;
+
+ my $match_found = 0;
+ foreach my $expected_name (@sonames) {
+ $expected_name =~ s/([0-9])\.so\./$1-/;
+ $expected_name =~ s/\.so(?:\.|\z)//;
+ $expected_name =~ s/_/-/g;
+
+ if ( (lc($expected_name) eq $pkg)
+ || (lc($expected_name) eq $base_pkg)) {
+ $match_found = 1;
+ last;
+ }
}
-}
-tag 'package-name-doesnt-match-sonames', "@sonames"
- if @sonames && !$match_found;
+ tag 'package-name-doesnt-match-sonames', "@sonames"
+ if @sonames && !$match_found;
-my %directories;
-for my $file ($info->sorted_index) {
- my $name = $file->name;
- next unless $file->is_dir || $file->is_symlink;
- $name =~ s,/\z,,;
- $directories{"/$name"}++;
-}
+ my %directories;
+ for my $file ($info->sorted_index) {
+ my $name = $file->name;
+ next unless $file->is_dir || $file->is_symlink;
+ $name =~ s,/\z,,;
+ $directories{"/$name"}++;
+ }
-my $src = $group->get_source_processable();
-my $built_with_golang;
-if (defined($src)) {
- $built_with_golang = $src->info->relation('build-depends')->implies('golang-go');
-}
+ my $src = $group->get_source_processable();
+ my $built_with_golang;
+ if (defined($src)) {
+ $built_with_golang
+ = $src->info->relation('build-depends')->implies('golang-go');
+ }
-# process all files in package
-foreach my $file ($info->sorted_index) {
- my $fileinfo = $info->file_info ($file);
- my $objdump = $info->objdump_info->{$file};
+ # process all files in package
+ foreach my $file ($info->sorted_index) {
+ my $fileinfo = $info->file_info($file);
+ my $objdump = $info->objdump_info->{$file};
- # binary or object file?
- next unless ($fileinfo =~ m/^[^,]*\bELF\b/) or ($fileinfo =~ m/\bcurrent ar archive\b/);
+ # binary or object file?
+ next
+ unless ($fileinfo =~ m/^[^,]*\bELF\b/)
+ or ($fileinfo =~ m/\bcurrent ar archive\b/);
- # Warn about Architecture: all packages that contain shared libraries.
- if ($arch eq 'all') {
- tag 'arch-independent-package-contains-binary-or-object', $file;
- }
+ # Warn about Architecture: all packages that contain shared libraries.
+ if ($arch eq 'all') {
+ tag 'arch-independent-package-contains-binary-or-object', $file;
+ }
- if ($file =~ m,^etc/,) {
- tag 'binary-in-etc', $file;
- }
+ if ($file =~ m,^etc/,) {
+ tag 'binary-in-etc', $file;
+ }
- if ($file =~ m,^usr/share/,) {
- tag 'arch-dependent-file-in-usr-share', $file;
- }
+ if ($file =~ m,^usr/share/,) {
+ tag 'arch-dependent-file-in-usr-share', $file;
+ }
- if ($multiarch eq 'same') {
- unless ($file =~ m,\b$gnu_triplet_re\b|/(?:$ruby_triplet_re|java-\d+-openjdk-\Q$arch\E|\.build-id)/,) {
- tag 'arch-dependent-file-not-in-arch-specific-directory', $file;
+ if ($multiarch eq 'same') {
+ unless ($file
+ =~ m,\b$gnu_triplet_re\b|/(?:$ruby_triplet_re|java-\d+-openjdk-\Q$arch\E|\.build-id)/,
+ ) {
+ tag 'arch-dependent-file-not-in-arch-specific-directory',
+ $file;
+ }
}
- }
- # ELF?
- next unless $fileinfo =~ m/^[^,]*\bELF\b/o;
+ # ELF?
+ next unless $fileinfo =~ m/^[^,]*\bELF\b/o;
- if ($arch eq 'all' or not $ARCH_REGEX->known ($arch)) {
- # arch:all or unknown architecture - not much we can say here
- 1;
- } else {
- my $archre = $ARCH_REGEX->value ($arch);
- my $bad = 1;
- if ($fileinfo =~ m/$archre/) {
- # If it matches the architecture regex, it is good
- $bad = 0;
- } elsif ($file =~ m,(?:^|/)lib(x?\d{2})/, or $file =~ m,^emul/ia(\d{2}),) {
- my $bitre = $ARCH_REGEX-> value($1);
- # Special case - "old" multi-arch dirs
- $bad = 0 if $bitre and $fileinfo =~ m/$bitre/
- } elsif ($ARCH_64BIT_EQUIVS->known ($arch) && $file =~ m,^lib/modules/,) {
- my $arch64re = $ARCH_REGEX->value ($ARCH_64BIT_EQUIVS->value ($arch));
- # Allow amd64 kernel modules to be installed on i386.
- $bad = 0 if $fileinfo =~ m/$arch64re/;
- } elsif ($arch eq 'amd64') {
- my $arch32re = $ARCH_REGEX->value ('i386');
- # Ignore i386 binaries in amd64 packages for right now.
- $bad = 0 if $fileinfo =~ m/$arch32re/;
+ if ($arch eq 'all' or not $ARCH_REGEX->known($arch)) {
+ # arch:all or unknown architecture - not much we can say here
+ 1;
+ } else {
+ my $archre = $ARCH_REGEX->value($arch);
+ my $bad = 1;
+ if ($fileinfo =~ m/$archre/) {
+ # If it matches the architecture regex, it is good
+ $bad = 0;
+ } elsif ($file =~ m,(?:^|/)lib(x?\d{2})/,
+ or $file =~ m,^emul/ia(\d{2}),) {
+ my $bitre = $ARCH_REGEX->value($1);
+ # Special case - "old" multi-arch dirs
+ $bad = 0 if $bitre and $fileinfo =~ m/$bitre/;
+ } elsif ($ARCH_64BIT_EQUIVS->known($arch)
+ && $file =~ m,^lib/modules/,) {
+ my $arch64re
+ = $ARCH_REGEX->value($ARCH_64BIT_EQUIVS->value($arch));
+ # Allow amd64 kernel modules to be installed on i386.
+ $bad = 0 if $fileinfo =~ m/$arch64re/;
+ } elsif ($arch eq 'amd64') {
+ my $arch32re = $ARCH_REGEX->value('i386');
+ # Ignore i386 binaries in amd64 packages for right now.
+ $bad = 0 if $fileinfo =~ m/$arch32re/;
+ }
+ tag 'binary-from-other-architecture', $file if $bad;
}
- tag 'binary-from-other-architecture', $file if $bad;
- }
- my $strings = slurp_entire_file ($info->strings ($file));
- my $exceptions = {
- %{ $group->info->spelling_exceptions },
- 'teH' => 1, # From #711207
- };
- check_spelling('spelling-error-in-binary', $strings, $file,
- $exceptions);
-
- # stripped?
- if ($fileinfo =~ m,not stripped\s*$,o) {
- # Is it an object file (which generally can not be stripped),
- # a kernel module, debugging symbols, or perhaps a debugging package?
- unless ($file =~ m,\.k?o$, or $pkg =~ m/-dbg$/ or $pkg =~ m/debug/
- or $file =~ m,/lib/debug/, or $file =~ m,\.gox$,o) {
- if ($fileinfo =~ m/executable/
- and $strings =~ m/^Caml1999X0[0-9][0-9]$/m) {
- # Check for OCaml custom executables (#498138)
- tag 'ocaml-custom-executable', $file;
- } else {
- tag 'unstripped-binary-or-object', $file;
+ my $strings = slurp_entire_file($info->strings($file));
+ my $exceptions = {
+ %{ $group->info->spelling_exceptions },
+ 'teH' => 1, # From #711207
+ };
+ check_spelling('spelling-error-in-binary',
+ $strings, $file, $exceptions);
+
+ # stripped?
+ if ($fileinfo =~ m,not stripped\s*$,o) {
+ # Is it an object file (which generally can not be
+ # stripped), a kernel module, debugging symbols, or
+ # perhaps a debugging package?
+ unless ($file =~ m,\.k?o$,
+ or $pkg =~ m/-dbg$/
+ or $pkg =~ m/debug/
+ or $file =~ m,/lib/debug/,
+ or $file =~ m,\.gox$,o) {
+ if ( $fileinfo =~ m/executable/
+ and $strings =~ m/^Caml1999X0[0-9][0-9]$/m) {
+ # Check for OCaml custom executables (#498138)
+ tag 'ocaml-custom-executable', $file;
+ } else {
+ tag 'unstripped-binary-or-object', $file;
+ }
}
- }
- } else {
- # stripped but a debug or profiling library?
- if (($file =~ m,/lib/debug/,o) or ($file =~ m,/lib/profile/,o)) {
- tag 'library-in-debug-or-profile-should-not-be-stripped', $file;
} else {
- # appropriately stripped, but is it stripped enough?
- foreach my $sect ('.note', '.comment') {
- if (exists $objdump->{'SH'}->{$sect}) {
- tag 'binary-has-unneeded-section', "$file $sect";
+ # stripped but a debug or profiling library?
+ if (($file =~ m,/lib/debug/,o) or ($file =~ m,/lib/profile/,o)) {
+ tag 'library-in-debug-or-profile-should-not-be-stripped',
+ $file;
+ } else {
+ # appropriately stripped, but is it stripped enough?
+ foreach my $sect ('.note', '.comment') {
+ if (exists $objdump->{'SH'}->{$sect}) {
+ tag 'binary-has-unneeded-section', "$file $sect";
+ }
}
}
}
- }
- # rpath is disallowed, except in private directories
- if (exists $objdump->{RPATH}) {
- foreach my $rpath (map {File::Spec->canonpath($_)} keys %{$objdump->{RPATH}}) {
- next if $rpath =~ m,^/usr/lib/(?:$madir/)?(?:games/)?(?:\Q$pkg\E|\Q$srcpkg\E)(?:/|\z),;
- next if $rpath =~ m,^\$\{?ORIGIN\}?,;
- next if $directories{$rpath} and $rpath !~ m,^(?:/usr)?/lib(?:/$madir)?/?\z,;
- tag 'binary-or-shlib-defines-rpath', "$file $rpath";
+ # rpath is disallowed, except in private directories
+ if (exists $objdump->{RPATH}) {
+ foreach my $rpath (map { File::Spec->canonpath($_) }
+ keys %{ $objdump->{RPATH} }) {
+ next
+ if $rpath
+ =~ m,^/usr/lib/(?:$madir/)?(?:games/)?(?:\Q$pkg\E|\Q$srcpkg\E)(?:/|\z),;
+ next if $rpath =~ m,^\$\{?ORIGIN\}?,;
+ next
+ if $directories{$rpath}
+ and $rpath !~ m,^(?:/usr)?/lib(?:/$madir)?/?\z,;
+ tag 'binary-or-shlib-defines-rpath', "$file $rpath";
+ }
}
- }
- foreach my $emlib ($EMBEDDED_LIBRARIES->all) {
- my $ldata = $EMBEDDED_LIBRARIES->value ($emlib);
- if ($ldata->{'source-regex'}) {
- next if $proc->pkg_src =~ m/^$ldata->{'source-regex'}$/;
- } else {
- next if $proc->pkg_src eq $ldata->{'source'};
- }
- if ($strings =~ $ldata->{'match'}) {
- tag 'embedded-library', "$file: $ldata->{'libname'}";
+ foreach my $emlib ($EMBEDDED_LIBRARIES->all) {
+ my $ldata = $EMBEDDED_LIBRARIES->value($emlib);
+ if ($ldata->{'source-regex'}) {
+ next if $proc->pkg_src =~ m/^$ldata->{'source-regex'}$/;
+ } else {
+ next if $proc->pkg_src eq $ldata->{'source'};
+ }
+ if ($strings =~ $ldata->{'match'}) {
+ tag 'embedded-library', "$file: $ldata->{'libname'}";
+ }
}
- }
-
- # binary or shared object?
- next unless ($fileinfo =~ m/executable/) or ($fileinfo =~ m/shared object/);
- next if $type eq 'udeb';
-
- # Perl library?
- if ($file =~ m,^usr/lib/perl5/.*\.so$,) {
- $has_perl_lib = 1;
- }
- # PHP extension?
- if ($file =~ m,^usr/lib/php\d/.*\.so(?:\.\d+)*$,) {
- $has_php_ext = 1;
- }
+ # binary or shared object?
+ next
+ unless ($fileinfo =~ m/executable/)
+ or ($fileinfo =~ m/shared object/);
+ next if $type eq 'udeb';
- # Python extension using Numpy C ABI?
- if ($file =~ m,usr/lib/(?:pyshared/)?python2\.\d+/.*(?<!_d)\.so$, or
- ($file =~ m,usr/lib/python3/.+\.cpython-\d+([a-z]+)\.so$, and $1 !~ /d/)) {
- if ($strings =~ m,module compiled against ABI version %x but this version of numpy is %x,) {
- $uses_numpy_c_abi = 1;
+ # Perl library?
+ if ($file =~ m,^usr/lib/perl5/.*\.so$,) {
+ $has_perl_lib = 1;
}
- }
- # Something other than detached debugging symbols in /usr/lib/debug paths.
- if ($file =~ m,^usr/lib/debug/(?:lib\d*|s?bin|usr|opt|dev|emul|\.build-id)/,) {
- if (scalar (@{ $objdump->{NEEDED} }) ) {
- tag 'debug-file-should-use-detached-symbols', $file;
+ # PHP extension?
+ if ($file =~ m,^usr/lib/php\d/.*\.so(?:\.\d+)*$,) {
+ $has_php_ext = 1;
}
- tag 'debug-file-with-no-debug-symbols', $file
- unless (exists $objdump->{'SH'}->{'.debug_line'}
- or exists $objdump->{'SH'}->{'.zdebug_line'});
- }
- # Detached debugging symbols directly in /usr/lib/debug.
- if ($file =~ m,^usr/lib/debug/[^/]+$,) {
- unless (scalar (@{ $objdump->{NEEDED} })
- || $fileinfo =~ m/statically linked/) {
- tag 'debug-symbols-directly-in-usr-lib-debug', $file;
+ # Python extension using Numpy C ABI?
+ if (
+ $file =~ m,usr/lib/(?:pyshared/)?python2\.\d+/.*(?<!_d)\.so$,
+ or ( $file =~ m,usr/lib/python3/.+\.cpython-\d+([a-z]+)\.so$,
+ and $1 !~ /d/)
+ ) {
+ if ($strings
+ =~ m,module compiled against ABI version %x but this version of numpy is %x,
+ ) {
+ $uses_numpy_c_abi = 1;
+ }
}
- }
- # statically linked?
- if (! scalar (@{ $objdump->{NEEDED} }) ) {
- if ($fileinfo =~ m/shared object/o) {
- # Some exceptions: kernel modules, detached debugging information
- # and the dynamic loader (which itself has no dependencies).
- next if ($file =~ m%^lib/modules/%);
- next if ($file =~ m%^usr/lib/debug/%);
- next if ($file =~ m%^lib(?:|32|64)/(?:[\w/]+/)?ld-[\d.]+\.so$%);
- tag 'shared-lib-without-dependency-information', $file;
- } else {
- # Some exceptions: files in /boot, /usr/lib/debug/*, named *-static or
- # *.static, or *-static as package-name.
- next if ($file =~ m%^boot/%);
- next if ($file =~ /[\.-]static$/);
- next if ($pkg =~ /-static$/);
- # Binaries built by the Go compiler are statically linked by default.
- next if ($built_with_golang);
- # klibc binaries appear to be static.
- next if (exists $objdump->{INTERP}
- && $objdump->{INTERP} =~ m,/lib/klibc-\S+\.so,);
- # Location of debugging symbols.
- next if ($file =~ m%^usr/lib/debug/%);
- # ldconfig must be static.
- next if ($file eq 'sbin/ldconfig');
- tag 'statically-linked-binary', $file;
+ # Something other than detached debugging symbols in
+ # /usr/lib/debug paths.
+ if ($file
+ =~ m,^usr/lib/debug/(?:lib\d*|s?bin|usr|opt|dev|emul|\.build-id)/,)
+ {
+ if (scalar(@{ $objdump->{NEEDED} })) {
+ tag 'debug-file-should-use-detached-symbols', $file;
+ }
+ tag 'debug-file-with-no-debug-symbols', $file
+ unless (exists $objdump->{'SH'}->{'.debug_line'}
+ or exists $objdump->{'SH'}->{'.zdebug_line'});
}
- } else {
- my $lib;
- my $no_libc = 1;
- $needs_depends_line = 1;
- for $lib (@{$objdump->{NEEDED}}) {
- if ($lib =~ /^libc\.so\.(\d+.*)/) {
- $needs_libc = "libc$1";
- $needs_libc_file = $file->name unless $needs_libc_file;
- $needs_libc_count++;
- $no_libc = 0;
+
+ # Detached debugging symbols directly in /usr/lib/debug.
+ if ($file =~ m,^usr/lib/debug/[^/]+$,) {
+ unless (scalar(@{ $objdump->{NEEDED} })
+ || $fileinfo =~ m/statically linked/) {
+ tag 'debug-symbols-directly-in-usr-lib-debug', $file;
}
}
- if ($no_libc and not $file =~ m,/libc\b,) {
- if ($fileinfo =~ m/shared object/) {
- tag 'library-not-linked-against-libc', $file;
+
+ # statically linked?
+ if (!scalar(@{ $objdump->{NEEDED} })) {
+ if ($fileinfo =~ m/shared object/o) {
+ # Some exceptions: kernel modules, detached debugging
+ # information and the dynamic loader (which itself has
+ # no dependencies).
+ next if ($file =~ m%^lib/modules/%);
+ next if ($file =~ m%^usr/lib/debug/%);
+ next
+ if ($file =~ m%^lib(?:|32|64)/(?:[\w/]+/)?ld-[\d.]+\.so$%);
+ tag 'shared-lib-without-dependency-information', $file;
} else {
- tag 'program-not-linked-against-libc', $file;
+ # Some exceptions: files in /boot, /usr/lib/debug/*,
+ # named *-static or *.static, or *-static as
+ # package-name.
+ next if ($file =~ m%^boot/%);
+ next if ($file =~ /[\.-]static$/);
+ next if ($pkg =~ /-static$/);
+ # Binaries built by the Go compiler are statically
+ # linked by default.
+ next if ($built_with_golang);
+ # klibc binaries appear to be static.
+ next
+ if (exists $objdump->{INTERP}
+ && $objdump->{INTERP} =~ m,/lib/klibc-\S+\.so,);
+ # Location of debugging symbols.
+ next if ($file =~ m%^usr/lib/debug/%);
+ # ldconfig must be static.
+ next if ($file eq 'sbin/ldconfig');
+ tag 'statically-linked-binary', $file;
+ }
+ } else {
+ my $lib;
+ my $no_libc = 1;
+ $needs_depends_line = 1;
+ for $lib (@{ $objdump->{NEEDED} }) {
+ if ($lib =~ /^libc\.so\.(\d+.*)/) {
+ $needs_libc = "libc$1";
+ $needs_libc_file = $file->name unless $needs_libc_file;
+ $needs_libc_count++;
+ $no_libc = 0;
+ }
+ }
+ if ($no_libc and not $file =~ m,/libc\b,) {
+ if ($fileinfo =~ m/shared object/) {
+ tag 'library-not-linked-against-libc', $file;
+ } else {
+ tag 'program-not-linked-against-libc', $file;
+ }
}
- }
- # Check for missing hardening characteristics. This currently
- # handles the following checks:
- # no-relro no-fortify-functions no-stackprotector no-bindnow no-pie
- if (exists($info->hardening_info->{$file})) {
- my $flags = $HARDENING->value ($arch);
- if ($flags) {
- foreach my $t (@{$info->hardening_info->{$file}}) {
- my $tag = "hardening-$t";
- tag $tag, $file if $flags->{$tag};
+ # Check for missing hardening characteristics. This currently
+ # handles the following checks:
+ #
+ # no-relro no-fortify-functions no-stackprotector
+ # no-bindnow no-pie
+ if (exists($info->hardening_info->{$file})) {
+ my $flags = $HARDENING->value($arch);
+ if ($flags) {
+ foreach my $t (@{ $info->hardening_info->{$file} }) {
+ my $tag = "hardening-$t";
+ tag $tag, $file if $flags->{$tag};
+ }
}
}
}
}
-}
-# Find the package dependencies, which is used by various checks.
-my $depends = $info->relation ('strong');
-
-# Check for a libc dependency.
-if ($needs_depends_line) {
- if ($depends->empty) {
- tag 'missing-depends-line';
- } elsif ($needs_libc && $pkg !~ /^libc[\d.]+(?:-|\z)/) {
- # Match libcXX or libcXX-*, but not libc3p0.
- my $re = qr/^\Q$needs_libc\E\b/;
- if (!$depends->matches ($re)) {
- my $others = '';
- $needs_libc_count--;
- if ($needs_libc_count > 0) {
- $others = " and $needs_libc_count others";
+ # Find the package dependencies, which is used by various checks.
+ my $depends = $info->relation('strong');
+
+ # Check for a libc dependency.
+ if ($needs_depends_line) {
+ if ($depends->empty) {
+ tag 'missing-depends-line';
+ } elsif ($needs_libc && $pkg !~ /^libc[\d.]+(?:-|\z)/) {
+ # Match libcXX or libcXX-*, but not libc3p0.
+ my $re = qr/^\Q$needs_libc\E\b/;
+ if (!$depends->matches($re)) {
+ my $others = '';
+ $needs_libc_count--;
+ if ($needs_libc_count > 0) {
+ $others = " and $needs_libc_count others";
+ }
+ tag 'missing-dependency-on-libc',
+ "needed by $needs_libc_file$others";
}
- tag 'missing-dependency-on-libc',
- "needed by $needs_libc_file$others";
}
}
-}
-# Check for a Perl dependency.
-if ($has_perl_lib) {
- # It is a virtual package, so no version is allowed and
- # alternatives probably does not make sense here either.
- my $re = qr/^perlapi-[\d.]+(?:\s*\[[^\]]+\])?$/;
- unless ($depends->matches ($re, VISIT_OR_CLAUSE_FULL)) {
- tag 'missing-dependency-on-perlapi';
+ # Check for a Perl dependency.
+ if ($has_perl_lib) {
+ # It is a virtual package, so no version is allowed and
+ # alternatives probably does not make sense here either.
+ my $re = qr/^perlapi-[\d.]+(?:\s*\[[^\]]+\])?$/;
+ unless ($depends->matches($re, VISIT_OR_CLAUSE_FULL)) {
+ tag 'missing-dependency-on-perlapi';
+ }
}
-}
-# Check for a phpapi- dependency.
-if ($has_php_ext) {
- # It is a virtual package, so no version is allowed and
- # alternatives probably does not make sense here either.
- unless ($depends->matches (qr/^phpapi-[\d\w+]+$/, VISIT_OR_CLAUSE_FULL)) {
- tag 'missing-dependency-on-phpapi';
+ # Check for a phpapi- dependency.
+ if ($has_php_ext) {
+ # It is a virtual package, so no version is allowed and
+ # alternatives probably does not make sense here either.
+ unless ($depends->matches(qr/^phpapi-[\d\w+]+$/, VISIT_OR_CLAUSE_FULL))
+ {
+ tag 'missing-dependency-on-phpapi';
+ }
}
-}
-# Check for dependency on python-numpy-abiN dependency (or strict versioned
-# dependency on python-numpy)
-if ($uses_numpy_c_abi and $pkg ) {
- # We do not allow alternatives as it would mostly likely defeat the purpose of this
- # relation. Also, we do not allow versions for -abi as it is a virtual package.
- tag 'missing-dependency-on-numpy-abi'
- unless
- $depends->matches (qr/^python3?-numpy-abi\d+$/, VISIT_OR_CLAUSE_FULL) or (
- $depends->matches (qr/^python-numpy \(>[>=][^\|]+$/, VISIT_OR_CLAUSE_FULL) and
- $depends->matches (qr/^python-numpy \(<[<=][^\|]+$/, VISIT_OR_CLAUSE_FULL)) or
- $pkg =~ m,^python3?-numpy$,;
-}
+ # Check for dependency on python-numpy-abiN dependency (or strict
+ # versioned dependency on python-numpy)
+ if ($uses_numpy_c_abi and $pkg) {
+ # We do not allow alternatives as it would mostly likely
+ # defeat the purpose of this relation. Also, we do not allow
+ # versions for -abi as it is a virtual package.
+ tag 'missing-dependency-on-numpy-abi'
+ unless $depends->matches(qr/^python3?-numpy-abi\d+$/,
+ VISIT_OR_CLAUSE_FULL)
+ or (
+ $depends->matches(qr/^python-numpy \(>[>=][^\|]+$/,
+ VISIT_OR_CLAUSE_FULL)
+ and $depends->matches(
+ qr/^python-numpy \(<[<=][^\|]+$/,
+ VISIT_OR_CLAUSE_FULL
+ )
+ ) or $pkg =~ m,^python3?-numpy$,;
+ }
-return;
+ return;
}
1;
diff --git a/checks/changelog-file.pm b/checks/changelog-file.pm
index 35b44d8..726a544 100644
--- a/checks/changelog-file.pm
+++ b/checks/changelog-file.pm
@@ -35,344 +35,380 @@ use Lintian::Util qw(file_is_encoded_in_non_utf8);
sub run {
-my ($pkg, undef, $info, undef, $group) = @_;
+ my ($pkg, undef, $info, undef, $group) = @_;
-my $found_html=0;
-my $found_text=0;
-my $native_pkg;
-my $foreign_pkg;
-my $ppkg = quotemeta($pkg);
+ my $found_html = 0;
+ my $found_text = 0;
+ my $native_pkg;
+ my $foreign_pkg;
+ my $ppkg = quotemeta($pkg);
-my @doc_files;
+ my @doc_files;
-# skip packages which have a /usr/share/doc/$pkg -> foo symlink
-return if $info->index("usr/share/doc/$pkg") and
- $info->index ("usr/share/doc/$pkg")->is_symlink;
+ # skip packages which have a /usr/share/doc/$pkg -> foo symlink
+ return
+ if $info->index("usr/share/doc/$pkg")
+ and $info->index("usr/share/doc/$pkg")->is_symlink;
-if (my $docdir = $info->index("usr/share/doc/$pkg/")) {
- for my $path ($docdir->children) {
- my $basename = $path->basename;
+ if (my $docdir = $info->index("usr/share/doc/$pkg/")) {
+ for my $path ($docdir->children) {
+ my $basename = $path->basename;
- next unless $path->is_file or $path->is_symlink;
+ next unless $path->is_file or $path->is_symlink;
- push(@doc_files, $basename);
+ push(@doc_files, $basename);
- # Check a few things about the NEWS.Debian file.
- if ($basename =~ m{\A NEWS\.Debian (?:\.gz)? \Z}ixsm) {
- if ($basename !~ m{ \.gz \Z }xsm) {
- tag 'debian-news-file-not-compressed', $path->name;
- } elsif ($basename ne 'NEWS.Debian.gz') {
- tag 'wrong-name-for-debian-news-file', $path->name;
- }
- }
-
- # Check if changelog files are compressed with gzip -9. It's a bit of
- # an open question here what we should do with a file named ChangeLog.
- # If there's also a changelog file, it might be a duplicate, or the
- # packager may have installed NEWS as changelog intentionally.
- next unless $basename =~ m{\A changelog(?:\.html|\.Debian)?(?:\.gz)? \Z}xsm;
-
- if ($basename !~ m{ \.gz \Z}xsm) {
- tag 'changelog-file-not-compressed', $basename;
- } else {
- my $max_compressed = 0;
- my $file_info = $info->file_info($path);
- if ($path->is_symlink) {
- my $normalized = $path->link_normalized;
- if (defined($normalized)) {
- $file_info = $info->file_info($normalized);
+ # Check a few things about the NEWS.Debian file.
+ if ($basename =~ m{\A NEWS\.Debian (?:\.gz)? \Z}ixsm) {
+ if ($basename !~ m{ \.gz \Z }xsm) {
+ tag 'debian-news-file-not-compressed', $path->name;
+ } elsif ($basename ne 'NEWS.Debian.gz') {
+ tag 'wrong-name-for-debian-news-file', $path->name;
}
}
- if (defined($file_info)) {
- if (index($file_info, 'max compression') != -1) {
- $max_compressed = 1;
+
+ # Check if changelog files are compressed with gzip -9.
+ # It's a bit of an open question here what we should do
+ # with a file named ChangeLog. If there's also a
+ # changelog file, it might be a duplicate, or the packager
+ # may have installed NEWS as changelog intentionally.
+ next
+ unless $basename
+ =~ m{\A changelog(?:\.html|\.Debian)?(?:\.gz)? \Z}xsm;
+
+ if ($basename !~ m{ \.gz \Z}xsm) {
+ tag 'changelog-file-not-compressed', $basename;
+ } else {
+ my $max_compressed = 0;
+ my $file_info = $info->file_info($path);
+ if ($path->is_symlink) {
+ my $normalized = $path->link_normalized;
+ if (defined($normalized)) {
+ $file_info = $info->file_info($normalized);
+ }
}
- if (not $max_compressed
+ if (defined($file_info)) {
+ if (index($file_info, 'max compression') != -1) {
+ $max_compressed = 1;
+ }
+ if (not $max_compressed
and index($file_info, 'gzip compressed') != -1) {
- tag 'changelog-not-compressed-with-max-compression',
- $basename;
+ tag 'changelog-not-compressed-with-max-compression',
+ $basename;
+ }
}
}
- }
- if ($basename eq 'changelog.html'
+ if ( $basename eq 'changelog.html'
or $basename eq 'changelog.html.gz') {
- $found_html = 1;
- } elsif ($basename eq 'changelog' or $basename eq 'changelog.gz') {
- $found_text = 1;
+ $found_html = 1;
+ } elsif ($basename eq 'changelog' or $basename eq 'changelog.gz') {
+ $found_text = 1;
+ }
}
}
-}
-# Check a NEWS.Debian file if we have one. Save the parsed version of the
-# flie for later checks against the changelog file.
-my $news;
-my $dnews = $info->lab_data_path ('NEWS.Debian');
-if (-f $dnews) {
- my $line = file_is_encoded_in_non_utf8($dnews);
- if ($line) {
- tag 'debian-news-file-uses-obsolete-national-encoding', "at line $line"
- }
- my $changes = Parse::DebianChangelog->init( { infile => $dnews, quiet => 1 } );
- if (my @errors = $changes->get_parse_errors) {
- for (@errors) {
- tag 'syntax-error-in-debian-news-file', "line $_->[1]", "\"$_->[2]\"";
+ # Check a NEWS.Debian file if we have one. Save the parsed
+ # version of the flie for later checks against the changelog file.
+ my $news;
+ my $dnews = $info->lab_data_path('NEWS.Debian');
+ if (-f $dnews) {
+ my $line = file_is_encoded_in_non_utf8($dnews);
+ if ($line) {
+ tag 'debian-news-file-uses-obsolete-national-encoding',
+ "at line $line";
}
- }
-
- # Some checks on the most recent entry.
- if ($changes->data and defined (($changes->data)[0])) {
- ($news) = $changes->data;
- if ($news->Distribution && $news->Distribution =~ /unreleased/i) {
- tag 'debian-news-entry-has-strange-distribution', $news->Distribution;
+ my $changes
+ = Parse::DebianChangelog->init({ infile => $dnews, quiet => 1 });
+ if (my @errors = $changes->get_parse_errors) {
+ for (@errors) {
+ tag 'syntax-error-in-debian-news-file', "line $_->[1]",
+ "\"$_->[2]\"";
+ }
}
- check_spelling('spelling-error-in-news-debian', $news->Changes,
- undef, $group->info->spelling_exceptions);
- if ($news->Changes =~ /^\s*\*\s/) {
- tag 'debian-news-entry-uses-asterisk';
+
+ # Some checks on the most recent entry.
+ if ($changes->data and defined(($changes->data)[0])) {
+ ($news) = $changes->data;
+ if ($news->Distribution && $news->Distribution =~ /unreleased/i) {
+ tag 'debian-news-entry-has-strange-distribution',
+ $news->Distribution;
+ }
+ check_spelling('spelling-error-in-news-debian',
+ $news->Changes, undef, $group->info->spelling_exceptions);
+ if ($news->Changes =~ /^\s*\*\s/) {
+ tag 'debian-news-entry-uses-asterisk';
+ }
}
}
-}
-
-if ( $found_html && !$found_text ) {
- tag 'html-changelog-without-text-version';
-}
-# is this a native Debian package?
-my $version;
-if (defined $info->field('version')) {
- $version = $info->field('version');
-} else {
- # We do not know, but we assume it to be non-native
- # as that is most likely.
- $version = '0-1';
-}
+ if ($found_html && !$found_text) {
+ tag 'html-changelog-without-text-version';
+ }
-$native_pkg = $info->native;
-$foreign_pkg = (!$native_pkg && $version !~ m/-0\./);
-# A version of 1.2.3-0.1 could be either, so in that
-# case, both vars are false
-
-if ($native_pkg) {
- # native Debian package
- if (any { m/^changelog(?:\.gz)?$/} @doc_files) {
- # everything is fine
- } elsif (my $chg = first { m/^changelog\.debian(?:\.gz)$/i} @doc_files) {
- tag 'wrong-name-for-changelog-of-native-package', "usr/share/doc/$pkg/$chg";
+ # is this a native Debian package?
+ my $version;
+ if (defined $info->field('version')) {
+ $version = $info->field('version');
} else {
- tag 'changelog-file-missing-in-native-package';
+ # We do not know, but we assume it to be non-native
+ # as that is most likely.
+ $version = '0-1';
}
-} else {
- # non-native (foreign :) Debian package
-
- # 1. check for upstream changelog
- my $found_upstream_text_changelog = 0;
- if (any { m/^changelog(\.html)?(?:\.gz)?$/ } @doc_files) {
- $found_upstream_text_changelog = 1 unless $1;
- # everything is fine
- } else {
- # search for changelogs with wrong file name
- my $found = 0;
- for (@doc_files) {
- if (m/^change/i and not m/debian/i) {
- tag 'wrong-name-for-upstream-changelog', "usr/share/doc/$pkg/$_";
- $found = 1;
- last;
+
+ $native_pkg = $info->native;
+ $foreign_pkg = (!$native_pkg && $version !~ m/-0\./);
+ # A version of 1.2.3-0.1 could be either, so in that
+ # case, both vars are false
+
+ if ($native_pkg) {
+ # native Debian package
+ if (any { m/^changelog(?:\.gz)?$/ } @doc_files) {
+ # everything is fine
+ } elsif (
+ my $chg = first {
+ m/^changelog\.debian(?:\.gz)$/i;
}
+ @doc_files
+ ) {
+ tag 'wrong-name-for-changelog-of-native-package',
+ "usr/share/doc/$pkg/$chg";
+ } else {
+ tag 'changelog-file-missing-in-native-package';
}
- if (not $found) {
- tag 'no-upstream-changelog' unless $info->is_pkg_class ('transitional');
+ } else {
+ # non-native (foreign :) Debian package
+
+ # 1. check for upstream changelog
+ my $found_upstream_text_changelog = 0;
+ if (any { m/^changelog(\.html)?(?:\.gz)?$/ } @doc_files) {
+ $found_upstream_text_changelog = 1 unless $1;
+ # everything is fine
+ } else {
+ # search for changelogs with wrong file name
+ my $found = 0;
+ for (@doc_files) {
+ if (m/^change/i and not m/debian/i) {
+ tag 'wrong-name-for-upstream-changelog',
+ "usr/share/doc/$pkg/$_";
+ $found = 1;
+ last;
+ }
+ }
+ if (not $found) {
+ tag 'no-upstream-changelog'
+ unless $info->is_pkg_class('transitional');
+ }
}
- }
- # 2. check for Debian changelog
- if (any { m/^changelog\.Debian(?:\.gz)?$/ } @doc_files) {
- # everything is fine
- } elsif (my $chg = first { m/^changelog\.debian(?:\.gz)?$/i } @doc_files) {
- tag 'wrong-name-for-debian-changelog-file', "usr/share/doc/$pkg/$chg";
- } else {
- if ($foreign_pkg && $found_upstream_text_changelog) {
- tag 'debian-changelog-file-missing-or-wrong-name';
- } elsif ($foreign_pkg) {
- tag 'debian-changelog-file-missing';
+ # 2. check for Debian changelog
+ if (any { m/^changelog\.Debian(?:\.gz)?$/ } @doc_files) {
+ # everything is fine
+ } elsif (
+ my $chg = first {
+ m/^changelog\.debian(?:\.gz)?$/i;
+ }
+ @doc_files
+ ) {
+ tag 'wrong-name-for-debian-changelog-file',
+ "usr/share/doc/$pkg/$chg";
+ } else {
+ if ($foreign_pkg && $found_upstream_text_changelog) {
+ tag 'debian-changelog-file-missing-or-wrong-name';
+ } elsif ($foreign_pkg) {
+ tag 'debian-changelog-file-missing';
+ }
+ # TODO: if uncertain whether foreign or native, either
+ # changelog.gz or changelog.debian.gz should exists
+ # though... but no tests catches this (extremely rare)
+ # border case... Keep in mind this is only happening if we
+ # have a -0.x version number... So not my priority to fix
+ #
+ # --Jeroen
}
- # TODO: if uncertain whether foreign or native, either changelog.gz or
- # changelog.debian.gz should exists though... but no tests catches
- # this (extremely rare) border case... Keep in mind this is only
- # happening if we have a -0.x version number... So not my priority to
- # fix --Jeroen
}
-}
-my $dchpath = $info->lab_data_path ('changelog');
-# Everything below involves opening and reading the changelog file, so bail
-# with a warning at this point if all we have is a symlink. Ubuntu permits
-# such symlinks, so their profile will suppress this tag.
-if (-l $dchpath) {
- tag 'debian-changelog-file-is-a-symlink';
- return;
-}
+ my $dchpath = $info->lab_data_path('changelog');
+ # Everything below involves opening and reading the changelog
+ # file, so bail with a warning at this point if all we have is a
+ # symlink. Ubuntu permits such symlinks, so their profile will
+ # suppress this tag.
+ if (-l $dchpath) {
+ tag 'debian-changelog-file-is-a-symlink';
+ return;
+ }
-# Bail at this point if the changelog file doesn't exist. We will have
-# already warned about this.
-unless (-f $dchpath) {
- return;
-}
+ # Bail at this point if the changelog file doesn't exist. We will
+ # have already warned about this.
+ unless (-f $dchpath) {
+ return;
+ }
-# check that changelog is UTF-8 encoded
-my $line = file_is_encoded_in_non_utf8($dchpath);
-if ($line) {
- tag 'debian-changelog-file-uses-obsolete-national-encoding', "at line $line"
-}
+ # check that changelog is UTF-8 encoded
+ my $line = file_is_encoded_in_non_utf8($dchpath);
+ if ($line) {
+ tag 'debian-changelog-file-uses-obsolete-national-encoding',
+ "at line $line";
+ }
-my $changelog = $info->changelog;
-if (my @errors = $changelog->get_parse_errors) {
- foreach (@errors) {
- tag 'syntax-error-in-debian-changelog', "line $_->[1]", "\"$_->[2]\"";
+ my $changelog = $info->changelog;
+ if (my @errors = $changelog->get_parse_errors) {
+ foreach (@errors) {
+ tag 'syntax-error-in-debian-changelog', "line $_->[1]",
+ "\"$_->[2]\"";
+ }
}
-}
-# Check for some things in the raw changelog file and compute the
-# "offset" to the first line of the first entry. We use this to
-# report the line number of "too-long" lines. (#657402)
-my $chloff = check_dch($dchpath);
-
-my @entries = $changelog->data;
-if (@entries) {
- my %versions;
- for my $entry (@entries) {
- if ($entry->Maintainer) {
- if ($entry->Maintainer =~ /<([^>\@]+\@[^>.]*)>/) {
- tag 'debian-changelog-file-contains-invalid-email-address', $1;
+ # Check for some things in the raw changelog file and compute the
+ # "offset" to the first line of the first entry. We use this to
+ # report the line number of "too-long" lines. (#657402)
+ my $chloff = check_dch($dchpath);
+
+ my @entries = $changelog->data;
+ if (@entries) {
+ my %versions;
+ for my $entry (@entries) {
+ if ($entry->Maintainer) {
+ if ($entry->Maintainer =~ /<([^>\@]+\@[^>.]*)>/) {
+ tag 'debian-changelog-file-contains-invalid-email-address',
+ $1;
+ }
}
+ $versions{ $entry->Version } = 1 if defined $entry->Version;
}
- $versions{$entry->Version} = 1 if defined $entry->Version;
- }
- if (@entries > 1) {
- my $first_timestamp = $entries[0]->Timestamp;
- my $second_timestamp = $entries[1]->Timestamp;
+ if (@entries > 1) {
+ my $first_timestamp = $entries[0]->Timestamp;
+ my $second_timestamp = $entries[1]->Timestamp;
- if ($first_timestamp && $second_timestamp) {
- tag 'latest-debian-changelog-entry-without-new-date'
- unless (($first_timestamp - $second_timestamp) > 0
- or lc($entries[0]->Distribution) eq 'unreleased');
- }
+ if ($first_timestamp && $second_timestamp) {
+ tag 'latest-debian-changelog-entry-without-new-date'
+ unless (($first_timestamp - $second_timestamp) > 0
+ or lc($entries[0]->Distribution) eq 'unreleased');
+ }
- my $first_version = $entries[0]->Version;
- my $second_version = $entries[1]->Version;
- if ($first_version and $second_version) {
- tag 'latest-debian-changelog-entry-without-new-version'
- unless versions_gt($first_version, $second_version)
- or $entries[0]->Changes =~ /backport/i;
- tag 'latest-debian-changelog-entry-changed-to-native'
- if $native_pkg and $second_version =~ m/-/;
- }
+ my $first_version = $entries[0]->Version;
+ my $second_version = $entries[1]->Version;
+ if ($first_version and $second_version) {
+ tag 'latest-debian-changelog-entry-without-new-version'
+ unless versions_gt($first_version, $second_version)
+ or $entries[0]->Changes =~ /backport/i;
+ tag 'latest-debian-changelog-entry-changed-to-native'
+ if $native_pkg and $second_version =~ m/-/;
+ }
- my $first_upstream = $first_version;
- $first_upstream =~ s/-[^-]+$//;
- my $second_upstream = $second_version;
- $second_upstream =~ s/-[^-]+$//;
- if ($first_upstream eq $second_upstream
- and $entries[0]->Changes =~ /^\s*\*\s+new\s+upstream\s+(?:\S+\s+)?release\b/im) {
- tag 'possible-new-upstream-release-without-new-version';
- }
+ my $first_upstream = $first_version;
+ $first_upstream =~ s/-[^-]+$//;
+ my $second_upstream = $second_version;
+ $second_upstream =~ s/-[^-]+$//;
+ if ( $first_upstream eq $second_upstream
+ and $entries[0]->Changes
+ =~ /^\s*\*\s+new\s+upstream\s+(?:\S+\s+)?release\b/im) {
+ tag 'possible-new-upstream-release-without-new-version';
+ }
- my $first_dist = lc $entries[0]->Distribution;
- my $second_dist = lc $entries[1]->Distribution;
- if ($first_dist eq 'unstable' and $second_dist eq 'experimental') {
- unless ($entries[0]->Changes =~ /\bto\s+unstable\b/) {
- tag 'experimental-to-unstable-without-comment';
+ my $first_dist = lc $entries[0]->Distribution;
+ my $second_dist = lc $entries[1]->Distribution;
+ if ($first_dist eq 'unstable' and $second_dist eq 'experimental') {
+ unless ($entries[0]->Changes =~ /\bto\s+unstable\b/) {
+ tag 'experimental-to-unstable-without-comment';
+ }
}
}
- }
- # Some checks should only be done against the most recent changelog entry.
- my $entry = $entries[0];
- my $changes = $entry->Changes || '';
+ # Some checks should only be done against the most recent
+ # changelog entry.
+ my $entry = $entries[0];
+ my $changes = $entry->Changes || '';
- if (@entries == 1) {
- if ($entry->Version and $entry->Version =~ /-1$/) {
- tag 'new-package-should-close-itp-bug'
- unless @{ $entry->Closes };
+ if (@entries == 1) {
+ if ($entry->Version and $entry->Version =~ /-1$/) {
+ tag 'new-package-should-close-itp-bug'
+ unless @{ $entry->Closes };
+ }
+ if ($changes
+ =~ /(?:#?\s*)(?:\d|n)+ is the bug number of your ITP/i) {
+ tag 'changelog-is-dh_make-template';
+ }
}
- if ($changes =~ /(?:#?\s*)(?:\d|n)+ is the bug number of your ITP/i) {
- tag 'changelog-is-dh_make-template';
+ while ($changes =~ /(closes\s*(?:bug)?\#?\s?\d{6,})[^\w]/ig) {
+ tag 'possible-missing-colon-in-closes', $1 if $1;
+ }
+ my $closes = $entry->Closes;
+ for my $bug (@$closes) {
+ tag 'improbable-bug-number-in-closes', $bug if ($bug < 100);
}
- }
- while ($changes =~ /(closes\s*(?:bug)?\#?\s?\d{6,})[^\w]/ig) {
- tag 'possible-missing-colon-in-closes', $1 if $1;
- }
- my $closes = $entry->Closes;
- for my $bug (@$closes) {
- tag 'improbable-bug-number-in-closes', $bug if ($bug < 100);
- }
- # unstable, testing, and stable shouldn't be used in Debian version
- # numbers. unstable should get a normal version increment and testing and
- # stable should get suite-specific versions.
- #
- # NMUs get a free pass because they need to work with the version number
- # that was already there.
- my $changelog_version;
- if ($info->native) {
- $changelog_version = $entry->Version || '';
- } else {
- if ($entry->Version) {
- ($changelog_version) = (split('-', $entry->Version))[-1];
+ # unstable, testing, and stable shouldn't be used in Debian
+ # version numbers. unstable should get a normal version
+ # increment and testing and stable should get suite-specific
+ # versions.
+ #
+ # NMUs get a free pass because they need to work with the
+ # version number that was already there.
+ my $changelog_version;
+ if ($info->native) {
+ $changelog_version = $entry->Version || '';
} else {
- $changelog_version = '';
+ if ($entry->Version) {
+ ($changelog_version) = (split('-', $entry->Version))[-1];
+ } else {
+ $changelog_version = '';
+ }
}
- }
- unless (not $info->native and $changelog_version =~ /\./) {
- if ($info->native and $changelog_version =~ /testing|(?:un)?stable/i) {
- tag 'version-refers-to-distribution', $entry->Version;
- } elsif ($changelog_version =~ /woody|sarge|etch|lenny|squeeze/) {
- my %unreleased_dists = map { $_ => 1 } qw(unstable experimental);
- if (exists ($unreleased_dists{$entry->Distribution})) {
+ unless (not $info->native and $changelog_version =~ /\./) {
+ if ( $info->native
+ and $changelog_version =~ /testing|(?:un)?stable/i) {
tag 'version-refers-to-distribution', $entry->Version;
+ } elsif ($changelog_version =~ /woody|sarge|etch|lenny|squeeze/) {
+ my %unreleased_dists
+ = map { $_ => 1 } qw(unstable experimental);
+ if (exists($unreleased_dists{ $entry->Distribution })) {
+ tag 'version-refers-to-distribution', $entry->Version;
+ }
}
}
- }
- # Compare against NEWS.Debian if available.
- if ($news and $news->Version) {
- if ($entry->Version eq $news->Version) {
- for my $field (qw/Distribution Urgency/) {
- if ($entry->$field ne $news->$field) {
- tag 'changelog-news-debian-mismatch', lc ($field),
- $entry->$field . ' != ' . $news->$field;
+ # Compare against NEWS.Debian if available.
+ if ($news and $news->Version) {
+ if ($entry->Version eq $news->Version) {
+ for my $field (qw/Distribution Urgency/) {
+ if ($entry->$field ne $news->$field) {
+ tag 'changelog-news-debian-mismatch', lc($field),
+ $entry->$field . ' != ' . $news->$field;
+ }
}
}
+ unless ($versions{ $news->Version }) {
+ tag 'debian-news-entry-has-unknown-version', $news->Version;
+ }
}
- unless ($versions{$news->Version}) {
- tag 'debian-news-entry-has-unknown-version', $news->Version;
- }
- }
- # We have to decode into UTF-8 to get the right length for the length
- # check. For some reason, use open ':utf8' isn't sufficient. If the
- # changelog uses a non-UTF-8 encoding, this will mangle it, but it doesn't
- # matter for the length check.
- #
- # Parse::DebianChangelog adds an additional space to the beginning of each
- # line, so we have to adjust for that in the length check.
- my @lines = split ("\n", decode ('utf-8', $changes));
- for my $i (0 .. $#lines) {
- if (length($lines[$i]) > 81
- and $lines[$i] !~ /^[\s.o*+-]*(?:[Ss]ee:?\s+)?\S+$/) {
- tag 'debian-changelog-line-too-long', 'line ' . ($i + $chloff);
+ # We have to decode into UTF-8 to get the right length for the
+ # length check. For some reason, use open ':utf8' isn't
+ # sufficient. If the changelog uses a non-UTF-8 encoding,
+ # this will mangle it, but it doesn't matter for the length
+ # check.
+ #
+ # Parse::DebianChangelog adds an additional space to the
+ # beginning of each line, so we have to adjust for that in the
+ # length check.
+ my @lines = split("\n", decode('utf-8', $changes));
+ for my $i (0 .. $#lines) {
+ if (length($lines[$i]) > 81
+ and $lines[$i] !~ /^[\s.o*+-]*(?:[Ss]ee:?\s+)?\S+$/) {
+ tag 'debian-changelog-line-too-long', 'line ' . ($i + $chloff);
+ }
}
- }
- # Strip out all lines that contain the word spelling to avoid false
- # positives on changelog entries for spelling fixes.
- $changes =~ s/^.*spelling.*\n//gm;
- check_spelling('spelling-error-in-changelog', $changes, undef,
- $group->info->spelling_exceptions);
-}
+ # Strip out all lines that contain the word spelling to avoid false
+ # positives on changelog entries for spelling fixes.
+ $changes =~ s/^.*spelling.*\n//gm;
+ check_spelling('spelling-error-in-changelog', $changes, undef,
+ $group->info->spelling_exceptions);
+ }
-return;
+ return;
}
# read the changelog itself and check for some issues we cannot find
@@ -399,10 +435,12 @@ sub check_dch {
$tstart = 1 if m/^\s+\S/;
}
- if (/closes:\s*(((?:bug)?\#?\s?\d*)[[:alpha:]]\w*)/io
+ if (
+ /closes:\s*(((?:bug)?\#?\s?\d*)[[:alpha:]]\w*)/io
|| /closes:\s*(?:bug)?\#?\s?\d+
(?:,\s*(?:bug)?\#?\s?\d+)*
- (?:,\s*(((?:bug)?\#?\s?\d*)[[:alpha:]]\w*))/iox) {
+ (?:,\s*(((?:bug)?\#?\s?\d*)[[:alpha:]]\w*))/iox
+ ) {
tag 'wrong-bug-number-in-closes', "l$.:$1" if $2;
}
@@ -411,8 +449,9 @@ sub check_dch {
$suffix = $2;
}
# emacs allows whitespace between prefix and variable, hence \s*
- if (defined $prefix && defined $suffix
- && /^\Q$prefix\E\s*add-log-mailing-address:.*\Q$suffix\E$/) {
+ if ( defined $prefix
+ && defined $suffix
+ && /^\Q$prefix\E\s*add-log-mailing-address:.*\Q$suffix\E$/) {
tag 'debian-changelog-file-contains-obsolete-user-emacs-settings';
}
}
@@ -420,7 +459,6 @@ sub check_dch {
return $lineno;
}
-
1;
# Local Variables:
diff --git a/checks/systemd.pm b/checks/systemd.pm
index 6e60618..b719386 100644
--- a/checks/systemd.pm
+++ b/checks/systemd.pm
@@ -33,7 +33,7 @@ use Text::ParseWords qw(shellwords);
use Lintian::Tags qw(tag);
use Lintian::Util qw(
- fail is_ancestor_of normalize_pkg_path lstrip rstrip
+ fail is_ancestor_of normalize_pkg_path lstrip rstrip
);
sub run {
@@ -78,11 +78,11 @@ sub run {
if ($ships_systemd_file) {
for my $init_script (@init_scripts) {
tag 'systemd-no-service-for-init-script', $init_script
- unless any { m/\Q$init_script\E\.service/ } @systemd_targets;
+ unless any { m/\Q$init_script\E\.service/ } @systemd_targets;
}
}
- check_maintainer_scripts ($info);
+ check_maintainer_scripts($info);
return;
}
@@ -92,10 +92,13 @@ sub check_init_script {
my $lsb_source_seen;
# Couple of special cases we don't care about...
- return if $basename eq 'README' or $basename eq 'skeleton'
- or $basename eq 'rc' or $basename eq 'rcS';
+ return
+ if $basename eq 'README'
+ or $basename eq 'skeleton'
+ or $basename eq 'rc'
+ or $basename eq 'rcS';
- my $unpacked_file = $info->unpacked ($file);
+ my $unpacked_file = $info->unpacked($file);
if ($file->is_symlink) {
# We cannot test upstart-jobs
@@ -103,8 +106,8 @@ sub check_init_script {
}
if (!$file->is_regular_file) {
- unless (-f $unpacked_file &&
- is_ancestor_of($info->unpacked, $unpacked_file)) {
+ unless (-f $unpacked_file
+ && is_ancestor_of($info->unpacked, $unpacked_file)) {
tag 'init-script-is-not-a-file', $file;
return;
}
@@ -133,7 +136,8 @@ sub check_systemd_service_file {
my @values = extract_service_file_values($info, $file, 'Unit', 'After');
my @obsolete = grep { /^(?:syslog|dbus)\.target$/ } @values;
- tag 'systemd-service-file-refers-to-obsolete-target', $file, $_ for @obsolete;
+ tag 'systemd-service-file-refers-to-obsolete-target', $file, $_
+ for @obsolete;
return;
}
@@ -146,7 +150,7 @@ sub service_file_lines {
chomp;
if (defined($continuation)) {
- $_ = $continuation . $_;
+ $_ = $continuation . $_;
$continuation = undef;
}
@@ -176,13 +180,10 @@ sub extract_service_file_values {
my @values;
my $section;
- my $unpacked_file = $info->unpacked ($file);
+ my $unpacked_file = $info->unpacked($file);
unless (
- ( -f $unpacked_file
- && is_ancestor_of($info->unpacked, $unpacked_file)
- ) || ($file->is_symlink && $file->link eq '/dev/null')
- )
- {
+ (-f $unpacked_file && is_ancestor_of($info->unpacked, $unpacked_file))
+ || ($file->is_symlink && $file->link eq '/dev/null')) {
tag 'service-file-is-not-a-file', $file;
return;
}
@@ -199,9 +200,10 @@ sub extract_service_file_values {
$normalized = normalize_pkg_path($file->dirname, $path);
}
$included = $info->unpacked($normalized)
- if defined($normalized);
- if (defined($included) && -f $included
- && is_ancestor_of($info->unpacked, $included)) {
+ if defined($normalized);
+ if ( defined($included)
+ && -f $included
+ && is_ancestor_of($info->unpacked, $included)) {
service_file_lines($included);
} else {
# doesn't exist, exists but not a file or "out-of-bounds"
@@ -225,8 +227,8 @@ sub extract_service_file_values {
}
my ($key, $value) = ($_ =~ m,^(.*)=(.*)$,);
- if ($section eq $extract_section &&
- $key eq $extract_key) {
+ if ( $section eq $extract_section
+ && $key eq $extract_key) {
if ($value eq '') {
# Empty assignment resets the list
@values = ();
@@ -242,8 +244,9 @@ sub extract_service_file_values {
sub extract_service_file_names {
my ($info, $file) = @_;
- my @aliases = extract_service_file_values($info, $file, 'Install', 'Alias');
- return (basename ($file), @aliases);
+ my @aliases
+ = extract_service_file_values($info, $file, 'Install', 'Alias');
+ return (basename($file), @aliases);
}
sub check_maintainer_scripts {
@@ -254,18 +257,19 @@ sub check_maintainer_scripts {
while (<$fd>) {
m/^(\S*) (.*)$/ or fail("bad line in control-scripts file: $_");
my $interpreter = $1;
- my $file = $2;
- my $filename = $info->control ($file);
+ my $file = $2;
+ my $filename = $info->control($file);
# Don't follow links
next if -l $filename;
- # Don't try to parse the file if it does not appear to be a shell script
+ # Don't try to parse the file if it does not appear to be a
+ # shell script
next if $interpreter !~ m/sh\b/;
open(my $sfd, '<', $filename);
while (<$sfd>) {
# skip comments
- next if substr ($_, 0, $-[0]) =~ /#/;
+ next if substr($_, 0, $-[0]) =~ /#/;
# systemctl should not be called in maintainer scripts at all,
# except for systemctl --daemon-reload calls.
Reply to: