diff options
Diffstat (limited to 'lib/Lintian/Check')
345 files changed, 46943 insertions, 0 deletions
diff --git a/lib/Lintian/Check/Apache2.pm b/lib/Lintian/Check/Apache2.pm new file mode 100644 index 0000000..b8dde2d --- /dev/null +++ b/lib/Lintian/Check/Apache2.pm @@ -0,0 +1,337 @@ +# apache2 -- lintian check script -*- perl -*- +# +# Copyright (C) 2012 Arno Toell +# Copyright (C) 2017-2018 Chris Lamb <lamby@debian.org> +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Apache2; + +use v5.20; +use warnings; +use utf8; + +use File::Basename; +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::Relation; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +# whether the package appears to be an Apache2 module/web application +has is_apache2_related => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + for my $item (@{$self->processable->installed->sorted_list}) { + + return 1 + if $item->name =~ m{^ usr/lib/apache2/modules/ }x + && $item->basename =~ m{ [.]so $}x; + + return 1 + if $item->name + =~ m{^ etc/apache2/ (?:conf|site) - (?:available|enabled) / }x; + + return 1 + if $item->name =~ m{^ etc/apache2/conf[.]d/}x; + } + + return 0; + } +); + +sub visit_installed_files { + my ($self, $item) = @_; + + # Do nothing if the package in question appears to be related to + # the web server itself + return + if $self->processable->name =~ m/^apache2(:?\.2)?(?:-\w+)?$/; + + # File is probably not relevant to us, ignore it + return + if $item->is_dir; + + return + if $item->name !~ m{^(?:usr/lib/apache2/modules/|etc/apache2/)}; + + # Package installs an unrecognized file - check this for all files + if ( $item->name !~ /\.conf$/ + && $item->name =~ m{^etc/apache2/(conf|site|mods)-available/(.*)$}){ + + my $temp_type = $1; + my $temp_file = $2; + + # ... except modules which are allowed to ship .load files + $self->pointed_hint('apache2-configuration-files-need-conf-suffix', + $item->pointer) + unless $temp_type eq 'mods' && $temp_file =~ /\.load$/; + } + + # Package appears to be a binary module + if ($item->name =~ m{^usr/lib/apache2/modules/(.*)\.so$}) { + + $self->check_module_package($item, $1); + } + + # Package appears to be a web application + elsif ($item->name =~ m{^etc/apache2/(conf|site)-available/(.*)$}) { + + $self->check_web_application_package($item, $1, $2); + } + + # Package appears to be a legacy web application + elsif ($item->name =~ m{^etc/apache2/conf\.d/(.*)$}) { + + $self->pointed_hint( + 'apache2-reverse-dependency-uses-obsolete-directory', + $item->pointer); + $self->check_web_application_package($item,'conf', $1); + } + + # Package does scary things + elsif ($item->name =~ m{^etc/apache2/(?:conf|sites|mods)-enabled/.*$}) { + + $self->pointed_hint( + 'apache2-reverse-dependency-ships-file-in-not-allowed-directory', + $item->pointer); + } + + return; +} + +sub installable { + my ($self) = @_; + + # Do nothing if the package in question appears to be related to + # the web server itself + return + if $self->processable->name =~ m/^apache2(:?\.2)?(?:-\w+)?$/; + + return; +} + +sub check_web_application_package { + my ($self, $item, $pkgtype, $webapp) = @_; + + my $pkg = $self->processable->name; + my $processable = $self->processable; + + $self->pointed_hint('non-standard-apache2-configuration-name', + $item->pointer, "$webapp != $pkg.conf") + if $webapp ne "$pkg.conf" + || $webapp =~ /^local-/; + + my $rel = $processable->relation('strong') + ->logical_and($processable->relation('Recommends')); + + # A web application must not depend on apache2-whatever + my $visit = sub { + if (m/^apache2(?:\.2)?-(?:common|data|bin)$/) { + $self->pointed_hint( + 'web-application-depends-on-apache2-data-package', + $item->pointer, $_, $webapp); + return 1; + } + return 0; + }; + $rel->visit($visit, Lintian::Relation::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 + $self->pointed_hint('web-application-works-only-with-apache', + $item->pointer, $webapp) + if $rel->satisfies('apache2'); + + $self->inspect_conf_file($pkgtype, $item); + return; +} + +sub check_module_package { + my ($self, $item, $module) = @_; + + my $pkg = $self->processable->name; + my $processable = $self->processable; + + # We want packages to be follow our naming scheme. Modules should be named + # libapache2-mod-<foo> if it ships a mod_foo.so + # NB: Some modules have uppercase letters in them (e.g. Ruwsgi), but + # obviously the package should be in all lowercase. + my $expected_name = 'libapache2-' . lc($module); + + my $rel; + + $expected_name =~ tr/_/-/; + $self->pointed_hint('non-standard-apache2-module-package-name', + $item->pointer, "$pkg != $expected_name") + if $expected_name ne $pkg; + + $rel = $processable->relation('strong') + ->logical_and($processable->relation('Recommends')); + + $self->pointed_hint('apache2-module-does-not-depend-on-apache2-api', + $item->pointer) + if !$rel->matches(qr/^apache2-api-\d+$/); + + # The module is called mod_foo.so, thus the load file is expected to be + # named foo.load + my $load_file = $module; + my $conf_file = $module; + $load_file =~ s{^mod.(.*)$}{etc/apache2/mods-available/$1.load}; + $conf_file =~ s{^mod.(.*)$}{etc/apache2/mods-available/$1.conf}; + + if (my $f = $processable->installed->lookup($load_file)) { + $self->inspect_conf_file('mods', $f); + } else { + $self->pointed_hint('apache2-module-does-not-ship-load-file', + $item->pointer, $load_file); + } + + if (my $f = $processable->installed->lookup($conf_file)) { + $self->inspect_conf_file('mods', $f); + } + + return; +} + +sub visit_control_files { + my ($self, $item) = @_; + + return + unless $self->is_apache2_related; + + return + unless $item->is_maintainer_script; + + # skip anything but shell scripts + return + unless $item->is_shell_script; + + return + unless $item->is_open_ok; + + open(my $sfd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $position = 1; + while (my $line = <$sfd>) { + + # skip comments + next + if $line =~ /^ [#]/x; + + # Do not allow reverse dependencies to call "a2enmod" and friends + # directly + if ($line =~ m{ \b (a2(?:en|dis)(?:conf|site|mod)) \b }x) { + + my $command = $1; + + $self->pointed_hint( + 'apache2-reverse-dependency-calls-wrapper-script', + $item->pointer($position), $command); + } + + # Do not allow reverse dependencies to call "invoke-rc.d apache2 + $self->pointed_hint('apache2-reverse-dependency-calls-invoke-rc.d', + $item->pointer($position)) + if $line =~ /invoke-rc\.d\s+apache2/; + + # 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. + + } continue { + ++$position; + } + + return; +} + +sub inspect_conf_file { + my ($self, $conftype, $item) = @_; + + # Don't follow unsafe links + return + unless $item->is_open_ok; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $skip = 0; + + my $position = 1; + while (my $line = <$fd>) { + + ++$skip + if $line =~ m{<\s*IfModule.*!\s*mod_authz_core} + || $line =~ m{<\s*IfVersion\s+<\s*2\.3}; + + for my $directive ('Order', 'Satisfy', 'Allow', 'Deny', + qr{</?Limit.*?>}xsm, qr{</?LimitExcept.*?>}xsm) { + + if ($line =~ m{\A \s* ($directive) (?:\s+|\Z)}xsm && !$skip) { + + $self->pointed_hint('apache2-deprecated-auth-config', + $item->pointer($position), $1); + } + } + + if ($line =~ /^#\s*(Depends|Conflicts):\s+(.*?)\s*$/) { + my ($field, $value) = ($1, $2); + + $self->pointed_hint('apache2-unsupported-dependency', + $item->pointer($position), $field) + if $field eq 'Conflicts' && $conftype ne 'mods'; + + my @dependencies = split(/[\n\s]+/, $value); + for my $dep (@dependencies) { + + $self->pointed_hint('apache2-unparsable-dependency', + $item->pointer($position), $dep) + if $dep =~ /[^\w\.]/ + || $dep =~ /^mod\_/ + || $dep =~ /\.(?:conf|load)/; + } + } + + --$skip + if $line =~ m{<\s*/\s*If(Module|Version)}; + + } continue { + ++$position; + } + + close $fd; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/ApplicationNotLibrary.pm b/lib/Lintian/Check/ApplicationNotLibrary.pm new file mode 100644 index 0000000..a598385 --- /dev/null +++ b/lib/Lintian/Check/ApplicationNotLibrary.pm @@ -0,0 +1,141 @@ +# application-not-library -- find applications packaged like a library -*- perl -*- +# +# Copyright (C) 2014-2015 Axel Beckert <abe@debian.org> +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::ApplicationNotLibrary; + +use v5.20; +use warnings; +use utf8; + +use List::SomeUtils qw(any); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub installable { + my ($self) = @_; + + # big exception list for all tags + return + # perl itself + if $self->processable->name =~ /^perl(?:-base)?$/ + # ruby itself + || $self->processable->name =~ /^ruby[\d.]*$/ + # python itself + || $self->processable->name =~ /^python[\d.]*(?:-dev|-minimal)?$/ + # cpan related tools + || $self->processable->name =~ /^cpan/ + # perl module tools + || $self->processable->name =~ /^libmodule-.*-perl$/ + # perl debugging tools + || $self->processable->name =~ /^libdevel-.*-perl$/ + # perl-handling tools + || $self->processable->name =~ /^libperl.*-perl$/ + # perl testing tools + || $self->processable->name =~ /^libtest-.*-perl$/ + # python packaging stuff + || $self->processable->name =~ /^python[\d.]*-(?:stdeb|setuptools)$/ + # ruby packaging stuff + || $self->processable->name =~ /^gem2deb/ + # rendering engine + || $self->processable->name =~ /^xulrunner/ + # generic helpers + || $self->processable->name =~ /^lib.*-(?:utils|tools|bin|dev)/ + # whitelist + || ( + any { $self->processable->name eq $_ } + qw( + + rake + bundler + coderay + kdelibs-bin + libapp-options-perl + + ) + ); + + my @programs; + for my $searched_folder (qw{bin sbin usr/bin usr/sbin usr/games}) { + + my $directory_item + = $self->processable->installed->lookup("$searched_folder/"); + next + unless defined $directory_item; + + for my $program_item ($directory_item->children) { + + # ignore debhelper plugins + next + if $program_item->basename =~ /^dh_/; + + # ignore library configuration tools + next + if $program_item->name =~ /properties$/; + + # ignore library maintenance tools + next + if $program_item->name =~ /update$/; + + push(@programs, $program_item); + } + } + + return + unless @programs; + + # check for library style package names + if ( $self->processable->name =~ m{^ lib (?:.+) -perl $}x + || $self->processable->name =~ m{^ruby-}x + || $self->processable->name =~ m{^python[\d.]*-}x) { + + if ($self->processable->name =~ m{^ libapp (?:.+) -perl $}x) { + $self->pointed_hint('libapp-perl-package-name', $_->pointer) + for @programs; + + } else { + $self->pointed_hint('library-package-name-for-application', + $_->pointer) + for @programs; + } + } + + my $section = $self->processable->fields->value('Section'); + + # oldlibs is ok + if ($section =~ m{ perl | python | ruby | (?: ^ | / ) libs }x) { + + $self->pointed_hint('application-in-library-section', + $_->pointer, $section) + for @programs; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/AppstreamMetadata.pm b/lib/Lintian/Check/AppstreamMetadata.pm new file mode 100644 index 0000000..97a57d4 --- /dev/null +++ b/lib/Lintian/Check/AppstreamMetadata.pm @@ -0,0 +1,269 @@ +# appstream-metadata -- lintian check script -*- perl -*- + +# Copyright (C) 2016 Petter Reinholdtsen +# Copyright (C) 2017-2018 Chris Lamb <lamby@debian.org> +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::AppstreamMetadata; + +# For .desktop files, the lintian check would be really easy: Check if +# .desktop file is there, check if matching file exists in +# /usr/share/metainfo, if not throw a warning. Maybe while we're at it +# also check for legacy locations (stuff in /usr/share/appdata) and +# legacy data (metainfo files starting with `<application>`). +# +# For modaliases, maybe udev rules could give some hints. +# Check modalias values to ensure hex numbers are using capital A-F. + +use v5.20; +use warnings; +use utf8; +use autodie qw(open); + +use File::Basename qw(basename); +use Syntax::Keyword::Try; +use XML::LibXML; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub installable { + my ($self) = @_; + + my $pkg = $self->processable->name; + my $type = $self->processable->type; + my $processable = $self->processable; + my $group = $self->group; + + my (%desktopfiles, %metainfo, @udevrules); + my $found_modalias = 0; + my $modaliases = []; + if ( + defined( + my $dir + = $processable->installed->resolve_path( + 'usr/share/applications/') + ) + ) { + for my $item ($dir->descendants) { + $desktopfiles{$item} = 1 if ($item->is_file); + } + } + if ( + defined( + my $dir + = $processable->installed->resolve_path('usr/share/metainfo/') + ) + ) { + for my $item ($dir->children) { + if ($item->is_file) { + $metainfo{$item} = 1; + $found_modalias|= $self->check_modalias($item, $modaliases); + } + } + } + if ( + defined( + my $dir + = $processable->installed->resolve_path('usr/share/appdata/') + ) + ) { + for my $item ($dir->descendants) { + if ($item->is_file) { + + $self->pointed_hint('appstream-metadata-in-legacy-location', + $item->pointer); + $found_modalias|= $self->check_modalias($item, $modaliases); + } + } + } + foreach my $lib_dir (qw(usr/lib lib)) { + if ( + defined( + my $dir = $processable->installed->resolve_path( + "$lib_dir/udev/rules.d/") + ) + ) { + for my $item ($dir->descendants) { + push(@udevrules, $item) if ($item->is_file); + } + } + } + + for my $udevrule (@udevrules) { + if ($self->check_udev_rules($udevrule, $modaliases) + && !$found_modalias) { + + $self->hint('appstream-metadata-missing-modalias-provide', + $udevrule); + } + } + return; +} + +sub check_modalias { + my ($self, $item, $modaliases) = @_; + + if (!$item->is_open_ok) { + # FIXME report this as an error + return 0; + } + + my $parser = XML::LibXML->new; + $parser->set_option('no_network', 1); + + my $doc; + try { + $doc = $parser->parse_file($item->unpacked_path); + + } catch { + + $self->pointed_hint('appstream-metadata-invalid',$item->pointer); + + return 0; + } + + return 0 + unless $doc; + + if ($doc->findnodes('/application')) { + + $self->pointed_hint('appstream-metadata-legacy-format',$item->pointer); + return 0; + } + + my @provides = $doc->findnodes('/component/provides'); + return 0 + unless @provides; + + # take first one + my $first = $provides[0]; + return 0 + unless $first; + + my @nodes = $first->getChildrenByTagName('modalias'); + return 0 + unless @nodes; + + for my $node (@nodes) { + + my $alias = $node->firstChild->data; + next + unless $alias; + + push(@{$modaliases}, $alias); + + $self->pointed_hint('appstream-metadata-malformed-modalias-provide', + $item->pointer, + "include non-valid hex digit in USB matching rule '$alias'") + if $alias =~ /^usb:v[0-9a-f]{4}p[0-9a-f]{4}d/i + && $alias !~ /^usb:v[0-9A-F]{4}p[0-9A-F]{4}d/; + } + + return 1; +} + +sub provides_user_device { + my ($self, $item, $position, $rule, $data) = @_; + + my $retval = 0; + + if ( $rule =~ /plugdev/ + || $rule =~ /uaccess/ + || $rule =~ /MODE=\"0666\"/) { + + $retval = 1; + } + + if ($rule =~ m/SUBSYSTEM=="usb"/) { + my ($vmatch, $pmatch); + if ($rule =~ m/ATTR\{idVendor\}=="([0-9a-fA-F]{4})"/) { + $vmatch = 'v' . uc($1); + } + + if ($rule =~ m/ATTR\{idProduct\}=="([0-9a-fA-F]{4})"/) { + $pmatch = 'p' . uc($1); + } + + if (defined $vmatch && defined $pmatch) { + my $match = "usb:${vmatch}${pmatch}d"; + my $foundmatch; + for my $aliasmatch (@{$data}) { + if (0 == index($aliasmatch, $match)) { + $foundmatch = 1; + } + } + + $self->pointed_hint( + 'appstream-metadata-missing-modalias-provide', + $item->pointer($position), + "match rule $match*" + ) unless $foundmatch; + } + } + + return $retval; +} + +sub check_udev_rules { + my ($self, $item, $data) = @_; + + open(my $fd, '<', $item->unpacked_path); + + my $cont; + my $retval = 0; + + my $position = 0; + while (my $line = <$fd>) { + + chomp $line; + + if (defined $cont) { + $line = $cont . $line; + $cont = undef; + } + + if ($line =~ /^(.*)\\$/) { + $cont = $1; + next; + } + + # skip comments + next + if $line =~ /^#.*/; + + $retval |= $self->provides_user_device($item, $position, $line, $data); + + } continue { + ++$position; + } + + close $fd; + + return $retval; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Apt.pm b/lib/Lintian/Check/Apt.pm new file mode 100644 index 0000000..08b5ce6 --- /dev/null +++ b/lib/Lintian/Check/Apt.pm @@ -0,0 +1,69 @@ +# apt -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Apt; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + if $self->processable->source_name eq 'apt'; + + # /etc/apt/preferences + $self->pointed_hint('package-installs-apt-preferences', $item->pointer) + if $item->name =~ m{^ etc/apt/preferences (?: $ | [.]d / [^/]+ ) }x; + + # /etc/apt/sources + unless ($self->processable->name =~ m{ -apt-source $}x) { + + $self->pointed_hint('package-installs-apt-sources', $item->pointer) + if $item->name + =~ m{^ etc/apt/sources[.]list (?: $ | [.]d / [^/]+ ) }x; + } + + # /etc/apt/trusted.gpg + unless ( + $self->processable->name=~ m{ (?: -apt-source | -archive-keyring ) $}x) + { + + $self->pointed_hint('package-installs-apt-keyring', $item->pointer) + if $item->name=~ m{^ etc/apt/trusted[.]gpg (?: $ | [.]d / [^/]+ ) }x; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Archive/File/Name/Length.pm b/lib/Lintian/Check/Archive/File/Name/Length.pm new file mode 100644 index 0000000..212a6b9 --- /dev/null +++ b/lib/Lintian/Check/Archive/File/Name/Length.pm @@ -0,0 +1,93 @@ +# archive/file/name/length -- lintian check script -*- perl -*- + +# Copyright (C) 2011 Niels Thykier <niels@thykier.net> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Archive::File::Name::Length; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use File::Basename; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $SPACE => q{ }; + +const my $FILENAME_LENGTH_LIMIT => 80; + +# We could derive this from data/fields/architectures, but that +# contains things like kopensolaris-sparc64 and kfreebsd-sparc64, +# neither of which Debian officially supports. +const my $LONGEST_ARCHITECTURE => length 'kfreebsd-amd64'; + +sub always { + my ($self) = @_; + + # Skip auto-generated packages (dbgsym) + return + if $self->processable->fields->declares('Auto-Built-Package'); + + my $basename = basename($self->processable->path); + # remove salsaci suffix + my $nosalsabasename = $basename; + $nosalsabasename + =~ s/[+]salsaci[+]\d+[+]\d+(_[[:alnum:]]+\.[[:alnum:]]+)$/$1/; + + my $adjusted_length + = length($nosalsabasename) + - length($self->processable->architecture) + + $LONGEST_ARCHITECTURE; + + $self->hint('package-has-long-file-name', $basename) + if $adjusted_length > $FILENAME_LENGTH_LIMIT; + + return; +} + +sub source { + my ($self) = @_; + + my @lines = $self->processable->fields->trimmed_list('Files', qr/\n/); + + for my $line (@lines) { + + my (undef, undef, $name) = split($SPACE, $line); + next + unless length $name; + + $self->hint('source-package-component-has-long-file-name', $name) + if length $name > $FILENAME_LENGTH_LIMIT; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Archive/Liberty/Mismatch.pm b/lib/Lintian/Check/Archive/Liberty/Mismatch.pm new file mode 100644 index 0000000..6d050f6 --- /dev/null +++ b/lib/Lintian/Check/Archive/Liberty/Mismatch.pm @@ -0,0 +1,138 @@ +# archive/liberty/mismatch -- lintian check script -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Archive::Liberty::Mismatch; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(all none); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $ARROW => q{->}; + +sub source { + my ($self) = @_; + + my $control = $self->processable->debian_control; + my $source_fields = $control->source_fields; + + # Check that every package is in the same archive area, except + # that sources in main can deliver both main and contrib packages. + # The source package may or may not have a section specified; if + # it doesn't, derive the expected archive area from the first + # binary package by leaving $source_liberty undefined until parsing the + # first binary section. Missing sections will be caught by other + # checks. + + my $source_section = $source_fields->value('Section'); + return + unless length $source_section; + + # see policy 2.4 + $source_section = "main/$source_section" + if $source_section !~ m{/}; + + my $source_liberty = $source_section; + $source_liberty =~ s{ / .* $}{}x; + + my %liberty_by_installable; + + for my $installable ($control->installables) { + + my $installable_fields = $control->installable_fields($installable); + + my $installable_section; + if ($installable_fields->declares('Section')) { + + $installable_section = $installable_fields->value('Section'); + + # see policy 2.4 + $installable_section = "main/$installable_section" + if $installable_section !~ m{/}; + } + + $installable_section ||= $source_section; + + my $installable_liberty = $installable_section; + $installable_liberty =~ s{ / .* $}{}x; + + $liberty_by_installable{$installable} = $installable_liberty; + + # special exception for contrib built from main + next + if $source_liberty eq 'main' && $installable_liberty eq 'contrib'; + + # and non-free-firmware built from non-free + next + if $source_liberty eq 'non-free' + && $installable_liberty eq 'non-free-firmware'; + my $control_item= $self->processable->debian_control->item; + my $position = $installable_fields->position('Section'); + my $pointer = $control_item->pointer($position); + + $self->pointed_hint('archive-liberty-mismatch', $pointer, + "(in section for $installable)", + $installable_liberty, 'vs', $source_liberty) + if $source_liberty ne $installable_liberty; + } + + # in ascending order of liberty + for my $inferior_liberty ('non-free', 'contrib') { + + # must remain inferior + last + if $inferior_liberty eq $source_liberty; + + my $control_item= $self->processable->debian_control->item; + my $position = $source_fields->position('Section'); + my $pointer = $control_item->pointer($position); + + $self->pointed_hint('archive-liberty-mismatch', $pointer, + '(in source paragraph)', + $source_liberty,$ARROW, $inferior_liberty) + if ( + all { $liberty_by_installable{$_} eq $inferior_liberty } + keys %liberty_by_installable + ) + && ( + none { $liberty_by_installable{$_} eq $source_liberty } + keys %liberty_by_installable + ); + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Archive/NonFree/Autobuild.pm b/lib/Lintian/Check/Archive/NonFree/Autobuild.pm new file mode 100644 index 0000000..939f0fc --- /dev/null +++ b/lib/Lintian/Check/Archive/NonFree/Autobuild.pm @@ -0,0 +1,70 @@ +# archive/non-free/autobuild -- lintian check script -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Archive::NonFree::Autobuild; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + return + unless $self->processable->is_non_free; + + my $control = $self->processable->debian_control; + my $source_fields = $control->source_fields; + + my $changes = $self->group->changes; + + # source-only upload + if (defined $changes + && $changes->fields->value('Architecture') eq 'source') { + + my $field = 'XS-Autobuild'; + + my $control_item= $self->processable->debian_control->item; + my $position = $source_fields->position($field); + my $pointer = $control_item->pointer($position); + + $self->pointed_hint('source-only-upload-to-non-free-without-autobuild', + $pointer, '(in the source paragraph)', $field) + if !$source_fields->declares($field) + || $source_fields->value($field) eq 'no'; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Binaries.pm b/lib/Lintian/Check/Binaries.pm new file mode 100644 index 0000000..9e71f25 --- /dev/null +++ b/lib/Lintian/Check/Binaries.pm @@ -0,0 +1,73 @@ +# binaries -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2012 Kees Cook +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Binaries; + +use v5.20; +use warnings; +use utf8; + +use List::Compare; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + return + unless $item->file_type =~ /^ [^,]* \b ELF \b /x; + + my @KNOWN_STRIPPED_SECTION_NAMES = qw{.note .comment}; + + my @elf_sections = values %{$item->elf->{'SECTION-HEADERS'}}; + my @have_section_names = map { $_->name } @elf_sections; + + my $lc_name = List::Compare->new(\@have_section_names, + \@KNOWN_STRIPPED_SECTION_NAMES); + + my @have_stripped_sections = $lc_name->get_intersection; + + # appropriately stripped, but is it stripped enough? + if ( $item->file_type !~ m{ \b not [ ] stripped \b }x + && $item->name !~ m{^ (?:usr/)? lib/ (?: debug | profile ) / }x) { + + $self->pointed_hint('binary-has-unneeded-section', $item->pointer, $_) + for @have_stripped_sections; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Binaries/Architecture.pm b/lib/Lintian/Check/Binaries/Architecture.pm new file mode 100644 index 0000000..009b1f5 --- /dev/null +++ b/lib/Lintian/Check/Binaries/Architecture.pm @@ -0,0 +1,60 @@ +# binaries/architecture -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2012 Kees Cook +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Binaries::Architecture; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + return + unless $item->file_type =~ m{^ [^,]* \b ELF \b }x + || $item->file_type =~ m{ \b current [ ] ar [ ] archive \b }x; + + my $architecture = $self->processable->fields->value('Architecture'); + + $self->pointed_hint('arch-independent-package-contains-binary-or-object', + $item->pointer) + if $architecture eq 'all'; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Binaries/Architecture/Other.pm b/lib/Lintian/Check/Binaries/Architecture/Other.pm new file mode 100644 index 0000000..b40811f --- /dev/null +++ b/lib/Lintian/Check/Binaries/Architecture/Other.pm @@ -0,0 +1,141 @@ +# binaries/architecture/other -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2012 Kees Cook +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Binaries::Architecture::Other; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +# Guile object files do not objdump/strip correctly, so exclude them +# from a number of tests. (#918444) +const my $GUILE_PATH_REGEX => qr{^usr/lib(?:/[^/]+)+/guile/[^/]+/.+\.go$}; + +has ARCH_REGEX => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my %arch_regex; + + my $data = $self->data->load('binaries/arch-regex', qr/\s*\~\~/); + for my $architecture ($data->all) { + + my $pattern = $data->value($architecture); + $arch_regex{$architecture} = qr{$pattern}; + } + + return \%arch_regex; + } +); + +has ARCH_64BIT_EQUIVS => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return $self->data->load('binaries/arch-64bit-equivs',qr/\s*\=\>\s*/); + } +); + +sub from_other_architecture { + my ($self, $item) = @_; + + my $architecture = $self->processable->fields->value('Architecture'); + + return 0 + if $architecture eq 'all'; + + # If it matches the architecture regex, it is good + return 0 + if exists $self->ARCH_REGEX->{$architecture} + && $item->file_type =~ $self->ARCH_REGEX->{$architecture}; + + # Special case - "old" multi-arch dirs + if ( $item->name =~ m{(?:^|/)lib(x?\d\d)/} + || $item->name =~ m{^emul/ia(\d\d)}) { + + my $bus_width = $1; + + return 0 + if exists $self->ARCH_REGEX->{$bus_width} + && $item->file_type =~ $self->ARCH_REGEX->{$bus_width}; + } + + # Detached debug symbols could be for a biarch library. + return 0 + if $item->name =~ m{^usr/lib/debug/\.build-id/}; + + # Guile binaries do not objdump/strip (etc.) correctly. + return 0 + if $item->name =~ $GUILE_PATH_REGEX; + + # Allow amd64 kernel modules to be installed on i386. + if ( $item->name =~ m{^lib/modules/} + && $self->ARCH_64BIT_EQUIVS->recognizes($architecture)) { + + my $equivalent_64 = $self->ARCH_64BIT_EQUIVS->value($architecture); + + return 0 + if $item->file_type =~ $self->ARCH_REGEX->{$equivalent_64}; + } + + # Ignore i386 binaries in amd64 packages for right now. + return 0 + if $architecture eq 'amd64' + && $item->file_type =~ $self->ARCH_REGEX->{i386}; + + return 1; +} + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + return + unless $item->file_type =~ /^ [^,]* \b ELF \b /x; + + $self->pointed_hint('binary-from-other-architecture', $item->pointer) + if $self->from_other_architecture($item); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Binaries/Corrupted.pm b/lib/Lintian/Check/Binaries/Corrupted.pm new file mode 100644 index 0000000..834ed31 --- /dev/null +++ b/lib/Lintian/Check/Binaries/Corrupted.pm @@ -0,0 +1,93 @@ +# binaries/corrupted -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2012 Kees Cook +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Binaries::Corrupted; + +use v5.20; +use warnings; +use utf8; + +use List::SomeUtils qw(uniq); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_patched_files { + my ($self, $item) = @_; + + $self->check_elf_issues($item); + + return; +} + +sub visit_installed_files { + my ($self, $item) = @_; + + $self->check_elf_issues($item); + + return; +} + +sub check_elf_issues { + my ($self, $item) = @_; + + return unless $item->is_elf; + + for (uniq @{$item->elf->{ERRORS} // []}) { + $self->pointed_hint('elf-error',$item->pointer, $_) + unless ( + m{In program headers: Unable to find program interpreter name} + and $item->name =~ m{^usr/lib/debug/}); + } + + $self->pointed_hint('elf-warning', $item->pointer, $_) + for uniq @{$item->elf->{WARNINGS} // []}; + + # static library + for my $member_name (keys %{$item->elf_by_member}) { + + my $member_elf = $item->elf_by_member->{$member_name}; + + $self->pointed_hint('elf-error', $item->pointer, $member_name, $_) + for uniq @{$member_elf->{ERRORS} // []}; + + $self->pointed_hint('elf-warning', $item->pointer, $member_name, $_) + for uniq @{$member_elf->{WARNINGS} // []}; + } + + $self->pointed_hint('binary-with-bad-dynamic-table', $item->pointer) + if $item->elf->{'BAD-DYNAMIC-TABLE'} + && $item->name !~ m{^usr/lib/debug/}; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Binaries/DebugSymbols.pm b/lib/Lintian/Check/Binaries/DebugSymbols.pm new file mode 100644 index 0000000..4afe525 --- /dev/null +++ b/lib/Lintian/Check/Binaries/DebugSymbols.pm @@ -0,0 +1,72 @@ +# binaries/debug-symbols -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2012 Kees Cook +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Binaries::DebugSymbols; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +# Guile object files do not objdump/strip correctly, so exclude them +# from a number of tests. (#918444) +const my $GUILE_PATH_REGEX => qr{^usr/lib(?:/[^/]+)+/guile/[^/]+/.+\.go$}; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + return + unless $item->file_type =~ /^ [^,]* \b ELF \b /x; + + # Is it an object file (which generally cannot be + # stripped), a kernel module, debugging symbols, or + # perhaps a debugging package? + $self->pointed_hint('unstripped-binary-or-object', $item->pointer) + if $item->file_type =~ m{ \b not [ ] stripped \b }x + && $item->name !~ m{ [.]k?o $}x + && $self->processable->name !~ m{ -dbg $}x + && $item->name !~ m{^ (?:usr/)? lib/debug/ }x + && $item->name !~ $GUILE_PATH_REGEX + && $item->name !~ m{ [.]gox $}x + && ( $item->file_type !~ m/executable/ + || $item->strings !~ m{^ Caml1999X0[0-9][0-9] $}mx); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Binaries/DebugSymbols/Detached.pm b/lib/Lintian/Check/Binaries/DebugSymbols/Detached.pm new file mode 100644 index 0000000..b4f9a4f --- /dev/null +++ b/lib/Lintian/Check/Binaries/DebugSymbols/Detached.pm @@ -0,0 +1,86 @@ +# binaries/debug-symbols/detached -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2012 Kees Cook +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Binaries::DebugSymbols::Detached; + +use v5.20; +use warnings; +use utf8; + +use List::Compare; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + return + unless $item->file_type =~ /^ [^,]* \b ELF \b /x; + + return + unless $item->file_type =~ m{ executable | shared [ ] object }x; + + # Detached debugging symbols directly in /usr/lib/debug. + $self->pointed_hint('debug-symbols-directly-in-usr-lib-debug', + $item->pointer) + if $item->dirname eq 'usr/lib/debug/'; + + return + unless $item->name + =~ m{^ usr/lib/debug/ (?:lib\d*|s?bin|usr|opt|dev|emul|\.build-id) / }x; + + $self->pointed_hint('debug-symbols-not-detached', $item->pointer) + if exists $item->elf->{NEEDED}; + + # Something other than detached debugging symbols in + # /usr/lib/debug paths. + my @KNOWN_DEBUG_SECTION_NAMES + = qw{.debug_line .zdebug_line .debug_str .zdebug_str}; + + my @elf_sections = values %{$item->elf->{'SECTION-HEADERS'}}; + my @have_section_names = map { $_->name } @elf_sections; + + my $lc_name + = List::Compare->new(\@have_section_names, \@KNOWN_DEBUG_SECTION_NAMES); + + my @have_debug_sections = $lc_name->get_intersection; + + $self->pointed_hint('debug-file-with-no-debug-symbols', $item->pointer) + unless @have_debug_sections; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Binaries/Hardening.pm b/lib/Lintian/Check/Binaries/Hardening.pm new file mode 100644 index 0000000..55e70ac --- /dev/null +++ b/lib/Lintian/Check/Binaries/Hardening.pm @@ -0,0 +1,183 @@ +# binaries/hardening -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2012 Kees Cook +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Binaries::Hardening; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has HARDENED_FUNCTIONS => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return $self->data->load('binaries/hardened-functions'); + } +); + +has recommended_hardening_features => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my %recommended_hardening_features; + + my $hardening_buildflags = $self->data->hardening_buildflags; + my $architecture = $self->processable->fields->value('Architecture'); + + %recommended_hardening_features + = map { $_ => 1 } + @{$hardening_buildflags->recommended_features->{$architecture}} + if $architecture ne 'all'; + + return \%recommended_hardening_features; + } +); + +has built_with_golang => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $built_with_golang = $self->processable->name =~ m/^golang-/; + + my $source = $self->group->source; + + $built_with_golang + = $source->relation('Build-Depends-All') + ->satisfies('golang-go | golang-any') + if defined $source; + + return $built_with_golang; + } +); + +sub visit_installed_files { + my ($self, $item) = @_; + + my @elf_hardened; + my @elf_unhardened; + + for my $symbol (@{$item->elf->{SYMBOLS}}) { + + next + unless $symbol->section eq 'UND'; + + if ($symbol->name =~ /^__(\S+)_chk$/) { + + my $vulnerable = $1; + push(@elf_hardened, $vulnerable) + if $self->HARDENED_FUNCTIONS->recognizes($vulnerable); + + } else { + + push(@elf_unhardened, $symbol->name) + if $self->HARDENED_FUNCTIONS->recognizes($symbol->name); + } + } + + $self->pointed_hint('hardening-no-fortify-functions', $item->pointer) + if @elf_unhardened + && !@elf_hardened + && !$self->built_with_golang + && $self->recommended_hardening_features->{fortify}; + + for my $member_name (keys %{$item->elf_by_member}) { + + my @member_hardened; + my @member_unhardened; + + for my $symbol (@{$item->elf_by_member->{$member_name}{SYMBOLS}}) { + + next + unless $symbol->section eq 'UND'; + + if ($symbol->name =~ /^__(\S+)_chk$/) { + + my $vulnerable = $1; + push(@member_hardened, $vulnerable) + if $self->HARDENED_FUNCTIONS->recognizes($vulnerable); + + } else { + + push(@member_unhardened, $symbol->name) + if $self->HARDENED_FUNCTIONS->recognizes($symbol->name); + } + } + + $self->pointed_hint('hardening-no-fortify-functions', + $item->pointer, $member_name) + if @member_unhardened + && !@member_hardened + && !$self->built_with_golang + && $self->recommended_hardening_features->{fortify}; + } + + return + if $self->processable->type eq 'udeb'; + + return + unless $item->is_file; + + return + if $item->file_type !~ m{^ [^,]* \b ELF \b }x + || $item->file_type !~ m{ \b executable | shared [ ] object \b }x; + + # dynamically linked? + return + unless exists $item->elf->{NEEDED}; + + $self->pointed_hint('hardening-no-relro', $item->pointer) + if $self->recommended_hardening_features->{relro} + && !$self->built_with_golang + && !$item->elf->{PH}{RELRO}; + + $self->pointed_hint('hardening-no-bindnow', $item->pointer) + if $self->recommended_hardening_features->{bindnow} + && !$self->built_with_golang + && !exists $item->elf->{FLAGS_1}{NOW}; + + $self->pointed_hint('hardening-no-pie', $item->pointer) + if $self->recommended_hardening_features->{pie} + && !$self->built_with_golang + && $item->elf->{'ELF-HEADER'}{Type} =~ m{^ EXEC }x; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Binaries/LargeFileSupport.pm b/lib/Lintian/Check/Binaries/LargeFileSupport.pm new file mode 100644 index 0000000..e64d727 --- /dev/null +++ b/lib/Lintian/Check/Binaries/LargeFileSupport.pm @@ -0,0 +1,108 @@ +# binaries/large-file-support -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2012 Kees Cook +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Binaries::LargeFileSupport; + +use v5.20; +use warnings; +use utf8; + +use List::SomeUtils qw(any); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has ARCH_REGEX => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my %arch_regex; + + my $data = $self->data->load('binaries/arch-regex', qr/\s*\~\~/); + for my $architecture ($data->all) { + + my $pattern = $data->value($architecture); + $arch_regex{$architecture} = qr{$pattern}; + } + + return \%arch_regex; + } +); + +has LFS_SYMBOLS => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return $self->data->load('binaries/lfs-symbols'); + } +); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + # The LFS check only works reliably for ELF files due to the + # architecture regex. + return + unless $item->is_elf; + + # Only 32bit ELF binaries can lack LFS. + return + unless $item->file_type =~ $self->ARCH_REGEX->{'32'}; + + return + if $item->name =~ m{^usr/lib/debug/}; + + my @unresolved_symbols; + for my $symbol (@{$item->elf->{SYMBOLS} // [] }) { + + # ignore if defined in the binary + next + unless $symbol->section eq 'UND'; + + push(@unresolved_symbols, $symbol->name); + } + + # Using a 32bit only interface call, some parts of the + # binary are built without LFS + $self->pointed_hint('binary-file-built-without-LFS-support',$item->pointer) + if any { $self->LFS_SYMBOLS->recognizes($_) } @unresolved_symbols; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Binaries/Location.pm b/lib/Lintian/Check/Binaries/Location.pm new file mode 100644 index 0000000..c207ae0 --- /dev/null +++ b/lib/Lintian/Check/Binaries/Location.pm @@ -0,0 +1,138 @@ +# binaries/location -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2012 Kees Cook +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Binaries::Location; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; + +const my %PATH_DIRECTORIES => map { $_ => 1 } qw( + bin/ sbin/ usr/bin/ usr/sbin/ usr/games/ ); + +has DEB_HOST_MULTIARCH => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return $self->data->architectures->deb_host_multiarch; + } +); + +has gnu_triplet_pattern => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $gnu_triplet_pattern = $EMPTY; + + my $architecture = $self->processable->fields->value('Architecture'); + my $madir = $self->DEB_HOST_MULTIARCH->{$architecture}; + + if (length $madir) { + $gnu_triplet_pattern = quotemeta $madir; + $gnu_triplet_pattern =~ s{^i386}{i[3-6]86}; + } + + return $gnu_triplet_pattern; + } +); + +has ruby_triplet_pattern => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $ruby_triplet_pattern = $self->gnu_triplet_pattern; + $ruby_triplet_pattern =~ s{linux\\-gnu$}{linux}; + $ruby_triplet_pattern =~ s{linux\\-gnu}{linux\\-}; + + return $ruby_triplet_pattern; + } +); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + return + unless $item->file_type =~ /^ [^,]* \b ELF \b /x + || $item->file_type =~ / \b current [ ] ar [ ] archive \b /x; + + $self->pointed_hint('binary-in-etc', $item->pointer) + if $item->name =~ m{^etc/}; + + $self->pointed_hint('arch-dependent-file-in-usr-share', $item->pointer) + if $item->name =~ m{^usr/share/}; + + my $fields = $self->processable->fields; + + my $architecture = $fields->value('Architecture'); + my $multiarch = $fields->value('Multi-Arch') || 'no'; + + my $gnu_triplet_pattern = $self->gnu_triplet_pattern; + my $ruby_triplet_pattern = $self->ruby_triplet_pattern; + + $self->pointed_hint('arch-dependent-file-not-in-arch-specific-directory', + $item->pointer) + if $multiarch eq 'same' + && length $gnu_triplet_pattern + && $item->name !~ m{\b$gnu_triplet_pattern(?:\b|_)} + && length $ruby_triplet_pattern + && $item->name !~ m{/$ruby_triplet_pattern/} + && $item->name !~ m{/java-\d+-openjdk-\Q$architecture\E/} + && $item->name !~ m{/[.]build-id/}; + + return + unless $item->file_type =~ /^ [^,]* \b ELF \b /x; + + $self->pointed_hint('development-package-ships-elf-binary-in-path', + $item->pointer) + if exists $PATH_DIRECTORIES{$item->dirname} + && $fields->value('Section') =~ m{ (?:^|/) libdevel $}x + && $fields->value('Multi-Arch') ne 'foreign'; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Binaries/Obsolete/Crypt.pm b/lib/Lintian/Check/Binaries/Obsolete/Crypt.pm new file mode 100644 index 0000000..8813d8b --- /dev/null +++ b/lib/Lintian/Check/Binaries/Obsolete/Crypt.pm @@ -0,0 +1,90 @@ +# binaries/obsolete/crypt -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2012 Kees Cook +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Binaries::Obsolete::Crypt; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has OBSOLETE_CRYPT_FUNCTIONS => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return $self->data->load('binaries/obsolete-crypt-functions', + qr/\s*\|\|\s*/); + } +); + +sub visit_installed_files { + my ($self, $item) = @_; + + for my $symbol (@{$item->elf->{SYMBOLS} // []}) { + + next + unless $symbol->section eq 'UND'; + + next + unless $self->OBSOLETE_CRYPT_FUNCTIONS->recognizes($symbol->name); + + my $tag = $self->OBSOLETE_CRYPT_FUNCTIONS->value($symbol->name); + + $self->pointed_hint($tag, $item->pointer, $symbol->name); + } + + for my $member_name (keys %{$item->elf_by_member}) { + + for + my $symbol (@{$item->elf_by_member->{$member_name}{SYMBOLS} // []}) { + + next + unless $symbol->section eq 'UND'; + + next + unless $self->OBSOLETE_CRYPT_FUNCTIONS->recognizes( + $symbol->name); + + my $tag = $self->OBSOLETE_CRYPT_FUNCTIONS->value($symbol->name); + + $self->pointed_hint($tag, $item->pointer, "($member_name)", + $symbol->name); + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Binaries/Prerequisites.pm b/lib/Lintian/Check/Binaries/Prerequisites.pm new file mode 100644 index 0000000..cdc5868 --- /dev/null +++ b/lib/Lintian/Check/Binaries/Prerequisites.pm @@ -0,0 +1,214 @@ +# binaries/prerequisites -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2012 Kees Cook +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Binaries::Prerequisites; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(any none uniq); + +const my $SPACE => q{ }; +const my $LEFT_PARENTHESIS => q{(}; +const my $RIGHT_PARENTHESIS => q{)}; + +# Guile object files do not objdump/strip correctly, so exclude them +# from a number of tests. (#918444) +const my $GUILE_PATH_REGEX => qr{^usr/lib(?:/[^/]+)+/guile/[^/]+/.+\.go$}; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has built_with_octave => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $built_with_octave = $self->processable->name =~ m/^octave-/; + + my $source = $self->group->source; + + $built_with_octave + = $source->relation('Build-Depends')->satisfies('dh-octave:any') + if defined $source; + + return $built_with_octave; + } +); + +has files_by_library => (is => 'rw', default => sub { {} }); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + if $self->processable->type eq 'udeb'; + + return + unless $item->is_file; + + return + unless $item->file_type =~ /^ [^,]* \b ELF \b /x; + + return + unless $item->file_type =~ m{ executable | shared [ ] object }x; + + my $is_shared = $item->file_type =~ m/(shared object|pie executable)/; + + for my $library (@{$item->elf->{NEEDED} // [] }) { + + $self->files_by_library->{$library} //= []; + push(@{$self->files_by_library->{$library}}, $item->name); + } + + # Some exceptions: kernel modules, syslinux modules, detached + # debugging information and the dynamic loader (which itself + # has no dependencies). + $self->pointed_hint('shared-library-lacks-prerequisites', $item->pointer) + if $is_shared + && !@{$item->elf->{NEEDED} // []} + && $item->name !~ m{^boot/modules/} + && $item->name !~ m{^lib/modules/} + && $item->name !~ m{^usr/lib/debug/} + && $item->name !~ m{\.(?:[ce]32|e64)$} + && $item->name !~ m{^usr/lib/jvm/.*\.debuginfo$} + && $item->name !~ $GUILE_PATH_REGEX + && $item->name !~ m{ + ^lib(?:|32|x32|64)/ + (?:[-\w/]+/)? + ld-[\d.]+\.so$ + }xsm; + + my $depends = $self->processable->relation('strong'); + + $self->pointed_hint('undeclared-elf-prerequisites', $item->pointer, + $LEFT_PARENTHESIS + . join($SPACE, sort +uniq @{$item->elf->{NEEDED} // []}) + . $RIGHT_PARENTHESIS) + if @{$item->elf->{NEEDED} // [] } + && $depends->is_empty; + + # If there is no libc dependency, then it is most likely a + # bug. The major exception is that some C++ libraries, + # but these tend to link against libstdc++ instead. (see + # #719806) + my $linked_with_libc + = any { m{^ libc[.]so[.] }x } @{$item->elf->{NEEDED} // []}; + + $self->pointed_hint('library-not-linked-against-libc', $item->pointer) + if !$linked_with_libc + && $is_shared + && @{$item->elf->{NEEDED} // [] } + && (none { /^libc[.]so[.]/ } @{$item->elf->{NEEDED} // [] }) + && $item->name !~ m{/libc\b} + && (!$self->built_with_octave + || $item->name !~ m/\.(?:oct|mex)$/); + + $self->pointed_hint('program-not-linked-against-libc', $item->pointer) + if !$linked_with_libc + && !$is_shared + && @{$item->elf->{NEEDED} // [] } + && (none { /^libstdc[+][+][.]so[.]/ }@{$item->elf->{NEEDED} // [] }) + && !$self->built_with_octave; + + return; +} + +sub installable { + my ($self) = @_; + + my $depends = $self->processable->relation('strong'); + return + if $depends->is_empty; + + my %libc_files; + for my $library (keys %{$self->files_by_library}) { + + # Match libcXX or libcXX-*, but not libc3p0. + next + unless $library =~ m{^ libc [.] so [.] (\d+ .*) $}x; + + my $package = "libc$1"; + + $libc_files{$package} //= []; + push(@{$libc_files{$package}}, @{$self->files_by_library->{$library}}); + } + + for my $package (keys %libc_files) { + + next + if $depends->matches(qr/^\Q$package\E\b/); + + my @sorted = sort +uniq @{$libc_files{$package}}; + + my $context = 'needed by ' . $sorted[0]; + $context .= ' and ' . (scalar @sorted - 1) . ' others' + if @sorted > 1; + + $self->hint('missing-dependency-on-libc', $context) + unless $self->processable->name =~ m{^ libc [\d.]+ (?:-|\z) }x; + } + + my %libcxx_files; + for my $library (keys %{$self->files_by_library}) { + + # Match libstdc++XX or libcstdc++XX-* + next + unless $library =~ m{^ libstdc[+][+] [.] so [.] (\d+) $}xsm; + + my $package = "libstdc++$1"; + + $libcxx_files{$package} //= []; + push(@{$libcxx_files{$package}}, + @{$self->files_by_library->{$library}}); + } + + for my $package (keys %libcxx_files) { + + next + if $depends->matches(qr/^\Q$package\E\b/); + + my @sorted = sort +uniq @{$libcxx_files{$package}}; + + my $context = 'needed by ' . $sorted[0]; + $context .= ' and ' . (scalar @sorted - 1) . ' others' + if @sorted > 1; + + $self->hint('missing-dependency-on-libstdc++', $context); + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Binaries/Prerequisites/Numpy.pm b/lib/Lintian/Check/Binaries/Prerequisites/Numpy.pm new file mode 100644 index 0000000..c1ecfc3 --- /dev/null +++ b/lib/Lintian/Check/Binaries/Prerequisites/Numpy.pm @@ -0,0 +1,107 @@ +# binaries/prerequisites/numpy -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2012 Kees Cook +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Binaries::Prerequisites::Numpy; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +use Lintian::Relation; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $NUMPY_REGEX => qr{ + \Qmodule compiled against ABI version \E (?:0x)?%x + \Q but this version of numpy is \E (?:0x)?%x +}x; + +has uses_numpy_c_abi => (is => 'rw', default => 0); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + return + if $item->file_type !~ m{^ [^,]* \b ELF \b }x + || $item->file_type !~ m{ \b executable | shared [ ] object \b }x; + + # Python extension using Numpy C ABI? + if ( $item->name=~ m{^usr/lib/(?:pyshared/)?python2\.\d+/.*(?<!_d)\.so$} + || $item->name + =~ m{^ usr/lib/python3(?:[.]\d+)? / \S+ [.]cpython- \d+ - \S+ [.]so $}x + ){ + $self->uses_numpy_c_abi(1) + if $item->strings =~ / numpy /msx + && $item->strings =~ $NUMPY_REGEX; + } + + return; +} + +sub installable { + my ($self) = @_; + + return + if $self->processable->type eq 'udeb'; + + my $depends = $self->processable->relation('strong'); + + # Check for dependency on python3-numpy-abiN dependency (or strict + # versioned dependency on python3-numpy) + # 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. + $self->hint('missing-dependency-on-numpy-abi') + if $self->uses_numpy_c_abi + && !$depends->matches(qr/^python3?-numpy-abi\d+$/, + Lintian::Relation::VISIT_OR_CLAUSE_FULL) + && ( + !$depends->matches( + qr/^python3-numpy \(>[>=][^\|]+$/, + Lintian::Relation::VISIT_OR_CLAUSE_FULL + ) + || !$depends->matches( + qr/^python3-numpy \(<[<=][^\|]+$/, + Lintian::Relation::VISIT_OR_CLAUSE_FULL + ) + ) + && $self->processable->name !~ m{\A python3?-numpy \Z}xsm; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Binaries/Prerequisites/Perl.pm b/lib/Lintian/Check/Binaries/Prerequisites/Perl.pm new file mode 100644 index 0000000..a105d25 --- /dev/null +++ b/lib/Lintian/Check/Binaries/Prerequisites/Perl.pm @@ -0,0 +1,81 @@ +# binaries/prerequisites/perl -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2012 Kees Cook +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Binaries::Prerequisites::Perl; + +use v5.20; +use warnings; +use utf8; + +use Lintian::Relation; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has has_perl_lib => (is => 'rw', default => 0); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + return + if $item->file_type !~ m{^ [^,]* \b ELF \b }x + || $item->file_type !~ m{ \b executable | shared [ ] object \b }x; + + $self->has_perl_lib(1) + if $item->name =~ m{^ usr/lib/ (?:[^/]+/)? perl5/ .* [.]so $}x; + + return; +} + +sub installable { + my ($self) = @_; + + return + if $self->processable->type eq 'udeb'; + + my $depends = $self->processable->relation('strong'); + + # It is a virtual package, so no version is allowed and + # alternatives probably does not make sense here either. + $self->hint('missing-dependency-on-perlapi') + if $self->has_perl_lib + && !$depends->matches( + qr/^perlapi-[-\w.]+(?:\s*\[[^\]]+\])?$/, + Lintian::Relation::VISIT_OR_CLAUSE_FULL + ); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Binaries/Prerequisites/Php.pm b/lib/Lintian/Check/Binaries/Prerequisites/Php.pm new file mode 100644 index 0000000..f4f9634 --- /dev/null +++ b/lib/Lintian/Check/Binaries/Prerequisites/Php.pm @@ -0,0 +1,80 @@ +# binaries/prerequisites/php -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2012 Kees Cook +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Binaries::Prerequisites::Php; + +use v5.20; +use warnings; +use utf8; + +use Lintian::Relation; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has has_php_ext => (is => 'rw', default => 0); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + return + if $item->file_type !~ m{^ [^,]* \b ELF \b }x + || $item->file_type !~ m{ \b executable | shared [ ] object \b }x; + + # PHP extension? + $self->has_php_ext(1) + if $item->name =~ m{^usr/lib/php\d/.*\.so(?:\.\d+)*$}; + + return; +} + +sub installable { + my ($self) = @_; + + return + if $self->processable->type eq 'udeb'; + + my $depends = $self->processable->relation('strong'); + + # It is a virtual package, so no version is allowed and + # alternatives probably does not make sense here either. + $self->hint('missing-dependency-on-phpapi') + if $self->has_php_ext + && !$depends->matches(qr/^phpapi-[\d\w+]+$/, + Lintian::Relation::VISIT_OR_CLAUSE_FULL); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Binaries/Profiling.pm b/lib/Lintian/Check/Binaries/Profiling.pm new file mode 100644 index 0000000..4b52937 --- /dev/null +++ b/lib/Lintian/Check/Binaries/Profiling.pm @@ -0,0 +1,73 @@ +# binaries/profiling -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2012 Kees Cook +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Binaries::Profiling; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + my $architecture = $self->processable->fields->value('Architecture'); + + my $is_profiled = 0; + + for my $symbol (@{$item->elf->{SYMBOLS} // [] }) { + + # 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 + $is_profiled = 1 + if $symbol->version =~ /^GLIBC_.*/ + && $symbol->name =~ m{\A _?+ _?+ (gnu_)?+mcount(_nc)?+ \Z}xsm + && ($symbol->section eq 'UND' || $symbol->section eq '.text'); + + # This code was used to detect profiled code in Wheezy and earlier + $is_profiled = 1 + if $symbol->section eq '.text' + && $symbol->version eq 'Base' + && $symbol->name eq '__gmon_start__' + && $architecture ne 'hppa'; + } + + $self->pointed_hint('binary-compiled-with-profiling-enabled', + $item->pointer) + if $is_profiled; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Binaries/Rpath.pm b/lib/Lintian/Check/Binaries/Rpath.pm new file mode 100644 index 0000000..a4ecb93 --- /dev/null +++ b/lib/Lintian/Check/Binaries/Rpath.pm @@ -0,0 +1,145 @@ +# binaries/rpath -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2012 Kees Cook +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Binaries::Rpath; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use File::Spec; +use List::SomeUtils qw(any); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $SLASH => q{/}; + +has DEB_HOST_MULTIARCH => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return $self->data->architectures->deb_host_multiarch; + } +); + +has multiarch_component => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $architecture = $self->processable->fields->value('Architecture'); + my $multiarch_component = $self->DEB_HOST_MULTIARCH->{$architecture}; + + return $multiarch_component; + } +); + +has private_folders => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my @lib_folders = qw{lib}; + + push(@lib_folders, + map { $_ . $SLASH . $self->multiarch_component } @lib_folders) + if length $self->multiarch_component; + + my @usrlib_folders = qw{usr/lib}; + + push(@usrlib_folders, + map { $_ . $SLASH . $self->multiarch_component } @usrlib_folders) + if length $self->multiarch_component; + + my @game_folders = map { "$_/games" } @usrlib_folders; + + my @private_folders + = map { $_ . $SLASH . $self->processable->source_name } + (@lib_folders, @usrlib_folders, @game_folders); + + return \@private_folders; + } +); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + return + unless $item->file_type =~ /^ [^,]* \b ELF \b /x; + + for my $section (qw{RPATH RUNPATH}) { + + my @rpaths = keys %{$item->elf->{$section} // {}}; + + my @no_origin = grep { !m{^ \$ \{? ORIGIN \}? }x } @rpaths; + + my @canonical = map { File::Spec->canonpath($_) } @no_origin; + + my @custom; + for my $folder (@canonical) { + + # for shipped folders, would have to disallow system locations + next + if any { $folder =~ m{^ / \Q$_\E }x } @{$self->private_folders}; + + # GHC in Debian uses a scheme for RPATH (#914873) + next + if $folder =~ m{^ /usr/lib/ghc (?: / | $ ) }x; + + push(@custom, $folder); + } + + my @absolute = grep { m{^ / }x } @custom; + + $self->pointed_hint('custom-library-search-path', + $item->pointer, $section, $_) + for @absolute; + + my @relative = grep { m{^ [^/] }x } @custom; + + $self->pointed_hint('relative-library-search-path', + $item->pointer, $section, $_) + for @relative; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Binaries/Spelling.pm b/lib/Lintian/Check/Binaries/Spelling.pm new file mode 100644 index 0000000..38a2529 --- /dev/null +++ b/lib/Lintian/Check/Binaries/Spelling.pm @@ -0,0 +1,86 @@ +# binaries/spelling -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2012 Kees Cook +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Binaries::Spelling; + +use v5.20; +use warnings; +use utf8; + +use Lintian::Spelling qw(check_spelling); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has BINARY_SPELLING_EXCEPTIONS => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return $self->data->load('binaries/spelling-exceptions',qr/\s+/); + } +); + +sub spelling_tag_emitter { + my ($self, $tag_name, $item, @orig_args) = @_; + + return sub { + + my $pointer = $item->pointer($.); + + return $self->pointed_hint($tag_name, $pointer, @orig_args, @_); + }; +} + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + return + unless $item->file_type =~ /^ [^,]* \b ELF \b /x; + + my @acceptable = ( + @{ $self->group->spelling_exceptions }, + $self->BINARY_SPELLING_EXCEPTIONS->all + ); + + my $tag_emitter + = $self->spelling_tag_emitter('spelling-error-in-binary', $item); + + check_spelling($self->data, $item->strings, \@acceptable, $tag_emitter, 0); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Binaries/Static.pm b/lib/Lintian/Check/Binaries/Static.pm new file mode 100644 index 0000000..47eafb8 --- /dev/null +++ b/lib/Lintian/Check/Binaries/Static.pm @@ -0,0 +1,100 @@ +# binaries/static -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2012 Kees Cook +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Binaries::Static; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has built_with_golang => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $built_with_golang = $self->processable->name =~ m/^golang-/; + + my $source = $self->group->source; + + $built_with_golang + = $source->relation('Build-Depends-All') + ->satisfies('golang-go | golang-any') + if defined $source; + + return $built_with_golang; + } +); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + if $self->processable->type eq 'udeb'; + + return + unless $item->is_file; + + return + unless $item->file_type =~ /^ [^,]* \b ELF \b /x; + + return + unless $item->file_type =~ m{ executable | shared [ ] object }x; + + my $is_shared = $item->file_type =~ m/(shared object|pie executable)/; + + # Some exceptions: files in /boot, /usr/lib/debug/*, + # named *-static or *.static, or *-static as + # package-name. + # Binaries built by the Go compiler are statically + # linked by default. + # klibc binaries appear to be static. + # Location of debugging symbols. + # ldconfig must be static. + $self->pointed_hint('statically-linked-binary', $item->pointer) + if !$is_shared + && !exists $item->elf->{NEEDED} + && $item->name !~ m{^boot/} + && $item->name !~ /[\.-]static$/ + && $self->processable->name !~ /-static$/ + && !$self->built_with_golang + && (!exists $item->elf->{INTERP} + || $item->elf->{INTERP} !~ m{/lib/klibc-\S+\.so}) + && $item->name !~ m{^usr/lib/debug/} + && $item->name ne 'sbin/ldconfig'; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/BuildSystems/Automake.pm b/lib/Lintian/Check/BuildSystems/Automake.pm new file mode 100644 index 0000000..07a7d6d --- /dev/null +++ b/lib/Lintian/Check/BuildSystems/Automake.pm @@ -0,0 +1,54 @@ +# build-systems/automake -- lintian check script -*- perl -*- +# +# Copyright (C) 2013 Gautier Minster +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::BuildSystems::Automake; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + # automake probably isn't used without a Makefile.am + my $makefile = $self->processable->patched->lookup('Makefile.am'); + return + unless defined $makefile; + + my $configure_in = $self->processable->patched->lookup('configure.in'); + + $self->pointed_hint('deprecated-configure-filename',$configure_in->pointer) + if defined $configure_in; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/BuildSystems/Autotools.pm b/lib/Lintian/Check/BuildSystems/Autotools.pm new file mode 100644 index 0000000..cf40183 --- /dev/null +++ b/lib/Lintian/Check/BuildSystems/Autotools.pm @@ -0,0 +1,88 @@ +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 1999 Joey Hess +# Copyright (C) 2000 Sean 'Shaleh' Perry +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2007 Russ Allbery +# Copyright (C) 2013-2018 Bastien ROUCARIES +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::BuildSystems::Autotools; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + if ( $item->name =~ /configure\.(in|ac)$/ + && $item->is_open_ok) { + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $position = 1; + while (my $line = <$fd>) { + + next + if $line =~ m{^ \s* dnl }x; + + if ($line + =~ m{ (AC_PATH_PROG) \s* [(] [^,]+ , \s* \[? pkg-config \]? \s* , }x + ){ + + my $macro = $1; + $self->pointed_hint( + 'autotools-pkg-config-macro-not-cross-compilation-safe', + $item->pointer($position), $macro); + } + + } continue { + ++$position; + } + + close $fd; + } + + # Tests of autotools files are a special case. Ignore + # debian/config.cache as anyone doing that probably knows what + # they're doing and is using it as part of the build. + $self->pointed_hint('configure-generated-file-in-source', $item->pointer) + if $item->basename =~ m{\A config.(?:cache|log|status) \Z}xsm + && $item->name !~ m{^ debian/ }sx; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/BuildSystems/Autotools/Libtool.pm b/lib/Lintian/Check/BuildSystems/Autotools/Libtool.pm new file mode 100644 index 0000000..3f0865a --- /dev/null +++ b/lib/Lintian/Check/BuildSystems/Autotools/Libtool.pm @@ -0,0 +1,99 @@ +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 1999 Joey Hess +# Copyright (C) 2000 Sean 'Shaleh' Perry +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2007 Russ Allbery +# Copyright (C) 2013-2018 Bastien ROUCARIES +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::BuildSystems::Autotools::Libtool; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $ACCEPTABLE_LIBTOOL_MAJOR => 5; +const my $ACCEPTABLE_LIBTOOL_MINOR => 2; +const my $ACCEPTABLE_LIBTOOL_DEBIAN => 2; + +# Check if the package build-depends on autotools-dev, automake, +# or libtool. +my $LIBTOOL = Lintian::Relation->new->load('libtool | dh-autoreconf'); +has libtool_in_build_depends => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return $self->processable->relation('Build-Depends-All') + ->satisfies($LIBTOOL); + } +); + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + $self->pointed_hint('ancient-libtool', $item->pointer) + if $item->basename eq 'ltconfig' + && $item->name !~ m{^ debian/ }sx + && !$self->libtool_in_build_depends; + + if ( $item->basename eq 'ltmain.sh' + && $item->name !~ m{^ debian/ }sx + && !$self->libtool_in_build_depends) { + + if ($item->bytes =~ /^VERSION=[\"\']?(1\.(\d)\.(\d+)(?:-(\d))?)/m) { + my ($version, $major, $minor, $debian)=($1, $2, $3, $4); + + $debian //= 0; + + $self->pointed_hint('ancient-libtool', $item->pointer, $version) + if $major < $ACCEPTABLE_LIBTOOL_MAJOR + || ( + $major == $ACCEPTABLE_LIBTOOL_MAJOR + && ( + $minor < $ACCEPTABLE_LIBTOOL_MINOR + || ( $minor == $ACCEPTABLE_LIBTOOL_MINOR + && $debian < $ACCEPTABLE_LIBTOOL_DEBIAN) + ) + ); + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/BuildSystems/Cmake.pm b/lib/Lintian/Check/BuildSystems/Cmake.pm new file mode 100644 index 0000000..0dfaf2c --- /dev/null +++ b/lib/Lintian/Check/BuildSystems/Cmake.pm @@ -0,0 +1,73 @@ +# build-systems/cmake -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 1999 Joey Hess +# Copyright (C) 2000 Sean 'Shaleh' Perry +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2007 Russ Allbery +# Copyright (C) 2013-2018 Bastien ROUCARIES +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::BuildSystems::Cmake; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + # Check for CMake cache files. These embed the source path and hence + # will cause FTBFS on buildds, so they should never be present + $self->pointed_hint('source-contains-cmake-cache-file', $item->pointer) + if $item->basename eq 'CMakeCache.txt'; + + return; +} + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + # /usr/share/cmake-* + $self->pointed_hint('package-contains-cmake-private-file', $item->pointer) + if $item->name =~ m{^ usr/share/cmake- \d+ [.] \d+ / }x + && $self->processable->source_name ne 'cmake'; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/BuildSystems/Debhelper/MaintainerScript/Token.pm b/lib/Lintian/Check/BuildSystems/Debhelper/MaintainerScript/Token.pm new file mode 100644 index 0000000..7d54b79 --- /dev/null +++ b/lib/Lintian/Check/BuildSystems/Debhelper/MaintainerScript/Token.pm @@ -0,0 +1,80 @@ +# build-systems/debhelper/maintainer-script/token -- lintian check script -*- perl -*- +# +# Copyright (C) 1998 Richard Braakman +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::BuildSystems::Debhelper::MaintainerScript::Token; + +use v5.20; +use warnings; +use utf8; + +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_control_files { + my ($self, $item) = @_; + + return + unless $item->is_maintainer_script; + + return + unless length $item->interpreter; + + return + unless $item->is_open_ok; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $position = 1; + while (my $line = <$fd>) { + + next + unless $line =~ m{( [#] DEBHELPER [#] )}x; + + my $token = $1; + + my $pointer = $item->pointer($position); + + $self->pointed_hint('maintainer-script-has-unexpanded-debhelper-token', + $pointer, $token); + + } continue { + ++$position; + } + + close $fd; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/BuildSystems/Libtool/LaFile.pm b/lib/Lintian/Check/BuildSystems/Libtool/LaFile.pm new file mode 100644 index 0000000..7431c41 --- /dev/null +++ b/lib/Lintian/Check/BuildSystems/Libtool/LaFile.pm @@ -0,0 +1,94 @@ +# build-systems/libtool/la-file -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz +# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::BuildSystems::Libtool::LaFile; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $SLASH => q{/}; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + if $item->name !~ /[.]la$/ || length $item->link; + + my @lines = split(/\n/, $item->decoded_utf8); + + my $position = 1; + for my $line (@lines) { + + if ($line =~ /^ libdir=' (.+) ' $/x) { + + my $own_location = $1; + $own_location =~ s{^/+}{}; + $own_location =~ s{/*$}{/}; + + # python-central is a special case since the + # libraries are moved at install time. + next + if $own_location + =~ m{^ usr/lib/python [\d.]+ / (?:site|dist)-packages / }x + && $item->dirname =~ m{^ usr/share/pyshared/ }x; + + $self->pointed_hint( + 'incorrect-libdir-in-la-file', + $item->pointer($position), + "$own_location != " . $item->dirname + ) unless $own_location eq $item->dirname; + + } + + if ($line =~ /^ dependency_libs=' (.+) ' $/x){ + + my $prerequisites = $1; + + $self->pointed_hint( + 'non-empty-dependency_libs-in-la-file', + $item->pointer($position), + $prerequisites + ); + } + + } continue { + ++$position; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/BuildSystems/Waf.pm b/lib/Lintian/Check/BuildSystems/Waf.pm new file mode 100644 index 0000000..4825a11 --- /dev/null +++ b/lib/Lintian/Check/BuildSystems/Waf.pm @@ -0,0 +1,87 @@ +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 1999 Joey Hess +# Copyright (C) 2000 Sean 'Shaleh' Perry +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2007 Russ Allbery +# Copyright (C) 2013-2018 Bastien ROUCARIES +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::BuildSystems::Waf; + +use v5.20; +use warnings; +use utf8; + +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + return + unless $item->basename =~ m{ \b waf $}x; + + return + unless $item->is_open_ok; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $marker = 0; + + while (my $line = <$fd>) { + + next + unless $line =~ m/^#/; + + if ($marker && $line =~ m/^#BZ[h0][0-9]/) { + + # waf is not allowed + $self->pointed_hint('source-contains-waf-binary', $item->pointer); + last; + } + + $marker = 1 + if $line =~ m/^#==>/; + + # We could probably stop here, but just in case + $marker = 0 + if $line =~ m/^#<==/; + } + + close $fd; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/ChangesFile.pm b/lib/Lintian/Check/ChangesFile.pm new file mode 100644 index 0000000..617de64 --- /dev/null +++ b/lib/Lintian/Check/ChangesFile.pm @@ -0,0 +1,121 @@ +# changes-file -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2017-2019 Chris Lamb <lamby@debian.org> +# +# This program is free software. It is distributed 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::ChangesFile; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::Compare; +use List::SomeUtils qw(uniq); +use Path::Tiny; + +use Lintian::Util qw(get_file_checksum); + +const my $NOT_EQUALS => q{!=}; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub changes { + my ($self) = @_; + + my %count_by_algorithm; + + for my $basename (keys %{$self->processable->files}) { + + my $details = $self->processable->files->{$basename}; + + $self->hint('bad-section-in-changes-file', $basename, + $details->{section}) + if $details->{section} eq 'non-free' + || $details->{section} eq 'contrib'; + + # take from location near input file + my $physical_path + = path($self->processable->path)->sibling($basename)->stringify; + my $actual_size = -s $physical_path; + + # check size + $self->hint('file-size-mismatch-in-changes-file', + $basename, $details->{size}, $NOT_EQUALS, $actual_size) + unless $details->{size} == $actual_size; + + for my $algorithm (qw(Md5 Sha1 Sha256)) { + + my $checksum_info = $details->{checksums}{$algorithm}; + next + unless defined $checksum_info; + + $self->hint('file-size-mismatch-in-changes-file', + $basename,$details->{size}, $NOT_EQUALS, + $checksum_info->{filesize}) + unless $details->{size} == $checksum_info->{filesize}; + + my $actual_checksum= get_file_checksum($algorithm, $physical_path); + + $self->hint('checksum-mismatch-in-changes-file', + "Checksum-$algorithm", $basename) + unless $checksum_info->{sum} eq $actual_checksum; + + ++$count_by_algorithm{$algorithm}; + } + } + + my @installables= grep { m{ [.]deb $}x } keys %{$self->processable->files}; + my @installable_names = map { m{^ ([^_]+) _ }x } @installables; + my @stems = uniq map { m{^ (.+) -dbg (?:sym) $}x } @installable_names; + + for my $stem (@stems) { + + my @conflicting = ("$stem-dbg", "$stem-dbgsym"); + + my $lc = List::Compare->new(\@conflicting, \@installable_names); + $self->hint('package-builds-dbg-and-dbgsym-variants', + (sort @conflicting)) + if $lc->is_LsubsetR; + } + + # Check that we have a consistent number of checksums and files + for my $algorithm (keys %count_by_algorithm) { + + my $actual_count = $count_by_algorithm{$algorithm}; + my $expected_count = scalar keys %{$self->processable->files}; + + $self->hint('checksum-count-mismatch-in-changes-file', +"$actual_count Checksum-$algorithm checksums != $expected_count files" + ) if $actual_count != $expected_count; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Conffiles.pm b/lib/Lintian/Check/Conffiles.pm new file mode 100644 index 0000000..076c17f --- /dev/null +++ b/lib/Lintian/Check/Conffiles.pm @@ -0,0 +1,136 @@ +# conffiles -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz +# Copyright (C) 2000 Sean 'Shaleh' Perry +# Copyright (C) 2017 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Conffiles; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::Compare; +use List::SomeUtils qw(any none); +use Path::Tiny; + +const my $SPACE => q{ }; + +const my @KNOWN_INSTRUCTIONS => qw(remove-on-upgrade); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + if $self->processable->type =~ 'udeb'; + + my $declared_conffiles = $self->processable->declared_conffiles; + + unless ($item->is_file) { + $self->pointed_hint('conffile-has-bad-file-type', $item->pointer) + if $declared_conffiles->is_known($item->name); + return; + } + + # files /etc must be conffiles, with some exceptions). + $self->pointed_hint('file-in-etc-not-marked-as-conffile',$item->pointer) + if $item->name =~ m{^etc/} + && !$declared_conffiles->is_known($item->name) + && $item->name !~ m{/README$} + && $item->name !~ m{^ etc/init[.]d/ (?: skeleton | rc S? ) $}x; + + return; +} + +sub binary { + my ($self) = @_; + + my $declared_conffiles = $self->processable->declared_conffiles; + for my $relative ($declared_conffiles->all) { + + my $item = $self->processable->conffiles_item; + + my @entries = @{$declared_conffiles->by_file->{$relative}}; + + my @positions = map { $_->position } @entries; + my $lines = join($SPACE, (sort { $a <=> $b } @positions)); + + $self->pointed_hint('duplicate-conffile', $item->pointer, + $relative, "(lines $lines)") + if @entries > 1; + + for my $entry (@entries) { + + my $conffiles_item = $self->processable->conffiles_item; + my $pointer = $conffiles_item->pointer($entry->position); + + $self->pointed_hint('relative-conffile', $pointer,$relative) + if $entry->is_relative; + + $self->pointed_hint('file-in-etc-rc.d-marked-as-conffile', + $pointer, $relative) + if $relative =~ m{^etc/rc.\.d/}; + + $self->pointed_hint('file-in-usr-marked-as-conffile', + $pointer, $relative) + if $relative =~ m{^usr/}; + + $self->pointed_hint('non-etc-file-marked-as-conffile', + $pointer, $relative) + unless $relative =~ m{^etc/}; + + my @instructions = @{$entry->instructions}; + + my $instruction_lc + = List::Compare->new(\@instructions, \@KNOWN_INSTRUCTIONS); + my @unknown = $instruction_lc->get_Lonly; + + $self->pointed_hint('unknown-conffile-instruction', $pointer, $_) + for @unknown; + + my $should_exist= none { $_ eq 'remove-on-upgrade' } @instructions; + my $may_not_exist= any { $_ eq 'remove-on-upgrade' } @instructions; + + my $shipped = $self->processable->installed->lookup($relative); + + $self->pointed_hint('missing-conffile', $pointer, $relative) + if $should_exist && !defined $shipped; + + $self->pointed_hint('unexpected-conffile', $pointer, $relative) + if $may_not_exist && defined $shipped; + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/ContinuousIntegration/Salsa.pm b/lib/Lintian/Check/ContinuousIntegration/Salsa.pm new file mode 100644 index 0000000..3faa978 --- /dev/null +++ b/lib/Lintian/Check/ContinuousIntegration/Salsa.pm @@ -0,0 +1,103 @@ +# continuous-integration/salsa -- lintian check script -*- perl -*- + +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::ContinuousIntegration::Salsa; + +use v5.20; +use warnings; +use utf8; + +use Data::DPath qw(dpath); +use List::SomeUtils qw(any); +use Scalar::Util qw(reftype); +use YAML::XS qw(LoadFile); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +# ci is configured in gitlab and can be located anywere +# https://salsa.debian.org/salsa-ci-team/pipeline/-/issues/86 +my @KNOWN_LOCATIONS = qw( + debian/salsa-ci.yml + debian/gitlab-ci.yml + gitlab-ci.yml + .gitlab-ci.yml +); + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + return + unless any { $item->name eq $_ } @KNOWN_LOCATIONS; + + $self->pointed_hint('specification', $item->pointer); + + return + unless $item->is_open_ok; + + my $yaml = LoadFile($item->unpacked_path); + return + unless defined $yaml; + +# traditionally examined via codesearch +# https://codesearch.debian.net/search?q=salsa-ci-team%2Fpipeline%2Fraw%2Fmaster%2Fsalsa-ci.yml&literal=1 + my @items = dpath('//include')->match($yaml); + + my @includes; + for my $item (@items) { + + my $item_type = reftype $item; + + if (!length $item_type) { + push(@includes, $item); + + } elsif ($item_type eq 'ARRAY') { + for my $element (@{$item}) { + + my $element_type = reftype $element; + if (!length $element_type) { + push(@includes, $element); + + } elsif ($element_type eq 'HASH') { + # new Gitlab style with desciptors + push(@includes, $element->{file}) + if exists $element->{file}; + } + } + } + } + + $self->pointed_hint('include', $item->pointer, $_) for @includes; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/ControlFiles.pm b/lib/Lintian/Check/ControlFiles.pm new file mode 100644 index 0000000..d0c44a2 --- /dev/null +++ b/lib/Lintian/Check/ControlFiles.pm @@ -0,0 +1,132 @@ +# control-files -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2017 Chris Lamb <lamby@debian.org> +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::ControlFiles; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +const my $SPACE => q{ }; +const my $SLASH => q{/}; + +const my $WIDELY_EXECUTABLE => oct(111); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has ships_ctrl_script => (is => 'rw', default => 0); + +sub visit_control_files { + my ($self, $item) = @_; + + my $type = $self->processable->type; + my $processable = $self->processable; + + my $DEB_PERMISSIONS + = $self->data->load('control-files/deb-permissions',qr/\s+/); + my $UDEB_PERMISSIONS + = $self->data->load('control-files/udeb-permissions',qr/\s+/); + + my $ctrl = $type eq 'udeb' ? $UDEB_PERMISSIONS : $DEB_PERMISSIONS; + my $ctrl_alt = $type eq 'udeb' ? $DEB_PERMISSIONS : $UDEB_PERMISSIONS; + + # the control.tar.gz should only contain files (and the "root" + # dir, but that is excluded from the index) + if (!$item->is_regular_file) { + + $self->pointed_hint('control-file-is-not-a-file', $item->pointer); + # Doing further checks is probably not going to yield anything + # remotely useful. + return; + } + + # valid control file? + unless ($ctrl->recognizes($item->name)) { + + if ($ctrl_alt->recognizes($item->name)) { + $self->pointed_hint('not-allowed-control-file', $item->pointer); + + } else { + $self->pointed_hint('unknown-control-file', $item->pointer); + } + + return; + } + + my $experm = oct($ctrl->value($item->name)); + + $self->pointed_hint('control-file-is-empty', $item->pointer) + if $item->size == 0 + && $item->basename ne 'md5sums'; + + # skip `control' control file (that's an exception: dpkg + # doesn't care and this file isn't installed on the systems + # anyways) + return + if $item->name eq 'control'; + + my $operm = $item->operm; + if ($item->is_executable || $experm & $WIDELY_EXECUTABLE) { + + $self->ships_ctrl_script(1); + $self->pointed_hint('ctrl-script', $item->pointer); + } + + # correct permissions? + unless ($operm == $experm) { + + $self->pointed_hint('control-file-has-bad-permissions', + $item->pointer,sprintf('%04o != %04o', $operm, $experm)); + } + + # correct owner? + unless ($item->identity eq 'root/root' || $item->identity eq '0/0') { + + $self->pointed_hint('control-file-has-bad-owner',$item->pointer, + $item->identity,'!= root/root (or 0/0)'); + } + + # for other maintainer scripts checks, see the scripts check + + return; +} + +sub installable { + my ($self) = @_; + + $self->hint('no-ctrl-scripts') + unless $self->ships_ctrl_script; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Cron.pm b/lib/Lintian/Check/Cron.pm new file mode 100644 index 0000000..cca2420 --- /dev/null +++ b/lib/Lintian/Check/Cron.pm @@ -0,0 +1,67 @@ +# cron -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Cron; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +const my $READ_WRITE_PERMISSIONS => oct(644); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->name =~ m{^ etc/cron }x; + + # /etc/cron.daily, etc. + # NB: cron ships ".placeholder" files, which shouldn't be run. + $self->pointed_hint('run-parts-cron-filename-contains-illegal-chars', + $item->pointer) + if $item->name + =~ m{^ etc/cron[.] (?: daily | hourly | monthly | weekly |d ) / [^.] .* [+.] }x; + + # /etc/cron.d + # NB: cron ships ".placeholder" files in etc/cron.d, + # which we shouldn't tag. + $self->pointed_hint('bad-permissions-for-etc-cron.d-script', + $item->pointer, + sprintf('%04o != %04o', $item->operm, $READ_WRITE_PERMISSIONS)) + if $item->name =~ m{ ^ etc/cron\.d/ [^.] }msx + && $item->operm != $READ_WRITE_PERMISSIONS; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Cruft.pm b/lib/Lintian/Check/Cruft.pm new file mode 100644 index 0000000..1a402c6 --- /dev/null +++ b/lib/Lintian/Check/Cruft.pm @@ -0,0 +1,836 @@ +# cruft -- lintian check script -*- perl -*- +# +# based on debhelper check, +# Copyright (C) 1999 Joey Hess +# Copyright (C) 2000 Sean 'Shaleh' Perry +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2007 Russ Allbery +# Copyright (C) 2013-2018 Bastien ROUCARIES +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Cruft; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(any none); + +const my $EMPTY => q{}; +const my $ASTERISK => q{*}; +const my $DOT => q{.}; + +const my $ITEM_NOT_FOUND => -1; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +# Half of the size used in the "sliding window" for detecting bad +# licenses like GFDL with invariant sections. +# NB: Keep in sync cruft-gfdl-fp-sliding-win/pre_build. +# not less than 8192 for source missing +use constant BLOCKSIZE => 16_384; +use Lintian::SlidingWindow; + +my %NVIDIA_LICENSE = ( + keywords => [qw{license intellectual retain property}], + sentences =>[ +'retain all intellectual property and proprietary rights in and to this software and related documentation' + ] +); + +my %NON_FREE_LICENSES = ( +# first field is tag +# second field is a list of keywords in lower case +# third field are lower case sentences to match the license. Notes that space are normalized before and formatting removed +# fourth field is a regex to use to match the license, use lower case and [ ] for space. +# 5th field is a function to call if the field 2th to 5th match. +# (see dispatch table %LICENSE_CHECK_DISPATCH_TABLE + + # json license + 'license-problem-json-evil' => { + keywords => [qw{software evil good}], + sentences => ['software shall be used for good'], + regex => +qr{software [ ] shall [ ] be [ ] used [ ] for [ ] good [ ]? ,? [ ]? not [ ] evil}msx + }, + # non free RFC old version + 'license-problem-non-free-RFC' => { + keywords => [qw{document purpose translate language}], + sentences => ['this document itself may not be modified in any way'], + regex => +qr{this [ ] document [ ] itself [ ] may [ ] not [ ] be [ ] modified [ ] in [ ] any [ ] way [ ]?, + [ ]? such [ ] as [ ] by [ ] removing [ ] the [ ] copyright [ ] notice [ ] or [ ] references + [ ] to [ ] .{0,256} [ ]? except [ ] as [ ] needed [ ] for [ ] the [ ] purpose [ ] of [ ] developing + [ ] .{0,128} [ ]? in [ ] which [ ] case [ ] the [ ] procedures [ ] for [ ] copyrights [ ] defined + [ ] in [ ] the [ ] .{0,128} [ ]? process [ ] must [ ] be [ ] followed[ ]?,[ ]? + or [ ] as [ ] required [ ] to [ ] translate [ ] it [ ] into [ ] languages [ ]}msx, + callsub => 'rfc_whitelist_filename' + }, + 'license-problem-non-free-RFC-BCP78' => { + keywords => [qw{license document bcp restriction}], + sentences => ['bcp 78'], + regex => +qr{this [ ] document [ ] is [ ] subject [ ] to [ ] (?:the [ ] rights [ ]?, [ ] licenses [ ] and [ ]restrictions [ ] contained [ ] in [ ])? bcp [ ] 78}msx, + callsub => 'rfc_whitelist_filename' + }, +# check GFDL block - The ".{0,1024}"-part in the regex +# will contain the "no invariants etc." part if +# it is a good use of the license. We include it +# here to ensure that we do not emit a false positive +# if the "redeeming" part is in the next block +# keyword document is here in order to benefit for other license keyword and a shortcut for documentation + 'license-problem-gfdl-invariants' => { + keywords => [qw{license document gnu copy documentation}], + sentences => ['gnu free documentation license'], + regex => +qr{(?'rawcontextbefore'(?:(?:(?!a [ ] copy [ ] of [ ] the [ ] license [ ] is).){1024}| +\A(?:(?!a [ ] copy [ ] of [ ] the [ ] license [ ] is).){0,1024}| +(?:[ ] copy [ ] of [ ] the [ ] license [ ] is.{0,1024}?))) gnu [ ] free [ ] +documentation [ ] license (?'rawgfdlsections'(?:(?!gnu [ ] free [ ] documentation +[ ] license).){0,1024}?) (?:a [ ] copy [ ] of [ ] the [ ] license [ ] is| +this [ ] document [ ] is [ ] distributed)}msx, + callsub => 'check_gfdl_license_problem' + }, + # php license + 'license-problem-php-license' => { + keywords => [qw{www.php.net group\@php.net phpfoo conjunction php}], + sentences => ['this product includes php'], + regex => qr{php [ ] license [ ]?[,;][ ]? version [ ] 3(?:\.\d+)?}msx, + callsub => 'php_source_whitelist' + }, + 'license-problem-bad-php-license' => { + keywords => [qw{www.php.net add-on conjunction}], + sentences => ['this product includes php'], + regex => qr{php [ ] license [ ]?[,;][ ]? version [ ] 2(?:\.\d+)?}msx, + callsub => 'php_source_whitelist' + }, + # cc by nc sa note that " is replaced by [ ] + 'license-problem-cc-by-nc-sa' => { + keywords => [qw{license by-nc-sa creativecommons.org}], + sentences => [ + '://creativecommons.org/licenses/by-nc-sa', + 'under attribution-noncommercial' + ], + regex => +qr{(?:license [ ] rdf:[^=:]+=[ ]* (?:ht|f)tps?://(?:[^/.]\.)??creativecommons\.org/licenses/by-nc-sa/\d+(?:\.\d+)?(?:/[[:alpha:]]+)?/? [ ]* >|available [ ] under [ ] attribution-noncommercial)}msx + }, + # not really a license but warn it: visual c++ generated file + 'source-contains-autogenerated-visual-c++-file' => { + keywords => [qw{microsoft visual generated}], + sentences => ['microsoft visual c++ generated'], + regex => +qr{microsoft [ ] visual [ ] c[+][+] [ ] generated (?![ ] by [ ] freeze\.py)}msx + }, + # not really a license but warn about it: gperf generated file + 'source-contains-autogenerated-gperf-data' => { + keywords => [qw{code produced gperf version}], + sentences => ['code produced by gperf version'], + regex => + qr{code [ ] produced [ ] by [ ] gperf [ ] version [ ] \d+\.\d+}msx + }, + # warn about copy of ieee-data + 'source-contains-data-from-ieee-data-oui-db' => { + keywords => [qw{struck scitex racore}], + sentences => ['dr. b. struck'], + regex => qr{dr. [ ] b. [ ] struck}msx + }, + # warn about unicode license for utf for convert utf + 'license-problem-convert-utf-code' => { + keywords => [qw{fall-through bytestowrite utf-8}], + sentences => ['the fall-through switches in utf-8 reading'], + regex => +qr{the [ ] fall-through [ ] switches [ ] in [ ] utf-8 [ ] reading [ ] code [ ] save}msx + } +); + +# get usual data about admissible/not admissible GFDL invariant part of license +has GFDL_FRAGMENTS => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my %gfdl_fragments; + + my $data = $self->data->load('cruft/gfdl-license-fragments-checks', + qr/\s*\~\~\s*/); + + for my $gfdlsectionsregex ($data->all) { + + my $secondpart = $data->value($gfdlsectionsregex); + + # allow empty parameters + $secondpart //= $EMPTY; + my ($acceptonlyinfile,$applytag) + = split(/\s*\~\~\s*/, $secondpart, 2); + + $acceptonlyinfile //= $EMPTY; + $applytag //= $EMPTY; + + # trim both ends + $acceptonlyinfile =~ s/^\s+|\s+$//g; + $applytag =~ s/^\s+|\s+$//g; + + # accept all files if empty + $acceptonlyinfile ||= $DOT . $ASTERISK; + + my %ret = ( + 'gfdlsectionsregex' => qr/$gfdlsectionsregex/xis, + 'acceptonlyinfile' => qr/$acceptonlyinfile/xs, + ); + + $ret{'tag'} = $applytag + if length $applytag; + + $gfdl_fragments{$gfdlsectionsregex} = \%ret; + } + + return \%gfdl_fragments; + } +); + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + # license string in debian/changelog are probably just change + # Ignore these strings in d/README.{Debian,source}. If they + # appear there it is probably just "file XXX got removed + # because of license Y". + $self->full_text_check($item) + unless $item->name eq 'debian/changelog' + && $item->name eq 'debian/README.Debian' + && $item->name eq 'debian/README.source'; + + return; +} + +# do basic license check against well known offender +# note that it does not replace licensecheck(1) +# and is only used for autoreject by ftp-master +sub full_text_check { + my ($self, $item) = @_; + + return undef + unless $item ->is_regular_file; + + open(my $fd, '<:raw', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $sfd = Lintian::SlidingWindow->new; + $sfd->handle($fd); + $sfd->blocksize(BLOCKSIZE); + $sfd->blocksub(sub { $_ = lc; }); + + unless (-T $fd) { + close($fd); + return undef; + } + + # we try to read this file in block and use a sliding window + # for efficiency. We store two blocks in @queue and the whole + # string to match in $block. Please emit license tags only once + # per file + BLOCK: + while (my $lowercase = $sfd->readwindow()) { + + my $blocknumber = $sfd->blocknumber(); + + my $clean = clean_text($lowercase); + + # Check for non-distributable files - this + # applies even to non-free, as we still need + # permission to distribute those. + # nvdia opencv infamous license + last BLOCK + if $self->check_for_single_bad_license($item, $lowercase, $clean, + 'license-problem-nvidia-intellectual', + \%NVIDIA_LICENSE); + + unless ($self->processable->is_non_free) { + + for my $tag_name (keys %NON_FREE_LICENSES) { + + last BLOCK + if $self->check_for_single_bad_license($item, $lowercase, + $clean,$tag_name, $NON_FREE_LICENSES{$tag_name}); + } + } + + # check javascript in html file + if ($item->basename =~ /\.(?:x?html?\d?|xht)$/i) { + + my $blockscript = $lowercase; + my $indexscript; + + while (($indexscript = index($blockscript, '<script')) + > $ITEM_NOT_FOUND){ + + $blockscript = substr($blockscript,$indexscript); + + # sourced script ok + if ($blockscript =~ m{\A<script\s+[^>]*?src="[^"]+?"[^>]*?>}sm) + { + + $blockscript = substr($blockscript,$+[0]); + next; + } + + # extract script + if ($blockscript =~ m{<script[^>]*?>(.*?)</script>}sm) { + + $blockscript = substr($blockscript,$+[0]); + + my $lcscript = $1; + + # check if js script is minified + my $firstline = $EMPTY; + for my $line (split /\n/, $lcscript) { + + if ($line =~ /^\s*$/) { + next; + + } else { + $firstline = $line; + last; + } + } + + if ($firstline + =~ m/.{0,20}((?:\bcopyright\b|[\(]c[\)]\s*\w|\N{COPYRIGHT SIGN}).{0,50})/ + ){ + + my $extract = $1; + $extract =~ s/^\s+|\s+$//g; + + $self->pointed_hint( + 'embedded-script-includes-copyright-statement', + $item->pointer, + 'extract of copyright statement:', + $extract + ); + } + + # clean up jslint craps line + my $cleaned = $lcscript; + $cleaned =~ s{^\s*/[*][^\n]*[*]/\s*$}{}gm; + $cleaned =~ s{^\s*//[^\n]*$}{}gm; + $cleaned =~ s/^\s+//gm; + + # strip indentation + $cleaned =~ s/^\s+//mg; + $cleaned = _strip_c_comments($cleaned); + # strip empty line + $cleaned =~ s/^\s*\n//mg; + # remove last \n + $cleaned =~ s/\n\Z//m; + +# detect browserified javascript (comment are removed here and code is stripped) + my $contiguous = $cleaned; + $contiguous =~ s/\n/ /msg; + + # get browserified regexp + my $BROWSERIFY_REGEX + = $self->data->load('cruft/browserify-regex', + qr/\s*\~\~\s*/); + + for my $condition ($BROWSERIFY_REGEX->all) { + + my $pattern = $BROWSERIFY_REGEX->value($condition); + if ($contiguous =~ m{$pattern}msx) { + + my $extra + = (defined $1) ? 'code fragment:'.$1 : $EMPTY; + $self->pointed_hint( + 'source-contains-browserified-javascript', + $item->pointer, $extra); + + last; + } + } + + next; + } + + last; + } + } + + # check if file is javascript but not minified + my $isjsfile = ($item->name =~ m/\.js$/) ? 1 : 0; + if ($isjsfile) { + my $minjsregexp + = qr/(?i)[-._](?:compiled|compressed|lite|min|pack(?:ed)?|prod|umd|yc)\.js$/; + $isjsfile = ($item->name =~ m{$minjsregexp}) ? 0 : 1; + } + + if ($isjsfile) { + # exception sphinx documentation + if ($item->basename eq 'searchindex.js') { + if ($lowercase =~ m/\A\s*search\.setindex\s* \s* \(\s*\{/xms) { + + $self->pointed_hint( + 'source-contains-prebuilt-sphinx-documentation', + $item->parent_dir->pointer); + last BLOCK; + } + } + + if ($item->basename eq 'search_index.js') { + if ($lowercase =~ m/\A\s*var\s*search_index\s*=/xms) { + + $self->pointed_hint( + 'source-contains-prebuilt-pandoc-documentation', + $item->parent_dir->pointer); + last BLOCK; + } + } + # false positive in dx package at least + elsif ($item->basename eq 'srchidx.js') { + + last BLOCK + if $lowercase + =~ m/\A\s*profiles \s* = \s* new \s* Array\s*\(/xms; + } + # https://github.com/rafaelp/css_browser_selector is actually the + # original source. (#874381) + elsif ($lowercase =~ m/css_browser_selector\(/) { + + last BLOCK; + } + # Avoid false-positives in Jush's syntax highlighting definition files. + elsif ($lowercase =~ m/jush\.tr\./) { + + last BLOCK; + } + + # now search hidden minified + + # clean up jslint craps line + my $cleaned = $lowercase; + $cleaned =~ s{^\s*/[*][^\n]*[*]/\s*$}{}gm; + $cleaned =~ s{^\s*//[^\n]*$}{}gm; + $cleaned =~ s/^\s+//gm; + + # strip indentation + $cleaned =~ s/^\s+//mg; + $cleaned = _strip_c_comments($cleaned); + # strip empty line + $cleaned =~ s/^\s*\n//mg; + # remove last \n + $cleaned =~ s/\n\Z//m; + +# detect browserified javascript (comment are removed here and code is stripped) + my $contiguous = $cleaned; + $contiguous =~ s/\n/ /msg; + + # get browserified regexp + my $BROWSERIFY_REGEX + = $self->data->load('cruft/browserify-regex',qr/\s*\~\~\s*/); + + for my $condition ($BROWSERIFY_REGEX->all) { + + my $pattern = $BROWSERIFY_REGEX->value($condition); + if ($contiguous =~ m{$pattern}msx) { + + my $extra = (defined $1) ? 'code fragment:'.$1 : $EMPTY; + $self->pointed_hint( + 'source-contains-browserified-javascript', + $item->pointer, $extra); + + last; + } + } + } + + # search link rel header + if ($lowercase =~ / \Q rel="copyright" \E /msx) { + + my $href = $lowercase; + $href =~ m{<link \s+ + rel="copyright" \s+ + href="([^"]+)" \s*/? \s*>}xmsi; + + my $url = $1 // $EMPTY; + + $self->pointed_hint('license-problem-cc-by-nc-sa', $item->pointer) + if $url =~ m{^https?://creativecommons.org/licenses/by-nc-sa/}; + } + last BLOCK; + } + return close($fd); +} + +# strip C comment +# warning block is at more 8192 char in order to be too slow +# and in order to avoid regex recursion +sub _strip_c_comments { + my ($lowercase) = @_; + + # from perl faq strip comments + $lowercase =~ s{ + # Strip /* */ comments + /\* [^*]*+ \*++ (?: [^/*][^*]*+\*++ ) */ + # Strip // comments (C++ style) + | // (?: [^\\] | [^\n][\n]? )*? (?=\n) + | ( + # Keep "/* */" (etc) as is + "(?: \\. | [^"\\]++)*" + # Keep '/**/' (etc) as is + | '(?: \\. | [^'\\]++)*' + # Keep anything else + | .[^/"'\\]*+ + ) + }{defined $1 ? $1 : ""}xgse; + + return $lowercase; +} + +# return True in case of license problem +sub check_gfdl_license_problem { + my ($self, $item, $tag_name, %matchedhash) = @_; + + my $rawgfdlsections = $matchedhash{rawgfdlsections} || $EMPTY; + my $rawcontextbefore = $matchedhash{rawcontextbefore} || $EMPTY; + + # strip punctuation + my $gfdlsections = _strip_punct($rawgfdlsections); + my $contextbefore = _strip_punct($rawcontextbefore); + + # remove line number at beginning of line + # see krusader/1:2.4.0~beta3-2/doc/en_US/advanced-functions.docbook/ + $gfdlsections =~ s{[ ]\d+[ ]}{ }gxsmo; + $gfdlsections =~ s{^\d+[ ]}{ }xsmo; + $gfdlsections =~ s{[ ]\d+$}{ }xsmo; + $gfdlsections =~ s{[ ]+}{ }xsmo; + + # remove classical and without meaning part of + # matched string + my $oldgfdlsections; + do { + $oldgfdlsections = $gfdlsections; + $gfdlsections =~ s{ \A \(?[ ]? g?fdl [ ]?\)?[ ]? [,\.;]?[ ]?}{}xsmo; + $gfdlsections =~ s{ \A (?:either[ ])? + version [ ] \d+(?:\.\d+)? [ ]?}{}xsmo; + $gfdlsections =~ s{ \A of [ ] the [ ] license [ ]?[,\.;][ ]?}{}xsmo; + $gfdlsections=~ s{ \A or (?:[ ]\(?[ ]? at [ ] your [ ] option [ ]?\)?)? + [ ] any [ ] later [ ] version[ ]?}{}xsmo; + $gfdlsections =~ s{ \A (as[ ])? published [ ] by [ ] + the [ ] free [ ] software [ ] foundation[ ]?}{}xsmo; + $gfdlsections =~ s{\(?[ ]? fsf [ ]?\)?[ ]?}{}xsmo; + $gfdlsections =~ s{\A [ ]? [,\.;]? [ ]?}{}xsmo; + $gfdlsections =~ s{[ ]? [,\.]? [ ]?\Z}{}xsmo; + } while ($oldgfdlsections ne $gfdlsections); + + $contextbefore =~ s{ + [ ]? (:?[,\.;]? [ ]?)? + permission [ ] is [ ] granted [ ] to [ ] copy [ ]?[,\.;]?[ ]? + distribute [ ]?[,\.;]?[ ]? and[ ]?/?[ ]?or [ ] modify [ ] + this [ ] document [ ] under [ ] the [ ] terms [ ] of [ ] the\Z}{}xsmo; + + # Treat ambiguous empty text + if ($gfdlsections eq $EMPTY) { + + # lie in order to check more part + $self->pointed_hint('license-problem-gfdl-invariants-empty', + $item->pointer); + + return 0; + } + + # official wording + if( + $gfdlsections =~ m{\A + with [ ] no [ ] invariant [ ] sections[ ]?, + [ ]? no [ ] front(?:[ ]?-[ ]?|[ ])cover [ ] texts[ ]?,? + [ ]? and [ ] no [ ] back(?:[ ]?-?[ ]?|[ ])cover [ ] texts + \Z}xs + ) { + return 0; + } + + # example are ok + if ( + $contextbefore =~ m{following [ ] is [ ] an [ ] example + (:?[ ] of [ ] the [ ] license [ ] notice [ ] to [ ] use + (?:[ ] after [ ] the [ ] copyright [ ] (?:line(?:\(s\)|s)?)? + (?:[ ] using [ ] all [ ] the [ ] features? [ ] of [ ] the [ ] gfdl)? + )? + )? [ ]? [,:]? \Z}xs + ){ + return 0; + } + + # GFDL license, assume it is bad unless it + # explicitly states it has no "bad sections". + for my $gfdl_fragment (keys %{$self->GFDL_FRAGMENTS}) { + + my $gfdl_data = $self->GFDL_FRAGMENTS->{$gfdl_fragment}; + my $gfdlsectionsregex = $gfdl_data->{'gfdlsectionsregex'}; + if ($gfdlsections =~ m{$gfdlsectionsregex}) { + + my $acceptonlyinfile = $gfdl_data->{'acceptonlyinfile'}; + if ($item->name =~ m{$acceptonlyinfile}) { + + my $applytag = $gfdl_data->{'tag'}; + + # lie will allow checking more blocks + $self->pointed_hint($applytag, $item->pointer, + 'invariant part is:', + $gfdlsections) + if defined $applytag; + + return 0; + + } else { + $self->pointed_hint( + 'license-problem-gfdl-invariants', + $item->pointer,'invariant part is:', + $gfdlsections + ); + return 1; + } + } + } + + # catch all + $self->pointed_hint( + 'license-problem-gfdl-invariants', + $item->pointer,'invariant part is:', + $gfdlsections + ); + + return 1; +} + +sub rfc_whitelist_filename { + my ($self, $item, $tag_name, %matchedhash) = @_; + + return 0 + if $item->name eq 'debian/copyright'; + + my $lcname = lc($item->basename); + + # prebuilt-file or forbidden file type + # specified separator protects against spaces in pattern + my $RFC_WHITELIST= $self->data->load('cruft/rfc-whitelist',qr/\s*\~\~\s*/); + + my @patterns = $RFC_WHITELIST->all; + + return 0 + if any { $lcname =~ m/ $_ /xms } @patterns; + + $self->pointed_hint($tag_name, $item->pointer); + + return 1; +} + +sub php_source_whitelist { + my ($self, $item, $tag_name, %matchedhash) = @_; + + my $copyright_path + = $self->processable->patched->resolve_path('debian/copyright'); + + return 0 + if defined $copyright_path + && $copyright_path->bytes + =~ m{^Source: https?://(pecl|pear).php.net/package/.*$}m; + + return 0 + if $self->processable->source_name =~ /^php\d*(?:\.\d+)?$/xms; + + $self->pointed_hint($tag_name, $item->pointer); + + return 1; +} + +sub clean_text { + my ($text) = @_; + + # be paranoiac replace gnu with texinfo by gnu + $text =~ s{ + (?:@[[:alpha:]]*?\{)?\s*gnu\s*\} # Texinfo cmd + }{ gnu }gxms; + + # pod2man formatting + $text =~ s{ \\ \* \( [LR] \" }{\"}gxsm; + $text =~ s{ \\ -}{-}gxsm; + + # replace some shortcut (clisp) + $text =~ s{\(&fdl;\)}{ }gxsm; + $text =~ s{&fsf;}{free software foundation}gxsm; + + # non breaking space + $text =~ s{ }{ }gxsm; + + # replace some common comment-marker/markup with space + $text =~ s{^\.\\\"}{ }gxms; # man comments + + # po comment may include html tag + $text =~ s/\"\s?\v\#~\s?\"//gxms; + + # strip .rtf paragraph marks (#892967) + $text =~ s/\\par\b//gxms; + + $text =~ s/\\url[{][^}]*?[}]/ /gxms; # (la)?tex url + $text =~ s/\\emph[{]/ /gxms; # (la)?tex emph + $text =~ s<\\href[{][^}]*?[}] + [{]([^}]*?)[}]>< $1 >gxms;# (la)?tex href + $text =~ s<\\hyperlink + [{][^}]*?[}] + [{]([^}]*?)[}]>< $1 >gxms; # (la)?tex hyperlink + $text =~ s{-\\/}{-}gxms; # tex strange hyphen + $text =~ s/\\char/ /gxms; # tex char command + + # Texinfo comment with end section + $text =~ s{\@c(?:omment)?\h+ + end \h+ ifman\s+}{ }gxms; + $text =~ s{\@c(?:omment)?\s+ + noman\s+}{ }gxms; # Texinfo comment no manual + + $text =~ s/\@c(?:omment)?\s+/ /gxms; # Texinfo comment + + # Texinfo bold,italic, roman, fixed width + $text =~ s/\@[birt][{]/ /gxms; + $text =~ s/\@sansserif[{]/ /gxms; # Texinfo sans serif + $text =~ s/\@slanted[{]/ /gxms; # Texinfo slanted + $text =~ s/\@var[{]/ /gxms; # Texinfo emphasis + + $text =~ s/\@(?:small)?example\s+/ /gxms; # Texinfo example + $text =~ s{\@end \h+ + (?:small)example\s+}{ }gxms; # Texinfo end example tag + $text =~ s/\@group\s+/ /gxms; # Texinfo group + $text =~ s/\@end\h+group\s+/ /gxms; # Texinfo end group + + $text =~ s/<!--/ /gxms; # XML comments + $text =~ s/-->/ /gxms; # end XML comment + + $text =~ s{</?a[^>]*?>}{ }gxms; # a link + $text =~ s{<br\s*/?>}{ }gxms; # (X)?HTML line + # breaks + $text =~ s{</?citetitle[^>]*?>}{ }gxms; # DocBook citation title + $text =~ s{</?div[^>]*?>}{ }gxms; # html style + $text =~ s{</?font[^>]*?>}{ }gxms; # bold + $text =~ s{</?b[^>]*?>}{ }gxms; # italic + $text =~ s{</?i[^>]*?>}{ }gxms; # italic + $text =~ s{</?link[^>]*?>}{ }gxms; # xml link + $text =~ s{</?p[^>]*?>}{ }gxms; # html paragraph + $text =~ s{</?quote[^>]*?>}{ }gxms; # xml quote + $text =~ s{</?span[^>]*?>}{ }gxms; # span tag + $text =~ s{</?ulink[^>]*?>}{ }gxms; # ulink DocBook + $text =~ s{</?var[^>]*?>}{ }gxms; # var used by texinfo2html + + $text =~ s{\&[lr]dquo;}{ }gxms; # html rquote + + $text =~ s{\(\*note.*?::\)}{ }gxms; # info file note + + # String array (e.g. "line1",\n"line2") + $text =~ s/\"\s*,/ /gxms; + # String array (e.g. "line1"\n ,"line2"), + $text =~ s/,\s*\"/ /gxms; + $text =~ s/\\n/ /gxms; # Verbatim \n in string array + + $text =~ s/\\&/ /gxms; # pod2man formatting + $text =~ s/\\s(?:0|-1)/ /gxms; # pod2man formatting + + $text =~ s/(?:``|'')/ /gxms; # quote like + + # diff/patch lines (should be after html tag) + $text =~ s/^[-\+!<>]/ /gxms; + $text =~ s{\@\@ \s* + [-+] \d+,\d+ \s+ + [-+] \d+,\d+ \s* + \@\@}{ }gxms; # patch line + + # Texinfo end tag (could be more clever but brute force is fast) + $text =~ s/}/ /gxms; + # Tex section titles + $text =~ s/^\s*\\(sub)*section\*?\{\s*\S+/ /gxms; + # single char at end + # String, C-style comment/javadoc indent, + # quotes for strings, pipe and backslash, tilde in some txt + $text =~ s/[%\*\"\|\\\#~]/ /gxms; + # delete double spacing now and normalize spacing + # to space character + $text =~ s{\s++}{ }gsm; + + # trim both ends + $text =~ s/^\s+|\s+$//g; + + return $text; +} + +# do not use space around punctuation +sub _strip_punct() { + my ($text) = @_; + # replace final punctuation + $text =~ s{(?: + \s*[,\.;]\s*\Z | # final punctuation + \A\s*[,\.;]\s* # punctuation at the beginning + )}{ }gxms; + + # delete double spacing now and normalize spacing + # to space character + $text =~ s{\s++}{ }gsm; + + # trim both ends + $text =~ s/^\s+|\s+$//g; + + return $text; +} + +sub check_for_single_bad_license { + my ($self, $item, $lowercase, $clean, $tag_name, $license_data) = @_; + + # do fast keyword search + # could make more sense as 'return 1 unless all' but does not work + return 0 + if none { $lowercase =~ / \Q$_\E /msx } @{$license_data->{keywords}}; + + return 0 + if none { $clean =~ / \Q$_\E /msx }@{$license_data->{sentences}}; + + my $regex = $license_data->{regex}; + return 0 + if defined $regex && $clean !~ $regex; + + my $callsub = $license_data->{callsub}; + if (!defined $callsub) { + + $self->pointed_hint($tag_name, $item->pointer); + return 1; + } + + return $self->$callsub($item, $tag_name, %+); +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/DebFormat.pm b/lib/Lintian/Check/DebFormat.pm new file mode 100644 index 0000000..57c57a4 --- /dev/null +++ b/lib/Lintian/Check/DebFormat.pm @@ -0,0 +1,227 @@ +# deb-format -- lintian check script -*- perl -*- + +# Copyright (C) 2009 Russ Allbery +# Copyright (C) 2018 Chris Lamb <lamby@debian.org> +# +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Check::DebFormat; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use IPC::Run3; +use List::SomeUtils qw(first_index none); +use Path::Tiny; +use Unicode::UTF8 qw(decode_utf8); + +use Lintian::IPC::Run3 qw(safe_qx); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $SPACE => q{ }; + +const my $MINIMUM_DEB_ARCHIVE_MEMBERS => 3; +const my $INDEX_NOT_FOUND => -1; + +sub installable { + my ($self) = @_; + + my $EXTRA_MEMBERS = $self->data->load('deb-format/extra-members'); + + my $deb_path = $self->processable->path; + + # set to one when something is so bad that we can't continue + my $failed; + + my @command = ('ar', 't', $deb_path); + + my $stdout; + my $stderr; + + run3(\@command, \undef, \$stdout, \$stderr); + + unless ($?) { + my @members = split(/\n/, $stdout); + my $count = scalar(@members); + my ($ctrl_member, $data_member); + + if ($count < $MINIMUM_DEB_ARCHIVE_MEMBERS) { + $self->hint('malformed-deb-archive', +"found only $count members instead of $MINIMUM_DEB_ARCHIVE_MEMBERS" + ); + + } elsif ($members[0] ne 'debian-binary') { + $self->hint('malformed-deb-archive', + "first member $members[0] not debian-binary"); + + } elsif ($count == $MINIMUM_DEB_ARCHIVE_MEMBERS + && none {substr($_, 0, 1) eq '_';}@members) { + # Fairly common case - if there are only 3 members without + # "_", we can trivially determine their (expected) + # positions. We only use this case when there are no + # "extra" members, because they can trigger more tags + # (see below) + (undef, $ctrl_member, $data_member) = @members; + + } else { + my $ctrl_index + = first_index { substr($_, 0, 1) ne '_' } @members[1..$#members]; + my $data_index; + + if ($ctrl_index != $INDEX_NOT_FOUND) { + # Since we searched only a sublist of @members, we have to + # add 1 to $ctrl_index + $ctrl_index++; + $ctrl_member = $members[$ctrl_index]; + $data_index = first_index { substr($_, 0, 1) ne '_' } + @members[$ctrl_index+1..$#members]; + if ($data_index != $INDEX_NOT_FOUND) { + # Since we searched only a sublist of @members, we + # have to adjust $data_index + $data_index += $ctrl_index + 1; + $data_member = $members[$data_index]; + } + } + + # Extra members + # NB: We deliberately do not allow _extra member, + # since various tools seems to be unable to cope + # with them particularly dak + # see https://wiki.debian.org/Teams/Dpkg/DebSupport + for my $i (1..$#members) { + my $member = $members[$i]; + my $actual_index = $i; + my ($expected, $text); + next if $i == $ctrl_index or $i == $data_index; + $expected = $EXTRA_MEMBERS->value($member); + if (defined($expected)) { + next if $expected eq 'ANYWHERE'; + next if $expected == $actual_index; + $text = "expected at position $expected, but appeared"; + } elsif (substr($member,0,1) eq '_') { + $text = 'unexpected _member'; + } else { + $text = 'unexpected member'; + } + $self->hint('misplaced-extra-member-in-deb', + "$member ($text at position $actual_index)"); + } + } + + if (not defined($ctrl_member)) { + # Somehow I doubt we will ever get this far without a control + # file... :) + $self->hint('malformed-deb-archive', 'Missing control.tar member'); + $failed = 1; + } else { + if ( + $ctrl_member !~ m{\A + control\.tar(?:\.(?:gz|xz))? \Z}xsm + ) { + $self->hint( + 'malformed-deb-archive', + join($SPACE, + "second (official) member $ctrl_member", + 'not control.tar.(gz|xz)') + ); + $failed = 1; + } elsif ($ctrl_member eq 'control.tar') { + $self->hint('uses-no-compression-for-control-tarball'); + } + $self->hint('control-tarball-compression-format', + $ctrl_member =~ s/^control\.tar\.?//r || '(none)'); + } + + if (not defined($data_member)) { + # Somehow I doubt we will ever get this far without a data + # member (i.e. I suspect unpacked and index will fail), but + # mah + $self->hint('malformed-deb-archive', 'Missing data.tar member'); + $failed = 1; + } else { + if ( + $data_member !~ m{\A + data\.tar(?:\.(?:gz|bz2|xz|lzma))? \Z}xsm + ) { + # wasn't okay after all + $self->hint( + 'malformed-deb-archive', + join($SPACE, + "third (official) member $data_member", + 'not data.tar.(gz|xz|bz2|lzma)') + ); + $failed = 1; + } elsif ($self->processable->type eq 'udeb' + && $data_member !~ m/^data\.tar\.[gx]z$/) { + $self->hint( + 'udeb-uses-unsupported-compression-for-data-tarball'); + } elsif ($data_member eq 'data.tar.lzma') { + $self->hint('uses-deprecated-compression-for-data-tarball', + 'lzma'); + # Ubuntu's archive allows lzma packages. + $self->hint('lzma-deb-archive'); + } elsif ($data_member eq 'data.tar.bz2') { + $self->hint('uses-deprecated-compression-for-data-tarball', + 'bzip2'); + } elsif ($data_member eq 'data.tar') { + $self->hint('uses-no-compression-for-data-tarball'); + } + $self->hint('data-tarball-compression-format', + $data_member =~ s/^data\.tar\.?//r || '(none)'); + } + } else { + # unpack will probably fail so we'll never get here, but may as well be + # complete just in case. + $stderr =~ s/\n.*//s; + $stderr =~ s/^ar:\s*//; + $stderr =~ s/^deb:\s*//; + $self->hint('malformed-deb-archive', "ar error: $stderr"); + } + + # Check the debian-binary version number. We probably won't get + # here because dpkg-deb will decline to unpack the deb, but be + # thorough just in case. We may eventually have a case where dpkg + # supports a newer format but it's not permitted in the archive + # yet. + if (not defined($failed)) { + my $bytes = safe_qx('ar', 'p', $deb_path, 'debian-binary'); + if ($? != 0) { + $self->hint('malformed-deb-archive', + 'cannot read debian-binary member'); + } else { + my $output = decode_utf8($bytes); + if ($output !~ /^2\.\d+\n/) { + my ($version) = split(m/\n/, $output); + $self->hint('malformed-deb-archive', + "version $version not 2.0"); + } + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debhelper.pm b/lib/Lintian/Check/Debhelper.pm new file mode 100644 index 0000000..b2cee04 --- /dev/null +++ b/lib/Lintian/Check/Debhelper.pm @@ -0,0 +1,1088 @@ +# debhelper format -- lintian check script -*- perl -*- + +# Copyright (C) 1999 by Joey Hess +# Copyright (C) 2016-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debhelper; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::Compare; +use List::SomeUtils qw(any firstval); +use List::UtilsBy qw(min_by); +use Text::LevenshteinXS qw(distance); +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::Relation; + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $DOLLAR => q{$}; +const my $UNDERSCORE => q{_}; +const my $HORIZONTAL_BAR => q{|}; + +const my $ARROW => q{=>}; + +# If there is no debian/compat file present but cdbs is being used, cdbs will +# create one automatically. Currently it always uses compatibility level 5. +# It may be better to look at what version of cdbs the package depends on and +# from that derive the compatibility level.... +const my $CDBS_COMPAT => 5; + +# minimum versions for features +const my $BRACE_EXPANSION => 5; +const my $USES_EXECUTABLE_FILES => 9; +const my $DH_PARALLEL_NOT_NEEDED => 10; +const my $REQUIRES_AUTOTOOLS => 10; +const my $USES_AUTORECONF => 10; +const my $INVOKES_SYSTEMD => 10; +const my $BETTER_SYSTEMD_INTEGRATION => 11; +const my $VERSIONED_PREREQUISITE_AVAILABLE => 11; + +const my $LEVENSHTEIN_TOLERANCE => 3; +const my $MANY_OVERRIDES => 20; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +my $MISC_DEPENDS = Lintian::Relation->new->load($DOLLAR . '{misc:Depends}'); + +# Manually maintained list of dh_commands that requires a versioned +# dependency *AND* are not provided by debhelper. Commands provided +# by debhelper is handled in checks/debhelper. +# +# This overrules any thing listed in dh_commands (which is auto-generated). + +my %DH_COMMAND_MANUAL_PREREQUISITES = ( + dh_apache2 => 'dh-apache2:any | apache2-dev:any', + dh_autoreconf_clean => +'dh-autoreconf:any | debhelper:any (>= 9.20160403~) | debhelper-compat:any', + dh_autoreconf => +'dh-autoreconf:any | debhelper:any (>= 9.20160403~) | debhelper-compat:any', + dh_dkms => 'dh-dkms:any | dh-sequence-dkms:any', + dh_girepository => 'gobject-introspection:any | dh-sequence-gir:any', + dh_gnome => 'gnome-pkg-tools:any | dh-sequence-gnome:any', + dh_gnome_clean => 'gnome-pkg-tools:any | dh-sequence-gnome:any', + dh_lv2config => 'lv2core:any', + dh_make_pgxs => 'postgresql-server-dev-all:any | postgresql-all:any', + dh_nativejava => 'gcj-native-helper:any | default-jdk-builddep:any', + dh_pgxs_test => 'postgresql-server-dev-all:any | postgresql-all:any', + dh_python2 => 'dh-python:any | dh-sequence-python2:any', + dh_python3 => + 'dh-python:any | dh-sequence-python3:any | pybuild-plugin-pyproject:any', + dh_sphinxdoc => +'sphinx:any | python-sphinx:any | python3-sphinx:any | dh-sequence-sphinxdoc:any', + dh_xine => 'libxine-dev:any | libxine2-dev:any' +); + +# Manually maintained list of dependencies needed for dh addons. This overrides +# information from data/common/dh_addons (the latter file is automatically +# generated). +my %DH_ADDON_MANUAL_PREREQUISITES = ( + ada_library => 'dh-ada-library:any | dh-sequence-ada-library:any', + apache2 => 'dh-apache2:any | apache2-dev:any', + autoreconf => +'dh-autoreconf:any | debhelper:any (>= 9.20160403~) | debhelper-compat:any', + cli => 'cli-common-dev:any | dh-sequence-cli:any', + dwz => 'debhelper:any | debhelper-compat:any | dh-sequence-dwz:any', + installinitramfs => +'debhelper:any | debhelper-compat:any | dh-sequence-installinitramfs:any', + gnome => 'gnome-pkg-tools:any | dh-sequence-gnome:any', + lv2config => 'lv2core:any', + nodejs => 'pkg-js-tools:any | dh-sequence-nodejs:any', + perl_dbi => 'libdbi-perl:any | dh-sequence-perl-dbi:any', + perl_imager => 'libimager-perl:any | dh-sequence-perl-imager:any', + pgxs => 'postgresql-server-dev-all:any | postgresql-all:any', + pgxs_loop => 'postgresql-server-dev-all:any | postgresql-all:any', + pypy => 'dh-python:any | dh-sequence-pypy:any', + python2 => 'python2:any | python2-dev:any | dh-sequence-python2:any', + python3 => +'python3:any | python3-all:any | python3-dev:any | python3-all-dev:any | dh-sequence-python3:any', + scour => 'scour:any | python-scour:any | dh-sequence-scour:any', + sphinxdoc => +'sphinx:any | python-sphinx:any | python3-sphinx:any | dh-sequence-sphinxdoc:any', + systemd => +'debhelper:any (>= 9.20160709~) | debhelper-compat:any | dh-sequence-systemd:any | dh-systemd:any', + vim_addon => 'dh-vim-addon:any | dh-sequence-vim-addon:any', +); + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->dirname eq 'debian/'; + + return + if !$item->is_symlink && !$item->is_file; + + if ( $item->basename eq 'control' + || $item->basename =~ m/^(?:.*\.)?(?:copyright|changelog|NEWS)$/) { + + # Handle "control", [<pkg>.]copyright, [<pkg>.]changelog + # and [<pkg>.]NEWS + + # The permissions of symlinks are not really defined, so resolve + # $item to ensure we are not dealing with a symlink. + my $actual = $item->resolve_path; + + $self->pointed_hint('package-file-is-executable', $item->pointer) + if $actual && $actual->is_executable; + + return; + } + + return; +} + +sub source { + my ($self) = @_; + + my @MAINT_COMMANDS = @{$self->data->debhelper_commands->maint_commands}; + + my $FILENAME_CONFIGS= $self->data->load('debhelper/filename-config-files'); + + my $DEBHELPER_LEVELS = $self->data->debhelper_levels; + my $DH_ADDONS = $self->data->debhelper_addons; + my $DH_COMMANDS_DEPENDS= $self->data->debhelper_commands; + + my @KNOWN_DH_COMMANDS; + for my $command ($DH_COMMANDS_DEPENDS->all) { + for my $focus ($EMPTY, qw(-arch -indep)) { + for my $timing (qw(override execute_before execute_after)) { + + push(@KNOWN_DH_COMMANDS, + $timing . $UNDERSCORE . $command . $focus); + } + } + } + + my $debhelper_level; + my $dh_compat_variable; + my $maybe_skipping; + + my $uses_debhelper = 0; + my $uses_dh_exec = 0; + my $uses_autotools_dev_dh = 0; + + my $includes_cdbs = 0; + my $modifies_scripts = 0; + + my $seen_any_dh_command = 0; + my $seen_dh_sequencer = 0; + my $seen_dh_dynamic = 0; + my $seen_dh_systemd = 0; + my $seen_dh_parallel = 0; + my $seen_dh_clean_k = 0; + + my %command_by_prerequisite; + my %addon_by_prerequisite; + my %overrides; + + my $droot = $self->processable->patched->resolve_path('debian/'); + + my $drules; + $drules = $droot->child('rules') if $droot; + + return + unless $drules && $drules->is_open_ok; + + open(my $rules_fd, '<', $drules->unpacked_path) + or die encode_utf8('Cannot open ' . $drules->unpacked_path); + + my $command_prefix_pattern = qr/\s+[@+-]?(?:\S+=\S+\s+)*/; + + my $build_prerequisites_norestriction + = $self->processable->relation_norestriction('Build-Depends-All'); + my $build_prerequisites= $self->processable->relation('Build-Depends-All'); + + my %seen = ( + 'python2' => 0, + 'python3' => 0, + 'runit' => 0, + 'sphinxdoc' => 0, + ); + + for (qw(python2 python3)) { + + $seen{$_} = 1 + if $build_prerequisites_norestriction->satisfies( + "dh-sequence-$_:any"); + } + + my %build_systems; + + my $position = 1; + while (my $line = <$rules_fd>) { + + my $pointer = $drules->pointer($position); + + while ($line =~ s/\\$// && defined(my $cont = <$rules_fd>)) { + $line .= $cont; + } + + if ($line =~ /^ifn?(?:eq|def)\s/) { + $maybe_skipping++; + + } elsif ($line =~ /^endif\s/) { + $maybe_skipping--; + } + + next + if $line =~ /^\s*\#/; + + if ($line =~ /^$command_prefix_pattern(dh_(?!autoreconf)\S+)/) { + + my $dh_command = $1; + + $build_systems{'debhelper'} = 1 + unless exists $build_systems{'dh'}; + + $self->pointed_hint('dh_installmanpages-is-obsolete',$pointer) + if $dh_command eq 'dh_installmanpages'; + + if ( $dh_command eq 'dh_autotools-dev_restoreconfig' + || $dh_command eq 'dh_autotools-dev_updateconfig') { + + $self->pointed_hint( + 'debhelper-tools-from-autotools-dev-are-deprecated', + $pointer, $dh_command); + $uses_autotools_dev_dh = 1; + } + + # Record if we've seen specific helpers, special-casing + # "dh_python" as Python 2.x. + $seen{'python2'} = 1 if $dh_command eq 'dh_python2'; + for my $k (keys %seen) { + $seen{$k} = 1 if $dh_command eq "dh_$k"; + } + + $seen_dh_clean_k = 1 + if $dh_command eq 'dh_clean' + && $line =~ /\s+\-k(?:\s+.*)?$/s; + + # if command is passed -n, it does not modify the scripts + $modifies_scripts = 1 + if (any { $dh_command eq $_ } @MAINT_COMMANDS) + && $line !~ /\s+\-n\s+/; + + # If debhelper commands are wrapped in make conditionals, assume the + # maintainer knows what they're doing and don't check build + # dependencies. + unless ($maybe_skipping) { + + if (exists $DH_COMMAND_MANUAL_PREREQUISITES{$dh_command}) { + my $prerequisite + = $DH_COMMAND_MANUAL_PREREQUISITES{$dh_command}; + $command_by_prerequisite{$prerequisite} = $dh_command; + + } elsif ($DH_COMMANDS_DEPENDS->installed_by($dh_command)) { + + my @broadened = map { "$_:any" } + $DH_COMMANDS_DEPENDS->installed_by($dh_command); + my $prerequisite + = join($SPACE . $HORIZONTAL_BAR . $SPACE,@broadened); + $command_by_prerequisite{$prerequisite} = $dh_command; + } + } + + $seen_any_dh_command = 1; + $uses_debhelper = 1; + + } elsif ($line =~ m{^(?:$command_prefix_pattern)dh\s+}) { + + $build_systems{'dh'} = 1; + delete($build_systems{'debhelper'}); + + $seen_dh_sequencer = 1; + $seen_any_dh_command = 1; + + $seen_dh_dynamic = 1 + if $line =~ /\$[({]\w/; + + $seen_dh_parallel = $position + if $line =~ /--parallel/; + + $uses_debhelper = 1; + $modifies_scripts = 1; + + while ($line =~ /\s--with(?:=|\s+)(['"]?)(\S+)\1/g) { + + my $addon_list = $2; + + for my $addon (split(/,/, $addon_list)) { + + my $orig_addon = $addon; + + $addon =~ y,-,_,; + + my @broadened + = map { "$_:any" } $DH_ADDONS->installed_by($addon); + my $prerequisite = $DH_ADDON_MANUAL_PREREQUISITES{$addon} + || join($SPACE . $HORIZONTAL_BAR . $SPACE,@broadened); + + if ($addon eq 'autotools_dev') { + + $self->pointed_hint( +'debhelper-tools-from-autotools-dev-are-deprecated', + $pointer,"dh ... --with $orig_addon" + ); + $uses_autotools_dev_dh = 1; + } + + $seen_dh_systemd = $position + if $addon eq 'systemd'; + + $self->pointed_hint( + 'dh-quilt-addon-but-quilt-source-format', + $pointer,"dh ... --with $orig_addon") + if $addon eq 'quilt' + && $self->processable->fields->value('Format') eq + '3.0 (quilt)'; + + $addon_by_prerequisite{$prerequisite} = $addon + if defined $prerequisite; + + for my $k (keys %seen) { + $seen{$k} = 1 + if $addon eq $k; + } + } + } + + } elsif ($line =~ m{^include\s+/usr/share/cdbs/1/rules/debhelper.mk} + || $line =~ m{^include\s+/usr/share/R/debian/r-cran.mk}) { + + $build_systems{'cdbs-with-debhelper.mk'} = 1; + delete($build_systems{'cdbs-without-debhelper.mk'}); + + $seen_any_dh_command = 1; + $uses_debhelper = 1; + $modifies_scripts = 1; + $includes_cdbs = 1; + + # CDBS sets DH_COMPAT but doesn't export it. + $dh_compat_variable = $CDBS_COMPAT; + + } elsif ($line =~ /^\s*export\s+DH_COMPAT\s*:?=\s*([^\s]+)/) { + $debhelper_level = $1; + + } elsif ($line =~ /^\s*export\s+DH_COMPAT/) { + $debhelper_level = $dh_compat_variable + if $dh_compat_variable; + + } elsif ($line =~ /^\s*DH_COMPAT\s*:?=\s*([^\s]+)/) { + $dh_compat_variable = $1; + + # one can export and then set the value: + $debhelper_level = $1 + if $debhelper_level; + + } elsif ( + $line =~ /^[^:]*(override|execute_(?:after|before))\s+(dh_[^:]*):/) + { + $self->pointed_hint('typo-in-debhelper-override-target', + $pointer, "$1 $2",$ARROW, "$1_$2"); + + } elsif ($line =~ /^([^:]*_dh_[^:]*):/) { + + my $alltargets = $1; + # can be multiple targets per rule. + my @targets = split(/\s+/, $alltargets); + my @dh_targets = grep { /_dh_/ } @targets; + + # If maintainer is using wildcards, it's unlikely to be a typo. + my @no_wildcards = grep { !/%/ } @dh_targets; + + my $lc = List::Compare->new(\@no_wildcards, \@KNOWN_DH_COMMANDS); + my @unknown = $lc->get_Lonly; + + for my $target (@unknown) { + + my %distance + = map { $_ => distance($target, $_) } @KNOWN_DH_COMMANDS; + my @near = grep { $distance{$_} < $LEVENSHTEIN_TOLERANCE } + keys %distance; + my $nearest = min_by { $distance{$_} } @near; + + $self->pointed_hint('typo-in-debhelper-override-target', + $pointer, $target, $ARROW, $nearest) + if length $nearest; + } + + for my $target (@no_wildcards) { + + next + unless $target + =~ /^(override|execute_(?:before|after))_dh_([^\s]+?)(-arch|-indep|)$/; + + my $timing = $1; + my $command = $2; + my $focus = $3; + my $dh_command = "dh_$command"; + + $overrides{$dh_command} = [$position, $focus]; + $uses_debhelper = 1; + + next + if $DH_COMMANDS_DEPENDS->installed_by($dh_command); + + # Unknown command, so check for likely misspellings + my $missingauto = firstval { "dh_auto_$command" eq $_ } + $DH_COMMANDS_DEPENDS->all; + + $self->pointed_hint( + 'typo-in-debhelper-override-target',$pointer, + $timing . $UNDERSCORE . $dh_command,$ARROW, + $timing . $UNDERSCORE . $missingauto, + )if length $missingauto; + } + + } elsif ($line =~ m{^include\s+/usr/share/cdbs/}) { + + $includes_cdbs = 1; + + $build_systems{'cdbs-without-debhelper.mk'} = 1 + unless exists $build_systems{'cdbs-with-debhelper.mk'}; + + } elsif ( + $line =~m{ + ^include \s+ + /usr/share/(?: + dh-php/pkg-pecl\.mk + |blends-dev/rules + ) + }xsm + ) { + # All of these indirectly use dh. + $seen_any_dh_command = 1; + $build_systems{'dh'} = 1; + delete($build_systems{'debhelper'}); + + } elsif ( + $line =~m{ + ^include \s+ + /usr/share/pkg-kde-tools/qt-kde-team/\d+/debian-qt-kde\.mk + }xsm + ) { + + $includes_cdbs = 1; + $build_systems{'dhmk'} = 1; + delete($build_systems{'debhelper'}); + } + + } continue { + ++$position; + } + + close $rules_fd; + + # Variables could contain any add-ons; assume we have seen them all + %seen = map { $_ => 1 } keys %seen + if $seen_dh_dynamic; + + # Okay - d/rules does not include any file in /usr/share/cdbs/ + $self->pointed_hint('unused-build-dependency-on-cdbs', $drules->pointer) + if $build_prerequisites->satisfies('cdbs:any') + && !$includes_cdbs; + + if (%build_systems) { + + my @systems = sort keys %build_systems; + $self->pointed_hint('debian-build-system', $drules->pointer, + join(', ', @systems)); + + } else { + $self->pointed_hint('debian-build-system', $drules->pointer, 'other'); + } + + unless ($seen_any_dh_command || $includes_cdbs) { + + $self->pointed_hint('package-does-not-use-debhelper-or-cdbs', + $drules->pointer); + return; + } + + my @installable_names= $self->processable->debian_control->installables; + + for my $installable_name (@installable_names) { + + next + if $self->processable->debian_control->installable_package_type( + $installable_name) ne 'deb'; + + my $strong + = $self->processable->binary_relation($installable_name, 'strong'); + my $all= $self->processable->binary_relation($installable_name, 'all'); + + $self->hint('debhelper-but-no-misc-depends', $installable_name) + unless $all->satisfies($MISC_DEPENDS); + + $self->hint('weak-dependency-on-misc-depends', $installable_name) + if $all->satisfies($MISC_DEPENDS) + && !$strong->satisfies($MISC_DEPENDS); + } + + for my $installable ($self->group->get_installables) { + + next + if $installable->type eq 'udeb'; + + my $breaks + = $self->processable->binary_relation($installable->name, 'Breaks'); + my $strong + = $self->processable->binary_relation($installable->name, 'strong'); + + $self->pointed_hint('package-uses-dh-runit-but-lacks-breaks-substvar', + $drules->pointer,$installable->name) + if $seen{'runit'} + && $strong->satisfies('runit:any') + && (any { m{^ etc/sv/ }msx } @{$installable->installed->sorted_list}) + && !$breaks->satisfies($DOLLAR . '{runit:Breaks}'); + } + + my $virtual_compat; + + $build_prerequisites->visit( + sub { + return 0 + unless + m{^ debhelper-compat (?: : \S+ )? \s+ [(]= \s+ (\d+) [)] $}x; + + $virtual_compat = $1; + + return 1; + }, + Lintian::Relation::VISIT_PRED_FULL + | Lintian::Relation::VISIT_STOP_FIRST_MATCH + ); + + my $control_item=$self->processable->debian_control->item; + + $self->pointed_hint('debhelper-compat-virtual-relation', + $control_item->pointer, $virtual_compat) + if length $virtual_compat; + + # gives precedence to virtual compat + $debhelper_level = $virtual_compat + if length $virtual_compat; + + my $compat_file = $droot->child('compat'); + + $self->hint('debhelper-compat-file-is-missing') + unless ($compat_file && $compat_file->is_open_ok) + || $virtual_compat; + + my $from_compat_file = $self->check_compat_file; + + if (length $debhelper_level && length $from_compat_file) { + + $self->pointed_hint( + 'declares-possibly-conflicting-debhelper-compat-versions', + $compat_file->pointer,$from_compat_file,'vs elsewhere', + $debhelper_level); + } + + # this is not just to fill in the gap, but because debhelper + # prefers DH_COMPAT over debian/compat + $debhelper_level ||= $from_compat_file; + + $self->hint('debhelper-compat-level', $debhelper_level) + if length $debhelper_level; + + $debhelper_level ||= 1; + + $self->hint('package-uses-deprecated-debhelper-compat-version', + $debhelper_level) + if $debhelper_level < $DEBHELPER_LEVELS->value('deprecated'); + + $self->hint('package-uses-old-debhelper-compat-version', $debhelper_level) + if $debhelper_level >= $DEBHELPER_LEVELS->value('deprecated') + && $debhelper_level < $DEBHELPER_LEVELS->value('recommended'); + + $self->hint('package-uses-experimental-debhelper-compat-version', + $debhelper_level) + if $debhelper_level >= $DEBHELPER_LEVELS->value('experimental'); + + $self->pointed_hint('dh-clean-k-is-deprecated', $drules->pointer) + if $seen_dh_clean_k; + + for my $suffix (qw(enable start)) { + + my ($stored_position, $focus) + = @{$overrides{"dh_systemd_$suffix"} // []}; + + $self->pointed_hint( + 'debian-rules-uses-deprecated-systemd-override', + $drules->pointer($stored_position), + "override_dh_systemd_$suffix$focus" + ) + if $stored_position + && $debhelper_level >= $BETTER_SYSTEMD_INTEGRATION; + } + + my $num_overrides = scalar(keys %overrides); + + $self->hint('excessive-debhelper-overrides', $num_overrides) + if $num_overrides >= $MANY_OVERRIDES; + + $self->pointed_hint( + 'debian-rules-uses-unnecessary-dh-argument', + $drules->pointer($seen_dh_parallel), + "$debhelper_level >= $DH_PARALLEL_NOT_NEEDED", + 'dh ... --parallel' + )if $seen_dh_parallel && $debhelper_level >= $DH_PARALLEL_NOT_NEEDED; + + $self->pointed_hint( + 'debian-rules-uses-unnecessary-dh-argument', + $drules->pointer($seen_dh_systemd), + "$debhelper_level >= $INVOKES_SYSTEMD", + 'dh ... --with=systemd' + )if $seen_dh_systemd && $debhelper_level >= $INVOKES_SYSTEMD; + + for my $item ($droot->children) { + + next + if !$item->is_symlink && !$item->is_file; + + next + if $item->name eq $drules->name; + + if ($item->basename =~ m/^(?:(.*)\.)?(?:post|pre)(?:inst|rm)$/) { + + next + unless $modifies_scripts; + + # They need to have #DEBHELPER# in their scripts. Search + # for scripts that look like maintainer scripts and make + # sure the token is there. + my $installable_name = $1 || $EMPTY; + my $seentag = 0; + + $seentag = 1 + if $item->decoded_utf8 =~ /\#DEBHELPER\#/; + + if (!$seentag) { + + my $single_pkg = $EMPTY; + $single_pkg + = $self->processable->debian_control + ->installable_package_type($installable_names[0]) + if scalar @installable_names == 1; + + my $installable_type + = $self->processable->debian_control + ->installable_package_type($installable_name); + + my $is_udeb = 0; + + $is_udeb = 1 + if $installable_name && $installable_type eq 'udeb'; + + $is_udeb = 1 + if !$installable_name && $single_pkg eq 'udeb'; + + $self->pointed_hint('maintainer-script-lacks-debhelper-token', + $item->pointer) + unless $is_udeb; + } + + next; + } + + my $category = $item->basename; + $category =~ s/^.+\.//; + + next + unless length $category; + + # Check whether this is a debhelper config file that takes + # a list of filenames. + if ($FILENAME_CONFIGS->recognizes($category)) { + + # The permissions of symlinks are not really defined, so resolve + # $item to ensure we are not dealing with a symlink. + my $actual = $item->resolve_path; + next + unless defined $actual; + + $self->check_for_brace_expansion($item, $debhelper_level); + + # debhelper only use executable files in compat 9 + $self->pointed_hint('package-file-is-executable', $item->pointer) + if $actual->is_executable + && $debhelper_level < $USES_EXECUTABLE_FILES; + + if ($debhelper_level >= $USES_EXECUTABLE_FILES) { + + $self->pointed_hint( + 'executable-debhelper-file-without-being-executable', + $item->pointer) + if $actual->is_executable + && !length $actual->hashbang; + + # Only /usr/bin/dh-exec is allowed, even if + # /usr/lib/dh-exec/dh-exec-subst works too. + $self->pointed_hint('dh-exec-private-helper', $item->pointer) + if $actual->is_executable + && $actual->hashbang =~ m{^/usr/lib/dh-exec/}; + + # Do not make assumptions about the contents of an + # executable debhelper file, unless it's a dh-exec + # script. + if ($actual->hashbang =~ /dh-exec/) { + + $uses_dh_exec = 1; + $self->check_dh_exec($item, $category); + } + } + } + } + + $self->pointed_hint('package-uses-debhelper-but-lacks-build-depends', + $drules->pointer) + if $uses_debhelper + && !$build_prerequisites->satisfies('debhelper:any') + && !$build_prerequisites->satisfies('debhelper-compat:any'); + + $self->pointed_hint('package-uses-dh-exec-but-lacks-build-depends', + $drules->pointer) + if $uses_dh_exec + && !$build_prerequisites->satisfies('dh-exec:any'); + + for my $prerequisite (keys %command_by_prerequisite) { + + my $command = $command_by_prerequisite{$prerequisite}; + + # handled above + next + if $prerequisite eq 'debhelper:any'; + + next + if $debhelper_level >= $REQUIRES_AUTOTOOLS + && (any { $_ eq $prerequisite } + qw(autotools-dev:any dh-strip-nondeterminism:any)); + + $self->pointed_hint('missing-build-dependency-for-dh_-command', + $drules->pointer,$command, "(does not satisfy $prerequisite)") + unless $build_prerequisites_norestriction->satisfies($prerequisite); + } + + for my $prerequisite (keys %addon_by_prerequisite) { + + my $addon = $addon_by_prerequisite{$prerequisite}; + + next + if $debhelper_level >= $REQUIRES_AUTOTOOLS + && $addon eq 'autoreconf'; + + $self->pointed_hint('missing-build-dependency-for-dh-addon', + $drules->pointer,$addon, "(does not satisfy $prerequisite)") + unless ( + $build_prerequisites_norestriction->satisfies($prerequisite)); + + # As a special case, the python3 addon needs a dependency on + # dh-python unless the -dev packages are used. + my $python_source + = 'dh-python:any | dh-sequence-python3:any | pybuild-plugin-pyproject:any'; + + $self->pointed_hint('missing-build-dependency-for-dh-addon', + $drules->pointer,$addon, "(does not satisfy $python_source)") + if $addon eq 'python3' + && $build_prerequisites_norestriction->satisfies($prerequisite) + && !$build_prerequisites_norestriction->satisfies( + 'python3-dev:any | python3-all-dev:any') + && !$build_prerequisites_norestriction->satisfies($python_source); + } + + $self->hint('no-versioned-debhelper-prerequisite', $debhelper_level) + unless $build_prerequisites->satisfies( + "debhelper:any (>= $debhelper_level~)") + || $build_prerequisites->satisfies( + "debhelper-compat:any (= $debhelper_level)"); + + if ($debhelper_level >= $USES_AUTORECONF) { + for my $autotools_source (qw(dh-autoreconf:any autotools-dev:any)) { + + next + if $autotools_source eq 'autotools-dev:any' + && $uses_autotools_dev_dh; + + $self->hint('useless-autoreconf-build-depends', + "(does not need to satisfy $autotools_source)") + if $build_prerequisites->satisfies($autotools_source); + } + } + + if ($seen_dh_sequencer && !$seen{'python2'}) { + + my %python_depends; + + for my $installable_name (@installable_names) { + + $python_depends{$installable_name} = 1 + if $self->processable->binary_relation($installable_name,'all') + ->satisfies($DOLLAR . '{python:Depends}'); + } + + $self->hint('python-depends-but-no-python-helper', + (sort keys %python_depends)) + if %python_depends; + } + + if ($seen_dh_sequencer && !$seen{'python3'}) { + + my %python3_depends; + + for my $installable_name (@installable_names) { + + $python3_depends{$installable_name} = 1 + if $self->processable->binary_relation($installable_name,'all') + ->satisfies($DOLLAR . '{python3:Depends}'); + } + + $self->hint('python3-depends-but-no-python3-helper', + (sort keys %python3_depends)) + if %python3_depends; + } + + if ($seen{'sphinxdoc'} && !$seen_dh_dynamic) { + + my $seen_sphinxdoc = 0; + + for my $installable_name (@installable_names) { + $seen_sphinxdoc = 1 + if $self->processable->binary_relation($installable_name,'all') + ->satisfies($DOLLAR . '{sphinxdoc:Depends}'); + } + + $self->pointed_hint('sphinxdoc-but-no-sphinxdoc-depends', + $drules->pointer) + unless $seen_sphinxdoc; + } + + return; +} + +sub check_for_brace_expansion { + my ($self, $item, $debhelper_level) = @_; + + return + unless $item->is_open_ok; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $position = 1; + while (my $line = <$fd>) { + + next + if $line =~ /^\s*$/; + + next + if $line =~ /^\#/ + && $debhelper_level >= $BRACE_EXPANSION; + + if ($line =~ /((?<!\\)\{(?:[^\s\\\}]*?,)+[^\\\}\s,]*,*\})/){ + my $expansion = $1; + + my $pointer = $item->pointer($position); + + $self->pointed_hint('brace-expansion-in-debhelper-config-file', + $pointer, $expansion); + + last; + } + + } continue { + ++$position; + } + + close $fd; + + return; +} + +sub check_compat_file { + my ($self) = @_; + + # Check the compat file. Do this separately from looping over all + # of the other files since we use the compat value when checking + # for brace expansion. + + my $compat_file + = $self->processable->patched->resolve_path('debian/compat'); + + # missing file is dealt with elsewhere + return $EMPTY + unless $compat_file && $compat_file->is_open_ok; + + my $debhelper_level; + + open(my $fd, '<', $compat_file->unpacked_path) + or die encode_utf8('Cannot open ' . $compat_file->unpacked_path); + + my $position = 1; + while (my $line = <$fd>) { + + if ($position == 1) { + + $debhelper_level = $line; + next; + } + + my $pointer = $compat_file->pointer($position); + + $self->pointed_hint('debhelper-compat-file-contains-multiple-levels', + $pointer) + if $line =~ /^\d/; + + } continue { + ++$position; + } + + close $fd; + + # trim both ends + $debhelper_level =~ s/^\s+|\s+$//g; + + if (!length $debhelper_level) { + + $self->pointed_hint('debhelper-compat-file-is-empty', + $compat_file->pointer); + return $EMPTY; + } + + my $DEBHELPER_LEVELS = $self->data->debhelper_levels; + + # Recommend people use debhelper-compat (introduced in debhelper + # 11.1.5~alpha1) over debian/compat, except for experimental/beta + # versions. + $self->pointed_hint('uses-debhelper-compat-file', $compat_file->pointer) + if $debhelper_level >= $VERSIONED_PREREQUISITE_AVAILABLE + && $debhelper_level < $DEBHELPER_LEVELS->value('experimental'); + + return $debhelper_level; +} + +sub check_dh_exec { + my ($self, $item, $category) = @_; + + return + unless $item->is_open_ok; + + my $dhe_subst = 0; + my $dhe_install = 0; + my $dhe_filter = 0; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $position = 1; + while (my $line = <$fd>) { + + chomp $line; + + my $pointer = $item->pointer($position); + + if ($line =~ /\$\{([^\}]+)\}/) { + + my $sv = $1; + $dhe_subst = 1; + + if ( + $sv !~ m{ \A + DEB_(?:BUILD|HOST)_(?: + ARCH (?: _OS|_CPU|_BITS|_ENDIAN )? + |GNU_ (?:CPU|SYSTEM|TYPE)|MULTIARCH + ) \Z}xsm + ) { + $self->pointed_hint('dh-exec-subst-unknown-variable', + $pointer, $sv); + } + } + + $dhe_install = 1 + if $line =~ /[ \t]=>[ \t]/; + + $dhe_filter = 1 + if $line =~ /\[[^\]]+\]/; + + $dhe_filter = 1 + if $line =~ /<[^>]+>/; + + if ( $line =~ /^usr\/lib\/\$\{([^\}]+)\}\/?$/ + || $line + =~ /^usr\/lib\/\$\{([^\}]+)\}\/?\s+\/usr\/lib\/\$\{([^\}]+)\}\/?$/ + || $line =~ /^usr\/lib\/\$\{([^\}]+)\}[^\s]+$/) { + + my $sv = $1; + my $dv = $2; + my $dhe_useless = 0; + + if ( + $sv =~ m{ \A + DEB_(?:BUILD|HOST)_(?: + ARCH (?: _OS|_CPU|_BITS|_ENDIAN )? + |GNU_ (?:CPU|SYSTEM|TYPE)|MULTIARCH + ) \Z}xsm + ) { + if (defined($dv)) { + $dhe_useless = ($sv eq $dv); + } else { + $dhe_useless = 1; + } + } + + $self->pointed_hint('dh-exec-useless-usage', $pointer, $line) + if $dhe_useless && $item =~ /debian\/.*(install|manpages)/; + } + + } continue { + ++$position; + } + + close $fd; + + $self->pointed_hint('dh-exec-script-without-dh-exec-features', + $item->pointer) + if !$dhe_subst + && !$dhe_install + && !$dhe_filter; + + $self->pointed_hint('dh-exec-install-not-allowed-here', $item->pointer) + if $dhe_install + && $category ne 'install' + && $category ne 'manpages'; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debhelper/Temporary.pm b/lib/Lintian/Check/Debhelper/Temporary.pm new file mode 100644 index 0000000..452d76c --- /dev/null +++ b/lib/Lintian/Check/Debhelper/Temporary.pm @@ -0,0 +1,55 @@ +# debhelper/temporary -- lintian check script -*- perl -*- + +# Copyright (C) 1999 by Joey Hess +# Copyright (C) 2016-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debhelper::Temporary; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->dirname eq 'debian/'; + + # The regex matches "debhelper", but debhelper/Dh_Lib does not + # make those, so skip it. + $self->pointed_hint('temporary-debhelper-file', $item->pointer) + if $item->basename =~ m{ (?: ^ | [.] ) debhelper (?: [.]log )? $}x + && $item->basename ne 'debhelper'; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Changelog.pm b/lib/Lintian/Check/Debian/Changelog.pm new file mode 100644 index 0000000..faa7890 --- /dev/null +++ b/lib/Lintian/Check/Debian/Changelog.pm @@ -0,0 +1,970 @@ +# debian/changelog -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz +# Copyright (C) 2019-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Changelog; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Data::Validate::Domain; +use Date::Format qw(time2str); +use Email::Address::XS; +use List::Util qw(first); +use List::SomeUtils qw(any all uniq); +use Path::Tiny; +use Syntax::Keyword::Try; +use Unicode::UTF8 qw(valid_utf8 decode_utf8 encode_utf8); + +use Lintian::Changelog; +use Lintian::Changelog::Version; +use Lintian::IPC::Run3 qw(safe_qx); +use Lintian::Relation::Version qw(versions_gt); +use Lintian::Spelling qw(check_spelling); + +const my $EMPTY => q{}; +const my $DOUBLE_QUOTE => q{"}; +const my $GREATER_THAN => q{>}; +const my $APPROXIMATELY_EQUAL => q{~}; + +const my $NOT_EQUALS => q{!=}; +const my $ARROW => q{->}; + +const my $MAXIMUM_WIDTH => 82; +const my $FIRST_ARCHIVED_BUG_NUMBER => 50_004; +const my $OUT_OF_REACH_BUG_NUMBER => 1_500_000; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub spelling_tag_emitter { + my ($self, $tag_name, $item, @orig_args) = @_; + + my $pointer = $item->pointer($.); + + return sub { + return $self->pointed_hint($tag_name, $pointer, @orig_args, @_); + }; +} + +sub source { + my ($self) = @_; + + my $pkg = $self->processable->name; + my $processable = $self->processable; + my $group = $self->group; + + my $changelog = $processable->changelog; + return + unless defined $changelog; + + my @entries = @{$changelog->entries}; + return + unless @entries; + + my $latest_entry = $entries[0]; + + my $changelog_item = $self->processable->changelog_item; + my $latest_pointer = $changelog_item->pointer($latest_entry->position); + + my $changes = $group->changes; + if ($changes) { + my $contents = path($changes->path)->slurp; + # make sure dot matches newlines, as well + if ($contents =~ qr/BEGIN PGP SIGNATURE.*END PGP SIGNATURE/ms) { + + $self->pointed_hint('unreleased-changelog-distribution', + $latest_pointer) + if $latest_entry->Distribution eq 'UNRELEASED'; + } + } + + my $versionstring = $processable->fields->value('Version'); + my $latest_version = Lintian::Changelog::Version->new; + + try { + $latest_version->assign($versionstring, $processable->native); + + } catch { + my $indicator= ($processable->native ? $EMPTY : 'non-') . 'native'; + $self->pointed_hint('malformed-debian-changelog-version', + $latest_pointer,$versionstring, "(for $indicator)"); + undef $latest_version; + + # perlcritic 1.140-1 requires a semicolon on the next line + }; + + if (defined $latest_version) { + + $self->pointed_hint( + 'hyphen-in-upstream-part-of-debian-changelog-version', + $latest_pointer,$latest_version->upstream) + if !$processable->native && $latest_version->upstream =~ qr/-/; + + # 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. + unless (length $latest_version->source_nmu) { + my $revision = $latest_version->maintainer_revision; + my $distribution = $latest_entry->Distribution; + + $self->pointed_hint('version-refers-to-distribution', + $latest_pointer,$latest_version->literal) + if ($revision =~ /testing|(?:un)?stable/i) + || ( + ($distribution eq 'unstable'|| $distribution eq 'experimental') + && $revision + =~ /woody|sarge|etch|lenny|squeeze|stretch|buster/); + } + + my $examine = $latest_version->maintainer_revision; + $examine = $latest_version->upstream + unless $processable->native; + + my $candidate_pattern = qr/rc|alpha|beta|pre(?:view|release)?/; + my $increment_pattern = qr/[^a-z].*|\Z/; + + my ($candidate_string, $increment_string) + = ($examine =~ m/[^~a-z]($candidate_pattern)($increment_pattern)/sm); + if (length $candidate_string && !length $latest_version->source_nmu) { + + $increment_string //= $EMPTY; + + # remove rc-part and any preceding symbol + my $expected = $examine; + $expected =~ s/[\.\+\-\:]?\Q$candidate_string\E.*//; + + my $suggestion = "$expected~$candidate_string$increment_string"; + + $self->pointed_hint( + 'rc-version-greater-than-expected-version', + $latest_pointer, + $examine, + $GREATER_THAN, + $expected, + "(consider using $suggestion)", + ) + if $latest_version->maintainer_revision eq '1' + || $latest_version->maintainer_revision=~ /^0(?:\.1|ubuntu1)?$/ + || $processable->native; + } + } + + if (@entries > 1) { + + my $previous_entry = $entries[1]; + my $latest_timestamp = $latest_entry->Timestamp; + my $previous_timestamp = $previous_entry->Timestamp; + + my $previous_version = Lintian::Changelog::Version->new; + try { + $previous_version->assign($previous_entry->Version, + $processable->native); + } catch { + my $indicator= ($processable->native ? $EMPTY : 'non-') . 'native'; + $self->pointed_hint( + 'odd-historical-debian-changelog-version', + $changelog_item->pointer($previous_entry->position), + $previous_entry->Version, + "(for $indicator)" + ); + undef $previous_version; + } + + if ($latest_timestamp && $previous_timestamp) { + + $self->pointed_hint( + 'latest-debian-changelog-entry-without-new-date', + $latest_pointer) + if $latest_timestamp <= $previous_timestamp + && lc($latest_entry->Distribution) ne 'unreleased'; + } + + if (defined $latest_version) { + + # skip first + for my $entry (@entries[1..$#entries]) { + + # cannot use parser; nativeness may differ + my ($no_epoch) = ($entry->Version =~ qr/^(?:[^:]+:)?([^:]+)$/); + + next + unless defined $no_epoch; + + # disallowed even if epochs differ; see tag description + if ( $latest_version->no_epoch eq $no_epoch + && $latest_entry->Source eq $entry->Source) { + + $self->pointed_hint( +'latest-debian-changelog-entry-reuses-existing-version', + $latest_pointer, + $latest_version->literal, + $APPROXIMATELY_EQUAL, + $entry->Version, + '(last used: '. $entry->Date . ')' + ); + + last; + } + } + } + + if (defined $latest_version && defined $previous_version) { + + # a reused version literal is caught by the broader previous check + + # start with a reasonable default + my $expected_previous = $previous_version->literal; + + $expected_previous = $latest_version->without_backport + if $latest_version->backport_release + && $latest_version->backport_revision + && $latest_version->debian_without_backport ne '0'; + + # find an appropriate prior version for a source NMU + if (length $latest_version->source_nmu) { + + # can only do first nmu for now + $expected_previous = $latest_version->without_source_nmu + if $latest_version->source_nmu eq '1' + &&$latest_version->maintainer_revision =~ qr/\d+/ + && $latest_version->maintainer_revision ne '0'; + } + + $self->pointed_hint( + 'changelog-file-missing-explicit-entry',$latest_pointer, + $previous_version->literal, $ARROW, + "$expected_previous (missing)", $ARROW, + $latest_version->literal + ) + unless $previous_version->literal eq $expected_previous + || $latest_entry->Distribution eq 'bullseye' + || $previous_entry->Distribution eq 'bullseye' + || $latest_entry->Distribution =~ /-security$/i; + + if ( $latest_version->epoch eq $previous_version->epoch + && $latest_version->upstream eq$previous_version->upstream + && $latest_entry->Source eq $previous_entry->Source + && !$processable->native) { + + $self->pointed_hint( + 'possible-new-upstream-release-without-new-version', + $latest_pointer) + if $latest_entry->Changes + =~ /^\s*\*\s+new\s+upstream\s+(?:\S+\s+)?release\b/im; + + my $non_consecutive = 0; + + $non_consecutive = 1 + if !length $latest_version->source_nmu + && $latest_version->maintainer_revision =~ /^\d+$/ + && $previous_version->maintainer_revision =~ /^\d+$/ + && $latest_version->maintainer_revision + != $previous_version->maintainer_revision + 1; + + $non_consecutive = 1 + if $latest_version->maintainer_revision eq + $previous_version->maintainer_revision + && $latest_version->source_nmu =~ /^\d+$/ + && $previous_version->source_nmu =~ /^\d+$/ + && $latest_version->source_nmu + != $previous_version->source_nmu + 1; + + $non_consecutive = 1 + if $latest_version->source_nmu =~ /^\d+$/ + && !length $previous_version->source_nmu + && $latest_version->source_nmu != 1; + + $self->pointed_hint( + 'non-consecutive-debian-revision', + $latest_pointer,$previous_version->literal, + $ARROW,$latest_version->literal + )if $non_consecutive; + } + + if ($latest_version->epoch ne $previous_version->epoch) { + $self->pointed_hint( + 'epoch-change-without-comment',$latest_pointer, + $previous_version->literal, $ARROW, + $latest_version->literal + )unless $latest_entry->Changes =~ /\bepoch\b/im; + + $self->pointed_hint( + 'epoch-changed-but-upstream-version-did-not-go-backwards', + $latest_pointer,$previous_version->literal, + $ARROW,$latest_version->literal + ) + unless $processable->native + || versions_gt($previous_version->upstream, + $latest_version->upstream); + } + } + } + + return; +} + +# no copyright in udebs +sub binary { + my ($self) = @_; + + my $pkg = $self->processable->name; + my $processable = $self->processable; + my $group = $self->group; + + my $is_symlink = 0; + my $native_pkg; + my $foreign_pkg; + my @doc_files; + + # skip packages which have a /usr/share/doc/$pkg -> foo symlink + my $docfile = $processable->installed->lookup("usr/share/doc/$pkg"); + return + if defined $docfile && $docfile->is_symlink; + + # trailing slash in indicates a directory + my $docdir = $processable->installed->lookup("usr/share/doc/$pkg/"); + @doc_files = grep { $_->is_file || $_->is_symlink } $docdir->children + if defined $docdir; + my @news_files + = grep { $_->basename =~ m{\A NEWS\.Debian (?:\.gz)? \Z}ixsm }@doc_files; + + $self->pointed_hint('debian-news-file-not-compressed', $_->pointer) + for grep { $_->basename !~ m{\.gz$} } @news_files; + + $self->pointed_hint('wrong-name-for-debian-news-file', $_->pointer) + for grep { $_->basename =~ m{\.gz$} && $_->basename ne 'NEWS.Debian.gz' } + @news_files; + + my @changelog_files = grep { + $_->basename =~ m{\A changelog (?:\.html|\.Debian)? (?:\.gz)? \Z}xsm + } @doc_files; + + # ubuntu permits symlinks; their profile suppresses the tag + $self->pointed_hint('debian-changelog-file-is-a-symlink', $_->pointer) + for grep { $_->is_symlink } @changelog_files; + + $self->pointed_hint('changelog-file-not-compressed', $_->pointer) + for grep { $_->basename !~ m{ \.gz \Z}xsm } @changelog_files; + + # 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. + for my $item (@changelog_files) { + + next + unless $item->basename =~ m{ \.gz \Z}xsm; + + my $resolved = $item->resolve_path; + next + unless defined $resolved; + + $self->pointed_hint('changelog-not-compressed-with-max-compression', + $item->pointer) + unless $resolved->file_type =~ /max compression/; + } + + my @html_changelogs + = grep { $_->basename =~ /^changelog\.html(?:\.gz)?$/ } @changelog_files; + my @text_changelogs + = grep { $_->basename =~ /^changelog(?:\.gz)?$/ } @changelog_files; + + if (!@text_changelogs) { + + $self->pointed_hint('html-changelog-without-text-version', $_->pointer) + for @html_changelogs; + } + + my $packagepath = 'usr/share/doc/' . $self->processable->name; + my $news_item + = $self->processable->installed->resolve_path( + "$packagepath/NEWS.Debian.gz"); + + my $news; + if (defined $news_item && $news_item->is_file) { + + my $bytes = safe_qx('gunzip', '-c', $news_item->unpacked_path); + + # another check complains about invalid encoding + if (valid_utf8($bytes)) { + + my $contents = decode_utf8($bytes); + my $newslog = Lintian::Changelog->new; + $newslog->parse($contents); + + for my $error (@{$newslog->errors}) { + + my $position = $error->[0]; + my $condition = $error->[1]; + + my $pointer = $news_item->pointer($position); + + $self->pointed_hint('syntax-error-in-debian-news-file', + $pointer, $DOUBLE_QUOTE . $condition . $DOUBLE_QUOTE); + } + + # Some checks on the most recent entry. + if ($newslog->entries && defined @{$newslog->entries}[0]) { + + $news = @{$newslog->entries}[0]; + + my $pointer = $news_item->pointer($news->position); + + $self->pointed_hint( + 'debian-news-entry-has-strange-distribution', + $pointer,$news->Distribution) + if length $news->Distribution + && $news->Distribution eq 'UNRELEASED'; + + check_spelling( + $self->data, + $news->Changes, + $group->spelling_exceptions, + $self->spelling_tag_emitter( + 'spelling-error-in-news-debian', $news_item + ) + ); + + $self->pointed_hint('debian-news-entry-uses-asterisk',$pointer) + if $news->Changes =~ /^ \s* [*] \s /x; + } + } + } + + # is this a native Debian package? + # If the version is missing, we assume it to be non-native + # as it is the most likely case. + my $source = $processable->fields->value('Source'); + my $source_version; + if ($processable->fields->declares('Source') && $source =~ m/\((.*)\)/) { + $source_version = $1; + } else { + $source_version = $processable->fields->value('Version'); + } + if (defined $source_version) { + $native_pkg = ($source_version !~ m/-/); + } else { + # We do not know, but assume it to non-native as it is + # the most likely case. + $native_pkg = 0; + } + $source_version = $processable->fields->value('Version') || '0-1'; + $foreign_pkg = (!$native_pkg && $source_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)?$/} map { $_->basename } @doc_files) { + # everything is fine + } elsif (my $chg + = first {$_->basename =~ m/^changelog[.]debian(?:\.gz)$/i;} + @doc_files) { + $self->pointed_hint('wrong-name-for-changelog-of-native-package', + $chg->pointer); + + } else { + $self->hint( + 'no-changelog', + "usr/share/doc/$pkg/changelog.gz", + '(native package)' + ); + } + } else { + # non-native (foreign :) Debian package + + # 1. check for upstream changelog + my $found_upstream_text_changelog = 0; + if ( + any { m/^changelog(\.html)?(?:\.gz)?$/ } + map { $_->basename } @doc_files + ) { + $found_upstream_text_changelog = 1 unless $1; + # everything is fine + } else { + # search for changelogs with wrong file name + for my $item (@doc_files) { + + if ( $item->basename =~ m/^change/i + && $item->basename !~ m/debian/i) { + + $self->pointed_hint('wrong-name-for-upstream-changelog', + $item->pointer); + last; + } + } + } + + # 2. check for Debian changelog + if ( + any { m/^changelog\.Debian(?:\.gz)?$/ } + map { $_->basename } @doc_files + ) { + # everything is fine + } elsif (my $chg + = first {$_->basename =~ m/^changelog\.debian(?:\.gz)?$/i;} + @doc_files) { + $self->pointed_hint('wrong-name-for-debian-changelog-file', + $chg->pointer); + + } else { + if ($foreign_pkg && $found_upstream_text_changelog) { + $self->hint('debian-changelog-file-missing-or-wrong-name'); + + } elsif ($foreign_pkg) { + $self->hint( + 'no-changelog', + "usr/share/doc/$pkg/changelog.Debian.gz", + '(non-native package)' + ); + } + # 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 $changelog_item = $self->processable->changelog_item; + return + unless defined $changelog_item; + + # another check complains about invalid encoding + my $changelog = $processable->changelog; + + for my $error (@{$changelog->errors}) { + + my $position = $error->[0]; + my $condition = $error->[1]; + + my $pointer = $changelog_item->pointer($position); + + $self->pointed_hint('syntax-error-in-debian-changelog', + $pointer, $DOUBLE_QUOTE . $condition . $DOUBLE_QUOTE); + } + + # 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 $real_start = $self->check_dch($changelog_item); + + my @entries = @{$changelog->entries}; + + # all versions from the changelog + my %allversions + = map { $_ => 1 } grep { defined } map { $_->Version } @entries; + + # checks applying to all entries + for my $entry (@entries) { + + my $position = $entry->position; + my $version = $entry->Version; + + my $pointer = $changelog_item->pointer($position); + + if (length $entry->Maintainer) { + my ($parsed) = Email::Address::XS->parse($entry->Maintainer); + + unless ($parsed->is_valid) { + + $self->pointed_hint( + 'bogus-mail-host-in-debian-changelog', + $pointer,$entry->Maintainer,"(for version $version)", + ); + next; + } + + unless (all { length } + ($parsed->address, $parsed->user, $parsed->host)) { + $self->pointed_hint( + 'bogus-mail-host-in-debian-changelog', + $pointer,$parsed->format,"(for version $version)", + ); + next; + } + + $self->pointed_hint( + 'bogus-mail-host-in-debian-changelog', + $pointer, $parsed->address,"(for version $version)", + ) + unless is_domain($parsed->host, + {domain_disable_tld_validation => 1}); + } + } + + my $INVALID_DATES + = $self->data->load('changelog-file/invalid-dates',qr/\s*=\>\s*/); + + if (@entries) { + + # checks related to the latest entry + my $latest_entry = $entries[0]; + + my $latest_pointer = $changelog_item->pointer($latest_entry->position); + + my $latest_timestamp = $latest_entry->Timestamp; + + if ($latest_timestamp) { + + my $warned = 0; + my $longdate = $latest_entry->Date; + + for my $re ($INVALID_DATES->all()) { + if ($longdate =~ m/($re)/i) { + + my $match = $1; + my $repl = $INVALID_DATES->value($re); + + $self->pointed_hint('invalid-date-in-debian-changelog', + $latest_pointer,"($match", $ARROW, "$repl)"); + + $warned = 1; + } + } + + my ($weekday_declared, $numberportion) + = split(m/,\s*/, $longdate, 2); + $numberportion //= $EMPTY; + my ($tz, $weekday_actual); + + if ($numberportion =~ m/[ ]+ ([^ ]+)\Z/xsm) { + $tz = $1; + $weekday_actual = time2str('%a', $latest_timestamp, $tz); + } + + if (not $warned and $tz and $weekday_declared ne $weekday_actual) { + my $real_weekday = time2str('%A', $latest_timestamp, $tz); + my $short_date = time2str('%Y-%m-%d', $latest_timestamp, $tz); + $self->pointed_hint('debian-changelog-has-wrong-day-of-week', + $latest_pointer,"$short_date was a $real_weekday"); + } + } + + # there is more than one changelog entry + if (@entries > 1) { + + my $previous_entry = $entries[1]; + + my $previous_timestamp = $previous_entry->Timestamp; + + $self->pointed_hint('latest-changelog-entry-without-new-date', + $latest_pointer) + if defined $latest_timestamp + && defined $previous_timestamp + && $latest_timestamp <= $previous_timestamp + && $latest_entry->Distribution ne 'UNRELEASED'; + + my $latest_dist = lc $latest_entry->Distribution; + my $previous_dist = lc $previous_entry->Distribution; + + $self->pointed_hint('experimental-to-unstable-without-comment', + $latest_pointer) + if $latest_dist eq 'unstable' + && $previous_dist eq 'experimental' + && $latest_entry->Changes + !~ m{ \b to \s+ ['"\N{LEFT SINGLE QUOTATION MARK}\N{LEFT DOUBLE QUOTATION MARK}]? (?:unstable|sid) ['"\N{RIGHT SINGLE QUOTATION MARK}\N{RIGHT DOUBLE QUOTATION MARK}]? \b }imx; + + my $changes = $group->changes; + if ($changes) { + my $changes_dist= lc $changes->fields->value('Distribution'); + + my %codename; + $codename{'unstable'} = 'sid'; + my @normalized + = uniq map { $codename{$_} // $_ } + ($latest_dist, $changes_dist); + + $self->pointed_hint( + 'changelog-distribution-does-not-match-changes-file', + $latest_pointer,$latest_dist, + $NOT_EQUALS, $changes_dist + )unless @normalized == 1; + } + + } + + # Some checks should only be done against the most recent + # changelog entry. + my $changes = $latest_entry->Changes || $EMPTY; + + if (@entries == 1) { + + if ($latest_entry->Version && $latest_entry->Version =~ /-1$/) { + $self->pointed_hint('initial-upload-closes-no-bugs', + $latest_pointer) + unless @{ $latest_entry->Closes }; + + $self->pointed_hint( + 'new-package-uses-date-based-version-number', + $latest_pointer, + $latest_entry->Version, + '(better: 0~' . $latest_entry->Version .')' + )if $latest_entry->Version =~ m/^\d{8}/; + } + + $self->pointed_hint('changelog-is-dh_make-template', + $latest_pointer) + if $changes + =~ /(?:#?\s*)(?:\d|n)+ is the bug number of your ITP/i; + } + + while ($changes =~ /(closes[\s;]*(?:bug)?\#?\s?\d{6,})[^\w]/ig) { + + my $closes = $1; + + $self->pointed_hint('possible-missing-colon-in-closes', + $latest_pointer, $closes) + if length $closes; + } + + if ($changes =~ m/(TEMP-\d{7}-[0-9a-fA-F]{6})/) { + + my $temporary_cve = $1; + + $self->pointed_hint( + 'changelog-references-temp-security-identifier', + $latest_pointer, $temporary_cve); + } + + # check for bad intended distribution + if ( + $changes =~ m{uploads? \s+ to \s+ + (?'intended'testing|unstable|experimental|sid)}xi + ){ + my $intended = lc($+{intended}); + + $intended = 'unstable' + if $intended eq 'sid'; + + my $uploaded = $latest_entry->Distribution; + + $self->pointed_hint('bad-intended-distribution', $latest_pointer, + "intended for $intended but uploaded to $uploaded") + if $uploaded ne $intended + && $uploaded ne 'UNRELEASED'; + } + + if ($changes =~ m{ (Close: \s+ [#] \d+) }xi) { + + my $statement = $1; + + $self->pointed_hint('misspelled-closes-bug', $latest_pointer, + $statement); + } + + my $changesempty = $changes; + $changesempty =~ s/\W//gms; + + $self->pointed_hint('changelog-empty-entry', $latest_pointer) + if !length $changesempty + && $latest_entry->Distribution ne 'UNRELEASED'; + + # before bug 50004 bts removed bug instead of archiving + for my $bug (@{$latest_entry->Closes}) { + + $self->pointed_hint('improbable-bug-number-in-closes', + $latest_pointer, $bug) + if $bug < $FIRST_ARCHIVED_BUG_NUMBER + || $bug >= $OUT_OF_REACH_BUG_NUMBER; + } + + # Compare against NEWS.Debian if available. + for my $field (qw/Distribution Urgency/) { + + $self->pointed_hint( + 'changelog-news-debian-mismatch', + $news_item->pointer($news->position), + $field, + $latest_entry->$field, + $NOT_EQUALS, + $news->$field + ) + if defined $news + && length $news->Version + && $news->Version eq $latest_entry->Version + && $news->$field ne $latest_entry->$field; + } + + $self->pointed_hint( + 'debian-news-entry-has-unknown-version', + $news_item->pointer($news->position), + $news->Version + ) + if defined $news + && length $news->Version + && !exists $allversions{$news->Version}; + + # 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/, $changes); + + # real start + my $position = $real_start; + for my $line (@lines) { + + my $pointer = $changelog_item->pointer($position); + + if ($line =~ /^ [*]\s(.{1,5})$/) { + + my $excerpt = $1; + + $self->pointed_hint('debian-changelog-line-too-short', + $pointer, $excerpt) + unless $1 =~ /:$/; + } + + $self->pointed_hint('debian-changelog-line-too-long', $pointer) + if length $line >= $MAXIMUM_WIDTH + && $line !~ /^ [\s.o*+-]* (?: [Ss]ee:?\s+ )? \S+ $/msx; + + } continue { + ++$position; + } + + # Strip out all lines that contain the word spelling to avoid false + # positives on changelog entries for spelling fixes. + $changes =~ s/^.*(?:spelling|typo).*\n//gm; + + check_spelling( + $self->data, + $changes, + $group->spelling_exceptions, + $self->spelling_tag_emitter( + 'spelling-error-in-changelog', $changelog_item + ) + ); + } + + return; +} + +# read the changelog itself and check for some issues we cannot find +# with Parse::DebianChangelog. Also return the "real" line number for +# the first line of text in the first entry. +# +sub check_dch { + my ($self) = @_; + + my $unresolved = $self->processable->changelog_item; + + # stop for dangling symbolic link + my $item = $unresolved->resolve_path; + return 0 + unless defined $item; + + # return empty changelog + return 0 + unless $item->is_file && $item->is_open_ok; + + # emacs only looks at the last "local variables" in a file, and only at + # one within 3000 chars of EOF and on the last page (^L), but that's a bit + # pesky to replicate. Demanding a match of $prefix and $suffix ought to + # be enough to avoid false positives. + + my $contents; + if ($item->basename =~ m{ [.]gz $}x) { + + my $bytes = safe_qx('gunzip', '-c', $item->unpacked_path); + + return 0 + unless valid_utf8($bytes); + + $contents = decode_utf8($bytes); + + } else { + + # empty unless valis UTF-8 + $contents = $item->decoded_utf8; + } + + my @lines = split(m{\n}, $contents); + + my $prefix; + my $suffix; + my $real_start = 0; + + my $saw_tab_lead = 0; + + my $position = 1; + for my $line (@lines) { + + ++$real_start + unless $saw_tab_lead; + + $saw_tab_lead = 1 + if $line =~ /^\s+\S/; + + my $pointer = $item->pointer($position); + + if ( + $line + =~ m{ closes: \s* (( (?:bug)? [#]? \s? \d*) [[:alpha:]] \w*) }ix + || $line =~ m{ closes: \s* (?:bug)? [#]? \s? \d+ + (?: , \s* (?:bug)? [#]? \s? \d+ )* + (?: , \s* (( (?:bug)? [#]? \s? \d* ) [[:alpha:]] \w*)) }ix + ) { + + my $bug = $1; + + $self->pointed_hint('wrong-bug-number-in-closes', $pointer, $bug) + if length $2; + } + + if ($line =~ /^(.*)Local\ variables:(.*)$/i) { + $prefix = $1; + $suffix = $2; + } + + # emacs allows whitespace between prefix and variable, hence \s* + $self->pointed_hint( + 'debian-changelog-file-contains-obsolete-user-emacs-settings', + $pointer) + if defined $prefix + && defined $suffix + && $line =~ /^\Q$prefix\E\s*add-log-mailing-address:.*\Q$suffix\E$/; + + } continue { + ++$position; + } + + return $real_start; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Control/Field/Adopted.pm b/lib/Lintian/Check/Debian/Control/Field/Adopted.pm new file mode 100644 index 0000000..d9d9379 --- /dev/null +++ b/lib/Lintian/Check/Debian/Control/Field/Adopted.pm @@ -0,0 +1,98 @@ +# debian/control/field/adopted -- lintian check script -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Control::Field::Adopted; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $control = $self->processable->debian_control; + my $source_fields = $control->source_fields; + + my $KNOWN_SOURCE_FIELDS= $self->data->load('common/source-fields'); + my $KNOWN_BINARY_FIELDS= $self->data->load('fields/binary-fields'); + + for my $field ($source_fields->names) { + + my ($marker, $bare) = split(qr{-}, $field, 2); + + next + unless length $marker + && length $bare; + + my $control_item= $self->processable->debian_control->item; + my $position = $source_fields->position($field); + my $pointer = $control_item->pointer($position); + + # case-insensitive match + $self->pointed_hint( + 'adopted-extended-field',$pointer, + '(in section for source)', $field + ) + if $marker =~ m{^ X }ix + && $KNOWN_SOURCE_FIELDS->resembles($bare); + } + + for my $installable ($control->installables) { + my $installable_fields = $control->installable_fields($installable); + + for my $field ($installable_fields->names) { + + my ($marker, $bare) = split(qr{-}, $field, 2); + + next + unless length $marker + && length $bare; + + my $control_item= $self->processable->debian_control->item; + my $position = $installable_fields->position($field); + my $pointer = $control_item->pointer($position); + + # case-insensitive match + $self->pointed_hint( + 'adopted-extended-field', $pointer, + "(in section for $installable)", $field + ) + if $marker =~ m{^ X }ix + && $KNOWN_BINARY_FIELDS->resembles($bare); + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Control/Field/Architecture/Multiline.pm b/lib/Lintian/Check/Debian/Control/Field/Architecture/Multiline.pm new file mode 100644 index 0000000..dbb5dc2 --- /dev/null +++ b/lib/Lintian/Check/Debian/Control/Field/Architecture/Multiline.pm @@ -0,0 +1,63 @@ +# debian/control/field/architecture/multiline -- lintian check script -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Control::Field::Architecture::Multiline; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $control = $self->processable->debian_control; + + for my $installable ($control->installables) { + + my $installable_fields = $control->installable_fields($installable); + + my $field = 'Architecture'; + + my $control_item= $self->processable->debian_control->item; + my $position = $installable_fields->position($field); + my $pointer = $control_item->pointer($position); + + $self->pointed_hint('multiline-architecture-field', + $pointer, $field,"(in section for $installable)") + if $installable_fields->value($field)=~ /\n./; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Control/Field/BuildProfiles.pm b/lib/Lintian/Check/Debian/Control/Field/BuildProfiles.pm new file mode 100644 index 0000000..50e9663 --- /dev/null +++ b/lib/Lintian/Check/Debian/Control/Field/BuildProfiles.pm @@ -0,0 +1,110 @@ +# debian/control/field/build-profiles -- lintian check script -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Control::Field::BuildProfiles; + +use v5.20; +use warnings; +use utf8; + +use Lintian::Relation; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $control = $self->processable->debian_control; + + my $KNOWN_BUILD_PROFILES= $self->data->load('fields/build-profiles'); + + for my $installable ($control->installables) { + my $installable_fields = $control->installable_fields($installable); + + my $field = 'Build-Profiles'; + + my $raw = $installable_fields->value($field); + next + unless $raw; + + my $control_item= $self->processable->debian_control->item; + my $position = $installable_fields->position($field); + my $pointer = $control_item->pointer($position); + + if ( + $raw!~ m{^\s* # skip leading whitespace + < # first list start + !?[^\s<>]+ # (possibly negated) term + (?: # any additional terms + \s+ # start with a space + !?[^\s<>]+ # (possibly negated) term + )* # zero or more additional terms + > # first list end + (?: # any additional restriction lists + \s+ # start with a space + < # additional list start + !?[^\s<>]+ # (possibly negated) term + (?: # any additional terms + \s+ # start with a space + !?[^\s<>]+ # (possibly negated) term + )* # zero or more additional terms + > # additional list end + )* # zero or more additional lists + \s*$ # trailing spaces at the end + }x + ) { + $self->pointed_hint( + 'invalid-restriction-formula-in-build-profiles-field', + $pointer, $raw,"(in section for $installable)"); + + } else { + # parse the field and check the profile names + $raw =~ s/^\s*<(.*)>\s*$/$1/; + + for my $restrlist (split />\s+</, $raw) { + for my $profile (split /\s+/, $restrlist) { + + $profile =~ s/^!//; + + $self->pointed_hint( + 'invalid-profile-name-in-build-profiles-field', + $pointer, $profile,"(in section for $installable)") + unless $KNOWN_BUILD_PROFILES->recognizes($profile) + || $profile =~ /^pkg\.[a-z0-9][a-z0-9+.-]+\../; + } + } + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Control/Field/BuiltUsing.pm b/lib/Lintian/Check/Debian/Control/Field/BuiltUsing.pm new file mode 100644 index 0000000..560f89b --- /dev/null +++ b/lib/Lintian/Check/Debian/Control/Field/BuiltUsing.pm @@ -0,0 +1,66 @@ +# debian/control/field/built-using -- lintian check script -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Control::Field::BuiltUsing; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $control = $self->processable->debian_control; + + for my $installable ($control->installables) { + my $installable_fields= $control->installable_fields($installable); + + my $field = 'Built-Using'; + + my $control_item= $self->processable->debian_control->item; + my $position = $installable_fields->position($field); + my $pointer = $control_item->pointer($position); + + $self->pointed_hint( + 'built-using-field-on-arch-all-package',$pointer, + "(in section for $installable)", $field, + $installable_fields->value($field) + ) + if $installable_fields->declares($field) + && $installable_fields->value('Architecture') eq 'all'; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Control/Field/Description/Duplicate.pm b/lib/Lintian/Check/Debian/Control/Field/Description/Duplicate.pm new file mode 100644 index 0000000..294893b --- /dev/null +++ b/lib/Lintian/Check/Debian/Control/Field/Description/Duplicate.pm @@ -0,0 +1,114 @@ +# debian/control/field/description/duplicate -- lintian check script -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Control::Field::Description::Duplicate; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; + +sub source { + my ($self) = @_; + + my $control = $self->processable->debian_control; + + my %installables_by_synopsis; + my %installables_by_exended; + + for my $installable ($control->installables) { + + next + if $control->installable_package_type($installable) eq 'udeb'; + + my $installable_fields = $control->installable_fields($installable); + + my $description = $installable_fields->untrimmed_value('Description'); + next + unless length $description; + + my ($synopsis, $extended) = split(/\n/, $description, 2); + + $synopsis //= $EMPTY; + $extended //= $EMPTY; + + # trim both ends + $synopsis =~ s/^\s+|\s+$//g; + $extended =~ s/^\s+|\s+$//g; + + if (length $synopsis) { + $installables_by_synopsis{$synopsis} //= []; + push(@{$installables_by_synopsis{$synopsis}}, $installable); + } + + if (length $extended) { + $installables_by_exended{$extended} //= []; + push(@{$installables_by_exended{$extended}}, $installable); + } + } + + # check for duplicate short description + for my $synopsis (keys %installables_by_synopsis) { + + # Assume that substvars are correctly handled + next + if $synopsis =~ m/\$\{.+\}/; + + $self->pointed_hint( + 'duplicate-short-description', + $control->item->pointer, + (sort @{$installables_by_synopsis{$synopsis}}) + )if scalar @{$installables_by_synopsis{$synopsis}} > 1; + } + + # check for duplicate long description + for my $extended (keys %installables_by_exended) { + + # Assume that substvars are correctly handled + next + if $extended =~ m/\$\{.+\}/; + + $self->pointed_hint( + 'duplicate-long-description', + $control->item->pointer, + (sort @{$installables_by_exended{$extended}}) + )if scalar @{$installables_by_exended{$extended}} > 1; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Control/Field/DoubledUp.pm b/lib/Lintian/Check/Debian/Control/Field/DoubledUp.pm new file mode 100644 index 0000000..1e1e69a --- /dev/null +++ b/lib/Lintian/Check/Debian/Control/Field/DoubledUp.pm @@ -0,0 +1,83 @@ +# debian/control/field/doubled-up -- lintian check script -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Control::Field::DoubledUp; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $control = $self->processable->debian_control; + my $source_fields = $control->source_fields; + + # something like "Maintainer: Maintainer: bad field" + my @doubled_up_source_fields + = grep { $source_fields->value($_) =~ m{^ \Q$_\E \s* : }ix } + $source_fields->names; + + for my $field (@doubled_up_source_fields) { + + my $control_item= $self->processable->debian_control->item; + my $position = $source_fields->position($field); + my $pointer = $control_item->pointer($position); + + $self->pointed_hint('debian-control-repeats-field-name-in-value', + $pointer, '(in section for source)', $field); + } + + for my $installable ($control->installables) { + my $installable_fields = $control->installable_fields($installable); + + # something like "Maintainer: Maintainer: bad field" + my @doubled_up_installable_fields + = grep { $installable_fields->value($_) =~ m{^ \Q$_\E \s* : }ix } + $installable_fields->names; + + for my $field (@doubled_up_installable_fields) { + + my $control_item= $self->processable->debian_control->item; + my $position = $installable_fields->position($field); + my $pointer = $control_item->pointer($position); + + $self->pointed_hint('debian-control-repeats-field-name-in-value', + $pointer,"(in section for $installable)", $field); + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Control/Field/Empty.pm b/lib/Lintian/Check/Debian/Control/Field/Empty.pm new file mode 100644 index 0000000..15b48ca --- /dev/null +++ b/lib/Lintian/Check/Debian/Control/Field/Empty.pm @@ -0,0 +1,84 @@ +# debian/control/field/empty -- lintian check script -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Control::Field::Empty; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $control = $self->processable->debian_control; + my $source_fields = $control->source_fields; + + my @empty_source_fields + = grep { !length $source_fields->value($_) } $source_fields->names; + + for my $field (@empty_source_fields) { + + my $control_item= $self->processable->debian_control->item; + my $position = $source_fields->position($field); + my $pointer = $control_item->pointer($position); + + $self->pointed_hint( + 'debian-control-has-empty-field', $pointer, + '(in source paragraph)', $field + ); + } + + for my $installable ($control->installables) { + my $installable_fields = $control->installable_fields($installable); + + my @empty_installable_fields + = grep { !length $installable_fields->value($_) } + $installable_fields->names; + + for my $field (@empty_installable_fields) { + + my $control_item= $self->processable->debian_control->item; + my $position = $installable_fields->position($field); + my $pointer = $control_item->pointer($position); + + $self->pointed_hint( + 'debian-control-has-empty-field',$pointer, + "(in section for $installable)", $field + ); + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Control/Field/Misplaced.pm b/lib/Lintian/Check/Debian/Control/Field/Misplaced.pm new file mode 100644 index 0000000..743be38 --- /dev/null +++ b/lib/Lintian/Check/Debian/Control/Field/Misplaced.pm @@ -0,0 +1,67 @@ +# debian/control/field/misplaced -- lintian check script -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Control::Field::Misplaced; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $control = $self->processable->debian_control; + my $source_fields = $control->source_fields; + + my @build_fields + =qw{Build-Depends Build-Depends-Indep Build-Conflicts Build-Conflicts-Indep}; + + for my $installable ($control->installables) { + my $installable_fields = $control->installable_fields($installable); + + for my $field (@build_fields) { + + my $control_item= $self->processable->debian_control->item; + my $position = $installable_fields->position($field); + my $pointer = $control_item->pointer($position); + + $self->pointed_hint('build-prerequisite-in-installable-section', + $pointer, $field,"(in section for $installable)") + if $installable_fields->declares($field); + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Control/Field/Redundant.pm b/lib/Lintian/Check/Debian/Control/Field/Redundant.pm new file mode 100644 index 0000000..9f78dd4 --- /dev/null +++ b/lib/Lintian/Check/Debian/Control/Field/Redundant.pm @@ -0,0 +1,68 @@ +# debian/control/field/redundant -- lintian check script -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Control::Field::Redundant; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $control = $self->processable->debian_control; + my $source_fields = $control->source_fields; + + for my $installable ($control->installables) { + my $installable_fields = $control->installable_fields($installable); + + for my $field ($installable_fields->names) { + + my $control_item= $self->processable->debian_control->item; + my $position = $installable_fields->position($field); + my $pointer = $control_item->pointer($position); + + $self->pointed_hint( + 'installable-field-mirrors-source',$pointer, + "(in section for $installable)", $field + ) + if $source_fields->declares($field) + && $installable_fields->value($field) eq + $source_fields->value($field); + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Control/Field/Relation.pm b/lib/Lintian/Check/Debian/Control/Field/Relation.pm new file mode 100644 index 0000000..3047971 --- /dev/null +++ b/lib/Lintian/Check/Debian/Control/Field/Relation.pm @@ -0,0 +1,180 @@ +# debian/control/field/relation -- lintian check script -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Control::Field::Relation; + +use v5.20; +use warnings; +use utf8; + +use Lintian::Relation; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $control = $self->processable->debian_control; + my $source_fields = $control->source_fields; + + # Check that fields which should be comma-separated or + # pipe-separated have separators. Places where this tends to + # cause problems are with wrapped lines such as: + # + # Depends: foo, bar + # baz + # + # or with substvars. If two substvars aren't separated by a + # comma, but at least one of them expands to an empty string, + # there will be a lurking bug. The result will be syntactically + # correct, but as soon as both expand into something non-empty, + # there will be a syntax error. + # + # The architecture list can contain things that look like packages + # separated by spaces, so we have to remove any architecture + # restrictions first. This unfortunately distorts our report a + # little, but hopefully not too much. + # + # Also check for < and > relations. dpkg-gencontrol warns about + # them and then transforms them in the output to <= and >=, but + # it's easy to miss the error message. Similarly, check for + # duplicates, which dpkg-source eliminates. + + for my $field ( + qw(Build-Depends Build-Depends-Indep + Build-Conflicts Build-Conflicts-Indep) + ) { + next + unless $source_fields->declares($field); + + my $control_item= $self->processable->debian_control->item; + my $position = $source_fields->position($field); + my $pointer = $control_item->pointer($position); + + my @values = $source_fields->trimmed_list($field, qr{ \s* , \s* }x); + my @obsolete = grep { m{ [(] [<>] \s* [^<>=]+ [)] }x } @values; + + $self->pointed_hint( + 'obsolete-relation-form-in-source', + $pointer, '(in source paragraph)', + $field, $_ + )for @obsolete; + + my $raw = $source_fields->value($field); + my $relation = Lintian::Relation->new->load($raw); + + for my $redundant_set ($relation->redundancies) { + + $self->pointed_hint('redundant-control-relation', $pointer, + '(in source paragraph)', + $field,join(', ', sort @{$redundant_set})); + } + + $self->check_separators($raw, $pointer, '(in source paragraph)'); + } + + for my $installable ($control->installables) { + my $installable_fields = $control->installable_fields($installable); + + for my $field ( + qw(Pre-Depends Depends Recommends Suggests Breaks + Conflicts Provides Replaces Enhances) + ) { + next + unless $installable_fields->declares($field); + + my $control_item= $self->processable->debian_control->item; + my $position = $installable_fields->position($field); + my $pointer = $control_item->pointer($position); + + my @values + = $installable_fields->trimmed_list($field, qr{ \s* , \s* }x); + my @obsolete = grep { m{ [(] [<>] \s* [^<>=]+ [)] }x } @values; + + $self->pointed_hint( + 'obsolete-relation-form-in-source', + $pointer, "(in section for $installable)", + $field, $_ + )for @obsolete; + + my $relation + = $self->processable->binary_relation($installable, $field); + + for my $redundant_set ($relation->redundancies) { + + $self->pointed_hint( + 'redundant-control-relation', $pointer, + "(in section for $installable)", $field, + join(', ', sort @{$redundant_set}) + ); + } + + my $raw = $installable_fields->value($field); + $self->check_separators($raw, $pointer, + "(in section for $installable)"); + } + } + + return; +} + +sub check_separators { + my ($self, $string, $pointer, $explainer) = @_; + + $string =~ s/\n(\s)/$1/g; + $string =~ s/\[[^\]]*\]//g; + + if ( + $string =~ m{(?:^|\s) + ( + (?:\w[^\s,|\$\(]+|\$\{\S+:Depends\})\s* + (?:\([^\)]*\)\s*)? + ) + \s+ + ( + (?:\w[^\s,|\$\(]+|\$\{\S+:Depends\})\s* + (?:\([^\)]*\)\s*)? + )}x + ) { + my ($prev, $next) = ($1, $2); + + # trim right + $prev =~ s/\s+$//; + $next =~ s/\s+$//; + + $self->pointed_hint('missing-separator-between-items', + $pointer,$explainer, "'$prev' and '$next'"); + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Control/Field/RulesRequiresRoot.pm b/lib/Lintian/Check/Debian/Control/Field/RulesRequiresRoot.pm new file mode 100644 index 0000000..b97a673 --- /dev/null +++ b/lib/Lintian/Check/Debian/Control/Field/RulesRequiresRoot.pm @@ -0,0 +1,99 @@ +# debian/control/field/rules-requires-root -- lintian check script -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Control::Field::RulesRequiresRoot; + +use v5.20; +use warnings; +use utf8; + +use List::SomeUtils qw(first_value); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $control = $self->processable->debian_control; + my $source_fields = $control->source_fields; + + my @r3_misspelled = grep { $_ ne 'Rules-Requires-Root' } + grep { m{^ Rules? - Requires? - Roots? $}xi } $source_fields->names; + + for my $field (@r3_misspelled) { + + my $control_item= $self->processable->debian_control->item; + my $position = $source_fields->position($field); + my $pointer = $control_item->pointer($position); + + $self->pointed_hint('spelling-error-in-rules-requires-root', + $pointer, $field); + } + + my $control_item= $self->processable->debian_control->item; + my $position = $source_fields->position('Rules-Requires-Root'); + my $pointer = $control_item->pointer($position); + + $self->pointed_hint('rules-do-not-require-root', $pointer) + if $source_fields->value('Rules-Requires-Root') eq 'no'; + + $self->pointed_hint('rules-require-root-explicitly', $pointer) + if $source_fields->declares('Rules-Requires-Root') + && $source_fields->value('Rules-Requires-Root') ne 'no'; + + $self->pointed_hint('silent-on-rules-requiring-root', $pointer) + unless $source_fields->declares('Rules-Requires-Root'); + + if ( !$source_fields->declares('Rules-Requires-Root') + || $source_fields->value('Rules-Requires-Root') eq 'no') { + + for my $installable ($self->group->get_installables) { + + my $user_owned_item + = first_value { $_->owner ne 'root' || $_->group ne 'root' } + @{$installable->installed->sorted_list}; + + next + unless defined $user_owned_item; + + my $owner = $user_owned_item->owner; + my $group = $user_owned_item->group; + + $self->pointed_hint('rules-silently-require-root', + $pointer, $installable->name, + "($owner:$group)", $user_owned_item->name); + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Control/Field/Section.pm b/lib/Lintian/Check/Debian/Control/Field/Section.pm new file mode 100644 index 0000000..dd0ba52 --- /dev/null +++ b/lib/Lintian/Check/Debian/Control/Field/Section.pm @@ -0,0 +1,52 @@ +# debian/control/field/section -- lintian check script -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Control::Field::Section; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $control = $self->processable->debian_control; + my $source_fields = $control->source_fields; + + $self->pointed_hint('no-source-section', $control->item->pointer) + unless $source_fields->declares('Section'); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Control/Field/Spacing.pm b/lib/Lintian/Check/Debian/Control/Field/Spacing.pm new file mode 100644 index 0000000..070ebdf --- /dev/null +++ b/lib/Lintian/Check/Debian/Control/Field/Spacing.pm @@ -0,0 +1,78 @@ +# debian/control/field/spacing -- lintian check script -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Control::Field::Spacing; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $item = $self->processable->debian_control->item; + return + unless defined $item; + + my @lines = split(/\n/, $item->decoded_utf8); + + my $position = 1; + while (defined(my $line = shift @lines)) { + + # strip leading spaces + $line =~ s{\s*$}{}; + + next + if $line =~ m{^ [#]}x; + + # line with field: + if ($line =~ m{^ (\S+) : }x) { + + my $field = $1; + + my $pointer = $item->pointer($position); + + $self->pointed_hint('debian-control-has-unusual-field-spacing', + $pointer, $field) + unless $line =~ m{^ \S+ : [ ] \S }x + || $line =~ m{^ \S+ : $}x; + } + + } continue { + ++$position; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Control/Link.pm b/lib/Lintian/Check/Debian/Control/Link.pm new file mode 100644 index 0000000..5f3f751 --- /dev/null +++ b/lib/Lintian/Check/Debian/Control/Link.pm @@ -0,0 +1,57 @@ +# debian/control/link -- lintian check script -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Control::Link; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $debian_dir = $self->processable->patched->resolve_path('debian/'); + return + unless $debian_dir; + + my $item = $debian_dir->child('control'); + return + unless $item; + + $self->pointed_hint('debian-control-file-is-a-symlink', $item->pointer) + if $item->is_symlink; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Control/Prerequisite/Circular.pm b/lib/Lintian/Check/Debian/Control/Prerequisite/Circular.pm new file mode 100644 index 0000000..7cd78e5 --- /dev/null +++ b/lib/Lintian/Check/Debian/Control/Prerequisite/Circular.pm @@ -0,0 +1,74 @@ +# debian/control/prerequisite/circular -- lintian check script -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Control::Prerequisite::Circular; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $control = $self->processable->debian_control; + + my @prerequisite_fields = qw(Pre-Depends Depends Recommends Suggests); + + for my $installable ($control->installables) { + my $installable_fields = $control->installable_fields($installable); + + for my $field (@prerequisite_fields) { + + next + unless $control->installable_fields($installable) + ->declares($field); + + my $relation + = $self->processable->binary_relation($installable, $field); + + my $control_item= $self->processable->debian_control->item; + my $position = $installable_fields->position($field); + my $pointer = $control_item->pointer($position); + + $self->pointed_hint( + 'circular-installation-prerequisite', + $pointer, "(in section for $installable)", + $field,$relation->to_string + )if $relation->satisfies($installable); + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Control/Prerequisite/Development.pm b/lib/Lintian/Check/Debian/Control/Prerequisite/Development.pm new file mode 100644 index 0000000..948076f --- /dev/null +++ b/lib/Lintian/Check/Debian/Control/Prerequisite/Development.pm @@ -0,0 +1,145 @@ +# debian/control/prerequisite/development -- lintian check script -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Control::Prerequisite::Development; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(any); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; + +sub source { + my ($self) = @_; + + my $control = $self->processable->debian_control; + + for my $installable ($control->installables) { + my $installable_fields = $control->installable_fields($installable); + + next + unless $installable =~ /-dev$/; + + my $field = 'Depends'; + + next + unless $installable_fields->declares($field); + + my $control_item= $self->processable->debian_control->item; + my $position = $installable_fields->position($field); + my $pointer = $control_item->pointer($position); + + my @depends + = $installable_fields->trimmed_list($field, qr{ \s* , \s* }x); + + for my $other_name ($control->installables) { + + next + if $other_name =~ /-(?:dev|docs?|common)$/; + + next + unless $other_name =~ /^lib[\w.+-]+\d/; + + my @relevant + = grep { m{ (?: ^ | [\s|] ) \Q$other_name\E (?: [\s|(] | \z ) }x } + @depends; + + # If there are any alternatives here, something special is + # going on. Assume that the maintainer knows what they're + # doing. Otherwise, separate out just the versions. + next + if any { m{ [|] }x } @relevant; + + my @unsorted; + for my $package (@relevant) { + + $package =~ m{^ [\w.+-]+ \s* [(] ([^)]+) [)] }x; + push(@unsorted, ($1 // $EMPTY)); + } + + my @versions = sort @unsorted; + + my $context; + + # If there's only one mention of this package, the dependency + # should be tight. Otherwise, there should be both >>/>= and + # <</<= dependencies that mention the source, binary, or + # upstream version. If there are more than three mentions of + # the package, again something is weird going on, so we assume + # they know what they're doing. + if (@relevant == 1) { + unless ($versions[0] + =~ /^\s*=\s*\$\{(?:binary:Version|Source-Version)\}/) { + # Allow "pkg (= ${source:Version})" if (but only if) + # the target is an arch:all package. This happens + # with a lot of mono-packages. + # + # Note, we do not check if the -dev package is + # arch:all as well. The version-substvars check + # handles that for us. + next + if $control->installable_fields($other_name) + ->value('Architecture') eq 'all' + && $versions[0] + =~ m{^ \s* = \s* \$[{]source:Version[}] }x; + + $context = $relevant[0]; + } + + } elsif (@relevant == 2) { + unless ( + $versions[0] =~ m{^ \s* <[=<] \s* \$[{] + (?: (?:binary|source):(?:Upstream-)?Version + | Source-Version) [}] }xsm + && $versions[1] =~ m{^ \s* >[=>] \s* \$[{] + (?: (?:binary|source):(?:Upstream-)?Version + | Source-Version) [}] }xsm + ) { + $context = "$relevant[0], $relevant[1]"; + } + } + + $self->pointed_hint('weak-library-dev-dependency', + $pointer, "(in section for $installable)", + $field, $context) + if length $context; + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Control/Prerequisite/Redundant.pm b/lib/Lintian/Check/Debian/Control/Prerequisite/Redundant.pm new file mode 100644 index 0000000..08ea510 --- /dev/null +++ b/lib/Lintian/Check/Debian/Control/Prerequisite/Redundant.pm @@ -0,0 +1,99 @@ +# debian/control/prerequisitie/redundant -- lintian check script -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Control::Prerequisite::Redundant; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $ARROW => q{->}; + +sub source { + my ($self) = @_; + + my $control = $self->processable->debian_control; + + # Make sure that a stronger dependency field doesn't satisfy any of + # the elements of a weaker dependency field. dpkg-gencontrol will + # fix this up for us, but we want to check the source package + # since dpkg-gencontrol may silently "fix" something that's a more + # subtle bug. + + # ordered from stronger to weaker + my @ordered_fields = qw(Pre-Depends Depends Recommends Suggests); + + for my $installable ($control->installables) { + my $installable_fields = $control->installable_fields($installable); + + my @remaining_fields = @ordered_fields; + + for my $stronger (@ordered_fields) { + + shift @remaining_fields; + + next + unless $control->installable_fields($installable) + ->declares($stronger); + + my $control_item= $self->processable->debian_control->item; + my $position = $installable_fields->position($stronger); + my $pointer = $control_item->pointer($position); + + my $relation + = $self->processable->binary_relation($installable,$stronger); + + for my $weaker (@remaining_fields) { + + my @prerequisites = $control->installable_fields($installable) + ->trimmed_list($weaker, qr{\s*,\s*}); + + for my $prerequisite (@prerequisites) { + + $self->pointed_hint( + 'redundant-installation-prerequisite',$pointer, + "(in section for $installable)",$weaker, + $ARROW, $stronger, + $prerequisite + )if $relation->satisfies($prerequisite); + } + } + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Copyright.pm b/lib/Lintian/Check/Debian/Copyright.pm new file mode 100644 index 0000000..6eb8900 --- /dev/null +++ b/lib/Lintian/Check/Debian/Copyright.pm @@ -0,0 +1,586 @@ +# copyright -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz +# Copyright (C) 1998 Richard Braakman +# Copyright (C) 2011 Jakub Wilk +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Copyright; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(any all none uniq); +use Path::Tiny; +use Syntax::Keyword::Try; +use Unicode::UTF8 qw(valid_utf8 decode_utf8 encode_utf8); + +use Lintian::Deb822; +use Lintian::IPC::Run3 qw(safe_qx); +use Lintian::Spelling qw(check_spelling); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; + +const my $APPROXIMATE_GPL_LENGTH => 12_000; +const my $APPROXIMATE_GFDL_LENGTH => 12_000; +const my $APPROXIMATE_APACHE_2_LENGTH => 10_000; + +sub spelling_tag_emitter { + my ($self, @orig_args) = @_; + + return sub { + return $self->hint(@orig_args, @_); + }; +} + +sub source { + my ($self) = @_; + + my $debian_dir = $self->processable->patched->resolve_path('debian/'); + return + unless defined $debian_dir; + + my @installables = $self->processable->debian_control->installables; + my @additional = map { $_ . '.copyright' } @installables; + + my @candidates = ('copyright', @additional); + my @files = grep { defined } map { $debian_dir->child($_) } @candidates; + + # look for <pkgname>.copyright for a single installable + if (@files == 1) { + my $single = $files[0]; + + $self->pointed_hint('named-copyright-for-single-installable', + $single->pointer) + unless $single->name eq 'debian/copyright'; + } + + $self->hint('no-debian-copyright-in-source') + unless @files; + + my @symlinks = grep { $_->is_symlink } @files; + $self->pointed_hint('debian-copyright-is-symlink', $_->pointer) + for @symlinks; + + return; +} + +# no copyright in udebs +sub binary { + my ($self) = @_; + + my $package = $self->processable->name; + + # looking up entry without slash first; index should not be so picky + my $doclink + = $self->processable->installed->lookup("usr/share/doc/$package"); + if ($doclink && $doclink->is_symlink) { + + # check if this symlink references a directory elsewhere + if ($doclink->link =~ m{^(?:\.\.)?/}s) { + $self->pointed_hint( + 'usr-share-doc-symlink-points-outside-of-usr-share-doc', + $doclink->pointer, $doclink->link); + return; + } + + # The symlink may point to a subdirectory of another + # /usr/share/doc directory. This is allowed if this + # package depends on link and both packages come from the + # same source package. + # + # Policy requires that packages be built from the same + # source if they're going to do this, which by my (rra's) + # reading means that we should have a strict version + # dependency. However, in practice the copyright file + # doesn't change a lot and strict version dependencies + # cause other problems (such as with arch: any / arch: all + # package combinations and binNMUs). + # + # We therefore just require the dependency for now and + # don't worry about the version number. + my $link = $doclink->link; + $link =~ s{/.*}{}; + + unless ($self->depends_on($self->processable, $link)) { + $self->hint('usr-share-doc-symlink-without-dependency', $link); + + return; + } + + # Check if the link points to a package from the same source. + $self->check_cross_link($link); + + return; + } + + # now with a slash; indicates directory + my $docdir + = $self->processable->installed->lookup("usr/share/doc/$package/"); + unless ($docdir) { + $self->hint('no-copyright-file'); + return; + } + + my $found = 0; + my $zipped = $docdir->child('copyright.gz'); + if (defined $zipped) { + + $self->pointed_hint('copyright-file-compressed', $zipped->pointer); + $found = 1; + } + + my $linked = 0; + + my $item = $docdir->child('copyright'); + if (defined $item) { + $found = 1; + + if ($item->is_symlink) { + + $self->pointed_hint('copyright-file-is-symlink', $item->pointer); + $linked = 1; + # fall through; coll/copyright-file prevents reading through evil link + } + } + + unless ($found) { + + # #522827: special exception for perl for now + $self->hint('no-copyright-file') + unless $package eq 'perl'; + + return; + } + + my $copyrigh_path; + + my $uncompressed + = $self->processable->installed->resolve_path( + "usr/share/doc/$package/copyright"); + $copyrigh_path = $uncompressed->unpacked_path + if defined $uncompressed; + + my $compressed + = $self->processable->installed->resolve_path( + "usr/share/doc/$package/copyright.gz"); + if (defined $compressed) { + + my $bytes = safe_qx('gunzip', '-c', $compressed->unpacked_path); + my $contents = decode_utf8($bytes); + + my $extracted + = path($self->processable->basedir)->child('copyright')->stringify; + path($extracted)->spew($contents); + + $copyrigh_path = $extracted; + } + + return + unless length $copyrigh_path; + + my $bytes = path($copyrigh_path)->slurp; + + # another check complains about invalid encoding + return + unless valid_utf8($bytes); + + # check contents of copyright file + my $contents = decode_utf8($bytes); + + $self->hint('copyright-has-crs') + if $contents =~ /\r/; + + my $wrong_directory_detected = 0; + + my $KNOWN_COMMON_LICENSES + = $self->data->load('copyright-file/common-licenses'); + + if ($contents =~ m{ (usr/share/common-licenses/ ( [^ \t]*? ) \.gz) }xsm) { + my ($path, $license) = ($1, $2); + if ($KNOWN_COMMON_LICENSES->recognizes($license)) { + $self->hint('copyright-refers-to-compressed-license', $path); + } + } + + # Avoid complaining about referring to a versionless license file + # if the word "version" appears nowhere in the copyright file. + # This won't catch all of our false positives for GPL references + # that don't include a specific version number, but it will get + # the obvious ones. + if ($contents =~ m{(usr/share/common-licenses/(L?GPL|GFDL))([^-])}i) { + my ($ref, $license, $separator) = ($1, $2, $3); + if ($separator =~ /[\d\w]/) { + $self->hint('copyright-refers-to-nonexistent-license-file', + "$ref$separator"); + } elsif ($contents =~ /\b(?:any|or)\s+later(?:\s+version)?\b/i + || $contents =~ /License: $license-[\d\.]+\+/i + || $contents =~ /as Perl itself/i + || $contents =~ /License-Alias:\s+Perl/ + || $contents =~ /License:\s+Perl/) { + $self->hint('copyright-refers-to-symlink-license', $ref); + } else { + $self->hint('copyright-refers-to-versionless-license-file', $ref) + if $contents =~ /\bversion\b/; + } + } + + # References to /usr/share/common-licenses/BSD are deprecated as of Policy + # 3.8.5. + if ($contents =~ m{/usr/share/common-licenses/BSD}) { + $self->hint('copyright-refers-to-deprecated-bsd-license-file'); + } + + if ($contents =~ m{(usr/share/common-licences)}) { + $self->hint('copyright-refers-to-incorrect-directory', $1); + $wrong_directory_detected = 1; + } + + if ($contents =~ m{usr/share/doc/copyright}) { + $self->hint('copyright-refers-to-old-directory'); + $wrong_directory_detected = 1; + } + + if ($contents =~ m{usr/doc/copyright}) { + $self->hint('copyright-refers-to-old-directory'); + $wrong_directory_detected = 1; + } + + # Lame check for old FSF zip code. Try to avoid false positives from other + # Cambridge, MA addresses. + if ($contents =~ m/(?:Free\s*Software\s*Foundation.*02139|02111-1307)/s) { + $self->hint('old-fsf-address-in-copyright-file'); + } + + # Whether the package is covered by the GPL, used later for the + # libssl check. + my $gpl; + + if ( + length $contents > $APPROXIMATE_GPL_LENGTH + && ( + $contents =~ m{ \b \QGNU GENERAL PUBLIC LICENSE\E \s* + \QTERMS AND CONDITIONS FOR COPYING,\E \s* + \QDISTRIBUTION AND MODIFICATION\E \b }msx + || ( + $contents =~ m{ \b \QGNU GENERAL PUBLIC LICENSE\E + \s* \QVersion 3\E }msx + && $contents =~ m{ \b \QTERMS AND CONDITIONS\E \s }msx + ) + ) + ) { + $self->hint('copyright-file-contains-full-gpl-license'); + $gpl = 1; + } + + if ( + length $contents > $APPROXIMATE_GFDL_LENGTH + && $contents =~ m{ \b \QGNU Free Documentation License\E + \s* \QVersion 1.2\E }msx + && $contents =~ m{ \b \Q1. APPLICABILITY AND DEFINITIONS\E }msx + ) { + + $self->hint('copyright-file-contains-full-gfdl-license'); + } + + if ( length $contents > $APPROXIMATE_APACHE_2_LENGTH + && $contents =~ m{ \b \QApache License\E \s+ \QVersion 2.0,\E }msx + && $contents + =~ m{ \QTERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION\E }msx + ) { + + $self->hint('copyright-file-contains-full-apache-2-license'); + } + + # wtf? + if ( ($contents =~ m{common-licenses(/\S+)}) + && ($contents !~ m{/usr/share/common-licenses/})) { + $self->hint('copyright-does-not-refer-to-common-license-file', $1); + } + + # This check is a bit prone to false positives, since some other + # licenses mention the GPL. Also exclude any mention of the GPL + # following what looks like mail header fields, since sometimes + # e-mail discussions of licensing are included in the copyright + # file but aren't referring to the license of the package. + unless ( + $contents =~ m{/usr/share/common-licenses} + || $contents =~ m/Zope Public License/ + || $contents =~ m/LICENSE AGREEMENT FOR PYTHON 1.6.1/ + || $contents =~ m/LaTeX Project Public License/ + || $contents + =~ m/(?:^From:.*^To:|^To:.*^From:).*(?:GNU General Public License|GPL)/ms + || $contents =~ m/AFFERO GENERAL PUBLIC LICENSE/ + || $contents =~ m/GNU Free Documentation License[,\s]*Version 1\.1/ + || $contents =~ m/CeCILL FREE SOFTWARE LICENSE AGREEMENT/ #v2.0 + || $contents =~ m/FREE SOFTWARE LICENSING AGREEMENT CeCILL/ #v1.1 + || $contents =~ m/CNRI OPEN SOURCE GPL-COMPATIBLE LICENSE AGREEMENT/ + || $contents =~ m/compatible\s+with\s+(?:the\s+)?(?:GNU\s+)?GPL/ + || $contents =~ m/(?:GNU\s+)?GPL\W+compatible/ + || $contents + =~ m/was\s+previously\s+(?:distributed\s+)?under\s+the\s+GNU/ + || $contents + =~ m/means\s+either\s+the\s+GNU\s+General\s+Public\s+License/ + || $wrong_directory_detected + ) { + if ( + check_names_texts( + $contents, + qr/\b(?:GFDL|gnu[-_]free[-_]documentation[-_]license)\b/i, + qr/GNU Free Documentation License|(?-i:\bGFDL\b)/i + ) + ) { + $self->hint('copyright-not-using-common-license-for-gfdl'); + }elsif ( + check_names_texts( + $contents, +qr/\b(?:LGPL|gnu[-_](?:lesser|library)[-_]general[-_]public[-_]license)\b/i, +qr/GNU (?:Lesser|Library) General Public License|(?-i:\bLGPL\b)/i + ) + ) { + $self->hint('copyright-not-using-common-license-for-lgpl'); + }elsif ( + check_names_texts( + $contents, + qr/\b(?:GPL|gnu[-_]general[-_]public[-_]license)\b/i, + qr/GNU General Public License|(?-i:\bGPL\b)/i + ) + ) { + $self->hint('copyright-not-using-common-license-for-gpl'); + $gpl = 1; + }elsif ( + check_names_texts( + $contents,qr/\bapache[-_]2/i, + qr/\bApache License\s*,?\s*Version 2|\b(?-i:Apache)-2/i + ) + ) { + $self->hint('copyright-not-using-common-license-for-apache2'); + } + } + + if ( + check_names_texts( + $contents, + qr/\b(?:perl|artistic)\b/, + sub { + my ($text) = @_; + $text + =~ /(?:under )?(?:the )?(?:same )?(?:terms )?as Perl itself\b/i + && $text !~ m{usr/share/common-licenses/}; + } + ) + ) { + $self->hint('copyright-file-lacks-pointer-to-perl-license'); + } + + # Checks for various packaging helper boilerplate. + + $self->hint('helper-templates-in-copyright') + if $contents =~ m{<fill in (?:http/)?ftp site>} + || $contents =~ /<Must follow here>/ + || $contents =~ /<Put the license of the package here/ + || $contents =~ /<put author[\'\(]s\)? name and email here>/ + || $contents =~ /<Copyright \(C\) YYYY Name OfAuthor>/ + || $contents =~ /Upstream Author\(s\)/ + || $contents =~ /<years>/ + || $contents =~ /<special license>/ + || $contents + =~ /<Put the license of the package here indented by 1 space>/ + || $contents + =~ /<This follows the format of Description: lines\s*in control file>/ + || $contents =~ /<Including paragraphs>/ + || $contents =~ /<likewise for another author>/; + + # dh-make-perl + $self->hint('copyright-contains-automatically-extracted-boilerplate') + if $contents =~ /This copyright info was automatically extracted/; + + $self->hint('helper-templates-in-copyright') + if $contents =~ /<INSERT COPYRIGHT YEAR\(S\) HERE>/; + + $self->hint('copyright-has-url-from-dh_make-boilerplate') + if $contents =~ m{url://}; + + # dh-make boilerplate + my @dh_make_boilerplate = ( +"# Please also look if there are files or directories which have a\n# different copyright/license attached and list them here.", +"# If you want to use GPL v2 or later for the /debian/* files use\n# the following clauses, or change it to suit. Delete these two lines" + ); + + $self->hint('copyright-contains-dh_make-todo-boilerplate') + if any { $contents =~ /$_/ } @dh_make_boilerplate; + + $self->hint('copyright-with-old-dh-make-debian-copyright') + if $contents =~ /The\s+Debian\s+packaging\s+is\s+\(C\)\s+\d+/i; + + # Other flaws in the copyright phrasing or contents. + if ($found && !$linked) { + $self->hint('copyright-without-copyright-notice') + unless $contents + =~ m{(?:Copyright|Copr\.|\N{COPYRIGHT SIGN})(?:.*|[\(C\):\s]+)\b\d{4}\b + |\bpublic(?:\s+|-)domain\b}xi; + } + + check_spelling( + $self->data,$contents, + $self->group->spelling_exceptions, + $self->spelling_tag_emitter('spelling-error-in-copyright'), 0 + ); + + # Now, check for linking against libssl if the package is covered + # by the GPL. (This check was requested by ftp-master.) First, + # see if the package is under the GPL alone and try to exclude + # packages with a mix of GPL and LGPL or Artistic licensing or + # with an exception or exemption. + if (($gpl || $contents =~ m{/usr/share/common-licenses/GPL}) + &&$contents + !~ m{exception|exemption|/usr/share/common-licenses/(?!GPL)\S}){ + + my @depends + = split(/\s*,\s*/,$self->processable->fields->value('Depends')); + my @predepends + = split(/\s*,\s*/,$self->processable->fields->value('Pre-Depends')); + + $self->hint('possible-gpl-code-linked-with-openssl') + if any { /^libssl[0-9.]+(?:\s|\z)/ && !/\|/ }(@depends, @predepends); + } + + return; +} # </run> + +# ----------------------------------- + +# Returns true if the package whose information is in $processable depends $package +# or if $package is essential. +sub depends_on { + my ($self, $processable, $package) = @_; + + my $KNOWN_ESSENTIAL = $self->data->load('fields/essential'); + + return 1 + if $KNOWN_ESSENTIAL->recognizes($package); + + my $strong = $processable->relation('strong'); + return 1 + if $strong->satisfies($package); + + my $arch = $processable->architecture; + return 1 + if $arch ne 'all' and $strong->satisfies("${package}:${arch}"); + + return 0; +} + +# Checks cross pkg links for /usr/share/doc/$pkg links +sub check_cross_link { + my ($self, $foreign) = @_; + + my $source = $self->group->source; + if ($source) { + + # source package is available; check its list of binaries + return + if any { $foreign eq $_ } $source->debian_control->installables; + + $self->hint('usr-share-doc-symlink-to-foreign-package', $foreign); + + } else { + # The source package is not available, but the binary could + # be present anyway; If they are in the same group, they claim + # to have the same source (and source version) + return + if any { $_->name eq $foreign }$self->group->get_installables; + + # It was not, but since the source package was not present, we cannot + # tell if it is foreign or not at this point. + + $self->hint( +'cannot-check-whether-usr-share-doc-symlink-points-to-foreign-package' + ); + } + + return; +} + +# Checks the name and text of every license in the file against given name and +# text check coderefs, if the file is in the new format, if the file is in the +# old format only runs the text coderef against the whole file. +sub check_names_texts { + my ($contents, $name_check, $action) = @_; + + my $text_check; + + if ((ref($action) || $EMPTY) eq 'Regexp') { + $text_check = sub { + my ($textref) = @_; + return ${$textref} =~ $action; + }; + + } else { + $text_check = sub { + my ($textref) = @_; + return $action->(${$textref}); + }; + } + + my $deb822 = Lintian::Deb822->new; + + my @paragraphs; + try { + @paragraphs = $deb822->parse_string($contents); + + } catch { + # parse error: copyright not in new format, just check text + return $text_check->(\$contents); + } + + my @licenses = grep { length } map { $_->value('License') } @paragraphs; + for my $license (@licenses) { + + my ($name, $text) = ($license =~ /^\s*([^\r\n]+)\r?\n(.*)\z/s); + + next + unless length $text; + + next + if $text =~ /^[\s\r\n]*\z/; + + return 1 + if $name =~ $name_check + && $text_check->(\$text); + } + + # did not match anything + return 0; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Copyright/ApacheNotice.pm b/lib/Lintian/Check/Debian/Copyright/ApacheNotice.pm new file mode 100644 index 0000000..72e91b4 --- /dev/null +++ b/lib/Lintian/Check/Debian/Copyright/ApacheNotice.pm @@ -0,0 +1,105 @@ +# debian/copyright/apache-notice -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz +# Copyright (C) 2011 Jakub Wilk +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Copyright::ApacheNotice; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(any); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $SPACE => q{ }; + +sub source { + my ($self) = @_; + + my $debian_dir = $self->processable->patched->resolve_path('debian/'); + return + unless defined $debian_dir; + + my @installables = $self->processable->debian_control->installables; + my @additional = map { $_ . '.copyright' } @installables; + + my @candidates = ('copyright', @additional); + my @files = grep { defined } map { $debian_dir->child($_) } @candidates; + + # another check complains about legacy encoding, if needed + my @valid_utf8 = grep { $_->is_valid_utf8 } @files; + + $self->check_apache_notice_files($_)for @valid_utf8; + + return; +} + +sub check_apache_notice_files { + my ($self, $file) = @_; + + my $contents = $file->decoded_utf8; + return + unless $contents =~ /apache[-\s]+2\./i; + + my @notice_files = grep { + $_->basename =~ /^NOTICE(\.txt)?$/ + and $_->is_open_ok + and $_->bytes =~ /apache/i + } @{$self->processable->patched->sorted_list}; + return + unless @notice_files; + + my @binaries = grep { $_->type ne 'udeb' } $self->group->get_installables; + return + unless @binaries; + + for my $binary (@binaries) { + + # look at all path names in the package + my @names = map { $_->name } @{$binary->installed->sorted_list}; + + # and also those shipped in jars + my @jars = grep { scalar keys %{$_->java_info} } + @{$binary->installed->sorted_list}; + push(@names, keys %{$_->java_info->{files}})for @jars; + + return + if any { m{/NOTICE(\.txt)?(\.gz)?$} } @names; + } + + $self->pointed_hint('missing-notice-file-for-apache-license', $_->pointer) + for @notice_files; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Copyright/Dep5.pm b/lib/Lintian/Check/Debian/Copyright/Dep5.pm new file mode 100644 index 0000000..1084de8 --- /dev/null +++ b/lib/Lintian/Check/Debian/Copyright/Dep5.pm @@ -0,0 +1,968 @@ +# debian/copyright/dep5 -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz +# Copyright (C) 2011 Jakub Wilk +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Copyright::Dep5; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::Compare; +use List::SomeUtils qw(any all none uniq); +use Syntax::Keyword::Try; +use Regexp::Wildcards; +use Time::Piece; +use XML::LibXML; + +use Lintian::Deb822; +use Lintian::Relation::Version qw(versions_compare); +use Lintian::Util qw(match_glob); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $LAST_SIGNIFICANT_DEP5_CHANGE => '0+svn~166'; +const my $LAST_DEP5_OVERHAUL => '0+svn~148'; + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $SLASH => q{/}; +const my $COLON => q{:}; +const my $HYPHEN => q{-}; +const my $ASTERISK => q{*}; + +const my $MINIMUM_CREATIVE_COMMMONS_LENGTH => 20; +const my $LAST_ITEM => -1; + +const my %NEW_FIELD_NAMES => ( + 'Format-Specification' => 'Format', + 'Maintainer' => 'Upstream-Contact', + 'Upstream-Maintainer' => 'Upstream-Contact', + 'Contact' => 'Upstream-Contact', + 'Name' => 'Upstream-Name', +); + +sub source { + my ($self) = @_; + + my $debian_dir = $self->processable->patched->resolve_path('debian/'); + return + unless defined $debian_dir; + + my @installables = $self->processable->debian_control->installables; + my @additional = map { $_ . '.copyright' } @installables; + + my @candidates = ('copyright', @additional); + my @files = grep { defined $_ && !$_->is_symlink } + map { $debian_dir->child($_) } @candidates; + + # another check complains about legacy encoding, if needed + my @valid_utf8 = grep { $_->is_valid_utf8 } @files; + + $self->check_dep5_copyright($_) for @valid_utf8; + + return; +} + +# The policy states, since 4.0.0, that people should use "https://" for the +# format URI. This is checked later in check_dep5_copyright. +# return undef is not dep5 and '' if unknown version +sub find_dep5_version { + my ($self, $file, $original_uri) = @_; + + my $uri = $original_uri; + my $version; + + if ($uri =~ /\b(?:rev=REVISION|VERSIONED_FORMAT_URL)\b/) { + + $self->pointed_hint('boilerplate-copyright-format-uri', + $file->pointer,$uri); + return undef; + } + + if ( + $uri =~ s{ https?://wiki\.debian\.org/ + Proposals/CopyrightFormat\b}{}xsm + ){ + $version = '0~wiki'; + + $version = "$version~$1" + if $uri =~ /^\?action=recall&rev=(\d+)$/; + + return $version; + } + + if ($uri =~ m{^https?://dep(-team\.pages)?\.debian\.net/deps/dep5/?$}) { + + $version = '0+svn'; + return $version; + } + + if ( + $uri =~ s{\A https?://svn\.debian\.org/ + wsvn/dep/web/deps/dep5\.mdwn\b}{}xsm + ){ + $version = '0+svn'; + + $version = "$version~$1" + if $uri =~ /^\?(?:\S+[&;])?rev=(\d+)(?:[&;]\S+)?$/; + + return $version; + } + if ( + $uri =~ s{ \A https?://(?:svn|anonscm)\.debian\.org/ + viewvc/dep/web/deps/dep5\.mdwn\b}{}xsm + ){ + $version = '0+svn'; + $uri =~ m{\A \? (?:\S+[&;])? + (?:pathrev|revision|rev)=(\d+)(?:[&;]\S+)? + \Z}xsm + and $version = "$version~$1"; + return $version; + } + if ( + $uri =~ m{ \A + https?://www\.debian\.org/doc/ + (?:packaging-manuals/)?copyright-format/(\d+\.\d+)/? + \Z}xsm + ){ + $version = $1; + return $version; + } + + $self->pointed_hint('unknown-copyright-format-uri', + $file->pointer, $original_uri); + + return undef; +} + +sub check_dep5_copyright { + my ($self, $copyright_file) = @_; + + my $contents = $copyright_file->decoded_utf8; + + if ($contents =~ /^Files-Excluded:/m) { + + if ($contents + =~ m{^Format:.*/doc/packaging-manuals/copyright-format/1.0/?$}m) { + + $self->pointed_hint('repackaged-source-not-advertised', + $copyright_file->pointer) + unless $self->processable->repacked + || $self->processable->native; + + } else { + $self->pointed_hint('files-excluded-without-copyright-format-1.0', + $copyright_file->pointer); + } + } + + unless ( + $contents =~ m{ + (?:^ | \n) + (?i: format(?: [:] |[-\s]spec) ) + (?: . | \n\s+ )* + (?: /dep[5s]?\b | \bDEP ?5\b + | [Mm]achine-readable\s(?:license|copyright) + | /copyright-format/ | CopyrightFormat + | VERSIONED_FORMAT_URL + ) }x + ){ + + $self->pointed_hint('no-dep5-copyright', $copyright_file->pointer); + return; + } + + # get format before parsing as a debian control file + my $first_para = $contents; + $first_para =~ s/^#.*//mg; + $first_para =~ s/[ \t]+$//mg; + $first_para =~ s/^\n+//g; + $first_para =~ s/\n\n.*/\n/s; #;; hi emacs + $first_para =~ s/\n?[ \t]+/ /g; + + if ($first_para !~ /^Format(?:-Specification)?:\s*(\S+)\s*$/mi) { + $self->pointed_hint('unknown-copyright-format-uri', + $copyright_file->pointer); + return; + } + + my $uri = $1; + + # strip fragment identifier + $uri =~ s/^([^#\s]+)#/$1/; + + my $version = $self->find_dep5_version($copyright_file, $uri); + return + unless defined $version; + + if ($version =~ /wiki/) { + $self->pointed_hint('wiki-copyright-format-uri', + $copyright_file->pointer, $uri); + + } elsif ($version =~ /svn$/) { + $self->pointed_hint('unversioned-copyright-format-uri', + $copyright_file->pointer, $uri); + + } elsif (versions_compare($version, '<<', $LAST_SIGNIFICANT_DEP5_CHANGE)) { + $self->pointed_hint('out-of-date-copyright-format-uri', + $copyright_file->pointer, $uri); + + } elsif ($uri =~ m{^http://www\.debian\.org/}) { + $self->pointed_hint('insecure-copyright-format-uri', + $copyright_file->pointer, $uri); + } + + return + if versions_compare($version, '<<', $LAST_DEP5_OVERHAUL); + + # probably DEP 5 format; let's try more checks + my $deb822 = Lintian::Deb822->new; + + my @sections; + try { + @sections = $deb822->read_file($copyright_file->unpacked_path); + + } catch { + my $error = $@; + chomp $error; + $error =~ s{^syntax error in }{}; + + $self->pointed_hint('syntax-error-in-dep5-copyright', + $copyright_file->pointer, $@); + + return; + } + + return + unless @sections; + + my %found_standalone; + my %license_names_by_section; + my %license_text_by_section; + my %license_identifier_by_section; + + my @license_sections = grep { $_->declares('License') } @sections; + for my $section (@license_sections) { + + my $position = $section->position('License'); + my $pointer = $copyright_file->pointer($position); + + $self->pointed_hint('tab-in-license-text', $pointer) + if $section->untrimmed_value('License') =~ /\t/; + + my ($anycase_identifier, $license_text) + = split(/\n/, $section->untrimmed_value('License'), 2); + + $anycase_identifier //= $EMPTY; + $license_text //= $EMPTY; + + # replace some weird characters + $anycase_identifier =~ s/[(),]/ /g; + + # trim both ends + $anycase_identifier =~ s/^\s+|\s+$//g; + $license_text =~ s/^\s+|\s+$//g; + + my $license_identifier = lc $anycase_identifier; + + my @license_names + = grep { length } split(/\s+(?:and|or)\s+/, $license_identifier); + + $license_names_by_section{$section->position} = \@license_names; + $license_text_by_section{$section->position} = $license_text; + $license_identifier_by_section{$section->position} + = $license_identifier; + + $self->pointed_hint('empty-short-license-in-dep5-copyright', $pointer) + unless length $license_identifier; + + $self->pointed_hint('pipe-symbol-used-as-license-disjunction', + $pointer, $license_identifier) + if $license_identifier =~ m{\s+\|\s+}; + + for my $name (@license_names) { + if ($name =~ /\s/) { + + if($name =~ /[^ ]+ \s+ with \s+ (.*)/x) { + + my $exceptiontext = $1; + + $self->pointed_hint( + 'bad-exception-format-in-dep5-copyright', + $pointer, $name) + unless $exceptiontext =~ /[^ ]+ \s+ exception/x; + + } else { + + $self->pointed_hint( + 'space-in-std-shortname-in-dep5-copyright', + $pointer, $name); + } + } + + $self->pointed_hint('invalid-short-name-in-dep5-copyright', + $pointer, $name) + if $name =~ m{^(?:agpl|gpl|lgpl)[^-]?\d(?:\.\d)?\+?$} + || $name =~ m{^bsd(?:[^-]?[234][^-]?(?:clause|cluase))?$}; + + $self->pointed_hint('license-problem-undefined-license', + $pointer, $name) + if $name eq $HYPHEN + || $name + =~ m{\b(?:fixmes?|todos?|undefined?|unknown?|unspecified)\b}; + } + + # stand-alone license + if ( length $license_identifier + && length $license_text + && !$section->declares('Files')) { + + $found_standalone{$license_identifier} //= []; + push(@{$found_standalone{$license_identifier}}, $section); + } + + if ($license_identifier =~ /^cc-/ && length $license_text) { + + my $num_lines = $license_text =~ tr/\n//; + + $self->pointed_hint('incomplete-creative-commons-license', + $pointer, $license_identifier) + if $num_lines < $MINIMUM_CREATIVE_COMMMONS_LENGTH; + } + } + + my @not_unique + = grep { @{$found_standalone{$_}} > 1 } keys %found_standalone; + for my $name (@not_unique) { + + next + if $name eq 'public-domain'; + + for my $section (@{$found_standalone{$name}}) { + + my $position = $section->position('License'); + my $pointer = $copyright_file->pointer($position); + + $self->pointed_hint('dep5-copyright-license-name-not-unique', + $pointer, $name); + } + } + + my ($header, @followers) = @sections; + + my @obsolete_fields = grep { $header->declares($_) } keys %NEW_FIELD_NAMES; + for my $old_name (@obsolete_fields) { + + my $position = $header->position($old_name); + my $pointer = $copyright_file->pointer($position); + + $self->pointed_hint('obsolete-field-in-dep5-copyright', + $pointer, $old_name, $NEW_FIELD_NAMES{$old_name}); + } + + my $header_pointer = $copyright_file->pointer($header->position); + + $self->pointed_hint('missing-field-in-dep5-copyright', + $header_pointer, 'Format') + if none { $header->declares($_) } qw(Format Format-Specification); + + my $debian_control = $self->processable->debian_control; + + $self->pointed_hint('missing-explanation-for-contrib-or-non-free-package', + $header_pointer) + if $debian_control->source_fields->value('Section') + =~ m{^(?:contrib|non-free)(?:/.+)?$} + && (none { $header->declares($_) } qw{Comment Disclaimer}); + + $self->pointed_hint('missing-explanation-for-repacked-upstream-tarball', + $header_pointer) + if $self->processable->repacked + && $header->value('Source') =~ m{^https?://} + && (none { $header->declares($_) } qw{Comment Files-Excluded}); + + my @ambiguous_sections = grep { + $_->declares('License') + && $_->declares('Copyright') + && !$_->declares('Files') + } @followers; + + $self->pointed_hint( + 'ambiguous-paragraph-in-dep5-copyright', + $copyright_file->pointer($_->position) + )for @ambiguous_sections; + + my @unknown_sections + = grep {!$_->declares('License')&& !$_->declares('Files')} @followers; + + $self->pointed_hint( + 'unknown-paragraph-in-dep5-copyright', + $copyright_file->pointer($_->position) + )for @unknown_sections; + + my @shipped_items; + + if ($self->processable->native) { + @shipped_items = @{$self->processable->patched->sorted_list}; + + } else { + @shipped_items = @{$self->processable->orig->sorted_list}; + + # remove ./debian folder from orig, if any + @shipped_items = grep { !m{^debian/} } @shipped_items + if $self->processable->fields->value('Format') eq '3.0 (quilt)'; + + # add ./ debian folder from patched + my $debian_dir = $self->processable->patched->resolve_path('debian/'); + push(@shipped_items, $debian_dir->descendants) + if $debian_dir; + } + + my @shipped_names + = sort map { $_->name } grep { $_->is_file } @shipped_items; + + my @excluded; + for my $wildcard ($header->trimmed_list('Files-Excluded')) { + + my $position = $header->position('Files-Excluded'); + my $pointer = $copyright_file->pointer($position); + + my @offenders = escape_errors($wildcard); + + $self->pointed_hint('invalid-escape-sequence-in-dep5-copyright', + $pointer, '(Files-Excluded)', $_) + for @offenders; + + next + if @offenders; + + # also match dir/filename for Files-Excluded: dir + unless ($wildcard =~ /\*/ || $wildcard =~ /\?/) { + + my $candidate = $wildcard; + $candidate .= $SLASH + unless $candidate =~ m{/$}; + + my $item = $self->processable->orig->lookup($candidate); + + $wildcard = $candidate . $ASTERISK + if defined $item && $item->is_dir; + } + + my @match = match_glob($wildcard, @shipped_names); + + # do not flag missing matches; uscan already excluded them + push(@excluded, @match); + } + + my @included; + for my $wildcard ($header->trimmed_list('Files-Included')) { + + my $position = $header->position('Files-Included'); + my $pointer = $copyright_file->pointer($position); + + my @offenders = escape_errors($wildcard); + + $self->pointed_hint('invalid-escape-sequence-in-dep5-copyright', + $pointer, '(Files-Included)', $_) + for @offenders; + + next + if @offenders; + + # also match dir/filename for Files-Excluded: dir + unless ($wildcard =~ /\*/ || $wildcard =~ /\?/) { + + my $candidate = $wildcard; + $candidate .= $SLASH + unless $candidate =~ m{/$}; + + my $item = $self->processable->orig->lookup($candidate); + + $wildcard = $candidate . $ASTERISK + if defined $item && $item->is_dir; + } + + my @match = match_glob($wildcard, @shipped_names); + + $self->pointed_hint( + 'superfluous-file-pattern', $pointer, + '(Files-Included)', $wildcard + )unless @match; + + push(@included, @match); + } + + my $lc = List::Compare->new(\@included, \@excluded); + my @affirmed = $lc->get_Lonly; + my @unwanted = $lc->get_Ronly; + + # already unique + for my $name (@affirmed) { + + my $position = $header->position('Files-Included'); + my $pointer = $copyright_file->pointer($position); + + $self->pointed_hint('file-included-already', $pointer, $name); + } + + # already unique + for my $name (@unwanted) { + + my $position = $header->position('Files-Excluded'); + my $pointer = $copyright_file->pointer($position); + + $self->pointed_hint('source-ships-excluded-file',$pointer, $name) + unless $name =~ m{^(?:debian|\.pc)/}; + } + + my @notice_names= grep { m{(^|/)(COPYING[^/]*|LICENSE)$} } @shipped_names; + my @quilt_names = grep { m{^\.pc/} } @shipped_names; + + my @names_with_comma = grep { /,/ } @shipped_names; + my @fields_with_comma = grep { $_->value('Files') =~ /,/ } @followers; + + for my $section (@fields_with_comma) { + + my $position = $section->position('Files'); + my $pointer = $copyright_file->pointer($position); + + $self->pointed_hint('comma-separated-files-in-dep5-copyright',$pointer) + if !@names_with_comma; + } + + # only attempt to evaluate globbing if commas could be legal + my $check_wildcards = !@fields_with_comma || @names_with_comma; + + my @files_sections = grep {$_->declares('Files')} @followers; + + for my $section (@files_sections) { + + if (!length $section->value('Files')) { + + my $position = $section->position('Files'); + my $pointer = $copyright_file->pointer($position); + + $self->pointed_hint('missing-field-in-dep5-copyright', + $pointer,'(empty field)', 'Files'); + } + + my $section_pointer = $copyright_file->pointer($section->position); + + $self->pointed_hint('missing-field-in-dep5-copyright', + $section_pointer, 'License') + if !$section->declares('License'); + + $self->pointed_hint('missing-field-in-dep5-copyright', + $section_pointer, 'Copyright') + if !$section->declares('Copyright'); + + if ($section->declares('Copyright') + && !length $section->value('Copyright')) { + + my $position = $section->position('Copyright'); + my $pointer = $copyright_file->pointer($position); + + $self->pointed_hint('missing-field-in-dep5-copyright', + $pointer, '(empty field)', 'Copyright'); + } + } + + my %sections_by_wildcard; + my %wildcard_by_file; + my %required_standalone; + my %positions_by_debian_year; + my @redundant_wildcards; + + my $section_count = 0; + for my $section (@followers) { + + my $wildcard_pointer + = $copyright_file->pointer($section->position('Files')); + + my $copyright_pointer + = $copyright_file->pointer($section->position('Copyright')); + + my $license_pointer + = $copyright_file->pointer($section->position('License')); + + my @license_names + = @{$license_names_by_section{$section->position} // []}; + my $license_text = $license_text_by_section{$section->position}; + + if ($section->declares('Files') && !length $license_text) { + $required_standalone{$_} = $section for @license_names; + } + + my @wildcards; + + # If it is the first paragraph, it might be an instance of + # the (no-longer) optional "first Files-field". + if ( $section_count == 0 + && $section->declares('License') + && $section->declares('Copyright') + && !$section->declares('Files')) { + + @wildcards = ($ASTERISK); + + } else { + @wildcards = $section->trimmed_list('Files'); + } + + my @rightholders = $section->trimmed_list('Copyright', qr{ \n }x); + my @years = map { /(\d{4})/g } @rightholders; + + if (any { m{^ debian (?: / | $) }x } @wildcards) { + + my $position = $section->position('Copyright'); + + push(@{$positions_by_debian_year{$_}}, $position)for @years; + } + + for my $wildcard (@wildcards) { + $sections_by_wildcard{$wildcard} //= []; + push(@{$sections_by_wildcard{$wildcard}}, $section); + } + + $self->pointed_hint( + 'global-files-wildcard-not-first-paragraph-in-dep5-copyright', + $wildcard_pointer) + if (any { $_ eq $ASTERISK } @wildcards) && $section_count > 0; + + # stand-alone license paragraph + $self->pointed_hint('missing-license-text-in-dep5-copyright', + $license_pointer, $section->untrimmed_value('License')) + if !@wildcards + && $section->declares('License') + && !length $license_text; + + next + unless $check_wildcards; + + my %wildcards_same_section_by_file; + + for my $wildcard (@wildcards) { + + my @offenders = escape_errors($wildcard); + + $self->pointed_hint('invalid-escape-sequence-in-dep5-copyright', + $wildcard_pointer, $_) + for @offenders; + + next + if @offenders; + + my @covered = match_glob($wildcard, @shipped_names); + + for my $name (@covered) { + $wildcards_same_section_by_file{$name} //= []; + push(@{$wildcards_same_section_by_file{$name}}, $wildcard); + } + } + + my @overwritten = grep { length $wildcard_by_file{$_} } + keys %wildcards_same_section_by_file; + + for my $name (@overwritten) { + + my $winning_wildcard + = @{$wildcards_same_section_by_file{$name}}[$LAST_ITEM]; + my $loosing_wildcard = $wildcard_by_file{$name}; + + my $winner_depth = ($winning_wildcard =~ tr{/}{}); + my $looser_depth = ($loosing_wildcard =~ tr{/}{}); + + $self->pointed_hint('globbing-patterns-out-of-order', + $wildcard_pointer,$loosing_wildcard, $winning_wildcard, $name) + if $looser_depth > $winner_depth; + } + + # later matches have precendence; depends on section ordering + $wildcard_by_file{$_} + = @{$wildcards_same_section_by_file{$_}}[$LAST_ITEM] + for keys %wildcards_same_section_by_file; + + my @overmatched_same_section + = grep { @{$wildcards_same_section_by_file{$_}} > 1 } + keys %wildcards_same_section_by_file; + + for my $file (@overmatched_same_section) { + + my $patterns + = join($SPACE, sort @{$wildcards_same_section_by_file{$file}}); + + $self->pointed_hint('redundant-globbing-patterns', + $wildcard_pointer,"($patterns) for $file"); + } + + push(@redundant_wildcards, + map { @{$wildcards_same_section_by_file{$_}} } + @overmatched_same_section); + + } continue { + $section_count++; + } + + my @debian_years = keys %positions_by_debian_year; + my @changelog_entries = @{$self->processable->changelog->entries}; + + if (@debian_years && @changelog_entries) { + + my @descending = reverse sort { $a <=> $b } @debian_years; + my $most_recent_copyright = $descending[0]; + + my $tp = Time::Piece->strptime($changelog_entries[0]->Date, + '%a, %d %b %Y %T %z'); + my $most_recent_changelog = $tp->year; + + my @candidates = @{$positions_by_debian_year{$most_recent_copyright}}; + my @sorted = sort { $a <=> $b } @candidates; + + # pick the topmost, which should be the broadest pattern + my $position = $candidates[0]; + + $self->pointed_hint('update-debian-copyright', + $copyright_file->pointer($position), + $most_recent_copyright, 'vs', $most_recent_changelog) + if $most_recent_copyright < $most_recent_changelog; + } + + if ($check_wildcards) { + + my @duplicate_wildcards= grep { @{$sections_by_wildcard{$_}} > 1 } + keys %sections_by_wildcard; + + for my $wildcard (@duplicate_wildcards) { + + my $lines = join($SPACE, + map { $_->position('Files') } + @{$sections_by_wildcard{$wildcard}}); + + $self->pointed_hint('duplicate-globbing-patterns', + $copyright_file->pointer,$wildcard, "(lines $lines)"); + } + + # do not issue next tag for duplicates or redundant wildcards + my $wildcard_lc = List::Compare->new( + [keys %sections_by_wildcard], + [ + ( + values %wildcard_by_file, @duplicate_wildcards, + @redundant_wildcards + ) + ] + ); + my @matches_nothing = $wildcard_lc->get_Lonly; + + for my $wildcard (@matches_nothing) { + for my $section (@{$sections_by_wildcard{$wildcard}}) { + + my $position = $section->position('Files'); + my $pointer = $copyright_file->pointer($position); + + $self->pointed_hint('superfluous-file-pattern', $pointer, + $wildcard); + } + } + + my %sections_by_file; + for my $name (keys %wildcard_by_file) { + + $sections_by_file{$name} //= []; + my $wildcard = $wildcard_by_file{$name}; + + push( + @{$sections_by_file{$name}}, + @{$sections_by_wildcard{$wildcard}} + ); + } + + my %license_identifiers_by_file; + for my $name (keys %sections_by_file) { + + $license_identifiers_by_file{$name} //= []; + + push( + @{$license_identifiers_by_file{$name}}, + $license_identifier_by_section{$_->position} + ) for @{$sections_by_file{$name}}; + } + + my @xml_searchspace = keys %license_identifiers_by_file; + + # do not examine Lintian's test suite for appstream metadata + @xml_searchspace = grep { !m{t/} } @xml_searchspace + if $self->processable->name eq 'lintian'; + + for my $name (@xml_searchspace) { + + next + if $name =~ '^\.pc/'; + + next + unless $name =~ /\.xml$/; + + my $parser = XML::LibXML->new; + $parser->set_option('no_network', 1); + + my $file = $self->processable->patched->resolve_path($name); + my $doc; + try { + $doc = $parser->parse_file($file->unpacked_path); + + } catch { + next; + } + + next + unless $doc; + + my @nodes = $doc->findnodes('/component/metadata_license'); + next + unless @nodes; + + # take first one + my $first = $nodes[0]; + next + unless $first; + + my $seen = lc($first->firstChild->data // $EMPTY); + next + unless $seen; + + # Compare and also normalize the seen and wanted license + # identifier wrt. to redundant trailing dot-zeros, + # -or-later suffix vs + suffix, -only suffix vs no + # suffix. Still display the original variant in the tag. + my $seen_normalized = $seen; + $seen_normalized = 'expat' if $seen_normalized eq 'mit'; + $seen_normalized =~ s/-or-later$/+/i; + $seen_normalized =~ s/-only$//i; + my $seen_nozero = $seen_normalized; + $seen_nozero =~ s/\.0//g; + + my @wanted = @{$license_identifiers_by_file{$name}}; + my @mismatched = grep { + my $want = $_; + my $want_normalized = $want; + $want_normalized = 'expat' if $want_normalized eq 'mit'; + $want_normalized =~ s/-or-later$/+/i; + $want_normalized =~ s/-only$//i; + my $want_nozero = $want_normalized; + $want_nozero =~ s/\.0//g; + + $want_normalized ne $seen_normalized + and $want_nozero ne $seen_normalized + and $want_normalized ne $seen_nozero + and $want_nozero ne $seen_nozero; + } @wanted; + + $self->pointed_hint('inconsistent-appstream-metadata-license', + $copyright_file->pointer, $name, "($seen != $_)") + for @mismatched; + } + + my @no_license_needed = (@quilt_names, @notice_names); + my $unlicensed_lc + = List::Compare->new(\@shipped_names, \@no_license_needed); + my @license_needed = $unlicensed_lc->get_Lonly; + + my @not_covered + = grep { !@{$sections_by_file{$_} // []} } @license_needed; + + $self->pointed_hint('file-without-copyright-information', + $copyright_file->pointer, $_) + for @not_covered; + } + + my $standalone_lc= List::Compare->new([keys %required_standalone], + [keys %found_standalone]); + my @missing_standalone = $standalone_lc->get_Lonly; + my @matched_standalone = $standalone_lc->get_intersection; + my @unused_standalone = $standalone_lc->get_Ronly; + + for my $license (@missing_standalone) { + + my $section = $required_standalone{$license}; + + my $position = $section->position('License'); + my $pointer = $copyright_file->pointer($position); + + $self->pointed_hint('missing-license-paragraph-in-dep5-copyright', + $pointer, $license); + } + + for my $license (grep { $_ ne 'public-domain' } @unused_standalone) { + + for my $section (@{$found_standalone{$license}}) { + + my $position = $section->position('License'); + my $pointer = $copyright_file->pointer($position); + + $self->pointed_hint('unused-license-paragraph-in-dep5-copyright', + $pointer, $license); + } + } + + for my $license (@matched_standalone) { + + my $section = $required_standalone{$license}; + + my $position = $section->position('Files'); + my $pointer = $copyright_file->pointer($position); + + $self->pointed_hint('dep5-file-paragraph-references-header-paragraph', + $pointer, $license) + if all { $_ == $header } @{$found_standalone{$license}}; + } + + # license files do not require their own entries in d/copyright. + my $license_lc + = List::Compare->new(\@notice_names, [keys %sections_by_wildcard]); + my @listed_licenses = $license_lc->get_intersection; + + $self->pointed_hint('license-file-listed-in-debian-copyright', + $copyright_file->pointer, $_) + for @listed_licenses; + + return; +} + +sub escape_errors { + my ($escaped) = @_; + + my @sequences = ($escaped =~ m{\\.?}g); + my @illegal = grep { !m{^\\[*?]$} } @sequences; + + return @illegal; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Copyright/Dep5/Components.pm b/lib/Lintian/Check/Debian/Copyright/Dep5/Components.pm new file mode 100644 index 0000000..453a40b --- /dev/null +++ b/lib/Lintian/Check/Debian/Copyright/Dep5/Components.pm @@ -0,0 +1,109 @@ +# debian/copyright/dep5/components -- lintian check script -*- perl -*- + +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Copyright::Dep5::Components; + +use v5.20; +use warnings; +use utf8; + +use List::Compare; +use Syntax::Keyword::Try; + +use Lintian::Deb822; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $debian_dir = $self->processable->patched->resolve_path('debian/'); + return + unless defined $debian_dir; + + my @installables = $self->processable->debian_control->installables; + my @additional = map { $_ . '.copyright' } @installables; + + my @candidates = ('copyright', @additional); + my @files = grep { defined $_ && !$_->is_symlink } + map { $debian_dir->child($_) } @candidates; + + # another check complains about legacy encoding, if needed + my @valid_utf8 = grep { $_->is_valid_utf8 } @files; + + $self->check_dep5_copyright($_) for @valid_utf8; + + return; +} + +sub check_dep5_copyright { + my ($self, $copyright_file) = @_; + + my $deb822 = Lintian::Deb822->new; + + my @sections; + try { + @sections = $deb822->read_file($copyright_file->unpacked_path); + + } catch { + # may not be in DEP 5 format + return; + } + + return + unless @sections; + + my ($header, @followers) = @sections; + + my @initial_path_components; + + for my $section (@followers) { + + my @subdirs = $section->trimmed_list('Files'); + s{ / .* $}{}x for @subdirs; + + my @definite = grep { !/[*?]/ } @subdirs; + + push(@initial_path_components, grep { length } @definite); + } + + my @extra_source_components + = grep { length } values %{$self->processable->components}; + my $component_lc = List::Compare->new(\@extra_source_components, + \@initial_path_components); + + my @missing_components = $component_lc->get_Lonly; + + $self->pointed_hint('add-component-copyright', $copyright_file->pointer,$_) + for @missing_components; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Debconf.pm b/lib/Lintian/Check/Debian/Debconf.pm new file mode 100644 index 0000000..6b86bf9 --- /dev/null +++ b/lib/Lintian/Check/Debian/Debconf.pm @@ -0,0 +1,794 @@ +# debian/debconf -- lintian check script -*- perl -*- + +# Copyright (C) 2001 Colin Watson +# Copyright (C) 2020-21 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Debconf; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(none); +use Path::Tiny; +use Syntax::Keyword::Try; +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::Deb822; +use Lintian::Deb822::Constants qw(DCTRL_DEBCONF_TEMPLATE); +use Lintian::Relation; +use Lintian::Util qw($PKGNAME_REGEX); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; +const my $SPACE => q{ }; + +const my $MAXIMUM_TEMPLATE_SYNOPSIS => 75; +const my $MAXIMUM_LINE_LENGTH => 80; +const my $MAXIMUM_LINES => 20; +const my $ITEM_NOT_FOUND => -1; + +# From debconf-devel(7), section 'THE TEMPLATES FILE', up to date with debconf +# version 1.5.24. Added indices for cdebconf (indicates sort order for +# choices); debconf doesn't support it, but it ignores it, which is safe +# behavior. Likewise, help is supported as of cdebconf 0.143 but is not yet +# supported by debconf. +my %template_fields + = map { $_ => 1 } qw(Template Type Choices Indices Default Description Help); + +# From debconf-devel(7), section 'THE TEMPLATES FILE', up to date with debconf +# version 1.5.24. +my %valid_types = map { $_ => 1 } qw( + string + password + boolean + select + multiselect + note + error + title + text); + +# From debconf-devel(7), section 'THE DEBCONF PROTOCOL' under 'INPUT', up to +# date with debconf version 1.5.24. +my %valid_priorities = map { $_ => 1 } qw(low medium high critical); + +# All the packages that provide debconf functionality. Anything using debconf +# needs to have dependencies that satisfy one of these. +my $ANY_DEBCONF = Lintian::Relation->new->load( + join( + ' | ', qw(debconf debconf-2.0 cdebconf + cdebconf-udeb libdebconfclient0 libdebconfclient0-udeb) + ) +); + +sub source { + my ($self) = @_; + + my @catalogs= ( + 'templates', + map { "$_.templates" }$self->processable->debian_control->installables + ); + my @files = grep { defined } + map { $self->processable->patched->resolve_path("debian/$_") } @catalogs; + + my @utf8 = grep { $_->is_valid_utf8 and $_->is_file } @files; + for my $item (@utf8) { + + my $deb822 = Lintian::Deb822->new; + + my @templates; + try { + @templates + = $deb822->read_file($item->unpacked_path, + DCTRL_DEBCONF_TEMPLATE); + + } catch { + my $error = $@; + chomp $error; + $error =~ s{^syntax error in }{}; + + $self->pointed_hint('syntax-error-in-debconf-template', + $item->pointer, $error); + + next; + } + + my @unsplit_choices + = grep {$_->declares('Template') && $_->declares('_Choices')} + @templates; + + $self->pointed_hint( + 'template-uses-unsplit-choices', + $item->pointer($_->position('_Choices')), + $_->value('Template') + )for @unsplit_choices; + } + + return; +} + +sub installable { + my ($self) = @_; + + my $usespreinst; + my $preinst = $self->processable->control->lookup('preinst'); + + if ($preinst and $preinst->is_file and $preinst->is_open_ok) { + + open(my $fd, '<', $preinst->unpacked_path) + or die encode_utf8('Cannot open ' . $preinst->unpacked_path); + + while (my $line = <$fd>) { + $line =~ s/\#.*//; # Not perfect for Perl, but should be OK + + if ( $line =~ m{/usr/share/debconf/confmodule} + || $line =~ /(?:Debconf|Debian::DebConf)::Client::ConfModule/){ + $usespreinst=1; + + last; + } + } + close($fd); + } + + my $seenconfig; + my $ctrl_config = $self->processable->control->lookup('config'); + if (defined $ctrl_config && $ctrl_config->is_file) { + + $self->pointed_hint('debconf-config-not-executable', + $ctrl_config->pointer) + unless $ctrl_config->is_executable; + + $seenconfig = 1; + } + + my $seentemplates; + my $ctrl_templates = $self->processable->control->lookup('templates'); + $seentemplates = 1 if $ctrl_templates and $ctrl_templates->is_file; + + # This still misses packages that use debconf only in the postrm. + # Packages that ask debconf questions in the postrm should load + # the confmodule in the postinst so that debconf can register + # their templates. + return + unless $seenconfig + or $seentemplates + or $usespreinst; + + # parse depends info for later checks + + # Consider every package to depend on itself. + my $selfrel; + if ($self->processable->fields->declares('Version')) { + my $version = $self->processable->fields->value('Version'); + $selfrel = $self->processable->name . " (= $version)"; + } else { + $selfrel = $self->processable->name; + } + + # Include self and provides as a package providing debconf presumably + # satisfies its own use of debconf (if any). + my $selfrelation + = $self->processable->relation('Provides')->logical_and($selfrel); + my $alldependencies + = $self->processable->relation('strong')->logical_and($selfrelation); + + # See if the package depends on dbconfig-common. Packages that do + # are allowed to have a config file with no templates, since they + # use the dbconfig-common templates. + my $usesdbconfig = $alldependencies->satisfies('dbconfig-common'); + + # Check that both debconf control area files are present. + if ($seenconfig and not $seentemplates and not $usesdbconfig) { + + $self->hint('no-debconf-templates'); + + } elsif ($seentemplates + and not $seenconfig + and not $usespreinst + and $self->processable->type ne 'udeb') { + + $self->hint('no-debconf-config'); + } + + # Lots of template checks. + + my @templates; + if ($seentemplates) { + + if ($ctrl_templates->is_valid_utf8) { + my $deb822 = Lintian::Deb822->new; + + try { + # $seentemplates (above) will be false if $ctrl_templates is a + # symlink or not a file, so this should be safe without + # (re-checking) with -f/-l. + @templates= $deb822->read_file($ctrl_templates->unpacked_path, + DCTRL_DEBCONF_TEMPLATE); + + } catch { + my $error = $@; + chomp $error; + $error =~ s{^syntax error in }{}; + + $self->pointed_hint('syntax-error-in-debconf-template', + $ctrl_templates->pointer, $error); + + @templates = (); + } + } + } + + my %template_by_name; + my %potential_db_abuse; + for my $template (@templates) { + + my $isselect = $EMPTY; + my $name = $template->value('Template'); + + if (!$template->declares('Template')) { + $self->pointed_hint('no-template-name', + $ctrl_templates->pointer($template->position)); + $name = 'no-template-name'; + + } else { + $template_by_name{$name} = $template; + + $self->pointed_hint('malformed-template-name', + $ctrl_templates->pointer($template->position('Template')), + $name) + unless $name =~ m{[A-Za-z0-9.+-](?:/[A-Za-z0-9.+-])}; + } + + my $type = $template->value('Type'); + if (!$template->declares('Type')) { + + $self->pointed_hint('no-template-type', + $ctrl_templates->pointer($template->position), $name); + + } elsif (!$valid_types{$type}) { + + # cdebconf has a special "entropy" type + $self->pointed_hint('unknown-template-type', + $ctrl_templates->pointer($template->position('Type')), $type) + unless $type eq 'entropy' + && $alldependencies->satisfies('cdebconf'); + + } elsif ($type eq 'select' || $type eq 'multiselect') { + $isselect = 1; + + } elsif ($type eq 'boolean') { + + my $default = $template->value('Default'); + + $self->pointed_hint( + 'boolean-template-has-bogus-default', + $ctrl_templates->pointer($template->position('Default')), + $name, $default + ) + if $template->declares('Default') + && (none { $default eq $_ } qw(true false)); + } + + my $choices = $template->value('Choices'); + if ($template->declares('Choices') && $choices !~ /^\s*$/) { + + my $nrchoices = count_choices($choices); + for my $key ($template->names) { + + if ($key =~ /^Choices-/) { + my $translated = $template->value($key); + + if (!length($translated) || $translated =~ /^\s*$/){ + $self->pointed_hint( + 'empty-translated-choices', + $ctrl_templates->pointer( + $template->position('Choices') + ), + $name, $key + ); + } + + if (count_choices($translated) != $nrchoices) { + $self->pointed_hint( + 'mismatch-translated-choices', + $ctrl_templates->pointer( + $template->position('Choices') + ), + $name,$key + ); + } + } + } + + $self->pointed_hint('select-with-boolean-choices', + $ctrl_templates->pointer($template->position('Choices')),$name) + if $choices =~ /^\s*(yes\s*,\s*no|no\s*,\s*yes)\s*$/i; + } + + $self->pointed_hint('select-without-choices', + $ctrl_templates->pointer($template->position), $name) + if $isselect && !$template->declares('Choices'); + + my $description = $template->value('Description'); + + $self->pointed_hint('no-template-description', + $ctrl_templates->pointer($template->position), $name) + unless length $description + || length $template->value('_Description'); + + if ($description =~ /^\s*(.*?)\s*?\n\s*\1\s*$/){ + + # Check for duplication. Should all this be folded into the + # description checks? + $self->pointed_hint('duplicate-long-description-in-template', + $ctrl_templates->pointer($template->position('Description')), + $name); + } + + my %languages; + for my $field ($template->names) { + # Tests on translations + my ($mainfield, $lang) = split m/-/, $field, 2; + if (defined $lang) { + $languages{$lang}{$mainfield}=1; + } + my $stripped = $mainfield; + $stripped =~ s/^_//; + unless ($template_fields{$stripped}) { + # Ignore language codes here + $self->pointed_hint('unknown-field-in-templates', + $ctrl_templates->pointer($template->position($field)), + $name, $field); + } + } + + if (length $name && length $type) { + $potential_db_abuse{$name} = 1 + if $type eq 'note' || $type eq 'text'; + } + + # Check the description against the best practices in the + # Developer's Reference, but skip all templates where the + # short description contains the string "for internal use". + my ($short, $extended); + if (length $description) { + ($short, $extended) = split(/\n/, $description, 2); + unless (defined $short) { + $short = $description; + $extended = $EMPTY; + } + } else { + $short = $EMPTY; + $extended = $EMPTY; + } + + my $ttype = $type; + unless ($short =~ /for internal use/i) { + + my $pointer + = $ctrl_templates->pointer($template->position('Description')); + + my $isprompt = grep { $_ eq $ttype } qw(string password); + if ($isprompt) { + if ( + $short + && ( $short !~ m/:$/ + || $short =~ m/^(what|who|when|where|which|how)/i) + ) { + $self->pointed_hint('malformed-prompt-in-templates', + $pointer, $name); + } + } + if ($isselect) { + if ($short =~ /^(Please|Cho+se|Enter|Select|Specify|Give)/) { + $self->pointed_hint('using-imperative-form-in-templates', + $pointer, $name); + } + } + if ($ttype eq 'boolean') { + if ($short !~ /\?/) { + $self->pointed_hint('malformed-question-in-templates', + $pointer, $name); + } + } + if (defined $extended && $extended =~ /[^\?]\?(\s+|$)/) { + $self->pointed_hint( + 'using-question-in-extended-description-in-templates', + $pointer, $name); + } + if ($ttype eq 'note') { + if ($short =~ /[.?;:]$/) { + $self->pointed_hint('malformed-title-in-templates', + $pointer, $name); + } + } + if (length $short > $MAXIMUM_TEMPLATE_SYNOPSIS) { + $self->pointed_hint('too-long-short-description-in-templates', + $pointer, $name) + unless $self->processable->type eq 'udeb' + && $ttype eq 'text'; + } + if (defined $description) { + if ($description + =~ /(\A|\s)(I|[Mm]y|[Ww]e|[Oo]ur|[Oo]urs|mine|myself|ourself|me|us)(\Z|\s)/ + ) { + $self->pointed_hint('using-first-person-in-templates', + $pointer,$name); + } + if ( $description =~ /[ \'\"]yes[ \'\",;.]/i + and $ttype eq 'boolean') { + + $self->pointed_hint( + 'making-assumptions-about-interfaces-in-templates', + $pointer, $name); + } + } + + # Check whether the extended description is too long. + if ($extended) { + + my $lines = 0; + for my $string (split(/\n/, $extended)) { + + while (length $string > $MAXIMUM_LINE_LENGTH) { + + my $index + = rindex($string, $SPACE, $MAXIMUM_LINE_LENGTH); + + if ($index == $ITEM_NOT_FOUND) { + $index = index($string, $SPACE); + } + + if ($index == $ITEM_NOT_FOUND) { + $string = $EMPTY; + + } else { + $string = substr($string, $index + 1); + $lines++; + } + } + + $lines++; + } + + if ($lines > $MAXIMUM_LINES) { + $self->pointed_hint( + 'too-long-extended-description-in-templates', + $pointer, $name); + } + } + } + } + + # Check the maintainer scripts. + + my ($config_calls_db_input, $db_purge); + my (%templates_used, %template_aliases); + for my $file (qw(config prerm postrm preinst postinst)) { + + my $potential_makedev = {}; + + my $item = $self->processable->control->lookup($file); + + if (defined $item && $item->is_file && $item->is_open_ok) { + + my ($usesconfmodule, $obsoleteconfmodule, $db_input, $isdefault); + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + # Only check scripts. + my $fl = <$fd>; + unless ($fl && $fl =~ /^\#!/) { + close($fd); + next; + } + + my $position = 1; + while (my $line = <$fd>) { + + # not perfect for Perl, but should be OK + $line =~ s/#.*//; + + next + unless $line =~ /\S/; + + while ($line =~ s{\\$}{}) { + my $next = <$fd>; + ++$position; + + last + unless $next; + + $line .= $next; + } + + if ($line =~ m{(?:\.|source)\s+/usr/share/debconf/confmodule} + || $line=~ /(?:use|require)\s+Debconf::Client::ConfModule/) + { + $usesconfmodule=1; + } + + my $pointer = $item->pointer($position); + + if ( + !$obsoleteconfmodule + && $line =~ m{(/usr/share/debconf/confmodule\.sh| + Debian::DebConf::Client::ConfModule)}x + ) { + my $module = $1; + + $self->pointed_hint('loads-obsolete-confmodule', $pointer, + $module); + + $usesconfmodule = 1; + $obsoleteconfmodule = 1; + } + + if ($item->name eq 'config' && $line =~ /db_input/) { + $config_calls_db_input = 1; + } + + if ( $item->name eq 'postinst' + && !$db_input + && $line =~ /db_input/ + && !$config_calls_db_input) { + + # TODO: Perl? + $self->pointed_hint('postinst-uses-db-input', $pointer) + unless $self->processable->type eq 'udeb'; + $db_input=1; + } + + if ($line =~ m{/dev/}) { + $potential_makedev->{$position} = 1; + } + + if ( + $line =~m{\A \s*(?:db_input|db_text)\s+ + [\"\']? (\S+?) [\"\']? \s+ (\S+)\s}xsm + ) { + my $priority = $1; + my $unmangled = $2; + + $templates_used{$self->get_template_name($unmangled)}= 1; + + if ($priority !~ /^\$\S+$/) { + + $self->pointed_hint('unknown-debconf-priority', + $pointer, $priority) + unless ($valid_priorities{$priority}); + + $self->pointed_hint('possible-debconf-note-abuse', + $pointer, $unmangled) + if ( + $potential_db_abuse{$unmangled} + and ( + not($potential_makedev->{($position - 1)} + and ($priority eq 'low')) + ) + and ($priority eq 'low' || $priority eq 'medium') + ); + } + } + + if ( + $line =~m{ \A \s* (?:db_get|db_set(?:title)?) \s+ + [\"\']? (\S+?) [\"\']? (?:\s|\Z)}xsm + ) { + $templates_used{$self->get_template_name($1)} = 1; + } + + # Try to handle Perl somewhat. + if ($line =~ /^\s*(?:.*=\s*get|set)\s*\(\s*[\"\'](\S+?)[\"\']/ + || $line + =~ /\b(?:metaget|settitle)\s*\(\s*[\"\'](\S+?)[\"\']/) { + $templates_used{$1} = 1; + } + + if ($line=~ /^\s*db_register\s+[\"\']?(\S+?)[\"\']?\s+(\S+)\s/) + { + my ($template, $question) = ($1, $2); + push @{$template_aliases{$template}}, $question; + } + if (!$isdefault && $line =~ /db_fset.*isdefault/) { + # TODO: Perl? + $self->pointed_hint('isdefault-flag-is-deprecated', + $pointer); + $isdefault = 1; + } + + if (!$db_purge && $line =~ /db_purge/) { # TODO: Perl? + $db_purge = 1; + } + + } continue { + ++$position; + } + + close $fd; + + if ($self->processable->type ne 'udeb') { + if ($item->name eq 'config' + || ($seenconfig && $item->name eq 'postinst')){ + + $self->pointed_hint("$file-does-not-load-confmodule", + $item->pointer) + unless $usesconfmodule; + } + } + + if ($item->name eq 'postrm') { + # If we haven't seen db_purge we emit the tag unless the + # package is a debconf provider (in which case db_purge + # won't be available) + unless ($db_purge or $selfrelation->satisfies($ANY_DEBCONF)) { + + $self->pointed_hint('postrm-does-not-purge-debconf', + $item->pointer); + } + } + + } elsif ($file eq 'postinst') { + + $self->hint('postinst-does-not-load-confmodule', $file) + if $self->processable->type ne 'udeb' && $seenconfig; + + } elsif ($file eq 'postrm') { + # Make an exception for debconf providing packages as some of + # them (incl. "debconf" itself) cleans up in prerm and have no + # postrm script at all. + $self->hint('postrm-does-not-purge-debconf', $file) + unless $self->processable->type eq 'udeb' + or $selfrelation->satisfies($ANY_DEBCONF); + } + } + + for my $name (keys %template_by_name) { + + $name =~ s/\s+\Z//; + + my $used = 0; + + if ($templates_used{$name}) { + $used = 1; + } else { + foreach my $alias (@{$template_aliases{$name}}) { + if ($templates_used{$alias}) { + $used = 1; + last; + } + } + } + + my $template = $template_by_name{$name}; + my $position = $template->position('Template'); + my $pointer = $ctrl_templates->pointer($position); + + $self->pointed_hint('unused-debconf-template', $pointer, $name) + unless $name =~ m{^shared/packages-(wordlist|ispell)$} + || $name =~ m{/languages$} + || $used + || $self->processable->name eq 'debconf' + || $self->processable->type eq 'udeb'; + } + + # Check that the right dependencies are in the control file. Accept any + # package that might provide debconf functionality. + + if ($usespreinst) { + unless ($self->processable->relation('Pre-Depends') + ->satisfies($ANY_DEBCONF)){ + $self->hint('missing-debconf-dependency-for-preinst') + unless $self->processable->type eq 'udeb'; + } + } else { + unless ($alldependencies->satisfies($ANY_DEBCONF) or $usesdbconfig) { + $self->hint('missing-debconf-dependency'); + } + } + + # Now make sure that no scripts are using debconf as a registry. + # Unfortunately this requires us to unpack to level 2 and grep all the + # scripts in the package. + # the following checks is ignored if the package being checked is debconf + # itself. + + return + if ($self->processable->name eq 'debconf') + || ($self->processable->type eq 'udeb'); + + my @scripts + = grep { $_->is_script } @{$self->processable->installed->sorted_list}; + for my $item (@scripts) { + + next + unless $item->is_open_ok; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $position = 1; + while (my $line = <$fd>) { + + # Not perfect for Perl, but should be OK + $line =~ s/#.*//; + + if ( $line =~ m{/usr/share/debconf/confmodule} + || $line =~ /(?:Debconf|Debian::DebConf)::Client::ConfModule/){ + + $self->pointed_hint('debconf-is-not-a-registry', + $item->pointer($position)); + last; + } + + } continue { + ++$position; + } + + close $fd; + } + + return; +} # </run> + +# ----------------------------------- + +# Count the number of choices. Splitting code copied from debconf 1.5.8 +# (Debconf::Question). +sub count_choices { + my ($choices) = @_; + my @items; + my $item = $EMPTY; + for my $chunk (split /(\\[, ]|,\s+)/, $choices) { + if ($chunk =~ /^\\([, ])$/) { + $item .= $1; + } elsif ($chunk =~ /^,\s+$/) { + push(@items, $item); + $item = $EMPTY; + } else { + $item .= $chunk; + } + } + push(@items, $item) if $item ne $EMPTY; + return scalar(@items); +} + +# Manually interpolate shell variables, eg. $DPKG_MAINTSCRIPT_PACKAGE +sub get_template_name { + my ($self, $name) = @_; + + my $package = $self->processable->name; + return $name =~ s/^\$DPKG_MAINTSCRIPT_PACKAGE/$package/r; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/DesktopEntries.pm b/lib/Lintian/Check/Debian/DesktopEntries.pm new file mode 100644 index 0000000..cff6042 --- /dev/null +++ b/lib/Lintian/Check/Debian/DesktopEntries.pm @@ -0,0 +1,58 @@ +# debian/desktop-entries -- lintian check script -*- perl -*- + +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::DesktopEntries; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + return + if $self->processable->native; + + my $debiandir = $self->processable->patched->resolve_path('debian'); + return + unless $debiandir; + + my @files = grep { $_->is_file } $debiandir->descendants; + my @nopatches = grep { $_->name !~ m{^debian/patches/} } @files; + + my @manpages = grep { $_->basename =~ m{\.desktop$} } @nopatches; + + $self->pointed_hint('maintainer-desktop-entry', $_->pointer) for @manpages; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Filenames.pm b/lib/Lintian/Check/Debian/Filenames.pm new file mode 100644 index 0000000..c18b129 --- /dev/null +++ b/lib/Lintian/Check/Debian/Filenames.pm @@ -0,0 +1,78 @@ +# debian/filenames -- lintian check script -*- perl -*- + +# Copyright (C) 2019 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Filenames; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + # names are different in installation packages (see #429510) + # README and TODO may be handled differently + + my @often_misnamed = ( + { correct => 'NEWS', problematic => 'NEWS.Debian' }, + { correct => 'NEWS', problematic => 'NEWS.debian' }, + { correct => 'TODO', problematic => 'TODO.Debian' }, + { correct => 'TODO', problematic => 'TODO.debian' } + ); + + for my $relative (@often_misnamed) { + + my $problematic_item = $self->processable->patched->resolve_path( + 'debian/' . $relative->{problematic}); + + next + unless defined $problematic_item; + + my $correct_name = 'debian/' . $relative->{correct}; + if ($self->processable->patched->resolve_path($correct_name)) { + + $self->pointed_hint('duplicate-packaging-file', + $problematic_item->pointer, + 'better:', $correct_name); + + } else { + $self->pointed_hint( + 'incorrect-packaging-filename', + $problematic_item->pointer, + 'better:', $correct_name + ); + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Files.pm b/lib/Lintian/Check/Debian/Files.pm new file mode 100644 index 0000000..921f48b --- /dev/null +++ b/lib/Lintian/Check/Debian/Files.pm @@ -0,0 +1,60 @@ +# debian/files -- lintian check script -*- perl -*- +# +# based on debhelper check, +# Copyright (C) 1999 Joey Hess +# Copyright (C) 2000 Sean 'Shaleh' Perry +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2007 Russ Allbery +# Copyright (C) 2013-2018 Bastien ROUCARIES +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Files; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + return + unless $item->name eq 'debian/files'; + + $self->pointed_hint('debian-files-list-in-source', $item->pointer) + if $item->size > 0; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/LineSeparators.pm b/lib/Lintian/Check/Debian/LineSeparators.pm new file mode 100644 index 0000000..3c174ab --- /dev/null +++ b/lib/Lintian/Check/Debian/LineSeparators.pm @@ -0,0 +1,62 @@ +# debian/line-separators -- lintian check script -*- perl -*- +# +# based on debhelper check, +# Copyright (C) 1999 Joey Hess +# Copyright (C) 2000 Sean 'Shaleh' Perry +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2007 Russ Allbery +# Copyright (C) 2013-2018 Bastien ROUCARIES +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::LineSeparators; + +use v5.20; +use warnings; +use utf8; + +use List::SomeUtils qw(none); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +# files in ./debian to check for line terminators +my @CANDIDATES = qw(debian/control debian/changelog); + +sub visit_patched_files { + my ($self, $item) = @_; + + return + if none { $item->name eq $_ } @CANDIDATES; + + $self->pointed_hint('carriage-return-line-feed', $item->pointer) + if $item->bytes =~ m{\r\n\Z}m; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/LintianOverrides.pm b/lib/Lintian/Check/Debian/LintianOverrides.pm new file mode 100644 index 0000000..448e7f9 --- /dev/null +++ b/lib/Lintian/Check/Debian/LintianOverrides.pm @@ -0,0 +1,64 @@ +# debian/lintian-overrides -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::LintianOverrides; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + my $ppkg = quotemeta($self->processable->name); + + # misplaced overrides + if ($item->name =~ m{^usr/share/doc/$ppkg/override\.[lL]intian(?:\.gz)?$} + || $item->name =~ m{^usr/share/lintian/overrides/$ppkg/.+}) { + + $self->pointed_hint('override-file-in-wrong-location', $item->pointer); + + } elsif ($item->name =~ m{^usr/share/lintian/overrides/(.+)/.+$}) { + + my $expected = $1; + + $self->pointed_hint('override-file-in-wrong-package', + $item->pointer, $expected) + unless $self->processable->name eq $expected; + } + + $self->pointed_hint('old-source-override-location', $item->pointer) + if $item->name eq 'debian/source.lintian-overrides'; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/LintianOverrides/Comments.pm b/lib/Lintian/Check/Debian/LintianOverrides/Comments.pm new file mode 100644 index 0000000..11c0077 --- /dev/null +++ b/lib/Lintian/Check/Debian/LintianOverrides/Comments.pm @@ -0,0 +1,88 @@ +# debian/lintian-overrides/comments -- lintian check script -*- perl -*- + +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::LintianOverrides::Comments; + +use v5.20; +use warnings; +use utf8; + +use POSIX qw(ENOENT); + +use Lintian::Spelling qw(check_spelling check_spelling_picky); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub always { + my ($self) = @_; + + my @declared_overrides = @{$self->processable->overrides}; + + for my $override (@declared_overrides) { + + next + unless length $override->justification; + + my $tag_name = $override->tag_name; + + # comments appear one or more lines before the override + # but they were concatenated + my $position = $override->position - 1; + + my $pointer= $self->processable->override_file->pointer($position); + + check_spelling( + $self->data, + $override->justification, + $self->group->spelling_exceptions, + $self->emitter('spelling-in-override-comment',$pointer, $tag_name) + ); + + check_spelling_picky( + $self->data, + $override->justification, + $self->emitter( + 'capitalization-in-override-comment', + $pointer,$tag_name + ) + ); + } + + return; +} + +sub emitter { + my ($self, @prefixed) = @_; + + return sub { + return $self->pointed_hint(@prefixed, @_); + }; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/LintianOverrides/Duplicate.pm b/lib/Lintian/Check/Debian/LintianOverrides/Duplicate.pm new file mode 100644 index 0000000..e52d140 --- /dev/null +++ b/lib/Lintian/Check/Debian/LintianOverrides/Duplicate.pm @@ -0,0 +1,75 @@ +# debian/lintian-overrides/duplicate -- lintian check script -*- perl -*- + +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::LintianOverrides::Duplicate; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +const my $SPACE => q{ }; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub always { + my ($self) = @_; + + my %pattern_tracker; + for my $override (@{$self->processable->overrides}) { + + my $pattern = $override->pattern; + + # catch renames + my $tag_name = $self->profile->get_current_name($override->tag_name); + + push(@{$pattern_tracker{$tag_name}{$pattern}}, $override); + } + + for my $tag_name (keys %pattern_tracker) { + for my $pattern (keys %{$pattern_tracker{$tag_name}}) { + + my @overrides = @{$pattern_tracker{$tag_name}{$pattern}}; + + my @same_context = map { $_->position } @overrides; + my $line_numbers = join($SPACE, (sort @same_context)); + + my $override_item = $self->processable->override_file; + + $self->pointed_hint('duplicate-override-context', + $override_item->pointer,$tag_name,"(lines $line_numbers)") + if @overrides > 1; + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/LintianOverrides/Malformed.pm b/lib/Lintian/Check/Debian/LintianOverrides/Malformed.pm new file mode 100644 index 0000000..3772889 --- /dev/null +++ b/lib/Lintian/Check/Debian/LintianOverrides/Malformed.pm @@ -0,0 +1,52 @@ +# debian/lintian-overrides/malformed -- lintian check script -*- perl -*- + +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::LintianOverrides::Malformed; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub always { + my ($self) = @_; + + for my $error (@{$self->processable->override_errors}) { + + my $message = $error->{message}; + my $pointer = $error->{pointer}; + + $self->pointed_hint('malformed-override', $pointer, $message); + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/LintianOverrides/Mystery.pm b/lib/Lintian/Check/Debian/LintianOverrides/Mystery.pm new file mode 100644 index 0000000..92e6125 --- /dev/null +++ b/lib/Lintian/Check/Debian/LintianOverrides/Mystery.pm @@ -0,0 +1,65 @@ +# debian/lintian-overrides/mystery -- lintian check script -*- perl -*- + +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::LintianOverrides::Mystery; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +const my $ARROW => q{=>}; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub always { + my ($self) = @_; + + for my $override (@{$self->processable->overrides}) { + + my $override_item = $self->processable->override_file; + my $pointer = $override_item->pointer($override->position); + + my $mystery_name = $override->tag_name; + my $current_name = $self->profile->get_current_name($mystery_name); + + $self->pointed_hint('alien-tag', $pointer, $mystery_name) + if !length $current_name; + + $self->pointed_hint('renamed-tag', $pointer, $mystery_name, $ARROW, + $current_name) + if length $current_name + && $current_name ne $mystery_name; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/LintianOverrides/Restricted.pm b/lib/Lintian/Check/Debian/LintianOverrides/Restricted.pm new file mode 100644 index 0000000..cc2cda4 --- /dev/null +++ b/lib/Lintian/Check/Debian/LintianOverrides/Restricted.pm @@ -0,0 +1,80 @@ +# debian/lintian-overrides/restricted -- lintian check script -*- perl -*- + +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::LintianOverrides::Restricted; + +use v5.20; +use warnings; +use utf8; + +use List::SomeUtils qw(true); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub always { + my ($self) = @_; + + for my $override (@{$self->processable->overrides}) { + + my $override_item = $self->processable->override_file; + my $pointer = $override_item->pointer($override->position); + + my @architectures = @{$override->architectures}; + + if (@architectures && $self->processable->architecture eq 'all') { + $self->pointed_hint('invalid-override-restriction', + $pointer,'Architecture list in Arch:all installable'); + next; + } + + my @invalid + = grep { !$self->data->architectures->valid_restriction($_) } + @architectures; + $self->pointed_hint('invalid-override-restriction', + $pointer,"Unknown architecture wildcard $_") + for @invalid; + + next + if @invalid; + + # count negations + my $negations = true { /^!/ } @architectures; + + # confirm it is either all or none + if ($negations > 0 && $negations != @architectures) { + $self->pointed_hint('invalid-override-restriction', + $pointer,'Inconsistent architecture negation'); + next; + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Maintscript.pm b/lib/Lintian/Check/Debian/Maintscript.pm new file mode 100644 index 0000000..adee6be --- /dev/null +++ b/lib/Lintian/Check/Debian/Maintscript.pm @@ -0,0 +1,73 @@ +# debian/maintscript -- lintian check script -*- perl -*- + +# Copyright (C) 1999 by Joey Hess +# Copyright (C) 2016-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Maintscript; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->dirname eq 'debian/'; + + return + unless $item->basename =~ m{ (?: ^ | [.] ) maintscript $}x; + + return + unless $item->is_open_ok; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $position = 1; + while (my $line = <$fd>) { + + my $pointer = $item->pointer($position); + + $self->pointed_hint('maintscript-includes-maint-script-parameters', + $pointer) + if $line =~ /--\s+"\$(?:@|{@})"\s*$/; + + } continue { + ++$position; + } + + close $fd; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/ManualPages.pm b/lib/Lintian/Check/Debian/ManualPages.pm new file mode 100644 index 0000000..f1b654a --- /dev/null +++ b/lib/Lintian/Check/Debian/ManualPages.pm @@ -0,0 +1,67 @@ +# debian/manual-pages -- lintian check script -*- perl -*- + +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::ManualPages; + +use v5.20; +use warnings; +use utf8; + +use List::SomeUtils qw{none}; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + return + if $self->processable->native; + + my $debiandir = $self->processable->patched->resolve_path('debian'); + return + unless $debiandir; + + my @files = grep { $_->is_file } $debiandir->descendants; + my @nopatches = grep { $_->name !~ m{^debian/patches/} } @files; + + my @manual_pages = grep { $_->basename =~ m{\.\d$} } @nopatches; + + for my $item (@manual_pages) { + + my $command = $item->basename; + $command =~ s/ [.] \d $//x; + + $self->pointed_hint('maintainer-manual-page', $item->pointer) + if none { $command eq $_->basename } @files; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/NotInstalled.pm b/lib/Lintian/Check/Debian/NotInstalled.pm new file mode 100644 index 0000000..6e787b4 --- /dev/null +++ b/lib/Lintian/Check/Debian/NotInstalled.pm @@ -0,0 +1,74 @@ +# debian/not-installed -- lintian check script -*- perl -*- + +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::NotInstalled; + +use v5.20; +use warnings; +use utf8; + +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->name eq 'debian/not-installed'; + + return + unless $item->is_open_ok; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $position = 1; + while (my $line = <$fd>) { + + # disregard comments + next + if $line =~ m{^ \s* [#] }x; + + # architecture triplet + $self->pointed_hint('unwanted-path-too-specific', + $item->pointer($position), $line) + if $line =~ m{^ usr/lib/ [^/-]+ - [^/-]+ - [^/-]+ / }x + && $line !~ m{^ usr/lib/ [*] / }x; + + } continue { + ++$position; + } + + close $fd; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Patches.pm b/lib/Lintian/Check/Debian/Patches.pm new file mode 100644 index 0000000..b9a3ec2 --- /dev/null +++ b/lib/Lintian/Check/Debian/Patches.pm @@ -0,0 +1,104 @@ +# debian/patches -- lintian check script -*- perl -*- +# +# Copyright (C) 2007 Marc Brockschmidt +# Copyright (C) 2008 Raphael Hertzog +# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Patches; + +use v5.20; +use warnings; +use utf8; + +use Path::Tiny; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my @patch_system; + + # Get build deps so we can decide which build system the + # maintainer meant to use: + my $build_deps = $self->processable->relation('Build-Depends-All'); + + # Get source package format + my $source_format = $self->processable->fields->value('Format'); + my $quilt_format = ($source_format =~ /3\.\d+ \(quilt\)/) ? 1 : 0; + + my $debian_dir = $self->processable->patched->resolve_path('debian/'); + return + unless defined $debian_dir; + + my $patch_dir = $debian_dir->resolve_path('patches'); + + # Find debian/patches/series, assuming debian/patches is a (symlink to a) + # dir. There are cases, where it is a file (ctwm: #778556) + my $patch_series; + $patch_series + = $self->processable->patched->resolve_path('debian/patches/series'); + + push(@patch_system, 'dpatch') + if $build_deps->satisfies('dpatch'); + + push(@patch_system, 'quilt') + if $quilt_format || $build_deps->satisfies('quilt'); + + $self->hint('patch-system', $_) for @patch_system; + + $self->hint('more-than-one-patch-system') + if @patch_system > 1; + + if (@patch_system && !$quilt_format) { + + my $readme = $debian_dir->resolve_path('README.source'); + $self->hint('patch-system-but-no-source-readme') + unless defined $readme; + } + + my @direct_changes + = grep { !m{^debian/} } keys %{$self->processable->diffstat}; + if (@direct_changes) { + + my $files = $direct_changes[0]; + $files .= " and $#direct_changes more" + if @direct_changes > 1; + + $self->hint('patch-system-but-direct-changes-in-diff', $files) + if @patch_system; + + $self->hint('direct-changes-in-diff-but-no-patch-system', $files) + unless @patch_system; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Patches/Count.pm b/lib/Lintian/Check/Debian/Patches/Count.pm new file mode 100644 index 0000000..589e2ba --- /dev/null +++ b/lib/Lintian/Check/Debian/Patches/Count.pm @@ -0,0 +1,54 @@ +# debian/patches/count -- lintian check script -*- perl -*- +# +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Patches::Count; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->name eq 'debian/patches/series'; + + my @lines = split(/\n/, $item->decoded_utf8); + + # remove lines containing only comments + my @patches = grep { !/^\s*(?:#|$)/ } @lines; + + $self->pointed_hint('number-of-patches', $item->pointer, scalar @patches); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Patches/Dep3.pm b/lib/Lintian/Check/Debian/Patches/Dep3.pm new file mode 100644 index 0000000..6624a0c --- /dev/null +++ b/lib/Lintian/Check/Debian/Patches/Dep3.pm @@ -0,0 +1,105 @@ +# debian/patches/dep3 -- lintian check script -*- perl -*- + +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Patches::Dep3; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(any none); +use Syntax::Keyword::Try; +use Unicode::UTF8 qw(valid_utf8 decode_utf8); + +use Lintian::Deb822; + +const my $EMPTY => q{}; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->name =~ m{^debian/patches/}; + + return + unless $item->is_file; + + return + if $item->name eq 'debian/patches/series' + || $item->name eq 'debian/patches/README'; + + my $bytes = $item->bytes; + return + unless length $bytes; + + my ($headerbytes) = split(/^---/m, $bytes, 2); + + return + unless valid_utf8($headerbytes); + + my $header = decode_utf8($headerbytes); + return + unless length $header; + + my $deb822 = Lintian::Deb822->new; + + my @sections; + try { + @sections = $deb822->parse_string($header); + + } catch { + return; + } + + return + unless @sections; + + # use last mention when present multiple times + my $origin = $deb822->last_mention('Origin'); + + my ($category) = split(m{\s*,\s*}, $origin, 2); + $category //= $EMPTY; + return + if any { $category eq $_ } qw(upstream backport); + + $self->pointed_hint('patch-not-forwarded-upstream', $item->pointer) + if $deb822->last_mention('Forwarded') eq 'no' + || none { length } ( + $deb822->last_mention('Applied-Upstream'), + $deb822->last_mention('Bug'), + $deb822->last_mention('Forwarded') + ); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Patches/Dpatch.pm b/lib/Lintian/Check/Debian/Patches/Dpatch.pm new file mode 100644 index 0000000..337fa53 --- /dev/null +++ b/lib/Lintian/Check/Debian/Patches/Dpatch.pm @@ -0,0 +1,150 @@ +# debian/patches -- lintian check script -*- perl -*- +# +# Copyright (C) 2007 Marc Brockschmidt +# Copyright (C) 2008 Raphael Hertzog +# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Patches::Dpatch; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; +const my $SPACE => q{ }; + +sub source { + my ($self) = @_; + + my $build_deps = $self->processable->relation('Build-Depends-All'); + return + unless $build_deps->satisfies('dpatch'); + + my $patch_dir + = $self->processable->patched->resolve_path('debian/patches/'); + return + unless defined $patch_dir; + + $self->hint('package-uses-deprecated-dpatch-patch-system'); + + my @list_files + = grep {$_->basename =~ m/^00list/ && $_->is_open_ok} + $patch_dir->children; + + $self->hint('dpatch-build-dep-but-no-patch-list') + unless @list_files; + + my $options_file = $patch_dir->resolve_path('00options'); + + my $list_uses_cpp = 0; + $list_uses_cpp = 1 + if defined $options_file + && $options_file->decoded_utf8 =~ /DPATCH_OPTION_CPP=1/; + + for my $file (@list_files) { + my @patches; + + open(my $fd, '<', $file->unpacked_path) + or die encode_utf8('Cannot open ' . $file->unpacked_path); + + while(my $line = <$fd>) { + chomp $line; + + #ignore comments or CPP directive + next + if $line =~ /^\#/; + + # remove C++ style comments + $line =~ s{//.*}{} + if $list_uses_cpp; + + if ($list_uses_cpp && $line =~ m{/\*}) { + + # remove C style comments + $line .= <$fd> while ($line !~ m{\*/}); + + $line =~ s{/\*[^*]*\*/}{}g; + } + + #ignore blank lines + next + if $line =~ /^\s*$/; + + push @patches, split($SPACE, $line); + } + close($fd); + + for my $patch_name (@patches) { + + my $patch_file = $patch_dir->child($patch_name); + $patch_file = $patch_dir->child("${patch_name}.dpatch") + unless defined $patch_file; + + unless (defined $patch_file) { + $self->hint('dpatch-index-references-non-existent-patch', + $patch_name); + next; + } + + next + unless $patch_file->is_open_ok; + + my $description = $EMPTY; + open(my $fd, '<', $patch_file->unpacked_path) + or die encode_utf8('Cannot open ' . $patch_file->unpacked_path); + + while (my $line = <$fd>) { + # stop if something looking like a patch + # starts: + last + if $line =~ /^---/; + # note comment if we find a proper one + $description .= $1 + if $line =~ /^\#+\s*DP:\s*(\S.*)$/ + && $1 !~ /^no description\.?$/i; + $description .= $1 + if $line =~ /^\# (?:Description|Subject): (.*)/; + } + close($fd); + + $self->pointed_hint('dpatch-missing-description', + $patch_file->pointer) + unless length $description; + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Patches/Quilt.pm b/lib/Lintian/Check/Debian/Patches/Quilt.pm new file mode 100644 index 0000000..2e78055 --- /dev/null +++ b/lib/Lintian/Check/Debian/Patches/Quilt.pm @@ -0,0 +1,290 @@ +# debian/patches/quilt -- lintian check script -*- perl -*- +# +# Copyright (C) 2007 Marc Brockschmidt +# Copyright (C) 2008 Raphael Hertzog +# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Patches::Quilt; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(any); +use Unicode::UTF8 qw(decode_utf8 encode_utf8); + +use Lintian::IPC::Run3 qw(safe_qx); +use Lintian::Spelling qw(check_spelling); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $PATCH_DESC_TEMPLATE => + 'TODO: Put a short summary on the line above and replace this paragraph'; +const my $EMPTY => q{}; + +sub spelling_tag_emitter { + my ($self, $tag_name, $item, @orig_args) = @_; + + my $pointer = $item->pointer($.); + + return sub { + return $self->pointed_hint($tag_name, $pointer, @orig_args, @_); + }; +} + +sub source { + my ($self) = @_; + + my $build_deps = $self->processable->relation('Build-Depends-All'); + + my $source_format = $self->processable->fields->value('Format'); + my $quilt_format = ($source_format =~ /3\.\d+ \(quilt\)/) ? 1 : 0; + + my $debian_dir = $self->processable->patched->resolve_path('debian/'); + return + unless defined $debian_dir; + + my $patch_dir = $debian_dir->resolve_path('patches'); + my %known_files; + + # Find debian/patches/series, assuming debian/patches is a (symlink to a) + # dir. There are cases, where it is a file (ctwm: #778556) + my $patch_series; + $patch_series + = $self->processable->patched->resolve_path('debian/patches/series'); + + # 3.0 (quilt) sources do not need quilt + unless ($quilt_format) { + + $self->hint('quilt-build-dep-but-no-series-file') + if $build_deps->satisfies('quilt') + && (!defined $patch_series || !$patch_series->is_open_ok); + + $self->pointed_hint('quilt-series-but-no-build-dep', + $patch_series->pointer) + if $patch_series + && $patch_series->is_file + && !$build_deps->satisfies('quilt'); + } + + return + unless $quilt_format || $build_deps->satisfies('quilt'); + + if ($patch_series && $patch_series->is_open_ok) { + + my @patch_names; + + open(my $series_fd, '<', $patch_series->unpacked_path) + or die encode_utf8('Cannot open ' . $patch_series->unpacked_path); + + my $position = 1; + while (my $line = <$series_fd>) { + + # Strip comment + $line =~ s/(?:^|\s+)#.*$//; + + if (rindex($line,"\n") < 0) { + $self->pointed_hint('quilt-series-without-trailing-newline', + $patch_series->pointer); + } + + # trim both ends + $line =~ s/^\s+|\s+$//g; + + next + unless length $line; + + if ($line =~ m{^(\S+)\s+(\S.*)$}) { + + my $patch = $1; + my $patch_options = $2; + + push(@patch_names, $patch); + + $self->pointed_hint('quilt-patch-with-non-standard-options', + $patch_series->pointer($position), $line) + unless $patch_options eq '-p1'; + + } else { + push(@patch_names, $line); + } + + } continue { + ++$position; + } + + close $series_fd; + + my @patch_files; + for my $name (@patch_names) { + + my $item = $patch_dir->resolve_path($name); + + if (defined $item && $item->is_file) { + push(@patch_files, $item); + + } else { + $self->pointed_hint( + 'quilt-series-references-non-existent-patch', + $patch_series->pointer, $name); + } + } + + for my $item (@patch_files) { + + next + unless $item->is_open_ok; + + my $description = $EMPTY; + my $has_template_description = 0; + + open(my $patch_fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + while (my $line = <$patch_fd>) { + + # stop if something looking like a patch starts: + last + if $line =~ /^---/; + + next + if $line =~ /^\s*$/; + + # Skip common "lead-in" lines + $description .= $line + unless $line =~ m{^(?:Index: |=+$|diff .+|index |From: )}; + + $has_template_description = 1 + if $line =~ / \Q$PATCH_DESC_TEMPLATE\E /msx; + } + close $patch_fd; + + $self->pointed_hint('quilt-patch-missing-description', + $item->pointer) + unless length $description; + + $self->pointed_hint('quilt-patch-using-template-description', + $item->pointer) + if $has_template_description; + + $self->check_patch($item, $description); + } + } + + if ($quilt_format) { # 3.0 (quilt) specific checks + # Format 3.0 packages may generate a debian-changes-$version patch + my $version = $self->processable->fields->value('Version'); + my $patch_header= $debian_dir->resolve_path('source/patch-header'); + my $versioned_patch; + + $versioned_patch= $patch_dir->resolve_path("debian-changes-$version") + if $patch_dir; + + if (defined $versioned_patch && $versioned_patch->is_file) { + + $self->pointed_hint('format-3.0-but-debian-changes-patch', + $versioned_patch->pointer) + if !defined $patch_header || !$patch_header->is_file; + } + } + + if ($patch_dir and $patch_dir->is_dir and $source_format ne '2.0') { + # Check all series files, including $vendor.series + for my $item ($patch_dir->children) { + next + unless $item->name =~ /\/(.+\.)?series$/; + next + unless $item->is_open_ok; + + $known_files{$item->basename}++; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + while (my $line = <$fd>) { + $known_files{$1}++ + if $line =~ m{^\s*(?:#+\s*)?(\S+)}; + } + close($fd); + + $self->pointed_hint('package-uses-vendor-specific-patch-series', + $item->pointer) + if $item->name =~ m{ [.]series $}x; + } + + for my $item ($patch_dir->descendants) { + next + if $item->basename =~ /^README(\.patches)?$/ + || $item->basename =~ /\.in/g; + + # Use path relative to debian/patches for "subdir/foo" + my $name = substr($item, length $patch_dir); + + $self->pointed_hint( + 'patch-file-present-but-not-mentioned-in-series', + $item->pointer) + unless $known_files{$name} || $item->is_dir; + } + } + + return; +} + +# Checks on patches common to all build systems. +sub check_patch { + my ($self, $item, $description) = @_; + + unless (any { /(spelling|typo)/i } ($item->name, $description)) { + my $tag_emitter + = $self->spelling_tag_emitter('spelling-error-in-patch-description', + $item); + check_spelling($self->data, $description, + $self->group->spelling_exceptions, + $tag_emitter, 0); + } + + # Use --strip=1 to strip off the first layer of directory in case + # the parent directory in which the patches were generated was + # named "debian". This will produce false negatives for --strip=0 + # patches that modify files in the debian/* directory, but as of + # 2010-01-01, all cases where the first level of the patch path is + # "debian/" in the archive are false positives. + my $bytes = safe_qx('lsdiff', '--strip=1', $item->unpacked_path); + my $output = decode_utf8($bytes); + + my @debian_files = ($output =~ m{^((?:\./)?debian/.*)$}ms); + + $self->pointed_hint('patch-modifying-debian-files', $item->pointer, $_) + for @debian_files; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/PoDebconf.pm b/lib/Lintian/Check/Debian/PoDebconf.pm new file mode 100644 index 0000000..333fee5 --- /dev/null +++ b/lib/Lintian/Check/Debian/PoDebconf.pm @@ -0,0 +1,391 @@ +# debian/po-debconf -- lintian check script -*- perl -*- + +# Copyright (C) 2002-2004 by Denis Barbier <barbier@linuxfr.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::PoDebconf; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Cwd qw(realpath); +use File::Temp(); +use IPC::Run3; +use Syntax::Keyword::Try; +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::IPC::Run3 qw(safe_qx); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; + +sub source { + my ($self) = @_; + + my $processable = $self->processable; + + my $has_template = 0; + my @lang_templates; + my $full_translation = 0; + + my $debian_dir = $processable->patched->resolve_path('debian/'); + return + unless $debian_dir; + + my $debian_po_dir = $debian_dir->resolve_path('po'); + my ($templ_pot_path, $potfiles_in_path); + + if ($debian_po_dir and $debian_po_dir->is_dir) { + $templ_pot_path = $debian_po_dir->resolve_path('templates.pot'); + $potfiles_in_path = $debian_po_dir->resolve_path('POTFILES.in'); + } + + # First, check whether this package seems to use debconf but not + # po-debconf. Read the templates file and look at the template + # names it provides, since some shared templates aren't + # translated. + for my $item ($debian_dir->children) { + next + unless $item->is_open_ok; + + if ($item->basename =~ m/^(.+\.)?templates(\..+)?$/) { + if ($item->basename =~ m/templates\.\w\w(_\w\w)?$/) { + push(@lang_templates, $item); + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + while (my $line = <$fd>) { + + $self->pointed_hint('untranslatable-debconf-templates', + $item->pointer($.)) + if $line =~ /^Description: (.+)/i + && $1 !~/for internal use/; + } + + close $fd; + + } else { + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $in_template = 0; + my $saw_tl_note = 0; + while (my $line = <$fd>) { + chomp $line; + + $self->pointed_hint('translated-default-field', + $item->pointer($.)) + if $line =~ m{^_Default(?:Choice)?: [^\[]*$} + && !$saw_tl_note; + + $self->pointed_hint('untranslatable-debconf-templates', + $item->pointer($.)) + if $line =~ /^Description: (.+)/i + && $1 !~/for internal use/; + + if ($line =~ /^#/) { + # Is this a comment for the translators? + $saw_tl_note = 1 + if $line =~ /translators/i; + + next; + } + + # If it is not a continuous comment immediately before the + # _Default(Choice) field, we don't care about it. + $saw_tl_note = 0; + + if ($line =~ /^Template: (\S+)/i) { + my $template = $1; + next + if $template eq 'shared/packages-wordlist' + or $template eq 'shared/packages-ispell'; + + next + if $template =~ m{/languages$}; + + $in_template = 1; + + } elsif ($in_template && $line =~ /^_?Description: (.+)/i){ + my $description = $1; + next + if $description =~ /for internal use/; + $has_template = 1; + + } elsif ($in_template && !length($line)) { + $in_template = 0; + } + } + + close($fd); + } + } + } + + #TODO: check whether all templates are named in TEMPLATES.pot + if ($has_template) { + if (not $debian_po_dir or not $debian_po_dir->is_dir) { + $self->hint('not-using-po-debconf'); + return; + } + } else { + return; + } + + # If we got here, we're using po-debconf, so there shouldn't be any stray + # language templates left over from debconf-mergetemplate. + for my $item (@lang_templates) { + $self->pointed_hint('stray-translated-debconf-templates', + $item->pointer) + unless $item->basename =~ m{ templates[.]in$}x; + } + + my $missing_files = 0; + + if ($potfiles_in_path and $potfiles_in_path->is_open_ok) { + + open(my $fd, '<', $potfiles_in_path->unpacked_path) + or + die encode_utf8('Cannot open ' . $potfiles_in_path->unpacked_path); + + my $position = 1; + while (my $line = <$fd>) { + chomp $line; + + next + if $line =~ /^\s*\#/; + + $line =~ s/.*\]\s*//; + + # Cannot check files which are not under debian/ + # m,^\.\./, or + next + if $line eq $EMPTY; + + my $pointer = $potfiles_in_path->pointer($position); + + my $po_path = $debian_dir->resolve_path($line); + unless ($po_path and $po_path->is_file) { + + $self->pointed_hint('missing-file-from-potfiles-in', + $pointer, $line); + $missing_files = 1; + } + + } continue { + ++$position; + } + + close $fd; + + } else { + $self->hint('missing-potfiles-in'); + $missing_files = 1; + } + if (not $templ_pot_path or not $templ_pot_path->is_open_ok) { + # We use is_open_ok here, because if it is present, we will + # (have a subprocess) open it if the POTFILES.in file also + # existed. + $self->hint('missing-templates-pot'); + $missing_files = 1; + } + + if ($missing_files == 0) { + my $temp_obj + = File::Temp->newdir('lintian-po-debconf-XXXXXX',TMPDIR => 1); + my $abs_tempdir = realpath($temp_obj->dirname) + or croak('Cannot resolve ' . $temp_obj->dirname . ": $!"); + # We need an extra level of dirs, as intltool (in)directly + # tries to use files in ".." if they exist + # (e.g. ../templates.h). + # - In fact, we also need to copy debian/templates into + # this "fake package directory", since intltool-updates + # sometimes want to write files to "../templates" based + # on the contents of the package. (See #778558) + my $tempdir = "$abs_tempdir/po"; + my $test_pot = "$tempdir/test.pot"; + my $tempdir_templates = "${abs_tempdir}/templates"; + my $d_templates = $debian_dir->resolve_path('templates'); + + # Create our extra level + mkdir($tempdir) + or die encode_utf8('Cannot create directory ' . $tempdir); + + # Copy the templates dir because intltool-update might + # write to it. + safe_qx( + qw{cp -a --reflink=auto --}, + $d_templates->unpacked_path, + $tempdir_templates + )if $d_templates; + + my $error; + my %save = %ENV; + my $cwd = Cwd::getcwd; + + try { + $ENV{INTLTOOL_EXTRACT} + = '/usr/share/intltool-debian/intltool-extract'; + # use of $debian_po is safe; we accessed two children by now. + $ENV{srcdir} = $debian_po_dir->unpacked_path; + + chdir($tempdir) + or die encode_utf8('Cannot change directory ' . $tempdir); + + # generate a "test.pot" in a tempdir + my @intltool = ( + '/usr/share/intltool-debian/intltool-update', + '--gettext-package=test','--pot' + ); + safe_qx(@intltool); + die encode_utf8("system @intltool failed: $?") + if $?; + + } catch { + # catch any error + $error = $@; + + } finally { + # restore environment + %ENV = %save; + + # restore working directory + chdir($cwd) + or die encode_utf8('Cannot change directory ' . $cwd); + } + + # output could be helpful to user but is currently not printed + + if ($error) { + $self->pointed_hint('invalid-potfiles-in', + $potfiles_in_path->pointer); + return; + } + + # throw away output on the following commands + $error = undef; + + try { + # compare our "test.pot" with the existing "templates.pot" + my @testleft = ( + 'msgcmp', '--use-untranslated', + $test_pot, $templ_pot_path->unpacked_path + ); + safe_qx(@testleft); + die encode_utf8("system @testleft failed: $?") + if $?; + + # is this not equivalent to the previous command? - FL + my @testright = ( + 'msgcmp', '--use-untranslated', + $templ_pot_path->unpacked_path, $test_pot + ); + safe_qx(@testright); + die encode_utf8("system @testright failed: $?") + if $?; + + } catch { + # catch any error + $error = $@; + } + + $self->pointed_hint('newer-debconf-templates',$templ_pot_path->pointer) + if length $error; + } + + return + unless $debian_po_dir; + + for my $po_item ($debian_po_dir->children) { + + next + unless $po_item->basename =~ m/\.po$/ || $po_item->is_dir; + + $self->pointed_hint('misnamed-po-file', $po_item->pointer) + unless ( + $po_item->basename =~ /^[a-z]{2,3}(_[A-Z]{2})?(?:\@[^\.]+)?\.po$/); + + next + unless $po_item->is_open_ok; + + my $bytes = $po_item->bytes; + + $self->pointed_hint('debconf-translation-using-general-list', + $po_item->pointer) + if $bytes =~ /Language\-Team:.*debian-i18n\@lists\.debian\.org/i; + + unless ($bytes =~ /^msgstr/m) { + + $self->pointed_hint('invalid-po-file', $po_item->pointer); + next; + } + + if ($bytes =~ /charset=(.*?)\\n/) { + + my $charset = ($1 eq 'CHARSET' ? $EMPTY : $1); + + $self->pointed_hint('unknown-encoding-in-po-file', + $po_item->pointer) + unless length $charset; + } + + my $error; + + my $stats; + + delete local $ENV{$_} + for grep { $_ ne 'PATH' && $_ ne 'TMPDIR' } keys %ENV; + local $ENV{LC_ALL} = 'C'; + + my @command = ( + 'msgfmt', '-o', '/dev/null', '--statistics', + $po_item->unpacked_path + ); + + run3(\@command, \undef, \undef, \$stats); + + $self->pointed_hint('invalid-po-file', $po_item->pointer) + if $?; + + $stats //= $EMPTY; + + $full_translation = 1 + if $stats =~ m/^\w+ \w+ \w+\.$/; + } + + $self->hint('no-complete-debconf-translation') + if !$full_translation; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Readme.pm b/lib/Lintian/Check/Debian/Readme.pm new file mode 100644 index 0000000..c8fd030 --- /dev/null +++ b/lib/Lintian/Check/Debian/Readme.pm @@ -0,0 +1,176 @@ +# debian/readme -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Richard Braakman +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Readme; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::Spelling qw(check_spelling); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; +const my $VERTICAL_BAR => q{|}; + +sub spelling_tag_emitter { + my ($self, $tag_name, $item, @orig_args) = @_; + + my $pointer = $item->pointer($.); + + return sub { + return $self->pointed_hint($tag_name, $pointer, @orig_args, @_); + }; +} + +sub open_readme { + my ($pkg_name, $processable) = @_; + + my $doc_dir + = $processable->installed->resolve_path("usr/share/doc/${pkg_name}/"); + + if (defined $doc_dir) { + + for my $name ( + qw(README.Debian.gz README.Debian README.debian.gz README.debian)){ + + my $path = $doc_dir->child($name); + + next + unless $path && $path->is_open_ok; + + if ($name =~ m/\.gz$/) { + open(my $fd, '<:gzip', $path->unpacked_path) + or die encode_utf8('Cannot open ' . $path->unpacked_path); + + return $fd; + } + + open(my $fd, '<', $path->unpacked_path) + or die encode_utf8('Cannot open ' . $path->unpacked_path); + + return $fd; + } + } + + return undef; +} + +sub installable { + my ($self) = @_; + + my $pkg_name = $self->processable->name; + my $group = $self->group; + + my $doc_dir + = $self->processable->installed->resolve_path( + "usr/share/doc/${pkg_name}/"); + + return + unless defined $doc_dir; + + my $item; + my $fd; + + for my $name ( + qw(README.Debian.gz README.Debian README.debian.gz README.debian)){ + + $item = $doc_dir->child($name); + + next + unless $item && $item->is_open_ok; + + if ($name =~ m/\.gz$/) { + open($fd, '<:gzip', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + last; + } + + open($fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + last; + } + + return + unless defined $item + && defined $fd; + + my $readme = $EMPTY; + + my $position = 1; + while (my $line = <$fd>) { + + my $pointer = $item->pointer($position); + + $self->pointed_hint('readme-debian-mentions-usr-doc', $pointer) + if $line =~ m{ /usr/doc \b }x; + + $readme .= $line; + + } continue { + ++$position; + } + + close $fd; + + my @template =( + 'Comments regarding the Package', + 'So far nothing to say', + '<possible notes regarding this package - if none, delete this file>', + 'Automatically generated by debmake' + ); + + my $regex = join($VERTICAL_BAR, @template); + + if ($readme =~ m/$regex/i) { + $self->pointed_hint('readme-debian-contains-debmake-template', + $item->pointer); + + } elsif ($readme =~ m/^\s*-- [^<]*<([^> ]+.\@[^>.]*)>/m) { + + my $address = $1; + + $self->pointed_hint('readme-debian-contains-invalid-email-address', + $item->pointer, $address); + } + + check_spelling($self->data,$readme,$group->spelling_exceptions, + $self->spelling_tag_emitter('spelling-error-in-readme-debian', $item)); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Rules.pm b/lib/Lintian/Check/Debian/Rules.pm new file mode 100644 index 0000000..ffae6cb --- /dev/null +++ b/lib/Lintian/Check/Debian/Rules.pm @@ -0,0 +1,671 @@ +# debian/rules -- lintian check script -*- perl -*- + +# Copyright (C) 2006 Russ Allbery <rra@debian.org> +# Copyright (C) 2005 Rene van Bevern <rvb@pro-linux.de> +# Copyright (C) 2019-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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. + +package Lintian::Check::Debian::Rules; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(croak); +use Const::Fast; +use List::Compare; +use List::SomeUtils qw(any none uniq); +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $PERCENT => q{%}; + +my @py3versions = qw(3.4 3.5 3.6 3.7); + +my $PYTHON_DEPEND= 'python2:any | python2-dev:any'; +my $PYTHON3_DEPEND + = 'python3:any | python3-dev:any | python3-all:any | python3-all-dev:any'; +my $PYTHON2X_DEPEND = 'python2.7:any | python2.7-dev:any'; +my $PYTHON3X_DEPEND + = join(' | ',map { "python${_}:any | python${_}-dev:any" } @py3versions); +my $ANYPYTHON_DEPEND + = "$PYTHON_DEPEND | $PYTHON2X_DEPEND | $PYTHON3_DEPEND | $PYTHON3X_DEPEND"; +my $PYTHON3_ALL_DEPEND + = 'python3-all:any | python3-all-dev:any | python3-all-dbg:any'; + +my %TAG_FOR_POLICY_TARGET = ( + build => 'debian-rules-missing-required-target', + binary => 'debian-rules-missing-required-target', + 'binary-arch' => 'debian-rules-missing-required-target', + 'binary-indep' => 'debian-rules-missing-required-target', + clean => 'debian-rules-missing-required-target', + 'build-arch' => 'debian-rules-missing-required-target', + 'build-indep' => 'debian-rules-missing-required-target' +); + +# Rules about required debhelper command ordering. Each command is put into a +# class and the tag is issued if they're called in the wrong order for the +# classes. Unknown commands won't trigger this flag. +my %debhelper_order = ( + dh_makeshlibs => 1, + dh_shlibdeps => 2, + dh_installdeb => 2, + dh_gencontrol => 2, + dh_builddeb => 3 +); + +sub source { + my ($self) = @_; + + my $debian_dir = $self->processable->patched->resolve_path('debian'); + + my $rules; + $rules = $debian_dir->child('rules') + if defined $debian_dir; + + return + unless defined $rules; + + # Policy could be read as allowing debian/rules to be a symlink to + # some other file, and in a native Debian package it could be a + # symlink to a file that we didn't unpack. + $self->pointed_hint('debian-rules-is-symlink', $rules->pointer) + if $rules->is_symlink; + + # dereference symbolic links + $rules = $rules->follow; + + return + unless defined $rules; + + $self->pointed_hint('debian-rules-not-executable', $rules->pointer) + unless $rules->is_executable; + + my $KNOWN_MAKEFILES= $self->data->load('rules/known-makefiles', '\|\|'); + my $DEPRECATED_MAKEFILES= $self->data->load('rules/deprecated-makefiles'); + + my $architecture = $self->processable->fields->value('Architecture'); + + # If the version field is missing, we assume a neutral non-native one. + my $version = $self->processable->fields->value('Version') || '0-1'; + + # Check for required #!/usr/bin/make -f opening line. Allow -r or -e; a + # strict reading of Policy doesn't allow either, but they seem harmless. + $self->pointed_hint('debian-rules-not-a-makefile', $rules->pointer) + unless $rules->hashbang =~ m{^/usr/bin/make\s+-[re]?f[re]?$}; + + # Certain build tools must be listed in Build-Depends even if there are no + # arch-specific packages because they're required in order to run the clean + # rule. (See Policy 7.6.) The following is a list of package dependencies; + # regular expressions that, if they match anywhere in the debian/rules file, + # say that this package is allowed (and required) in Build-Depends; and + # optional tags to use for reporting the problem if some information other + # than the default is required. + my %GLOBAL_CLEAN_DEPENDS = ( + 'ant:any' => [qr{^include\s*/usr/share/cdbs/1/rules/ant\.mk}], + 'cdbs:any' => [ + qr{^include\s+/usr/share/cdbs/}, + qr{^include\s+/usr/share/R/debian/r-cran\.mk} + ], + 'dbs:any' => [qr{^include\s+/usr/share/dbs/}], + 'dh-make-php:any' => [qr{^include\s+/usr/share/cdbs/1/class/pear\.mk}], + 'debhelper:any | debhelper-compat:any' =>[ + qr{^include\s+/usr/share/cdbs/1/rules/debhelper\.mk}, + qr{^include\s+/usr/share/R/debian/r-cran\.mk} + ], + 'dpatch:any' => [ + qr{^include\s+/usr/share/dpatch/}, + qr{^include\s+/usr/share/cdbs/1/rules/dpatch\.mk} + ], + 'gnome-pkg-tools:any | dh-sequence-gnome:any' => + [qr{^include\s+/usr/share/gnome-pkg-tools/}], + 'quilt:any' => [ + qr{^include\s+/usr/share/quilt/}, + qr{^include\s+/usr/share/cdbs/1/rules/patchsys-quilt\.mk} + ], + 'mozilla-devscripts:any' => + [qr{^include\s+/usr/share/mozilla-devscripts/}], + 'ruby-pkg-tools:any' => + [qr{^include\s+/usr/share/ruby-pkg-tools/1/class/}], + 'r-base-dev:any' => [qr{^include\s+/usr/share/R/debian/r-cran\.mk}], + $ANYPYTHON_DEPEND =>[qr{/usr/share/cdbs/1/class/python-distutils\.mk}], + ); + + # A list of packages; regular expressions that, if they match anywhere in the + # debian/rules file, this package must be listed in either Build-Depends or + # Build-Depends-Indep as appropriate; and optional tags as above. + my %GLOBAL_DEPENDS = ( + 'dh-ocaml:any, ocaml-nox:any | ocaml:any' => + [qr/^\t\s*dh_ocaml(?:init|doc)\s/], + 'debhelper:any | debhelper-compat:any | dh-autoreconf:any' => + [qr/^\t\s*dh_autoreconf(?:_clean)?\s/], + ); + + # Similarly, this list of packages, regexes, and optional tags say that if the + # regex matches in one of clean, build-arch, binary-arch, or a rule they + # depend on, this package is allowed (and required) in Build-Depends. + my %RULE_CLEAN_DEPENDS =( + 'ant:any' => [qr/^\t\s*(\S+=\S+\s+)*ant\s/], + 'debhelper:any | debhelper-compat:any' => + [qr/^\t\s*dh_(?!autoreconf).+/], + 'dh-ocaml:any, ocaml-nox:any | ocaml:any' =>[qr/^\t\s*dh_ocamlinit\s/], + 'dpatch:any' => [qr/^\t\s*(\S+=\S+\s+)*dpatch\s/], + 'po-debconf:any' => [qr/^\t\s*debconf-updatepo\s/], + $PYTHON_DEPEND => [qr/^\t\s*python\s/], + $PYTHON3_DEPEND => [qr/^\t\s*python3\s/], + $ANYPYTHON_DEPEND => [qr/\ssetup\.py\b/], + 'quilt:any' => [qr/^\t\s*(\S+=\S+\s+)*quilt\s/], + ); + + my $build_all = $self->processable->relation('Build-Depends-All'); + my $build_all_norestriction + = $self->processable->relation_norestriction('Build-Depends-All'); + my $build_regular = $self->processable->relation('Build-Depends'); + my $build_indep = $self->processable->relation('Build-Depends-Indep'); + + # no need to look for items we have + delete %GLOBAL_DEPENDS{$_} + for grep { $build_regular->satisfies($_) } keys %GLOBAL_DEPENDS; + delete %GLOBAL_CLEAN_DEPENDS{$_} + for grep { $build_regular->satisfies($_) } keys %GLOBAL_CLEAN_DEPENDS; + delete %RULE_CLEAN_DEPENDS{$_} + for grep { $build_regular->satisfies($_) } keys %RULE_CLEAN_DEPENDS; + + my @needed; + my @needed_clean; + + # Scan debian/rules. We would really like to let make do this for + # us, but unfortunately there doesn't seem to be a way to get make + # to syntax-check and analyze a makefile without running at least + # $(shell) commands. + # + # We skip some of the rule analysis if debian/rules includes any + # other files, since to chase all includes we'd have to have all + # of its build dependencies installed. + local $_ = undef; + + my @arch_rules = map { qr/^$_$/ } qw(clean binary-arch build-arch); + my @indep_rules = qw(build build-indep binary-indep); + my @current_targets; + my %rules_per_target; + my %debhelper_group; + my %seen; + my %overridden; + my $maybe_skipping; + my @conditionals; + my %variables; + my $includes = 0; + + my $contents = $rules->decoded_utf8; + return + unless length $contents; + + my @lines = split(/\n/, $contents); + + my $continued = $EMPTY; + my $position = 1; + + for my $line (@lines) { + + my $pointer = $rules->pointer($position); + + $self->pointed_hint('debian-rules-is-dh_make-template', $pointer) + if $line =~ m/dh_make generated override targets/; + + next + if $line =~ /^\s*\#/; + + if (length $continued) { + $line = $continued . $line; + $continued = $EMPTY; + } + + if ($line =~ s/\\$//) { + $continued = $line; + next; + } + + if ($line =~ /^\s*[s-]?include\s+(\S++)/){ + my $makefile = $1; + my $targets = $KNOWN_MAKEFILES->value($makefile); + if (defined $targets){ + for my $target (split /\s*+,\s*+/, $targets){ + $seen{$target}++ if exists $TAG_FOR_POLICY_TARGET{$target}; + } + } else { + $includes = 1; + } + + $self->pointed_hint('debian-rules-uses-deprecated-makefile', + $pointer, $makefile) + if $DEPRECATED_MAKEFILES->recognizes($makefile); + } + + # problems occurring only outside targets + unless (%seen) { + + # Check for DH_COMPAT settings outside of any rule, which are now + # deprecated. It's a bit easier structurally to do this here than in + # debhelper. + $self->pointed_hint('debian-rules-sets-DH_COMPAT', $pointer) + if $line =~ /^\s*(?:export\s+)?DH_COMPAT\s*:?=/; + + $self->pointed_hint('debian-rules-sets-DEB_BUILD_OPTIONS',$pointer) + if $line =~ /^\s*(?:export\s+)?DEB_BUILD_OPTIONS\s*:?=/; + + if ( + $line =~m{^ + \s*(?:export\s+)? + (DEB_(?:HOST|BUILD|TARGET)_(?:ARCH|MULTIARCH|GNU)[A-Z_]*)\s*:?= + }x + ) { + my $variable = $1; + + $self->pointed_hint( + 'debian-rules-sets-dpkg-architecture-variable', + $pointer, $variable); + } + + } + + if ( $line =~ /^\t\s*-(?:\$[\(\{]MAKE[\}\)]|make)\s.*(?:dist)?clean/s + || $line + =~ /^\t\s*(?:\$[\(\{]MAKE[\}\)]|make)\s(?:.*\s)?-(\w*)i.*(?:dist)?clean/s + ) { + my $flags = $1 // $EMPTY; + + # Ignore "-C<dir>" (#671537) + $self->pointed_hint('debian-rules-ignores-make-clean-error', + $pointer) + unless $flags =~ /^C/; + } + + if ($line + =~ m{dh_strip\b.*(--(?:ddeb|dbgsym)-migration=(?:'[^']*'|\S*))}) { + + my $context = $1; + + $self->pointed_hint('debug-symbol-migration-possibly-complete', + $pointer, $context); + } + + $self->pointed_hint('debian-rules-passes-version-info-to-dh_shlibdeps', + $pointer) + if $line =~ m{dh_shlibdeps\b.*(?:--version-info|-V)\b}; + + $self->pointed_hint('debian-rules-updates-control-automatically', + $pointer) + if $line =~ m{^\s*DEB_AUTO_UPDATE_DEBIAN_CONTROL\s*=\s*yes}; + + $self->pointed_hint('debian-rules-uses-deb-build-opts', $pointer) + if $line =~ m{\$[\(\{]DEB_BUILD_OPTS[\)\}]}; + + if ($line =~ m{^\s*DH_EXTRA_ADDONS\s*=\s*(.*)$}) { + + my $context = $1; + + $self->pointed_hint('debian-rules-should-not-use-DH_EXTRA_ADDONS', + $pointer, $context); + } + + $self->pointed_hint('debian-rules-uses-wrong-environment-variable', + $pointer) + if $line =~ m{\bDEB_[^_ \t]+FLAGS_(?:SET|APPEND)\b}; + + $self->pointed_hint('debian-rules-calls-pwd', $pointer) + if $line =~ m{\$[\(\{]PWD[\)\}]}; + + $self->pointed_hint( + 'debian-rules-should-not-use-sanitize-all-buildflag',$pointer) + if $line + =~ m{^\s*(?:export\s+)?DEB_BUILD_MAINT_OPTIONS\s*:?=.*\bsanitize=\+all\b}; + + $self->pointed_hint('debian-rules-uses-special-shell-variable', + $pointer) + if $line =~ m{\$[\(\{]_[\)\}]}; + + if ($line =~ m{(dh_builddeb\b.*--.*-[zZS].*)$}) { + + my $context = $1; + + $self->pointed_hint('custom-compression-in-debian-rules', + $pointer, $context); + } + + if ($line =~ m{(py3versions\s+([\w\-\s]*--installed|-\w*i\w*))}) { + + my $context = $1; + + $self->pointed_hint('debian-rules-uses-installed-python-versions', + $pointer, $context); + } + + $self->pointed_hint('debian-rules-uses-as-needed-linker-flag',$pointer) + if $line =~ /--as-needed/ && $line !~ /--no-as-needed/; + + if ($line =~ /(py3versions\s+([\w\-\s]*--supported|-\w*s\w*))/) { + + my $context = $1; + + $self->pointed_hint( +'debian-rules-uses-supported-python-versions-without-python-all-build-depends', + $pointer, + $context + )unless $build_all_norestriction->satisfies($PYTHON3_ALL_DEPEND); + } + + # General assignment - save the variable + if ($line =~ /^\s*(?:\S+\s+)*?(\S+)\s*[:\?\+]?=\s*(.*+)?$/s) { + # This is far too simple from a theoretical PoV, but should do + # rather well. + my ($var, $value) = ($1, $2); + $variables{$var} = $value; + + $self->pointed_hint('unnecessary-source-date-epoch-assignment', + $pointer) + if $var eq 'SOURCE_DATE_EPOCH' + && !$build_all->satisfies( + 'dpkg-dev:any (>= 1.18.8) | debhelper:any (>= 10.10)'); + } + + # Keep track of whether this portion of debian/rules may be optional + if ($line =~ /^ifn?(?:eq|def)\s(.*)/) { + push(@conditionals, $1); + $maybe_skipping++; + + } elsif ($line =~ /^endif\s/) { + $maybe_skipping--; + } + + unless ($maybe_skipping) { + + for my $prerequisite (keys %GLOBAL_DEPENDS) { + + my @patterns = @{ $GLOBAL_DEPENDS{$prerequisite} }; + + push(@needed, $prerequisite) + if any { $line =~ $_ } @patterns; + } + + for my $prerequisite (keys %GLOBAL_CLEAN_DEPENDS) { + + my @patterns = @{ $GLOBAL_CLEAN_DEPENDS{$prerequisite} }; + + if (any { $line =~ $_ } @patterns) { + + push(@needed, $prerequisite); + push(@needed_clean, $prerequisite); + } + } + } + + # Listing a rule as a dependency of .PHONY is sufficient to make it + # present for the purposes of GNU make and therefore the Policy + # requirement. + if ($line =~ /^(?:[^:]+\s)?\.PHONY(?:\s[^:]+)?:(.+)/s) { + + my @targets = split($SPACE, $1); + for my $target (@targets) { + # Is it $(VAR) ? + if ($target =~ /^\$[\(\{]([^\)\}]++)[\)\}]$/) { + my $name = $1; + my $val = $variables{$name}; + if ($val) { + # we think we know what it will expand to - note + # we ought to "delay" it was a "=" variable rather + # than ":=" or "+=". + + # discards empty elements at end, effectively trimming right + for (split(/\s+/, $val)) { + $seen{$target}++ + if exists $TAG_FOR_POLICY_TARGET{$target}; + } + last; + } + # We don't know, so just mark the target as seen. + } + $seen{$target}++ + if exists $TAG_FOR_POLICY_TARGET{$target}; + } + + #.PHONY implies the rest will not match + next; + } + + if ( !$includes + && $line + =~ /dpkg-parsechangelog.*(?:Source|Version|Date|Timestamp)/s) { + + $self->pointed_hint('debian-rules-parses-dpkg-parsechangelog', + $pointer); + } + + if ($line !~ /^ifn?(?:eq|def)\s/ && $line =~ /^([^\s:][^:]*):+(.*)/s) { + my ($target_names, $target_dependencies) = ($1, $2); + @current_targets = split $SPACE, $target_names; + + my @quoted = map { quotemeta } split($SPACE, $target_dependencies); + s/\\\$\\\([^\):]+\\:([^=]+)\\=([^\)]+)\1\\\)/$2.*/g for @quoted; + + my @depends = map { qr/^$_$/ } @quoted; + + for my $target (@current_targets) { + $overridden{$1} = $position if $target =~ m/override_(.+)/; + if ($target =~ /%/) { + my $pattern = quotemeta $target; + $pattern =~ s/\\%/.*/g; + for my $rulebypolicy (keys %TAG_FOR_POLICY_TARGET) { + $seen{$rulebypolicy}++ if $rulebypolicy =~ m/$pattern/; + } + } else { + # Is it $(VAR) ? + if ($target =~ m/^\$[\(\{]([^\)\}]++)[\)\}]$/) { + my $name = $1; + my $val = $variables{$name}; + if ($val) { + # we think we know what it will expand to - note + # we ought to "delay" it was a "=" variable rather + # than ":=" or "+=". + local $_ = undef; + + # discards empty elements at end, effectively trimming right + for (split(/\s+/, $val)) { + $seen{$_}++ + if exists $TAG_FOR_POLICY_TARGET{$_}; + } + last; + } + # We don't know, so just mark the target as seen. + } + $seen{$target}++ if exists $TAG_FOR_POLICY_TARGET{$target}; + } + if (any { $target =~ /$_/ } @arch_rules) { + push(@arch_rules, @depends); + } + } + undef %debhelper_group; + + } elsif ($line =~ /^define /) { + # We don't want to think the body of the define is part of + # the previous rule or we'll get false positives on tags + # like binary-arch-rules-but-pkg-is-arch-indep. Treat a + # define as the end of the current rule, although that + # isn't very accurate either. + @current_targets = (); + + } else { + # If we have non-empty, non-comment lines, store them for + # all current targets and check whether debhelper programs + # are called in a reasonable order. + if ($line =~ /^\s+[^\#]/) { + my ($arch, $indep) = (0, 0); + for my $target (@current_targets) { + $rules_per_target{$target} ||= []; + push(@{$rules_per_target{$target}}, $line); + + $arch = 1 + if any { $target =~ /$_/ } @arch_rules; + + $indep = 1 + if any { $target eq $_ } @indep_rules; + + $indep = 1 + if $target eq $PERCENT; + + $indep = 1 + if $target =~ /^override_/; + } + + if (!$maybe_skipping && ($arch || $indep)) { + + for my $prerequisite (keys %RULE_CLEAN_DEPENDS) { + + my @patterns = @{ $RULE_CLEAN_DEPENDS{$prerequisite} }; + + if (any { $line =~ $_ } @patterns) { + + push(@needed, $prerequisite); + push(@needed_clean, $prerequisite) + if $arch; + } + } + } + + if ($line =~ /^\s+(dh_\S+)\b/ && $debhelper_order{$1}) { + my $command = $1; + my ($package) = ($line =~ /\s(?:-p|--package=)(\S+)/); + $package ||= $EMPTY; + my $group = $debhelper_order{$command}; + $debhelper_group{$package} ||= 0; + + if ($group < $debhelper_group{$package}) { + + $self->pointed_hint( + 'debian-rules-calls-debhelper-in-odd-order', + $pointer, $command); + + } else { + $debhelper_group{$package} = $group; + } + } + } + } + + } continue { + ++$position; + } + + my @missing_targets; + @missing_targets = grep { !$seen{$_} } keys %TAG_FOR_POLICY_TARGET + unless $includes; + + $self->pointed_hint($TAG_FOR_POLICY_TARGET{$_}, $rules->pointer, $_) + for @missing_targets; + + # Make sure we have no content for binary-arch if we are arch-indep: + $rules_per_target{'binary-arch'} ||= []; + if ($architecture eq 'all' && scalar @{$rules_per_target{'binary-arch'}}) { + + my $nonempty = 0; + for my $rule (@{$rules_per_target{'binary-arch'}}) { + # dh binary-arch is actually a no-op if there is no + # Architecture: any package in the control file + $nonempty = 1 + unless $rule =~ /^\s*dh\s+(?:binary-arch|\$\@)/; + } + + $self->pointed_hint('binary-arch-rules-but-pkg-is-arch-indep', + $rules->pointer) + if $nonempty; + } + + for my $cmd (qw(dh_clean dh_fixperms)) { + for my $suffix ($EMPTY, '-indep', '-arch') { + + my $memorized_position = $overridden{"$cmd$suffix"}; + next + unless defined $memorized_position; + + $self->pointed_hint( + "override_$cmd-does-not-call-$cmd", + $rules->pointer($memorized_position) + ) + if none { m/^\t\s*-?($cmd\b|\$\(overridden_command\))/ } + @{$rules_per_target{"override_$cmd$suffix"}}; + } + } + + if (my $memorized_position = $overridden{'dh_auto_test'}) { + + my @rules = grep { + !m{^\t\s*[\:\[]} + && !m{^\s*$} + && !m{\bdh_auto_test\b} + && ! +m{^\t\s*[-@]?(?:(?:/usr)?/bin/)?(?:cp|chmod|echo|ln|mv|mkdir|rm|test|true)} + } @{$rules_per_target{'override_dh_auto_test'}}; + + $self->pointed_hint( + 'override_dh_auto_test-does-not-check-DEB_BUILD_OPTIONS', + $rules->pointer($memorized_position)) + if @rules and none { m/(DEB_BUILD_OPTIONS|nocheck)/ } @conditionals; + } + + $self->pointed_hint( + 'debian-rules-contains-unnecessary-get-orig-source-target', + $rules->pointer) + if any { m/^\s+uscan\b/ } @{$rules_per_target{'get-orig-source'}}; + + my @clean_in_indep + = grep { $build_indep->satisfies($_) } uniq @needed_clean; + $self->pointed_hint( + 'missing-build-depends-for-clean-target-in-debian-rules', + $rules->pointer, "(does not satisfy $_)") + for @clean_in_indep; + + # another check complains when debhelper is missing from d/rules + my $combined_lc = List::Compare->new(\@needed, ['debhelper:any']); + + my @still_missing + = grep { !$build_all_norestriction->satisfies($_) } + $combined_lc->get_Lonly; + + $self->pointed_hint('rules-require-build-prerequisite', + $rules->pointer, "(does not satisfy $_)") + for @still_missing; + + $self->pointed_hint('debian-rules-should-not-set-CFLAGS-from-noopt', + $rules->pointer) + if $contents + =~ m{^ ifn?eq \s+ [(] , \$ [(] findstring \s+ noopt , \$ [(] DEB_BUILD_OPTIONS [)] [)] [)] \n+ + \t+ CFLAGS \s+ \+ = \s+ -O[02] \n+ + else \n+ + \t+ CFLAGS \s+ \+ = \s+ -O[02] \n+ + endif $}xsm; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Rules/DhSequencer.pm b/lib/Lintian/Check/Debian/Rules/DhSequencer.pm new file mode 100644 index 0000000..bc2b239 --- /dev/null +++ b/lib/Lintian/Check/Debian/Rules/DhSequencer.pm @@ -0,0 +1,65 @@ +# debian/rules/dh-sequencer -- lintian check script -*- perl -*- + +# Copyright (C) 2019 Felix Lechner +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Rules::DhSequencer; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->name eq 'debian/rules'; + + my $bytes = $item->bytes; + + # strip comments (see #960485) + $bytes =~ s/^\h#.*\R?//mg; + + my $plain = qr/\$\@/; + my $curly = qr/\$\{\@\}/; + my $asterisk = qr/\$\*/; + my $parentheses = qr/\$\(\@\)/; + my $rule_altern = qr/(?:$plain|$curly|$asterisk|$parentheses)/; + my $rule_target = qr/(?:$rule_altern|'$rule_altern'|"$rule_altern")/; + + $self->pointed_hint('no-dh-sequencer', $item->pointer) + unless $bytes =~ /^\t+(?:[\+@-])?(?:[^=]+=\S+ )?dh[ \t]+$rule_target/m + || $bytes =~ m{^\s*include\s+/usr/share/cdbs/1/class/hlibrary.mk\s*$}m + || $bytes =~ m{\bDEB_CABAL_PACKAGE\b}; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Shlibs.pm b/lib/Lintian/Check/Debian/Shlibs.pm new file mode 100644 index 0000000..8e755d9 --- /dev/null +++ b/lib/Lintian/Check/Debian/Shlibs.pm @@ -0,0 +1,656 @@ +# debian/shlibs -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz +# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Shlibs; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use File::Basename; +use List::Compare; +use List::SomeUtils qw(any none uniq); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $SLASH => q{/}; +const my $EQUALS => q{=}; +const my $LEFT_PARENTHESIS => q{(}; +const my $RIGHT_PARENTHESIS => q{)}; + +my @known_meta_labels = qw{ + Build-Depends-Package + Build-Depends-Packages + Ignore-Blacklist-Groups +}; + +has soname_by_filename => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my %soname_by_filename; + for my $item (@{$self->processable->installed->sorted_list}) { + + $soname_by_filename{$item->name}= $item->elf->{SONAME}[0] + if exists $item->elf->{SONAME}; + } + + return \%soname_by_filename; + } +); + +has shlibs_positions_by_pretty_soname => (is => 'rw', default => sub { {} }); +has symbols_positions_by_soname => (is => 'rw', default => sub { {} }); + +sub installable { + my ($self) = @_; + + $self->check_shlibs_file; + $self->check_symbols_file; + + my @pretty_sonames_from_shlibs + = keys %{$self->shlibs_positions_by_pretty_soname}; + my @pretty_sonames_from_symbols + = map { human_soname($_) } keys %{$self->symbols_positions_by_soname}; + + # Compare the contents of the shlibs and symbols control files, but exclude + # from this check shared libraries whose SONAMEs has no version. Those can + # only be represented in symbols files and aren't expected in shlibs files. + my $extra_lc = List::Compare->new(\@pretty_sonames_from_symbols, + \@pretty_sonames_from_shlibs); + + if (%{$self->shlibs_positions_by_pretty_soname}) { + + my @versioned = grep { m{ } } $extra_lc->get_Lonly; + + $self->hint('symbols-for-undeclared-shared-library', $_)for @versioned; + } + + return; +} + +sub check_shlibs_file { + my ($self) = @_; + + my @ldconfig_folders = @{$self->data->architectures->ldconfig_folders}; + + # Libraries with no version information can't be represented by + # the shlibs format (but can be represented by symbols). We want + # to warn about them if they appear in public directories. If + # they're in private directories, assume they're plugins or + # private libraries and are safe. + my @unversioned_libraries; + for my $file_name (keys %{$self->soname_by_filename}) { + + my $pretty_soname + = human_soname($self->soname_by_filename->{$file_name}); + next + if $pretty_soname =~ m{ }; + + push(@unversioned_libraries, $file_name); + $self->hint('shared-library-lacks-version', $file_name, $pretty_soname) + if any { (dirname($file_name) . $SLASH) eq $_ } @ldconfig_folders; + } + + my $versioned_lc = List::Compare->new([keys %{$self->soname_by_filename}], + \@unversioned_libraries); + my @versioned_libraries = $versioned_lc->get_Lonly; + + # 4th step: check shlibs control file + # $package_version may be undef in very broken packages + my $shlibs_file = $self->processable->control->lookup('shlibs'); + $shlibs_file = undef + if defined $shlibs_file && !$shlibs_file->is_file; + + # no shared libraries included in package, thus shlibs control + # file should not be present + $self->pointed_hint('empty-shlibs', $shlibs_file->pointer) + if defined $shlibs_file && !@versioned_libraries; + + # shared libraries included, thus shlibs control file has to exist + for my $file_name (@versioned_libraries) { + + # only public shared libraries + $self->hint('no-shlibs', $file_name) + if (any { (dirname($file_name) . $SLASH) eq $_ } @ldconfig_folders) + && !defined $shlibs_file + && $self->processable->type ne 'udeb' + && !is_nss_plugin($file_name); + } + + if (@versioned_libraries && defined $shlibs_file) { + + my @shlibs_prerequisites; + + my @lines = split(/\n/, $shlibs_file->decoded_utf8); + + my $position = 1; + for my $line (@lines) { + + next + if $line =~ m{^ \s* $}x + || $line =~ m{^ [#] }x; + + # We exclude udebs from the checks for correct shared library + # dependencies, since packages may contain dependencies on + # other udeb packages. + + my $udeb = $EMPTY; + $udeb = 'udeb: ' + if $line =~ s/^udeb:\s+//; + + my ($name, $version, @prerequisites) = split($SPACE, $line); + my $pretty_soname = "$udeb$name $version"; + + $self->shlibs_positions_by_pretty_soname->{$pretty_soname} //= []; + push( + @{$self->shlibs_positions_by_pretty_soname->{$pretty_soname}}, + $position + ); + + push(@shlibs_prerequisites, join($SPACE, @prerequisites)) + unless $udeb; + + } continue { + ++$position; + } + + my @duplicate_pretty_sonames + = grep { @{$self->shlibs_positions_by_pretty_soname->{$_}} > 1 } + keys %{$self->shlibs_positions_by_pretty_soname}; + + for my $pretty_soname (@duplicate_pretty_sonames) { + + my $indicator + = $LEFT_PARENTHESIS . 'lines' + . $SPACE + . join($SPACE, + sort { $a <=> $b } + @{$self->shlibs_positions_by_pretty_soname->{$pretty_soname}} + ). $RIGHT_PARENTHESIS; + + $self->pointed_hint('duplicate-in-shlibs', $shlibs_file->pointer, + $indicator,$pretty_soname); + } + + my @used_pretty_sonames; + for my $file_name (@versioned_libraries) { + + my $pretty_soname + = human_soname($self->soname_by_filename->{$file_name}); + + push(@used_pretty_sonames, $pretty_soname); + push(@used_pretty_sonames, "udeb: $pretty_soname"); + + # only public shared libraries + $self->pointed_hint('ships-undeclared-shared-library', + $shlibs_file->pointer,$pretty_soname, 'for', $file_name) + if (any { (dirname($file_name) . $SLASH) eq $_ } + @ldconfig_folders) + && !@{$self->shlibs_positions_by_pretty_soname->{$pretty_soname} + // []} + && !is_nss_plugin($file_name); + } + + my $unused_lc + = List::Compare->new( + [keys %{$self->shlibs_positions_by_pretty_soname}], + \@used_pretty_sonames); + + $self->pointed_hint('shared-library-not-shipped', + $shlibs_file->pointer, $_) + for $unused_lc->get_Lonly; + + my $fields = $self->processable->fields; + + # Check that all of the packages listed as dependencies in + # the shlibs file are satisfied by the current package or + # its Provides. Normally, packages should only declare + # dependencies in their shlibs that they themselves can + # satisfy. + my $provides = $self->processable->name; + $provides + .= $LEFT_PARENTHESIS + . $EQUALS + . $SPACE + . $fields->value('Version') + . $RIGHT_PARENTHESIS + if $fields->declares('Version'); + + $provides + = $self->processable->relation('Provides')->logical_and($provides); + + for my $prerequisite (uniq @shlibs_prerequisites) { + + $self->pointed_hint('distant-prerequisite-in-shlibs', + $shlibs_file->pointer, $prerequisite) + unless $provides->satisfies($prerequisite); + + $self->pointed_hint('outdated-relation-in-shlibs', + $shlibs_file->pointer, $prerequisite) + if $prerequisite =~ m/\(\s*[><](?![<>=])\s*/; + } + } + + return; +} + +sub check_symbols_file { + my ($self) = @_; + + my @ldconfig_folders = @{$self->data->architectures->ldconfig_folders}; + my @shared_libraries = keys %{$self->soname_by_filename}; + + my $fields = $self->processable->fields; + my $symbols_file = $self->processable->control->lookup('symbols'); + + if (!defined $symbols_file + && $self->processable->type ne 'udeb') { + + for my $file_name (@shared_libraries){ + + my $item = $self->processable->installed->lookup($file_name); + next + unless defined $item; + + my @symbols + = grep { $_->section eq '.text' || $_->section eq 'UND' } + @{$item->elf->{SYMBOLS} // []}; + + # only public shared libraries + # Skip Objective C libraries as instance/class methods do not + # appear in the symbol table + $self->hint('no-symbols-control-file', $file_name) + if (any { (dirname($file_name) . $SLASH) eq $_ } + @ldconfig_folders) + && (none { $_->name =~ m/^__objc_/ } @symbols) + && !is_nss_plugin($file_name); + } + } + + return + unless defined $symbols_file; + + # no shared libraries included in package, thus symbols + # control file should not be present + $self->pointed_hint('empty-shared-library-symbols', $symbols_file->pointer) + unless @shared_libraries; + + # Assume the version to be a non-native version to avoid + # uninitialization warnings later. + my $package_version = $fields->value('Version') || '0-1'; + + my $package_version_wo_rev = $package_version; + $package_version_wo_rev =~ s/^ (.+) - [^-]+ $/$1/x; + + my @sonames; + my %symbols_by_soname; + my %full_version_symbols_by_soname; + my %debian_revision_symbols_by_soname; + my %prerequisites_by_soname; + my %positions_by_soname_and_meta_label; + my @syntax_errors; + my $template_count = 0; + + my @lines = split(/\n/, $symbols_file->decoded_utf8); + + my $current_soname = $EMPTY; + my $position = 1; + for my $line (@lines) { + + next + if $line =~ m{^ \s* $}x + || $line =~ m{^ [#] }x; + + # soname, main dependency template + if ($line + =~ m{^ ([^\s|*]\S+) \s\S+\s* (?: [(] \S+\s+\S+ [)] | [#]MINVER[#] )? }x + ){ + + $current_soname = $1; + push(@sonames, $current_soname); + + $line =~ s/^\Q$current_soname\E\s*//; + + $self->symbols_positions_by_soname->{$current_soname} //= []; + push( + @{$self->symbols_positions_by_soname->{$current_soname}}, + $position + ); + + for my $conjunctive (split(m{ \s* , \s* }x, $line)) { + for my $disjunctive (split(m{ \s* [|] \s* }x, $conjunctive)){ + + $disjunctive + =~ m{^ (\S+) ( \s* (?: [(] \S+\s+\S+ [)] | [#]MINVER[#]))? $}x; + + my $package = $1; + my $version = $2 || $EMPTY; + + if (length $package) { + $prerequisites_by_soname{$current_soname} //= []; + push( + @{$prerequisites_by_soname{$current_soname}}, + $package . $version + ); + + } else { + push(@syntax_errors, $position); + } + } + } + + $template_count = 0; + + next; + } + + # alternative dependency template + if ($line + =~ m{^ [|] \s+\S+\s* (?: [(] \S+\s+\S+ [)] | [#]MINVER[#] )? }x) { + + my $error = 0; + + if (%{$positions_by_soname_and_meta_label{$current_soname} // {} } + || !length $current_soname) { + + push(@syntax_errors, $position); + $error = 1; + } + + $line =~ s{^ [|] \s* }{}x; + + for my $conjunctive (split(m{ \s* , \s* }x, $line)) { + for my $disjunctive (split(m{ \s* [|] \s* }x, $conjunctive)) { + + $disjunctive + =~ m{^ (\S+) ( \s* (?: [(] \S+ \s+ \S+ [)] | [#]MINVER[#] ) )? $}x; + + my $package = $1; + my $version = $2 || $EMPTY; + + if (length $package) { + $prerequisites_by_soname{$current_soname} //= []; + push( + @{$prerequisites_by_soname{$current_soname}}, + $package . $version + ); + + } else { + push(@syntax_errors, $position) + unless $error; + + $error = 1; + } + } + } + + $template_count++ unless $error; + + next; + } + + # meta-information + if ($line =~ m{^ [*] \s (\S+) : \s \S+ }x) { + + my $meta_label = $1; + + $positions_by_soname_and_meta_label{$current_soname}{$meta_label} + //= []; + push( + @{ + $positions_by_soname_and_meta_label{$current_soname} + {$meta_label} + }, + $position + ); + + push(@syntax_errors, $position) + if !defined $current_soname + || @{$symbols_by_soname{$current_soname} // [] }; + + next; + } + + # Symbol definition + if ($line =~ m{^\s+ (\S+) \s (\S+) (?:\s (\S+ (?:\s\S+)? ) )? $}x) { + + my $symbol = $1; + my $version = $2; + my $selector = $3 // $EMPTY; + + push(@syntax_errors, $position) + unless length $current_soname; + + $symbols_by_soname{$current_soname} //= []; + push(@{$symbols_by_soname{$current_soname}}, $symbol); + + if ($version eq $package_version && $package_version =~ m{-}) { + $full_version_symbols_by_soname{$current_soname} //= []; + push( + @{$full_version_symbols_by_soname{$current_soname}}, + $symbol + ); + + } elsif ($version =~ m{-} + && $version !~ m{~$} + && $version ne $package_version_wo_rev) { + + $debian_revision_symbols_by_soname{$current_soname} //= []; + push( + @{$debian_revision_symbols_by_soname{$current_soname}}, + $symbol + ); + } + + $self->pointed_hint('invalid-template-id-in-symbols-file', + $symbols_file->pointer($position),$selector) + if length $selector + && ($selector !~ m{^ \d+ $}x || $selector > $template_count); + + next; + } + + push(@syntax_errors, $position); + + } continue { + ++$position; + } + + my @duplicate_sonames + = grep { @{$self->symbols_positions_by_soname->{$_}} > 1 } + keys %{$self->symbols_positions_by_soname}; + + for my $soname (@duplicate_sonames) { + + my $indicator + = $LEFT_PARENTHESIS . 'lines' + . $SPACE + . join($SPACE, + sort { $a <=> $b }@{$self->symbols_positions_by_soname->{$soname}}) + . $RIGHT_PARENTHESIS; + + my $pretty_soname = human_soname($soname); + + $self->pointed_hint('duplicate-entry-in-symbols-control-file', + $symbols_file->pointer,$indicator,$pretty_soname); + } + + $self->pointed_hint('syntax-error-in-symbols-file', + $symbols_file->pointer($_)) + for uniq @syntax_errors; + + # Check that all of the packages listed as dependencies in the symbols + # file are satisfied by the current package or its Provides. + # Normally, packages should only declare dependencies in their symbols + # files that they themselves can satisfy. + my $provides = $self->processable->name; + $provides + .= $LEFT_PARENTHESIS + . $EQUALS + . $SPACE + . $fields->value('Version') + . $RIGHT_PARENTHESIS + if $fields->declares('Version'); + + $provides + = $self->processable->relation('Provides')->logical_and($provides); + + for my $soname (uniq @sonames) { + + my @used_meta_labels + = keys %{$positions_by_soname_and_meta_label{$soname} // {} }; + + my $meta_lc + = List::Compare->new(\@used_meta_labels, \@known_meta_labels); + + for my $meta_label ($meta_lc->get_Lonly) { + + $self->pointed_hint( + 'unknown-meta-field-in-symbols-file', + $symbols_file->pointer($_), + $meta_label, "($soname)" + ) + for @{$positions_by_soname_and_meta_label{$soname}{$meta_label}}; + } + + $self->pointed_hint('symbols-file-missing-build-depends-package-field', + $symbols_file->pointer,$soname) + if none { $_ eq 'Build-Depends-Package' } @used_meta_labels; + + my @full_version_symbols + = @{$full_version_symbols_by_soname{$soname} // [] }; + if (@full_version_symbols) { + + my @sorted = sort +uniq @full_version_symbols; + + my $context = 'on symbol ' . $sorted[0]; + $context .= ' and ' . (scalar @sorted - 1) . ' others' + if @sorted > 1; + + $self->pointed_hint( + 'symbols-file-contains-current-version-with-debian-revision', + $symbols_file->pointer,$context, "($soname)"); + } + + my @debian_revision_symbols + = @{$debian_revision_symbols_by_soname{$soname} // [] }; + if (@debian_revision_symbols) { + + my @sorted = sort +uniq @debian_revision_symbols; + + my $context = 'on symbol ' . $sorted[0]; + $context .= ' and ' . (scalar @sorted - 1) . ' others' + if @sorted > 1; + + $self->pointed_hint('symbols-file-contains-debian-revision', + $symbols_file->pointer,$context, "($soname)"); + } + + # Deduplicate the list of dependencies before warning so that we don't + # duplicate warnings. + for + my $prerequisite (uniq @{$prerequisites_by_soname{$soname} // [] }) { + + $prerequisite =~ s/ [ ] [#] MINVER [#] $//x; + $self->pointed_hint('symbols-declares-dependency-on-other-package', + $symbols_file->pointer,$prerequisite, "($soname)") + unless $provides->satisfies($prerequisite); + } + } + + my @used_pretty_sonames; + for my $filename (@shared_libraries) { + + my $soname = $self->soname_by_filename->{$filename}; + my $pretty_soname = human_soname($soname); + + push(@used_pretty_sonames, $pretty_soname); + push(@used_pretty_sonames, "udeb: $pretty_soname"); + + # only public shared libraries + $self->pointed_hint('shared-library-symbols-not-tracked', + $symbols_file->pointer,$pretty_soname,'for', $filename) + if (any { (dirname($filename) . $SLASH) eq $_ }@ldconfig_folders) + && !@{$self->symbols_positions_by_soname->{$soname}// [] } + && !is_nss_plugin($filename); + } + + my @available_pretty_sonames + = map { human_soname($_) } keys %{$self->symbols_positions_by_soname}; + + my $unused_lc + = List::Compare->new(\@available_pretty_sonames,\@used_pretty_sonames); + + $self->pointed_hint('surplus-shared-library-symbols', + $symbols_file->pointer, $_) + for $unused_lc->get_Lonly; + + return; +} + +# Extract the library name and the version from an SONAME and return them +# separated by a space. This code should match the split_soname function in +# dpkg-shlibdeps. +sub human_soname { + my ($string) = @_; + + # libfoo.so.X.X + # libfoo-X.X.so + if ( $string =~ m{^ (.*) [.]so[.] (.*) $}x + || $string =~ m{^ (.*) - (\d.*) [.]so $}x) { + + my $name = $1; + my $version = $2; + + return $name . $SPACE . $version; + } + + return $string; +} + +# Returns a truth value if the first argument appears to be the path +# to a libc nss plugin (libnss_<name>.so.$version). +sub is_nss_plugin { + my ($name) = @_; + + return 1 + if $name =~ m{^ (?:.*/)? libnss_[^.]+ [.]so[.] \d+ $}x; + + return 0; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Source/IncludeBinaries.pm b/lib/Lintian/Check/Debian/Source/IncludeBinaries.pm new file mode 100644 index 0000000..48e8926 --- /dev/null +++ b/lib/Lintian/Check/Debian/Source/IncludeBinaries.pm @@ -0,0 +1,77 @@ +# debian/source/include-binaries -- lintian check script -*- perl -*- + +# Copyright (C) 2019 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Source::IncludeBinaries; + +use v5.20; +use warnings; +use utf8; + +use Path::Tiny; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $sourcedir= $self->processable->patched->resolve_path('debian/source/'); + return + unless $sourcedir; + + my $item = $sourcedir->child('include-binaries'); + return + unless $item && $item->is_open_ok; + + my @lines = path($item->unpacked_path)->lines({ chomp => 1 }); + + # format described in dpkg-source (1) + my $position = 1; + for my $line (@lines) { + + next + if $line =~ /^\s*$/; + + next + if $line =~ /^#/; + + # trim both ends + $line =~ s/^\s+|\s+$//g; + + $self->pointed_hint('unused-entry-in-debian-source-include-binaries', + $item->pointer($position), $line) + unless $self->processable->patched->resolve_path($line); + + } continue { + ++$position; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/SourceDir.pm b/lib/Lintian/Check/Debian/SourceDir.pm new file mode 100644 index 0000000..2fd2ebf --- /dev/null +++ b/lib/Lintian/Check/Debian/SourceDir.pm @@ -0,0 +1,170 @@ +# debian/source directory content -- lintian check script -*- perl -*- + +# Copyright (C) 2010 by Raphael Hertzog +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::SourceDir; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(any); +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; +const my $SPACE => q{ }; + +our %KNOWN_FORMATS = map { $_ => 1 } + ('1.0', '2.0', '3.0 (quilt)', '3.0 (native)', '3.0 (git)', '3.0 (bzr)'); + +my %OLDER_FORMATS = map { $_ => 1 }('1.0'); + +sub source { + my ($self) = @_; + + my $processable = $self->processable; + + my $dsrc = $processable->patched->resolve_path('debian/source/'); + my ($format_file, $git_pfile, $format, $format_extra); + + $format_file = $dsrc->child('format') if $dsrc; + + if ($format_file and $format_file->is_open_ok) { + + open(my $fd, '<', $format_file->unpacked_path) + or die encode_utf8('Cannot open ' . $format_file->unpacked_path); + + $format = <$fd>; + chomp $format; + close($fd); + $format_extra = $EMPTY; + die encode_utf8("unknown source format $format") + unless $KNOWN_FORMATS{$format}; + } else { + $self->hint('missing-debian-source-format'); + $format = '1.0'; + $format_extra = 'implicit'; + } + if ($format eq '1.0') { + $format_extra .= $SPACE if $format_extra; + if (keys %{$processable->diffstat}) { + $format_extra .= 'non-native'; + } else { + $format_extra .= 'native'; + } + } + my $format_info = $format; + $format_info .= " [$format_extra]" + if $format_extra; + $self->hint('source-format', $format_info); + + $self->hint('older-source-format', $format) if $OLDER_FORMATS{$format}; + + return if not $dsrc; + + $git_pfile = $dsrc->child('git-patches'); + + if ($git_pfile and $git_pfile->is_open_ok and $git_pfile->size != 0) { + + open(my $git_patches_fd, '<', $git_pfile->unpacked_path) + or die encode_utf8('Cannot open ' . $git_pfile->unpacked_path); + + if (any { !/^\s*+#|^\s*+$/} <$git_patches_fd>) { + my $dpseries + = $processable->patched->resolve_path('debian/patches/series'); + # gitpkg does not create series as a link, so this is most likely + # a traversal attempt. + if (not $dpseries or not $dpseries->is_open_ok) { + + $self->pointed_hint('git-patches-not-exported', + $git_pfile->pointer); + + } else { + open(my $series_fd, '<', $dpseries->unpacked_path) + or + die encode_utf8('Cannot open ' . $dpseries->unpacked_path); + + my $comment_line = <$series_fd>; + my $count = grep { !/^\s*+\#|^\s*+$/ } <$series_fd>; + + $self->pointed_hint('git-patches-not-exported', + $dpseries->pointer) + unless ( + $count + && ($comment_line + =~ /^\s*\#.*quilt-patches-deb-export-hook/) + ); + + close $series_fd; + } + } + close $git_patches_fd; + } + + my $KNOWN_FILES= $self->data->load('debian-source-dir/known-files'); + + my @files = grep { !$_->is_dir } $dsrc->children; + for my $item (@files) { + + $self->pointed_hint('unknown-file-in-debian-source', $item->pointer) + unless $KNOWN_FILES->recognizes($item->basename); + } + + my $options = $processable->patched->resolve_path('debian/source/options'); + if ($options and $options->is_open_ok) { + + open(my $fd, '<', $options->unpacked_path) + or die encode_utf8('Cannot open ' . $options->unpacked_path); + + my $position = 1; + while (my $line = <$fd>) { + + if ($line =~ /^\s*(compression(?:-level)?\s*=\s+\S+)\n/) { + + my $level = $1; + + $self->pointed_hint( + 'custom-compression-in-debian-source-options', + $options->pointer($position), $level); + } + + } continue { + ++$position; + } + + close $fd; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Substvars.pm b/lib/Lintian/Check/Debian/Substvars.pm new file mode 100644 index 0000000..d612783 --- /dev/null +++ b/lib/Lintian/Check/Debian/Substvars.pm @@ -0,0 +1,55 @@ +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 1999 Joey Hess +# Copyright (C) 2000 Sean 'Shaleh' Perry +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2007 Russ Allbery +# Copyright (C) 2013-2018 Bastien ROUCARIES +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Substvars; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + $self->pointed_hint('source-contains-debian-substvars', $item->pointer) + if $item->name =~ m{^debian/(?:.+\.)?substvars$}s; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Symbols.pm b/lib/Lintian/Check/Debian/Symbols.pm new file mode 100644 index 0000000..42b36fe --- /dev/null +++ b/lib/Lintian/Check/Debian/Symbols.pm @@ -0,0 +1,83 @@ +# debian/symbols -- lintian check script -*- perl -*- +# +# Copyright (C) 2019-2021 Felix Lechner +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Symbols; + +use v5.20; +use warnings; +use utf8; + +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_patched_files { + my ($self, $item) = @_; + + # look at symbols files + return + unless $item->name =~ qr{^ debian/ (?:.+[.]) symbols $}x; + + return + unless $item->is_file && $item->is_open_ok; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $position = 1; + while (my $line = <$fd>) { + + chop $line; + next + if $line =~ /^\s*$/ + || $line =~ /^#/; + + # meta-information + if ($line =~ /^\*\s(\S+):\s+(\S+)/) { + + my $field = $1; + my $value = $2; + + $self->pointed_hint('package-placeholder-in-symbols-file', + $item->pointer($position)) + if $field eq 'Build-Depends-Package' && $value =~ /#PACKAGE#/; + } + + } continue { + ++$position; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/TrailingWhitespace.pm b/lib/Lintian/Check/Debian/TrailingWhitespace.pm new file mode 100644 index 0000000..465fa59 --- /dev/null +++ b/lib/Lintian/Check/Debian/TrailingWhitespace.pm @@ -0,0 +1,105 @@ +# debian/trailing-whitespace -- lintian check script -*- perl -*- +# +# based on debhelper check, +# Copyright (C) 1999 Joey Hess +# Copyright (C) 2000 Sean 'Shaleh' Perry +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2007 Russ Allbery +# Copyright (C) 2013-2018 Bastien ROUCARIES +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::TrailingWhitespace; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $KEEP_EMPTY_FIELDS => -1; +const my $LAST_ITEM => -1; + +# list of files to check for a trailing whitespace characters +my %PROHIBITED_TRAILS = ( + 'debian/changelog' => qr{\s+$}, + 'debian/control' => qr{\s+$}, + # allow trailing tabs in make + 'debian/rules' => qr{[ ]+$}, +); + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless exists $PROHIBITED_TRAILS{$item->name}; + + return + unless $item->is_valid_utf8; + + my $contents = $item->decoded_utf8; + my @lines = split(/\n/, $contents, $KEEP_EMPTY_FIELDS); + + my @trailing_whitespace; + my @empty_at_end; + + my $position = 1; + for my $line (@lines) { + + push(@trailing_whitespace, $position) + if $line =~ $PROHIBITED_TRAILS{$item->name}; + + # keeps track of any empty lines at the end + if (length $line) { + @empty_at_end = (); + } else { + push(@empty_at_end, $position); + } + + } continue { + ++$position; + } + + # require a newline at end and remove it + if (scalar @empty_at_end && $empty_at_end[$LAST_ITEM] == scalar @lines){ + pop @empty_at_end; + } else { + $self->pointed_hint('no-newline-at-end', $item->pointer); + } + + push(@trailing_whitespace, @empty_at_end); + + $self->pointed_hint('trailing-whitespace', $item->pointer($_)) + for @trailing_whitespace; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Upstream/Metadata.pm b/lib/Lintian/Check/Debian/Upstream/Metadata.pm new file mode 100644 index 0000000..410733a --- /dev/null +++ b/lib/Lintian/Check/Debian/Upstream/Metadata.pm @@ -0,0 +1,191 @@ +# debian/upstream/metadata -- lintian check script -*- perl -*- + +# Copyright (C) 2016 Petter Reinholdtsen +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Jelmer Vernooij +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Upstream::Metadata; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::Compare; +use List::Util qw(none); +use Syntax::Keyword::Try; +use YAML::XS; + +# default changed to false in 0.81; enable then in .perlcriticrc +$YAML::XS::LoadBlessed = 0; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; + +# Need 0.69 for $LoadBlessed (#861958) +const my $HAS_LOAD_BLESSED => 0.69; + +# taken from https://wiki.debian.org/UpstreamMetadata +my @known_fields = qw( + Archive + ASCL-Id + Bug-Database + Bug-Submit + Cite-As + Changelog + CPE + Documentation + Donation + FAQ + Funding + Gallery + Other-References + Reference + Registration + Registry + Repository + Repository-Browse + Screenshots + Security-Contact + Webservice +); + +# tolerated for packages not using DEP-5 copyright +my @tolerated_fields = qw( + Name + Contact +); + +sub source { + my ($self) = @_; + + my $item + = $self->processable->patched->resolve_path('debian/upstream/metadata'); + + if ($self->processable->native) { + + $self->pointed_hint('upstream-metadata-in-native-source', + $item->pointer) + if defined $item; + return; + } + + unless (defined $item) { + $self->hint('upstream-metadata-file-is-missing'); + return; + } + + $self->pointed_hint('upstream-metadata-exists', $item->pointer); + + unless ($item->is_open_ok) { + $self->pointed_hint('upstream-metadata-is-not-a-file', $item->pointer); + return; + } + + return + if $YAML::XS::VERSION < $HAS_LOAD_BLESSED; + + my $yaml; + try { + $yaml = YAML::XS::LoadFile($item->unpacked_path); + + die + unless defined $yaml; + + } catch { + + my $message = $@; + my ($reason, $document, $line, $column)= ( + $message =~ m{ + \AYAML::XS::Load\sError:\sThe\sproblem:\n + \n\s++(.+)\n + \n + was\sfound\sat\sdocument:\s(\d+),\sline:\s(\d+),\scolumn:\s(\d+)\n}x + ); + + $message + = "$reason (at document $document, line $line, column $column)" + if ( length $reason + && length $document + && length $line + && length $document); + + $self->pointed_hint('upstream-metadata-yaml-invalid', + $item->pointer, $message); + + return; + } + + unless (ref $yaml eq 'HASH') { + + $self->pointed_hint('upstream-metadata-not-yaml-mapping', + $item->pointer); + return; + } + + for my $field (keys %{$yaml}) { + + $self->pointed_hint('upstream-metadata', $item->pointer, $field, + $yaml->{$field}) + if ref($yaml->{$field}) eq $EMPTY; + } + + my $lc + = List::Compare->new([keys %{$yaml}],[@known_fields, @tolerated_fields]); + my @invalid_fields = $lc->get_Lonly; + + $self->pointed_hint('upstream-metadata-field-unknown', $item->pointer, $_) + for @invalid_fields; + + $self->pointed_hint('upstream-metadata-missing-repository', $item->pointer) + if none { defined $yaml->{$_} } qw(Repository Repository-Browse); + + $self->pointed_hint('upstream-metadata-missing-bug-tracking', + $item->pointer) + if none { defined $yaml->{$_} } qw(Bug-Database Bug-Submit); + + return; +} + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + # here we check old upstream specification + # debian/upstream should be a directory + $self->pointed_hint('debian-upstream-obsolete-path', $item->pointer) + if $item->name eq 'debian/upstream' + || $item->name eq 'debian/upstream-metadata.yaml'; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Upstream/SigningKey.pm b/lib/Lintian/Check/Debian/Upstream/SigningKey.pm new file mode 100644 index 0000000..686966c --- /dev/null +++ b/lib/Lintian/Check/Debian/Upstream/SigningKey.pm @@ -0,0 +1,173 @@ +# debian/upstream/signing-key -- lintian check script -*- perl -*- + +# Copyright (C) 2018 Felix Lechner +# +# This program is free software. It is distributed 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Upstream::SigningKey; + +use v5.20; +use warnings; +use utf8; + +use File::Temp; +use List::Util qw(pairs); +use Unicode::UTF8 qw(decode_utf8); + +use Lintian::IPC::Run3 qw(safe_qx); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $SIGNING_KEY_FILENAMES + = $self->data->load('common/signing-key-filenames'); + + # Check all possible locations for signing keys + my %key_items; + for my $key_name ($SIGNING_KEY_FILENAMES->all) { + my $item + = $self->processable->patched->resolve_path("debian/$key_name"); + $key_items{$key_name} = $item + if $item && $item->is_file; + } + + # Check if more than one signing key is present + $self->hint('public-upstream-keys-in-multiple-locations', + (sort keys %key_items)) + if scalar keys %key_items > 1; + + # Go through signing keys and run checks for each + for my $key_name (sort keys %key_items) { + + # native packages should not have such keys + if ($self->processable->native) { + + $self->pointed_hint('public-upstream-key-in-native-package', + $key_items{$key_name}->pointer); + next; + } + + # set up a temporary directory for gpg + my $tempdir = File::Temp->newdir(); + + # get keys packets from gpg + my @command = ( + 'gpg', '--homedir', + $tempdir, '--batch', + '--attribute-fd', '1', + '--status-fd', '2', + '--with-colons', '--list-packets', + $key_items{$key_name}->unpacked_path + ); + my $bytes = safe_qx(@command); + + if ($?) { + $self->pointed_hint( + 'public-upstream-key-unusable', + $key_items{$key_name}->pointer, + 'cannot be processed' + ); + next; + } + + my $output = decode_utf8($bytes); + + # remove comments + $output =~ s/^#[^\n]*$//mg; + + # split into separate keys + my @keys = split(/^:public key packet:.*$/m, $output); + + # discard leading information + shift @keys; + + unless (scalar @keys) { + $self->pointed_hint( + 'public-upstream-key-unusable', + $key_items{$key_name}->pointer, + 'contains no keys' + ); + next; + } + + for my $key (@keys) { + + # parse each key into separate packets + my ($public_key, @pieces) = split(/^(:.+)$/m, $key); + my @packets = pairs @pieces; + + # require at least one packet + unless (length $public_key) { + $self->pointed_hint( + 'public-upstream-key-unusable', + $key_items{$key_name}->pointer, + 'has no public key' + ); + next; + } + + # look for key identifier + unless ($public_key =~ qr/^\s*keyid:\s+(\S+)$/m) { + $self->pointed_hint( + 'public-upstream-key-unusable', + $key_items{$key_name}->pointer, + 'has no keyid' + ); + next; + } + my $keyid = $1; + + # look for third-party signatures + my @thirdparty; + for my $packet (@packets) { + + my $header = $packet->[0]; + if ($header =~ qr/^:signature packet: algo \d+, keyid (\S*)$/){ + + my $signatory = $1; + push(@thirdparty, $signatory) + unless $signatory eq $keyid; + } + } + + # signatures by parties other than self + my $extrasignatures = scalar @thirdparty; + + # export-minimal strips such signatures + $self->pointed_hint( + 'public-upstream-key-not-minimal', + $key_items{$key_name}->pointer, + "has $extrasignatures extra signature(s) for keyid $keyid" + )if $extrasignatures; + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Variables.pm b/lib/Lintian/Check/Debian/Variables.pm new file mode 100644 index 0000000..31fa9a4 --- /dev/null +++ b/lib/Lintian/Check/Debian/Variables.pm @@ -0,0 +1,60 @@ +# debian/variables -- lintian check script -*- perl -*- + +# Copyright (C) 2006 Russ Allbery <rra@debian.org> +# Copyright (C) 2005 Rene van Bevern <rvb@pro-linux.de> +# Copyright (C) 2019-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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. + +package Lintian::Check::Debian::Variables; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(none); + +const my @WANTED_FILES => (qr{ (.+ [.])? install }sx, qr{ (.+ [.])? links }sx); + +const my @ILLEGAL_VARIABLES => qw(DEB_BUILD_MULTIARCH); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->name =~ m{^ debian/ }sx; + + return + if none { $item->name =~ m{ / $_ $}sx } @WANTED_FILES; + + for my $variable (@ILLEGAL_VARIABLES) { + + $self->pointed_hint('illegal-variable', $item->pointer, $variable) + if $item->decoded_utf8 =~ m{ \b $variable \b }msx; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/VersionSubstvars.pm b/lib/Lintian/Check/Debian/VersionSubstvars.pm new file mode 100644 index 0000000..e3789b8 --- /dev/null +++ b/lib/Lintian/Check/Debian/VersionSubstvars.pm @@ -0,0 +1,206 @@ +# debian/version-substvars -- lintian check script -*- perl -*- +# +# Copyright (C) 2006 Adeodato Simo +# Copyright (C) 2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +# SUMMARY +# ======= +# +# What breaks +# ----------- +# +# (b1) any -> any (= ${source:Version}) -> use b:V +# (b2) any -> all (= ${binary:Version}) [or S-V] -> use s:V +# (b3) all -> any (= ${either-of-them}) -> use (>= ${s:V}), +# optionally (<< ${s:V}.1~) +# +# Note (b2) also breaks if (>= ${binary:Version}) [or S-V] is used. +# +# Always warn on ${Source-Version} even if it doesn't break since the substvar +# is now considered deprecated. + +package Lintian::Check::Debian::VersionSubstvars; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(any uniq); + +use Lintian::Relation; +use Lintian::Util qw($PKGNAME_REGEX); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; +const my $EQUAL => q{=}; + +sub source { + my ($self) = @_; + + my $debian_control = $self->processable->debian_control; + + my @provides; + push(@provides, + $debian_control->installable_fields($_) + ->trimmed_list('Provides', qr/\s*,\s*/)) + for $debian_control->installables; + + for my $installable ($debian_control->installables) { + + my $installable_control + = $debian_control->installable_fields($installable); + + for my $field ( + qw(Depends Pre-Depends Recommends Suggests Conflicts Replaces)) { + + next + unless $installable_control->declares($field); + + my $position = $installable_control->position($field); + + my $relation + = $self->processable->binary_relation($installable, $field); + + $self->pointed_hint( + 'substvar-source-version-is-deprecated', + $debian_control->item->pointer($position), + $installable, $field + )if $relation->matches(qr/\$[{]Source-Version[}]/); + + my %external; + my $visitor = sub { + my ($value) = @_; + + if ( + $value + =~m{^($PKGNAME_REGEX)(?: :[-a-z0-9]+)? \s* # pkg-name $1 + \(\s*[\>\<]?[=\>\<]\s* # REL + (\$[{](?:source:|binary:)(?:Upstream-)?Version[}]) # {subvar} + }x + ) { + my $other = $1; + my $substvar = $2; + + $external{$substvar} //= []; + push(@{ $external{$substvar} }, $other); + } + }; + $relation->visit($visitor, Lintian::Relation::VISIT_PRED_FULL); + + for my $substvar (keys %external) { + for my $other (uniq @{ $external{$substvar} }) { + + # We can't test dependencies on packages whose names are + # formed via substvars expanded during the build. Assume + # those maintainers know what they're doing. + $self->pointed_hint( + 'version-substvar-for-external-package', + $debian_control->item->pointer($position), + $field, + $substvar, + "$installable -> $other" + ) + unless $debian_control->installable_fields($other) + ->declares('Architecture') + || (any { "$other (= $substvar)" eq $_ } @provides) + || $other =~ /\$\{\S+\}/; + } + } + } + + my @pre_depends + = $installable_control->trimmed_list('Pre-Depends', qr/\s*,\s*/); + my @depends + = $installable_control->trimmed_list('Depends', qr/\s*,\s*/); + + for my $versioned (uniq(@pre_depends, @depends)) { + + next + unless $versioned + =~m{($PKGNAME_REGEX)(?: :any)? \s* # pkg-name + \(\s*([>]?=)\s* # rel + \$[{]((?:Source-|source:|binary:)Version)[}] # subvar + }x; + + my $prerequisite = $1; + my $operator = $2; + my $substvar = $3; + + my $prerequisite_control + = $debian_control->installable_fields($prerequisite); + + # external relation or subst var package; handled above + next + unless $prerequisite_control->declares('Architecture'); + + my $prerequisite_is_all + = ($prerequisite_control->value('Architecture') eq 'all'); + my $installable_is_all + = ($installable_control->value('Architecture') eq 'all'); + + my $context = "$installable -> $prerequisite"; + + # (b1) any -> any (= ${source:Version}) + $self->hint('not-binnmuable-any-depends-any', $context) + if !$installable_is_all + && !$prerequisite_is_all + && $operator eq $EQUAL + && $substvar eq 'source:Version'; + + # (b2) any -> all (= ${binary:Version}) [or S-V] + $self->hint('maybe-not-arch-all-binnmuable', $context) + if !$installable_is_all + && $prerequisite_is_all + && $operator eq $EQUAL + && $substvar eq 'source:Version'; + + # (b2) any -> all (* ${binary:Version}) [or S-V] + $self->hint('not-binnmuable-any-depends-all', $context) + if !$installable_is_all + && $prerequisite_is_all + && $substvar ne 'source:Version'; + + # (b3) all -> any (= ${either-of-them}) + $self->hint('not-binnmuable-all-depends-any', $context) + if $installable_is_all + && !$prerequisite_is_all + && $operator eq $EQUAL; + + # any -> any (>= ${source:Version}) + # technically this can be "binNMU'ed", though it is + # a bit weird. + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Watch.pm b/lib/Lintian/Check/Debian/Watch.pm new file mode 100644 index 0000000..2f891d3 --- /dev/null +++ b/lib/Lintian/Check/Debian/Watch.pm @@ -0,0 +1,379 @@ +# debian/watch -- lintian check script -*- perl -*- +# +# Copyright (C) 2008 Patrick Schoenfeld +# Copyright (C) 2008 Russ Allbery +# Copyright (C) 2008 Raphael Geissert +# Copyright (C) 2019 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Watch; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(any firstval firstres); +use Path::Tiny; + +use Lintian::Util qw($PKGREPACK_REGEX); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; +const my $SPACE => q{ }; + +const my $URL_ACTION_FIELDS => 4; +const my $VERSION_ACTION_FIELDS => 3; + +const my $DMANGLES_AUTOMATICALLY => 4; + +sub source { + my ($self) = @_; + + my $item = $self->processable->patched->resolve_path('debian/watch'); + unless ($item && $item->is_file) { + + $self->hint('debian-watch-file-is-missing') + unless $self->processable->native; + + return; + } + + # Perform the other checks even if it is a native package + $self->pointed_hint('debian-watch-file-in-native-package', $item->pointer) + if $self->processable->native; + + # Check if the Debian version contains anything that resembles a repackaged + # source package sign, for fine grained version mangling check + # If the version field is missing, we assume a neutral non-native one. + + # upstream method returns empty for native packages + my $upstream = $self->processable->changelog_version->upstream; + my ($prerelease) = ($upstream =~ qr/(alpha|beta|rc)/i); + +# there is a good repack indicator in $processable->repacked but we need the text + my ($repack) = ($upstream =~ $PKGREPACK_REGEX); + + return + unless $item->is_open_ok; + + my $contents = $item->bytes; + + # each pattern marks a multi-line (!) selection for the tag message + my @templatepatterns + = (qr/^\s*#\s*(Example watch control file for uscan)/mi,qr/(<project>)/); + my $templatestring; + + for my $pattern (@templatepatterns) { + ($templatestring) = ($contents =~ $pattern); + last if defined $templatestring; + } + + $self->pointed_hint('debian-watch-contains-dh_make-template', + $item->pointer, $templatestring) + if length $templatestring; + + # remove backslash at end; uscan will catch it + $contents =~ s/(?<!\\)\\$//; + + my $standard; + + my @lines = split(/\n/, $contents); + + # look for watch file version + for my $line (@lines) { + + if ($line =~ /^\s*version\s*=\s*(\d+)\s*$/) { + if (length $1) { + $standard = $1; + last; + } + } + } + + return + unless defined $standard; + + # version 1 too broken to check + return + if $standard < 2; + + # allow spaces for all watch file versions (#950250, #950277) + my $separator = qr/\s*,\s*/; + + my $withpgpverification = 0; + my %dversions; + + my $position = 1; + my $continued = $EMPTY; + for my $line (@lines) { + + my $pointer = $item->pointer($position); + + # strip leading spaces + $line =~ s/^\s*//; + + # strip comments, if any + $line =~ s/^\#.*$//; + + unless (length $line) { + $continued = $EMPTY; + next; + } + + # merge continuation lines + if ($line =~ s/\\$//) { + $continued .= $line; + next; + } + + $line = $continued . $line + if length $continued; + + $continued = $EMPTY; + + next + if $line =~ /^version\s*=\s*\d+\s*$/; + + my $remainder = $line; + + my @options; + + # keep order; otherwise. alternative \S+ ends up with quotes + if ($remainder =~ s/opt(?:ion)?s=(?|\"((?:[^\"]|\\\")+)\"|(\S+))\s+//){ + @options = split($separator, $1); + } + + unless (length $remainder) { + + $self->pointed_hint('debian-watch-line-invalid', $pointer, $line); + next; + } + + my $repack_mangle = 0; + my $repack_dmangle = 0; + my $repack_dmangle_auto = 0; + my $prerelease_mangle = 0; + my $prerelease_umangle = 0; + + for my $option (@options) { + + if (length $repack) { + $repack_mangle = 1 + if $option + =~ /^[ud]?versionmangle\s*=\s*(?:auto|.*$repack.*)/; + $repack_dmangle = 1 + if $option =~ /^dversionmangle\s*=\s*(?:auto|.*$repack.*)/; + } + + if (length $prerelease) { + $prerelease_mangle = 1 + if $option =~ /^[ud]?versionmangle\s*=.*$prerelease/; + $prerelease_umangle = 1 + if $option =~ /^uversionmangle\s*=.*$prerelease/; + } + + $repack_dmangle_auto = 1 + if $option =~ /^dversionmangle\s*=.*(?:s\/\@DEB_EXT\@\/|auto)/ + && $standard >= $DMANGLES_AUTOMATICALLY; + + $withpgpverification = 1 + if $option =~ /^pgpsigurlmangle\s*=\s*/ + || $option =~ /^pgpmode\s*=\s*(?!none\s*$)\S.*$/; + + my ($name, $value) = split(m{ \s* = \s* }x, $option, 2); + + next + unless length $name; + + $value //= $EMPTY; + + $self->pointed_hint('prefer-uscan-symlink',$pointer, $name, $value) + if $name eq 'filenamemangle'; + } + + $self->pointed_hint( + 'debian-watch-file-uses-deprecated-sf-redirector-method', + $pointer,$remainder) + if $remainder =~ m{qa\.debian\.org/watch/sf\.php\?}; + + $self->pointed_hint('debian-watch-file-uses-deprecated-githubredir', + $pointer, $remainder) + if $remainder =~ m{githubredir\.debian\.net}; + + $self->pointed_hint('debian-watch-lacks-sourceforge-redirector', + $pointer, $remainder) + if $remainder =~ m{ (?:https?|ftp):// + (?:(?:.+\.)?dl|(?:pr)?downloads?|ftp\d?|upload) \. + (?:sourceforge|sf)\.net}xsm + || $remainder =~ m{https?://(?:www\.)?(?:sourceforge|sf)\.net + /project/showfiles\.php}xsm + || $remainder =~ m{https?://(?:www\.)?(?:sourceforge|sf)\.net + /projects/.+/files}xsm; + + if ($remainder =~ m{((?:http|ftp):(?!//sf.net/)\S+)}) { + $self->pointed_hint('debian-watch-uses-insecure-uri', $pointer,$1); + } + + # This bit is as-is from uscan.pl: + my ($base, $filepattern, $lastversion, $action) + = split($SPACE, $remainder, $URL_ACTION_FIELDS); + + # Per #765995, $base might be undefined. + if (defined $base) { + if ($base =~ s{/([^/]*\([^/]*\)[^/]*)$}{/}) { + # Last component of $base has a pair of parentheses, so no + # separate filepattern field; we remove the filepattern from the + # end of $base and rescan the rest of the line + $filepattern = $1; + (undef, $lastversion, $action) + = split($SPACE, $remainder, $VERSION_ACTION_FIELDS); + } + + $dversions{$lastversion} = 1 + if defined $lastversion; + + $lastversion = 'debian' + unless defined $lastversion; + } + + # If the version of the package contains dfsg, assume that it needs + # to be mangled to get reasonable matches with upstream. + my $needs_repack_mangling = ($repack && $lastversion eq 'debian'); + + $self->pointed_hint('debian-watch-not-mangling-version', + $pointer, $line) + if $needs_repack_mangling + && !$repack_mangle + && !$repack_dmangle_auto; + + $self->pointed_hint('debian-watch-mangles-debian-version-improperly', + $pointer, $line) + if $needs_repack_mangling + && $repack_mangle + && !$repack_dmangle; + + my $needs_prerelease_mangling + = ($prerelease && $lastversion eq 'debian'); + + $self->pointed_hint('debian-watch-mangles-upstream-version-improperly', + $pointer, $line) + if $needs_prerelease_mangling + && $prerelease_mangle + && !$prerelease_umangle; + + my $upstream_url = $remainder; + + # Keep only URL part + $upstream_url =~ s/(.*?\S)\s.*$/$1/; + + for my $option (@options) { + if ($option =~ /^ component = (.+) $/x) { + + my $component = $1; + + $self->pointed_hint('debian-watch-upstream-component', + $pointer, $upstream_url, $component); + } + } + + } continue { + ++$position; + } + + $self->pointed_hint('debian-watch-does-not-check-openpgp-signature', + $item->pointer) + unless $withpgpverification; + + my $SIGNING_KEY_FILENAMES + = $self->data->load('common/signing-key-filenames'); + + # look for upstream signing key + my @candidates + = map { $self->processable->patched->resolve_path("debian/$_") } + $SIGNING_KEY_FILENAMES->all; + my $keyfile = firstval {$_ && $_->is_file} @candidates; + + # check upstream key is present if needed + $self->pointed_hint('debian-watch-file-pubkey-file-is-missing', + $item->pointer) + if $withpgpverification && !$keyfile; + + # check upstream key is used if present + $self->pointed_hint('debian-watch-could-verify-download', + $item->pointer, $keyfile->name) + if $keyfile && !$withpgpverification; + + if (defined $self->processable->changelog && %dversions) { + + my %changelog_versions; + my $count = 1; + my $changelog = $self->processable->changelog; + for my $entry (@{$changelog->entries}) { + my $uversion = $entry->Version; + $uversion =~ s/-[^-]+$//; # revision + $uversion =~ s/^\d+://; # epoch + $changelog_versions{'orig'}{$entry->Version} = $count; + + # Preserve the first value here to correctly detect old versions. + $changelog_versions{'mangled'}{$uversion} = $count + unless (exists($changelog_versions{'mangled'}{$uversion})); + $count++; + } + + for my $dversion (sort keys %dversions) { + + next + if $dversion eq 'debian'; + + local $" = ', '; + + if (!$self->processable->native + && exists($changelog_versions{'orig'}{$dversion})) { + + $self->pointed_hint( + 'debian-watch-file-specifies-wrong-upstream-version', + $item->pointer, $dversion); + next; + } + + if (exists $changelog_versions{'mangled'}{$dversion} + && $changelog_versions{'mangled'}{$dversion} != 1) { + + $self->pointed_hint( + 'debian-watch-file-specifies-old-upstream-version', + $item->pointer, $dversion); + next; + } + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debian/Watch/Standard.pm b/lib/Lintian/Check/Debian/Watch/Standard.pm new file mode 100644 index 0000000..129966d --- /dev/null +++ b/lib/Lintian/Check/Debian/Watch/Standard.pm @@ -0,0 +1,98 @@ +# debian/watch/standard -- lintian check script -*- perl -*- +# +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debian::Watch::Standard; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::Compare; +use List::Util qw(max); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $SPACE => q{ }; + +const my @STANDARDS => (2, 3, 4); +const my $NEWLY_SUPERSEEDED => 3; + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->name eq 'debian/watch'; + + my $contents = $item->bytes; + return + unless length $contents; + + # look for version + my @mentioned = ($contents =~ /^ version \s* = \s* (\d+) \s* $/gmsx); + + my $has_contents = !!($contents =~ m{^ \s* [^#] }gmx); + + if ($has_contents && !@mentioned) { + + $self->pointed_hint('missing-debian-watch-file-standard', + $item->pointer); + return; + } + + $self->pointed_hint('multiple-debian-watch-file-standards', + $item->pointer,join($SPACE, @mentioned)) + if @mentioned > 1; + + my $standard_lc = List::Compare->new(\@mentioned, \@STANDARDS); + my @unknown = $standard_lc->get_Lonly; + my @known = $standard_lc->get_intersection; + + $self->pointed_hint('unknown-debian-watch-file-standard', + $item->pointer, $_) + for @unknown; + + return + unless @known; + + my $highest = max(@known); + $self->pointed_hint('debian-watch-file-standard', $item->pointer,$highest); + + $self->pointed_hint('older-debian-watch-file-standard', + $item->pointer, $highest) + if $highest == $NEWLY_SUPERSEEDED; + + $self->pointed_hint('obsolete-debian-watch-file-standard', + $item->pointer, $highest) + if $highest < $NEWLY_SUPERSEEDED; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debug/Automatic.pm b/lib/Lintian/Check/Debug/Automatic.pm new file mode 100644 index 0000000..1bb803f --- /dev/null +++ b/lib/Lintian/Check/Debug/Automatic.pm @@ -0,0 +1,63 @@ +# debug/automatic -- lintian check script -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debug::Automatic; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $control = $self->processable->debian_control; + + for my $installable ($control->installables) { + my $installable_fields = $control->installable_fields($installable); + + my $field = 'Package'; + + my $control_item= $self->processable->debian_control->item; + my $position = $installable_fields->position($field); + my $pointer = $control_item->pointer($position); + + $self->pointed_hint( + 'debian-control-has-dbgsym-package',$pointer, + "(in section for $installable)", $field + )if $installable =~ m{ [-] dbgsym $}x; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Debug/Obsolete.pm b/lib/Lintian/Check/Debug/Obsolete.pm new file mode 100644 index 0000000..77e9bba --- /dev/null +++ b/lib/Lintian/Check/Debug/Obsolete.pm @@ -0,0 +1,70 @@ +# debug/obsolete -- lintian check script -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Debug::Obsolete; + +use v5.20; +use warnings; +use utf8; + +use List::SomeUtils qw(none); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $control = $self->processable->debian_control; + + my $KNOWN_LEGACY_DBG_PATTERNS= $self->data->load('common/dbg-pkg'); + + for my $installable ($control->installables) { + my $installable_fields = $control->installable_fields($installable); + + my $field = 'Package'; + + my $control_item= $self->processable->debian_control->item; + my $position = $installable_fields->position($field); + my $pointer = $control_item->pointer($position); + + $self->pointed_hint( + 'debian-control-has-obsolete-dbg-package',$pointer, + "(in section for $installable)", $field + ) + if $installable =~ m{ [-] dbg $}x + && (none { $installable =~ m{$_}xms } + $KNOWN_LEGACY_DBG_PATTERNS->all); + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Desktop/Dbus.pm b/lib/Lintian/Check/Desktop/Dbus.pm new file mode 100644 index 0000000..31d1f79 --- /dev/null +++ b/lib/Lintian/Check/Desktop/Dbus.pm @@ -0,0 +1,189 @@ +# desktop/dbus -- lintian check script, vaguely based on apache2 -*- perl -*- +# +# Copyright (C) 2012 Arno Toell +# Copyright (C) 2014 Collabora Ltd. +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Desktop::Dbus; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::UtilsBy qw(uniq_by); + +const my $EMPTY => q{}; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub installable { + my ($self) = @_; + + my $index = $self->processable->installed; + + my @files; + for my $prefix (qw(etc/dbus-1 usr/share/dbus-1)) { + for my $suffix (qw(session system)) { + + my $folder = $index->resolve_path("${prefix}/${suffix}.d"); + next + unless defined $folder; + + push(@files, $folder->children); + } + } + + my @unique = uniq_by { $_->name } @files; + + $self->check_policy($_) for @unique; + + if (my $folder= $index->resolve_path('usr/share/dbus-1/services')) { + + $self->check_service($_, session => 1) for $folder->children; + } + + if (my $folder= $index->resolve_path('usr/share/dbus-1/system-services')) { + $self->check_service($_) for $folder->children; + } + + return; +} + +my $PROPERTIES = 'org.freedesktop.DBus.Properties'; + +sub check_policy { + my ($self, $item) = @_; + + $self->pointed_hint('dbus-policy-in-etc', $item->pointer) + if $item->name =~ m{^etc/}; + + my $xml = $item->decoded_utf8; + return + unless length $xml; + + # Parsing XML via regexes is evil, but good enough here... + # note that we are parsing the entire file as one big string, + # so that we catch <policy\nat_console="true"\n> or whatever. + + my @rules; + # a small rubbish state machine: we want to match a <policy> containing + # any <allow> or <deny> rule that is about sending + my $policy = $EMPTY; + while ($xml =~ m{(<policy[^>]*>)|(</policy\s*>)|(<(?:allow|deny)[^>]*>)}sg) + { + if (defined $1) { + $policy = $1; + + } elsif (defined $2) { + $policy = $EMPTY; + + } else { + push(@rules, $policy.$3); + } + } + + my $position = 1; + for my $rule (@rules) { + # normalize whitespace a bit so we can report it sensibly: + # typically it will now look like + # <policy context="default"><allow send_destination="com.example.Foo"/> + $rule =~ s{\s+}{ }g; + + if ($rule =~ m{send_} && $rule !~ m{send_destination=}) { + # It is about sending but does not specify a send-destination. + # This could be bad. + + if ($rule =~ m{[^>]*user=['"]root['"].*<allow}) { + # skip it: it's probably the "agent" pattern (as seen in + # e.g. BlueZ), and cannot normally be a security flaw + # because root can do anything anyway + + } else { + $self->pointed_hint('dbus-policy-without-send-destination', + $item->pointer($position), $rule); + + if ( $rule =~ m{send_interface=} + && $rule !~ m{send_interface=['"]\Q${PROPERTIES}\E['"]}) { + # That's undesirable, because it opens up communication + # with arbitrary services and can undo DoS mitigation + # efforts; but at least it's specific to an interface + # other than o.fd.DBus.Properties, so all that should + # happen is that the service sends back an error message. + # + # Properties doesn't count as an effective limitation, + # because it's a sort of meta-interface. + + } elsif ($rule =~ m{<allow}) { + # Looks like CVE-2014-8148 or similar. This is really bad; + # emit an additional tag. + $self->pointed_hint('dbus-policy-excessively-broad', + $item->pointer($position), $rule); + } + } + } + + $self->pointed_hint('dbus-policy-at-console', + $item->pointer($position), $rule) + if $rule =~ m{at_console=['"]true}; + + } continue { + ++$position; + } + + return; +} + +sub check_service { + my ($self, $item, %kwargs) = @_; + + my $text = $item->decoded_utf8; + return + unless length $text; + + while ($text =~ m{^Name=(.*)$}gm) { + + my $name = $1; + + next + if $item->basename eq "${name}.service"; + + if ($kwargs{session}) { + $self->pointed_hint('dbus-session-service-wrong-name', + $item->pointer,"better: ${name}.service"); + + } else { + $self->pointed_hint('dbus-system-service-wrong-name', + $item->pointer, "better: ${name}.service"); + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Desktop/Gnome.pm b/lib/Lintian/Check/Desktop/Gnome.pm new file mode 100644 index 0000000..16bb0d1 --- /dev/null +++ b/lib/Lintian/Check/Desktop/Gnome.pm @@ -0,0 +1,49 @@ +# desktop/gnome -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Desktop::Gnome; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + # /etc/gconf/schemas + $self->pointed_hint('package-installs-into-etc-gconf-schemas', + $item->pointer) + if $item->name =~ m{^etc/gconf/schemas/\S}; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Desktop/Gnome/Gir.pm b/lib/Lintian/Check/Desktop/Gnome/Gir.pm new file mode 100644 index 0000000..6f18594 --- /dev/null +++ b/lib/Lintian/Check/Desktop/Gnome/Gir.pm @@ -0,0 +1,166 @@ +# desktop/gnome/gir -- lintian check script for GObject-Introspection -*- perl -*- +# +# Copyright (C) 2012 Arno Toell +# Copyright (C) 2014 Collabora Ltd. +# Copyright (C) 2016 Simon McVittie +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Desktop::Gnome::Gir; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +const my $DOLLAR => q{$}; + +const my $NONE => q{NONE}; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $debian_control = $self->processable->debian_control; + + for my $installable ($debian_control->installables) { + + $self->pointed_hint('typelib-missing-gir-depends', + $debian_control->item->pointer, $installable) + if $installable =~ m/^gir1\.2-/ + && !$self->processable->binary_relation($installable, 'strong') + ->satisfies($DOLLAR . '{gir:Depends}'); + } + + return; +} + +sub installable { + my ($self) = @_; + + my $DEB_HOST_MULTIARCH= $self->data->architectures->deb_host_multiarch; + my $triplet = $DEB_HOST_MULTIARCH->{$self->processable->architecture}; + + # Slightly contrived, but it might be Architecture: all, in which + # case this is the best we can do + $triplet = $DOLLAR . '{DEB_HOST_MULTIARCH}' + unless defined $triplet; + + my $xml_dir + = $self->processable->installed->resolve_path('usr/share/gir-1.0/'); + + my @girs; + @girs = grep { $_->name =~ m{ [.]gir $}x } $xml_dir->children + if defined $xml_dir; + + my @type_libs; + + my $old_dir + = $self->processable->installed->resolve_path( + 'usr/lib/girepository-1.0/'); + + if (defined $old_dir) { + + $self->pointed_hint('typelib-not-in-multiarch-directory', + $_->pointer,"usr/lib/$triplet/girepository-1.0") + for $old_dir->children; + + push(@type_libs, $old_dir->children); + } + + my $multiarch_dir= $self->processable->installed->resolve_path( + "usr/lib/$triplet/girepository-1.0"); + push(@type_libs, $multiarch_dir->children) + if defined $multiarch_dir; + + my $section = $self->processable->fields->value('Section'); + if ($section ne 'libdevel' && $section ne 'oldlibs') { + + $self->pointed_hint('gir-section-not-libdevel', $_->pointer, + $section || $NONE) + for @girs; + } + + if ($section ne 'introspection' && $section ne 'oldlibs') { + + $self->pointed_hint('typelib-section-not-introspection', + $_->pointer, $section || $NONE) + for @type_libs; + } + + if ($self->processable->architecture eq 'all') { + + $self->pointed_hint('gir-in-arch-all-package', $_->pointer)for @girs; + + $self->pointed_hint('typelib-in-arch-all-package', $_->pointer) + for @type_libs; + } + + GIR: for my $gir (@girs) { + + my $expected = 'gir1.2-' . lc($gir->basename); + $expected =~ s/\.gir$//; + $expected =~ tr/_/-/; + + for my $installable ($self->group->get_installables) { + next + unless $installable->name =~ m/^gir1\.2-/; + + my $name = $installable->name; + my $version = $installable->fields->value('Version'); + + next GIR + if $installable->relation('Provides')->satisfies($expected) + && $self->processable->relation('strong') + ->satisfies("$name (= $version)"); + } + + my $our_version = $self->processable->fields->value('Version'); + + $self->pointed_hint('gir-missing-typelib-dependency', + $gir->pointer, $expected) + unless $self->processable->relation('strong') + ->satisfies("$expected (= $our_version)"); + } + + for my $type_lib (@type_libs) { + + my $expected = 'gir1.2-' . lc($type_lib->basename); + $expected =~ s/\.typelib$//; + $expected =~ tr/_/-/; + + $self->pointed_hint('typelib-package-name-does-not-match', + $type_lib->pointer, $expected) + if $self->processable->name ne $expected + && !$self->processable->relation('Provides')->satisfies($expected); + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Desktop/Gnome/Gir/Substvars.pm b/lib/Lintian/Check/Desktop/Gnome/Gir/Substvars.pm new file mode 100644 index 0000000..d667717 --- /dev/null +++ b/lib/Lintian/Check/Desktop/Gnome/Gir/Substvars.pm @@ -0,0 +1,65 @@ +# desktop/gnome/gir/substvars -- lintian check script -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Desktop::Gnome::Gir::Substvars; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +const my $DOLLAR => q{$}; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $debian_control = $self->processable->debian_control; + + for my $installable ($debian_control->installables) { + + next + unless $installable =~ m{ gir [\d.]+ - .* - [\d.]+ $}x; + + my $relation= $self->processable->binary_relation($installable, 'all'); + + $self->pointed_hint( + 'gobject-introspection-package-missing-depends-on-gir-depends', + $debian_control->item->pointer,$installable) + unless $relation->satisfies($DOLLAR . '{gir:Depends}'); + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Desktop/Icons.pm b/lib/Lintian/Check/Desktop/Icons.pm new file mode 100644 index 0000000..95565ed --- /dev/null +++ b/lib/Lintian/Check/Desktop/Icons.pm @@ -0,0 +1,69 @@ +# desktop/icons -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Desktop::Icons; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + if ($item->name =~ m{/icons/[^/]+/(\d+)x(\d+)/(?!animations/).*\.png$}){ + + my $directory_width = $1; + my $directory_height = $2; + + my $resolved = $item->resolve_path; + + if ($resolved && $resolved->file_type =~ m/,\s*(\d+)\s*x\s*(\d+)\s*,/){ + + my $file_width = $1; + my $file_height = $2; + + my $width_delta = abs($directory_width - $file_width); + my $height_delta = abs($directory_height - $file_height); + + $self->pointed_hint('icon-size-and-directory-name-mismatch', + $item->pointer, $file_width.'x'.$file_height) + if $width_delta > 2 || $height_delta > 2; + } + } + + $self->pointed_hint('raster-image-in-scalable-directory', $item->pointer) + if $item->is_file + && $item->name =~ m{/icons/[^/]+/scalable/.*\.(?:png|xpm)$}; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Desktop/X11.pm b/lib/Lintian/Check/Desktop/X11.pm new file mode 100644 index 0000000..4373980 --- /dev/null +++ b/lib/Lintian/Check/Desktop/X11.pm @@ -0,0 +1,94 @@ +# desktop/x11 -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Desktop::X11; + +use v5.20; +use warnings; +use utf8; + +use List::SomeUtils qw(any none); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has fontdirs => (is => 'rw', default => sub { {} }); + +sub visit_installed_files { + my ($self, $item) = @_; + + # links to FHS locations are allowed + $self->pointed_hint('package-installs-file-to-usr-x11r6', $item->pointer) + if $item->name =~ m{^usr/X11R6/} && !$item->is_symlink; + + return + if $item->is_dir; + + # /usr/share/fonts/X11 + my ($subdir) = ($item->name =~ m{^usr/share/fonts/X11/([^/]+)/\S+}); + if (defined $subdir) { + + $self->fontdirs->{$subdir}++ + if any { $subdir eq $_ } qw(100dpi 75dpi misc); + + if (any { $subdir eq $_ } qw(PEX CID Speedo cyrillic)) { + $self->pointed_hint('file-in-discouraged-x11-font-directory', + $item->pointer); + + } elsif (none { $subdir eq $_ } + qw(100dpi 75dpi misc Type1 encodings util)) { + $self->pointed_hint('file-in-unknown-x11-font-directory', + $item->pointer); + + } elsif ($item->basename eq 'encodings.dir' + or $item->basename =~ m{fonts\.(dir|scale|alias)}) { + $self->pointed_hint('package-contains-compiled-font-file', + $item->pointer); + } + } + + return; +} + +sub installable { + my ($self) = @_; + + # X11 font directories with files + my %fontdirs = %{$self->fontdirs}; + + # check for multiple DPIs in the same X11 bitmap font package. + $self->hint('package-contains-multiple-dpi-fonts') + if $fontdirs{'100dpi'} && $fontdirs{'75dpi'}; + + $self->hint('package-mixes-misc-and-dpi-fonts') + if $fontdirs{misc} && keys %fontdirs > 1; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Desktop/X11/Font/Update.pm b/lib/Lintian/Check/Desktop/X11/Font/Update.pm new file mode 100644 index 0000000..2315e7d --- /dev/null +++ b/lib/Lintian/Check/Desktop/X11/Font/Update.pm @@ -0,0 +1,159 @@ +# desktop/x11/font/update -- lintian check script -*- perl -*- +# +# Copyright (C) 1998 Richard Braakman +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Desktop::X11::Font::Update; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; + +# When detecting commands inside shell scripts, use this regex to match the +# beginning of the command rather than checking whether the command is at the +# beginning of a line. +const my $LEADING_PATTERN=> +'(?:(?:^|[`&;(|{])\s*|(?:if|then|do|while|!)\s+|env(?:\s+[[:alnum:]_]+=(?:\S+|\"[^"]*\"|\'[^\']*\'))*\s+)'; +const my $LEADING_REGEX => qr/$LEADING_PATTERN/; + +has x_fonts => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my @x_fonts + = grep { m{^usr/share/fonts/X11/.*\.(?:afm|pcf|pfa|pfb)(?:\.gz)?$} } + @{$self->processable->installed->sorted_list}; + + return \@x_fonts; + } +); + +sub visit_control_files { + my ($self, $item) = @_; + + return + unless $item->is_maintainer_script; + + return + unless length $item->interpreter; + + return + unless $item->is_open_ok; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $stashed = $EMPTY; + + my $saw_update_fonts = 0; + + my $position = 1; + while (my $possible_continuation = <$fd>) { + + chomp $possible_continuation; + + # skip empty lines + next + if $possible_continuation =~ /^\s*$/; + + # skip comment lines + next + if $possible_continuation =~ /^\s*\#/; + + my $no_comment = remove_comments($possible_continuation); + + # Concatenate lines containing continuation character (\) + # at the end + if ($no_comment =~ s{\\$}{}) { + + $stashed .= $no_comment; + + next; + } + + my $line = $stashed . $no_comment; + $stashed = $EMPTY; + + $saw_update_fonts = 1 + if $line + =~ m{$LEADING_REGEX(?:/usr/bin/)?update-fonts-(?:alias|dir|scale)\s(\S+)}; + + } continue { + ++$position; + } + + close $fd; + + if ($item->name eq 'postinst' && !$saw_update_fonts) { + + $self->pointed_hint('missing-call-to-update-fonts', $item->pointer, $_) + for @{$self->x_fonts}; + } + + return; +} + +sub remove_comments { + my ($line) = @_; + + return $line + unless length $line; + + my $simplified = $line; + + # Remove quoted strings so we can more easily ignore comments + # inside them + $simplified =~ s/(^|[^\\](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g; + $simplified =~ s/(^|[^\\](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g; + + # If the remaining string contains what looks like a comment, + # eat it. In either case, swap the unmodified script line + # back in for processing (if required) and return it. + if ($simplified =~ m/(?:^|[^[\\])[\s\&;\(\)](\#.*$)/) { + + my $comment = $1; + + # eat comment + $line =~ s/\Q$comment\E//; + } + + return $line; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/DhMake.pm b/lib/Lintian/Check/DhMake.pm new file mode 100644 index 0000000..42f8d94 --- /dev/null +++ b/lib/Lintian/Check/DhMake.pm @@ -0,0 +1,83 @@ +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 1999 Joey Hess +# Copyright (C) 2000 Sean 'Shaleh' Perry +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2007 Russ Allbery +# Copyright (C) 2013-2018 Bastien ROUCARIES +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::DhMake; + +use v5.20; +use warnings; +use utf8; + +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + $self->pointed_hint('readme-source-is-dh_make-template', $item->pointer) + if $item->name eq 'debian/README.source' + && $item->bytes + =~ / \QYou WILL either need to modify or delete this file\E /isx; + + if ( $item->name =~ m{^debian/(README.source|copyright|rules|control)$} + && $item->is_open_ok) { + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $position = 1; + while (my $line = <$fd>) { + + next + unless $line =~ m/(?<!")(FIX_?ME)(?!")/; + + my $placeholder = $1; + + $self->pointed_hint('file-contains-fixme-placeholder', + $item->pointer($position), $placeholder); + + } continue { + ++$position; + } + + close $fd; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/DhMake/Template.pm b/lib/Lintian/Check/DhMake/Template.pm new file mode 100644 index 0000000..64c1f57 --- /dev/null +++ b/lib/Lintian/Check/DhMake/Template.pm @@ -0,0 +1,52 @@ +# dh-make/template -- lintian check script -*- perl -*- + +# Copyright (C) 1999 by Joey Hess +# Copyright (C) 2016-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::DhMake::Template; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->dirname eq 'debian/'; + + $self->pointed_hint('dh-make-template-in-source', $item->pointer) + if $item->basename =~ m{^ ex[.] | [.]ex $}ix; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Documentation.pm b/lib/Lintian/Check/Documentation.pm new file mode 100644 index 0000000..364ecde --- /dev/null +++ b/lib/Lintian/Check/Documentation.pm @@ -0,0 +1,246 @@ +# documentation -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Documentation; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(any); +use Unicode::UTF8 qw(encode_utf8); + +const my $VERTICAL_BAR => q{|}; + +# 276 is 255 bytes (maximal length for a filename) plus gzip overhead +const my $MAXIMUM_EMPTY_GZIP_SIZE => 276; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +# a list of regex for detecting non documentation files checked against basename (xi) +my @NOT_DOCUMENTATION_FILE_REGEXES = qw{ + ^dependency_links[.]txt$ + ^entry_points[.]txt$ + ^requires[.]txt$ + ^top_level[.]txt$ + ^requirements[.]txt$ + ^namespace_packages[.]txt$ + ^bindep[.]txt$ + ^version[.]txt$ + ^robots[.]txt$ + ^cmakelists[.]txt$ +}; + +# a list of regex for detecting documentation file checked against basename (xi) +my @DOCUMENTATION_FILE_REGEXES = qw{ + [.]docx?$ + [.]html?$ + [.]info$ + [.]latex$ + [.]markdown$ + [.]md$ + [.]odt$ + [.]pdf$ + [.]readme$ + [.]rmd$ + [.]rst$ + [.]rtf$ + [.]tex$ + [.]txt$ + ^code[-_]of[-_]conduct$ + ^contribut(?:e|ing)$ + ^copyright$ + ^licen[sc]es?$ + ^howto$ + ^patents?$ + ^readme(?:[.]?first|[.]1st|[.]debian|[.]source)?$ + ^todos?$ +}; + +# an OR (|) regex of all compressed extension +has COMPRESS_FILE_EXTENSIONS_OR_ALL => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $COMPRESS_FILE_EXTENSIONS + = $self->data->load('files/compressed-file-extensions',qr/\s+/); + + my $text = join($VERTICAL_BAR, + (map { quotemeta } $COMPRESS_FILE_EXTENSIONS->all)); + + return qr/$text/; + } +); + +sub visit_installed_files { + my ($self, $item) = @_; + + my $ppkg = quotemeta($self->processable->name); + + if ( $self->processable->type eq 'udeb' + && $item->name =~ m{^usr/share/(?:doc|info)/\S}) { + + $self->pointed_hint('udeb-contains-documentation-file',$item->pointer); + return; + } + + $self->pointed_hint('package-contains-info-dir-file', $item->pointer) + if $item->name =~ m{^ usr/share/info/dir (?:[.]old)? (?:[.]gz)? $}x; + + # doxygen md5sum + $self->pointed_hint('useless-autogenerated-doxygen-file', $item->pointer) + if $item->name =~ m{^ usr/share/doc/ $ppkg / [^/]+ / .+ [.]md5$ }sx + && $item->parent_dir->child('doxygen.png'); + + my $regex = $self->COMPRESS_FILE_EXTENSIONS_OR_ALL; + + # doxygen compressed map + $self->pointed_hint('compressed-documentation', $item->pointer) + if $item->name + =~ m{^ usr/share/doc/ (?:.+/)? (?:doxygen|html) / .* [.]map [.] $regex }sx; + + if ($item->is_file + and any { $item->basename =~ m{$_}xi } @DOCUMENTATION_FILE_REGEXES + and any { $item->basename !~ m{$_}xi } @NOT_DOCUMENTATION_FILE_REGEXES) + { + + $self->pointed_hint( + 'package-contains-documentation-outside-usr-share-doc', + $item->pointer) + unless $item->name =~ m{^etc/} + || $item->name =~ m{^usr/share/(?:doc|help)/} + # see Bug#981268 + # usr/lib/python3/dist-packages/*.dist-info/entry_points.txt + || $item->name =~ m{^ usr/lib/python3/dist-packages/ + .+ [.] dist-info/entry_points.txt $}sx + # No need for dh-r packages to automatically + # create overrides if we just allow them all to + # begin with. + || $item->dirname =~ 'usr/lib/R/site-library/' + # SNMP MIB files, see Bug#971427 + || $item->dirname eq 'usr/share/snmp/mibs/' + # see Bug#904852 + || $item->dirname =~ m{templates?(?:[.]d)?/} + || ( $item->basename =~ m{^README}xi + && $item->bytes =~ m{this directory}xi) + # see Bug#1009679, not documentation, just an unlucky suffix + || $item->name =~ m{^var/lib/ocaml/lintian/.+[.]info$} + # see Bug#970275 + || $item->name =~ m{^usr/share/gtk-doc/html/.+[.]html?$}; + } + + if ($item->name =~ m{^usr/share/doc/\S}) { + + # file not owned by root? + unless ($item->identity eq 'root/root' || $item->identity eq '0/0') { + $self->pointed_hint('bad-owner-for-doc-file', $item->pointer, + $item->identity,'!= root/root (or 0/0)'); + } + + # executable in /usr/share/doc ? + if ( $item->is_file + && $item->name !~ m{^usr/share/doc/(?:[^/]+/)?examples/} + && $item->is_executable) { + + if ($item->is_script) { + $self->pointed_hint('script-in-usr-share-doc', $item->pointer); + } else { + $self->pointed_hint('executable-in-usr-share-doc', + $item->pointer,(sprintf '%04o', $item->operm)); + } + } + + # zero byte file in /usr/share/doc/ + if ($item->is_regular_file and $item->size == 0) { + # Exceptions: examples may contain empty files for various + # reasons, Doxygen generates empty *.map files, and Python + # uses __init__.py to mark module directories. + unless ($item->name =~ m{^usr/share/doc/(?:[^/]+/)?examples/} + || $item->name + =~ m{^usr/share/doc/(?:.+/)?(?:doxygen|html)/.*[.]map$}s + || $item->name=~ m{^usr/share/doc/(?:.+/)?__init__[.]py$}s){ + + $self->pointed_hint('zero-byte-file-in-doc-directory', + $item->pointer); + } + } + + if ( $item->name =~ / [.]gz $/msx + && $item->is_regular_file + && $item->size <= $MAXIMUM_EMPTY_GZIP_SIZE + && $item->file_type =~ / gzip \s compressed /msx) { + + open(my $fd, '<:gzip', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $f = <$fd>; + close($fd); + + unless (defined $f and length $f) { + $self->pointed_hint('zero-byte-file-in-doc-directory', + $item->pointer); + } + } + } + + # file directly in /usr/share/doc ? + $self->pointed_hint('file-directly-in-usr-share-doc', $item->pointer) + if $item->is_file + && $item->name =~ m{^ usr/share/doc/ [^/]+ $}x; + + # contains an INSTALL file? + $self->pointed_hint('package-contains-upstream-installation-documentation', + $item->pointer) + if $item->name =~ m{^ usr/share/doc/ $ppkg / INSTALL (?: [.] .+ )* $}sx; + + # contains a README for another distribution/platform? + $self->pointed_hint('package-contains-readme-for-other-platform-or-distro', + $item->pointer) + if $item->name =~ m{^usr/share/doc/$ppkg/readme[.] + (?:apple|aix|atari|be|beos|bsd|bsdi + |cygwin|darwin|irix|gentoo|freebsd|mac|macos + |macosx|netbsd|openbsd|osf|redhat|sco|sgi + |solaris|suse|sun|vms|win32|win9x|windows + )(?:[.]txt)?(?:[.]gz)?$}xi; + + # contains a compressed version of objects.inv in + # sphinx-generated documentation? + $self->pointed_hint('compressed-documentation', $item->pointer) + if $item->name + =~ m{^ usr/share/doc/ $ppkg / (?: [^/]+ / )+ objects [.]inv [.]gz $}x + && $item->file_type =~ m{gzip compressed}; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Documentation/Devhelp.pm b/lib/Lintian/Check/Documentation/Devhelp.pm new file mode 100644 index 0000000..cd186a5 --- /dev/null +++ b/lib/Lintian/Check/Documentation/Devhelp.pm @@ -0,0 +1,87 @@ +# documentation/devhelp -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2022 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Documentation::Devhelp; + +use v5.20; +use warnings; +use utf8; + +use List::SomeUtils qw(none); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +# *.devhelp and *.devhelp2 files must be accessible from a directory in +# the devhelp search path: /usr/share/devhelp/books and +# /usr/share/gtk-doc/html. We therefore look for any links in one of +# those directories to another directory. The presence of such a link +# blesses any file below that other directory. +has reachable_folders => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my @reachable_folders; + + for my $item (@{$self->processable->installed->sorted_list}) { + + # in search path + next + unless $item->name + =~ m{^ usr/share/ (?: devhelp/books | gtk-doc/html ) / }x; + + next + unless length $item->link; + + my $followed = $item->link_normalized; + + # drop broken links + push(@reachable_folders, $followed) + if length $followed; + } + + return \@reachable_folders; + } +); + +sub visit_installed_files { + my ($self, $item) = @_; + + # locate Devhelp files not discoverable by Devhelp + $self->pointed_hint('stray-devhelp-documentation', $item->pointer) + if $item->name =~ m{ [.]devhelp2? (?: [.]gz )? $}x + && $item->name !~ m{^ usr/share/ (?: devhelp/books | gtk-doc/html ) / }x + && (none { $item->name =~ /^\Q$_\E/ } @{$self->reachable_folders}); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Documentation/Devhelp/Standard.pm b/lib/Lintian/Check/Documentation/Devhelp/Standard.pm new file mode 100644 index 0000000..05d77db --- /dev/null +++ b/lib/Lintian/Check/Documentation/Devhelp/Standard.pm @@ -0,0 +1,47 @@ +# documentation/devhelp/standard -- lintian check script -*- perl -*- + +# Copyright (C) 2022 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Documentation::Devhelp::Standard; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + $self->pointed_hint('old-devhelp-standard', $item->pointer) + if $item->name =~ m{ [.]devhelp (?: [.]gz )? $}x; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Documentation/Doxygen.pm b/lib/Lintian/Check/Documentation/Doxygen.pm new file mode 100644 index 0000000..206a4b8 --- /dev/null +++ b/lib/Lintian/Check/Documentation/Doxygen.pm @@ -0,0 +1,75 @@ +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 1999 Joey Hess +# Copyright (C) 2000 Sean 'Shaleh' Perry +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2007 Russ Allbery +# Copyright (C) 2013-2018 Bastien ROUCARIES +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Documentation::Doxygen; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + $self->pointed_hint('source-contains-prebuilt-doxygen-documentation', + $item->parent_dir->pointer) + if $item->basename =~ m{^doxygen.(?:png|sty)$} + && $self->processable->source_name ne 'doxygen'; + + return + unless $item->basename =~ /\.(?:x?html?\d?|xht)$/i; + + my $contents = $item->decoded_utf8; + return + unless length $contents; + + my $lowercase = lc($contents); + + # Identify and ignore documentation templates by looking + # for the use of various interpolated variables. + # <http://www.doxygen.nl/manual/config.html#cfg_html_header> + $self->pointed_hint('source-contains-prebuilt-doxygen-documentation', + $item->pointer) + if $lowercase =~ m{<meta \s+ name="generator" \s+ content="doxygen}smx + && $lowercase + !~ /\$(?:doxygenversion|projectname|projectnumber|projectlogo)\b/; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Documentation/Examples.pm b/lib/Lintian/Check/Documentation/Examples.pm new file mode 100644 index 0000000..4c1b84a --- /dev/null +++ b/lib/Lintian/Check/Documentation/Examples.pm @@ -0,0 +1,48 @@ +# documentation/examples -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Documentation::Examples; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + $self->pointed_hint('nested-examples-directory', $item->pointer) + if $item->is_dir + && $item->name =~ m{^usr/share/doc/[^/]+/examples/examples/?$}; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Documentation/Manual.pm b/lib/Lintian/Check/Documentation/Manual.pm new file mode 100644 index 0000000..4171ef6 --- /dev/null +++ b/lib/Lintian/Check/Documentation/Manual.pm @@ -0,0 +1,663 @@ +# documentation/manual -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz +# Copyright (C) 2019-2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Documentation::Manual; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Cwd qw(getcwd); +use File::Basename; +use IO::Uncompress::Gunzip qw(gunzip $GunzipError); +use IPC::Run3; +use List::Compare; +use List::SomeUtils qw(any none); +use Path::Tiny; +use Text::Balanced qw(extract_delimited); +use Unicode::UTF8 qw(valid_utf8 decode_utf8 encode_utf8); + +use Lintian::Spelling qw(check_spelling); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; +const my $COLON => q{:}; +const my $COMMA => q{,}; +const my $DOT => q{.}; +const my $NEWLINE => qq{\n}; + +const my $USER_COMMAND_SECTION => 1; +const my $SYSTEM_COMMAND_SECTION => 8; + +const my $WAIT_STATUS_SHIFT => 8; +const my $MINIMUM_SHARED_OBJECT_SIZE => 256; +const my $WIDE_SCREEN => 120; + +has local_manpages => (is => 'rw', default => sub { {} }); + +sub spelling_tag_emitter { + my ($self, $tag_name, $pointer, @orig_args) = @_; + + return sub { + return $self->pointed_hint($tag_name, $pointer, @orig_args, @_); + }; +} + +my @user_locations= qw(bin/ usr/bin/ usr/bin/X11/ usr/bin/mh/ usr/games/); +my @admin_locations= qw(sbin/ usr/sbin/ usr/libexec/); + +sub visit_installed_files { + my ($self, $item) = @_; + + # no man pages in udebs + return + if $self->processable->type eq 'udeb'; + + if ($item->name =~ m{^usr/share/man/\S+}) { + + $self->pointed_hint('manual-page-in-udeb', $item->pointer) + if $self->processable->type eq 'udeb'; + + if ($item->is_dir) { + $self->pointed_hint('stray-folder-in-manual', $item->pointer) + unless $item->name + =~ m{^usr/(?:X11R6|share)/man/(?:[^/]+/)?(?:man\d/)?$}; + + } elsif ($item->is_file && $item->is_executable) { + $self->pointed_hint('executable-manual-page', $item->pointer); + } + } + + return + unless $item->is_file || $item->is_symlink; + + my ($manpage, $page_path, undef) = fileparse($item); + + if ($page_path eq 'usr/share/man/' && $manpage ne $EMPTY) { + $self->pointed_hint('odd-place-for-manual-page', $item->pointer); + return; + } + + # manual page? + my ($subdir) = ($page_path =~ m{^usr/share/man(/\S+)}); + return + unless defined $subdir; + + $self->pointed_hint('build-path-in-manual', $item->pointer) + if $item =~ m{/_build_} || $item =~ m{_tmp_buildd}; + + $self->pointed_hint('manual-page-with-generic-name', $item->pointer) + if $item =~ m{/README\.}; + + my ($section) = ($subdir =~ m{^.*man(\d)/$}); + unless (defined $section) { + $self->pointed_hint('odd-place-for-manual-page', $item->pointer); + return; + } + + my ($language) = ($subdir =~ m{^/([^/]+)/man\d/$}); + $language //= $EMPTY; + + # The country should not be part of the man page locale + # directory unless it's one of the known cases where the + # language is significantly different between countries. + $self->pointed_hint('country-in-manual', $item->pointer) + if $language =~ /_/ && $language !~ /^(?:pt_BR|zh_[A-Z][A-Z])$/; + + my @pieces = split(/\./, $manpage); + my $ext = pop @pieces; + + if ($ext ne 'gz') { + + push @pieces, $ext; + $self->pointed_hint('uncompressed-manual-page', $item->pointer); + + } elsif ($item->is_file) { # so it's .gz... files first; links later + + if ($item->file_type !~ m/gzip compressed data/) { + $self->pointed_hint('wrong-compression-in-manual-page', + $item->pointer); + + } elsif ($item->file_type !~ m/max compression/) { + $self->pointed_hint('poor-compression-in-manual-page', + $item->pointer); + } + } + + my $fn_section = pop @pieces; + my $section_num = $fn_section; + + if (scalar @pieces && $section_num =~ s/^(\d).*$/$1/) { + + my $bin = join($DOT, @pieces); + $self->local_manpages->{$bin} = [] + unless $self->local_manpages->{$bin}; + + push @{$self->local_manpages->{$bin}}, + { file => $item, language => $language, section => $section }; + + # number of directory and manpage extension equal? + if ($section_num != $section) { + $self->pointed_hint('odd-place-for-manual-page', $item->pointer); + } + + } else { + $self->pointed_hint('wrong-name-for-manual-page', $item->pointer); + } + + # check symbolic links to other manual pages + if ($item->is_symlink) { + if ($item->link =~ m{(^|/)undocumented}) { + # undocumented link in /usr/share/man -- possibilities + # undocumented... (if in the appropriate section) + # ../man?/undocumented... + # ../../man/man?/undocumented... + # ../../../share/man/man?/undocumented... + # ../../../../usr/share/man/man?/undocumented... + if ( + ( + $item->link =~ m{^undocumented\.([237])\.gz} + && $page_path =~ m{^usr/share/man/man$1} + ) + || $item->link =~ m{^\.\./man[237]/undocumented\.[237]\.gz$} + || $item->link + =~ m{^\.\./\.\./man/man[237]/undocumented\.[237]\.gz$} + || $item->link + =~ m{^\.\./\.\./\.\./share/man/man[237]/undocumented\.[237]\.gz$} + || $item->link + =~ m{^\.\./\.\./\.\./\.\./usr/share/man/man[237]/undocumented\.[237]\.gz$} + ) { + $self->pointed_hint('undocumented-manual-page',$item->pointer); + } else { + $self->pointed_hint('broken-link-to-undocumented', + $item->pointer); + } + } + } else { # not a symlink + + my $fd; + if ($item->file_type =~ m/gzip compressed/) { + + open($fd, '<:gzip', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + } else { + + open($fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + } + + my @manfile = <$fd>; + close $fd; + + # Is it a .so link? + if ($item->size < $MINIMUM_SHARED_OBJECT_SIZE) { + + my ($i, $first) = (0, $EMPTY); + do { + $first = $manfile[$i++] || $EMPTY; + } while ($first =~ /^\.\\"/ && $manfile[$i]); #"); + + unless ($first) { + $self->pointed_hint('empty-manual-page', $item->pointer); + return; + + } elsif ($first =~ /^\.so\s+(.+)?$/) { + my $dest = $1; + if ($dest =~ m{^([^/]+)/(.+)$}) { + + my ($manxorlang, $remainder) = ($1, $2); + + if ($manxorlang !~ /^man\d+$/) { + # then it's likely a language subdir, so let's run + # the other component through the same check + if ($remainder =~ m{^([^/]+)/(.+)$}) { + + my $rest = $2; + $self->pointed_hint( + 'bad-so-link-within-manual-page', + $item->pointer) + unless $rest =~ m{^[^/]+\.\d(?:\S+)?(?:\.gz)?$}; + + } else { + $self->pointed_hint( + 'bad-so-link-within-manual-page', + $item->pointer); + } + } + + } else { + $self->pointed_hint('bad-so-link-within-manual-page', + $item->pointer); + } + return; + } + } + + # If it's not a .so link, use lexgrog to find out if the + # man page parses correctly and make sure the short + # description is reasonable. + # + # This check is currently not applied to pages in + # language-specific hierarchies, because those pages are + # not currently scanned by mandb (bug #29448), and because + # lexgrog can't handle pages in all languages at the + # moment, leading to huge numbers of false negatives. When + # man-db is fixed, this limitation should be removed. + if ($page_path =~ m{/man/man\d/}) { + + delete local $ENV{$_} + for grep { $_ ne 'PATH' && $_ ne 'TMPDIR' } keys %ENV; + local $ENV{LC_ALL} = 'C.UTF-8'; + + my @command = ('lexgrog', $item->unpacked_path); + + my $stdout; + my $stderr; + + run3(\@command, \undef, \$stdout, \$stderr); + + my $exitcode = $?; + my $status = ($exitcode >> $WAIT_STATUS_SHIFT); + + $self->pointed_hint('bad-whatis-entry', $item->pointer) + if $status == 2; + + if ($status != 0 && $status != 2) { + my $message = "Non-zero status $status from @command"; + $message .= $COLON . $NEWLINE . $stderr + if length $stderr; + + warn encode_utf8($message); + + } else { + my $desc = $stdout; + $desc =~ s/^[^:]+: \"(.*)\"$/$1/; + + if ($desc =~ /(\S+)\s+-\s+manual page for \1/i) { + $self->pointed_hint('useless-whatis-entry',$item->pointer); + + } elsif ($desc =~ /\S+\s+-\s+programs? to do something/i) { + $self->pointed_hint('manual-page-from-template', + $item->pointer); + } + } + } + + # If it's not a .so link, run it through 'man' to check for errors. + # If it is in a directory with the standard man layout, cd to the + # parent directory before running man so that .so directives are + # processed properly. (Yes, there are man pages that include other + # pages with .so but aren't simple links; rbash, for instance.) + { + delete local $ENV{$_} + for grep { $_ ne 'PATH' && $_ ne 'TMPDIR' } keys %ENV; + local $ENV{LC_ALL} = 'C.UTF-8'; + + local $ENV{MANROFFSEQ} = $EMPTY; + + # set back to 80 when Bug#892423 is fixed in groff + local $ENV{MANWIDTH} = $WIDE_SCREEN; + + my $stdout; + my $stderr; + + my @command = qw(man --warnings -E UTF-8 -l -Tutf8 -Z); + push(@command, $item->unpacked_path); + + my $localdir = path($item->unpacked_path)->parent->stringify; + $localdir =~ s{^(.*)/man\d\b}{$1}s; + + my $savedir = getcwd; + chdir($localdir) + or die encode_utf8('Cannot change directory ' . $localdir); + + run3(\@command, \undef, \$stdout, \$stderr); + + my $exitcode = $?; + my $status = ($exitcode >> $WAIT_STATUS_SHIFT); + + my @lines = split(/\n/, $stderr); + + my $position = 1; + for my $line (@lines) { + + chomp $line; + + # Devel::Cover causes some annoying deep recursion + # warnings and sometimes in our child process. + # Filter them out, but only during coverage. + next + if $ENV{LINTIAN_COVERAGE} + && $line =~ m{ + \A Deep [ ] recursion [ ] on [ ] subroutine [ ] + "[^"]+" [ ] at [ ] .*B/Deparse.pm [ ] line [ ] + \d+}xsm; + + # ignore progress information from man + next + if $line =~ /^Reformatting/; + + next + if $line =~ /^\s*$/; + + # ignore errors from gzip; dealt with elsewhere + next + if $line =~ /^\bgzip\b/; + + # ignore wrapping failures for Asian man pages (groff problem) + if ($language =~ /^(?:ja|ko|zh)/) { + next + if $line =~ /warning \[.*\]: cannot adjust line/; + next + if $line =~ /warning \[.*\]: can\'t break line/; + } + + # ignore wrapping failures if they contain URLs (.UE is an + # extension for marking the end of a URL). + next + if $line + =~ /:(\d+): warning \[.*\]: (?:can\'t break|cannot adjust) line/ + && ( $manfile[$1 - 1] =~ m{(?:https?|ftp|file)://.+}i + || $manfile[$1 - 1] =~ m{^\s*\.\s*UE\b}); + + # ignore common undefined macros from pod2man << Perl 5.10 + next + if $line =~ /warning: (?:macro )?\'(?:Tr|IX)\' not defined/; + + $line =~ s/^[^:]+: //; + $line =~ s/^<standard input>://; + + $self->pointed_hint('groff-message', + $item->pointer($position), $line); + } continue { + ++$position; + } + + chdir($savedir) + or die encode_utf8('Cannot change directory ' . $savedir); + + } + + # Now we search through the whole man page for some common errors + my $position = 1; + my $seen_python_traceback; + for my $line (@manfile) { + + chomp $line; + + next + if $line =~ /^\.\\\"/; # comments .\" + + if ($line =~ /^\.TH\s/) { + + # title header + my $consumed = $line; + $consumed =~ s/ [.]TH \s+ //msx; + + my ($delimited, $after_names) = extract_delimited($consumed); + unless (length $delimited) { + $consumed =~ s/ ^ \s* \S+ , //gmsx; + $consumed =~ s/ ^ \s* \S+ //msx; + $after_names = $consumed; + } + + my ($th_section) = extract_delimited($after_names); + if (length $th_section) { + + # drop initial delimiter + $th_section =~ s/ ^. //msx; + + # drop final delimiter + $th_section =~ s/ .$ //msx; + + # unescape + $th_section =~ s/ [\\](.) /$1/gmsx; + + } elsif (length $after_names + && $after_names =~ / ^ \s* (\S+) /msx) { + $th_section = $1; + } + + $self->pointed_hint( + 'wrong-manual-section', + $item->pointer($position), + "$fn_section != $th_section" + )if length $th_section && fc($th_section) ne fc($fn_section); + } + + if ( ($line =~ m{(/usr/(dict|doc|etc|info|man|adm|preserve)/)}) + || ($line =~ m{(/var/(adm|catman|named|nis|preserve)/)})){ + # FSSTND dirs in man pages + # regexes taken from checks/files + $self->pointed_hint('FSSTND-dir-in-manual-page', + $item->pointer($position), $1); + } + + if ($line eq '.SH "POD ERRORS"') { + $self->pointed_hint('pod-conversion-message', + $item->pointer($position)); + } + + if ($line =~ /Traceback \(most recent call last\):/) { + $self->pointed_hint('python-traceback-in-manpage', + $item->pointer) + unless $seen_python_traceback; + $seen_python_traceback = 1; + } + + # Check for spelling errors if the manpage is English + my $stag_emitter + = $self->spelling_tag_emitter('typo-in-manual-page', + $item->pointer($position)); + check_spelling($self->data, $line, + $self->group->spelling_exceptions, + $stag_emitter, 0) + if $page_path =~ m{/man/man\d/}; + + } continue { + ++$position; + } + } + + # most man pages are zipped + my $bytes; + if ($item->file_type =~ /gzip compressed/) { + + my $path = $item->unpacked_path; + gunzip($path => \$bytes) + or die encode_utf8("gunzip $path failed: $GunzipError"); + + } elsif ($item->file_type =~ /^troff/ || $item->file_type =~ /text$/) { + $bytes = $item->bytes; + } + + return + unless length $bytes; + + # another check complains about invalid encoding + return + unless valid_utf8($bytes); + + my $contents = decode_utf8($bytes); + my @lines = split(/\n/, $contents); + + my $position = 1; + for my $line (@lines) { + + # see Bug#554897 and Bug#507673; exclude string variables + $self->pointed_hint('acute-accent-in-manual-page', + $item->pointer($position)) + if $line =~ /\\'/ && $line !~ /^\.\s*ds\s/; + + } continue { + $position++; + } + + return; +} + +sub installable { + my ($self) = @_; + + # no man pages in udebs + return + if $self->processable->type eq 'udeb'; + + my %local_user_executables; + my %local_admin_executables; + + for my $item (@{$self->processable->installed->sorted_list}) { + + next + unless $item->is_symlink || $item->is_file; + + my ($name, $path, undef) = fileparse($item->name); + + $local_user_executables{$name} = $item + if any { $path eq $_ } @user_locations; + + $local_admin_executables{$name} = $item + if any { $path eq $_ } @admin_locations; + } + + my %local_executables= (%local_user_executables, %local_admin_executables); + my @local_commands = keys %local_executables; + + my @direct_reliants + =@{$self->group->direct_reliants($self->processable) // []}; + my @reliant_files = map { @{$_->installed->sorted_list} } @direct_reliants; + + # for executables, look at packages relying on the current processable + my %distant_executables; + for my $item (@reliant_files) { + + next + unless $item->is_file || $item->is_symlink; + + my ($name, $path, undef) = fileparse($item, qr{\..+$}); + + $distant_executables{$name} = $item + if any { $path eq $_ } (@user_locations, @admin_locations); + } + + my @distant_commands = keys %distant_executables; + my @related_commands = (@local_commands, @distant_commands); + + my @direct_prerequisites + =@{$self->group->direct_dependencies($self->processable) // []}; + my@prerequisite_files + = map { @{$_->installed->sorted_list} } @direct_prerequisites; + + # for manpages, look at packages the current processable relies upon + my %distant_manpages; + for my $item (@prerequisite_files) { + + next + unless $item->is_file || $item->is_symlink; + + my ($name, $path, undef) = fileparse($item, qr{\..+$}); + + next + unless $path =~ m{^usr/share/man/\S+}; + + next + unless $path =~ m{man\d/$}; + + my ($language) = ($path =~ m{/([^/]+)/man\d/$}); + $language //= $EMPTY; + $language = $EMPTY if $language eq 'man'; + + $distant_manpages{$name} //= []; + + push @{$distant_manpages{$name}}, + {file => $item, language => $language}; + } + + my %local_manpages = %{$self->local_manpages}; + my %related_manpages = (%local_manpages, %distant_manpages); + + # provides sorted output + my $related + = List::Compare->new(\@local_commands, [keys %related_manpages]); + my @documented = $related->get_intersection; + my @manpage_missing = $related->get_Lonly; + + my @english_missing = grep { + none {$_->{language} eq $EMPTY} + @{$related_manpages{$_} // []} + } @documented; + + for my $command (keys %local_admin_executables) { + + my $item = $local_admin_executables{$command}; + my @manpages = @{$related_manpages{$command} // []}; + + my @sections = grep { defined } map { $_->{section} } @manpages; + $self->pointed_hint('manual-page-for-system-command', $item->pointer) + if $item->is_regular_file + && any { $_ == $USER_COMMAND_SECTION } @sections; + } + + for (map {$local_executables{$_}} @english_missing) { + $self->pointed_hint('no-english-manual-page', $_->pointer) + unless $_->name =~ m{/libexec/}; + } + + for (map {$local_executables{$_}} @manpage_missing) { + $self->pointed_hint('no-manual-page', $_->pointer) + unless $_->name =~ m{/libexec/}; + } + + # surplus manpages only for this package; provides sorted output + my $local = List::Compare->new(\@related_commands, [keys %local_manpages]); + my @surplus_manpages = $local->get_Ronly; + + # filter out sub commands, underscore for libreswan; see Bug#947258 + for my $command (@related_commands) { + @surplus_manpages = grep { !/^$command(?:\b|_)/ } @surplus_manpages; + } + + for my $manpage (map { @{$local_manpages{$_} // []} } @surplus_manpages) { + + my $item = $manpage->{file}; + my $section = $manpage->{section}; + + $self->pointed_hint('spare-manual-page', $item->pointer) + if $section == $USER_COMMAND_SECTION + || $section == $SYSTEM_COMMAND_SECTION; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Documentation/Texinfo.pm b/lib/Lintian/Check/Documentation/Texinfo.pm new file mode 100644 index 0000000..cc4be39 --- /dev/null +++ b/lib/Lintian/Check/Documentation/Texinfo.pm @@ -0,0 +1,195 @@ +# documentation/texinfo -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz +# Copyright (C) 2001 Josip Rodin +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Documentation::Texinfo; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Unicode::UTF8 qw(encode_utf8); +use List::SomeUtils qw(uniq); + +use Lintian::Util qw(normalize_link_target); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; + +sub binary { + my ($self) = @_; + + my $info_dir + = $self->processable->installed->resolve_path('usr/share/info/'); + return + unless $info_dir; + + # Read package contents... + for my $item ($info_dir->descendants) { + + next + unless $item->is_symlink + || $item->is_file; + + # Ignore dir files. That's a different error which we already catch in + # the files check. + next + if $item->basename =~ /^dir(?:\.old)?(?:\.gz)?/; + + # Analyze the file names making sure the documents are named + # properly. Note that Emacs 22 added support for images in + # info files, so we have to accept those and ignore them. + # Just ignore .png files for now. + my @fname_pieces = split(m{ [.] }x, $item->basename); + my $extension = pop @fname_pieces; + + if ($extension eq 'gz') { # ok! + if ($item->is_file) { + + # compressed with maximum compression rate? + if ($item->file_type !~ m/gzip compressed data/) { + $self->pointed_hint( + 'info-document-not-compressed-with-gzip', + $item->pointer); + + } else { + if ($item->file_type !~ m/max compression/) { + $self->pointed_hint( +'info-document-not-compressed-with-max-compression', + $item->pointer + ); + } + } + } + + } elsif ($extension =~ m/^(?:png|jpe?g)$/) { + next; + + } else { + push(@fname_pieces, $extension); + $self->pointed_hint('info-document-not-compressed',$item->pointer); + } + + my $infoext = pop @fname_pieces; + unless ($infoext && $infoext =~ /^info(-\d+)?$/) { # it's not foo.info + + # it's not foo{,-{1,2,3,...}} + $self->pointed_hint('info-document-has-wrong-extension', + $item->pointer) + if @fname_pieces; + } + + # If this is the main info file (no numeric extension). make + # sure it has appropriate dir entry information. + if ( $item->basename !~ /-\d+\.gz/ + && $item->file_type =~ /gzip compressed data/) { + + # unsafe symlink, skip. Actually, this should never + # be true as "$file_type" for symlinks will not be + # "gzip compressed data". But for good measure. + next + unless $item->is_open_ok; + + open(my $fd, '<:gzip', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my ($section, $start, $end); + while (my $line = <$fd>) { + + $section = 1 + if $line =~ /^INFO-DIR-SECTION\s+\S/; + + $start = 1 + if $line =~ /^START-INFO-DIR-ENTRY\b/; + + $end = 1 + if $line =~ /^END-INFO-DIR-ENTRY\b/; + } + + close $fd; + + $self->pointed_hint('info-document-missing-dir-section', + $item->pointer) + unless $section; + + $self->pointed_hint('info-document-missing-dir-entry', + $item->pointer) + unless $start && $end; + } + + # Check each [image src=""] form in the info files. The src + # filename should be in the package. As of Texinfo 5 it will + # be something.png or something.jpg, but that's not enforced. + # + # See Texinfo manual (info "(texinfo)Info Format Image") for + # details of the [image] form. Bytes \x00,\x08 introduce it + # (and distinguishes it from [image] appearing as plain text). + # + # String src="..." part has \" for literal " and \\ for + # literal \, though that would be unlikely in filenames. For + # the tag() message show $src unbackslashed since that's the + # filename sought. + # + if ($item->is_file && $item->basename =~ /\.info(?:-\d+)?\.gz$/) { + + open(my $fd, '<:gzip', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $position = 1; + while (my $line = <$fd>) { + + my @missing; + while ($line =~ /[\0][\b]\[image src="((?:\\.|[^\"])+)"/smg) { + + my $src = $1; + $src =~ s/\\(.)/$1/g; # unbackslash + + push(@missing, $src) + unless $self->processable->installed->lookup( + normalize_link_target('usr/share/info', $src)); + } + + $self->pointed_hint('info-document-missing-image-file', + $item->pointer($position), $_) + for uniq @missing; + + } continue { + ++$position; + } + + close $fd; + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Emacs.pm b/lib/Lintian/Check/Emacs.pm new file mode 100644 index 0000000..6c6f94e --- /dev/null +++ b/lib/Lintian/Check/Emacs.pm @@ -0,0 +1,58 @@ +# emacs -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Emacs; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +const my $WIDELY_READABLE => oct(644); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + # /etc/emacs.* + if ( $item->is_file + && $item->name =~ m{^etc/emacs.*/\S} + && $item->operm != $WIDELY_READABLE) { + + $self->pointed_hint('bad-permissions-for-etc-emacs-script', + $item->pointer, + sprintf('%04o != %04o', $item->operm, $WIDELY_READABLE)); + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Emacs/Elpa.pm b/lib/Lintian/Check/Emacs/Elpa.pm new file mode 100644 index 0000000..9b3528a --- /dev/null +++ b/lib/Lintian/Check/Emacs/Elpa.pm @@ -0,0 +1,51 @@ +# emacs/elpa -- lintian check script -*- perl -*- + +# Copyright (C) 2017 Sean Whitton +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Emacs::Elpa; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub installable { + my ($self) = @_; + + $self->hint('emacsen-common-without-dh-elpa') + if defined $self->processable->installed->lookup( + 'usr/lib/emacsen-common/packages/install/') + && ! + defined $self->processable->installed->lookup( + 'usr/share/emacs/site-lisp/elpa-src/'); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Examples.pm b/lib/Lintian/Check/Examples.pm new file mode 100644 index 0000000..ef9a452 --- /dev/null +++ b/lib/Lintian/Check/Examples.pm @@ -0,0 +1,82 @@ +# Check::Examples -- lintian check script -*- perl -*- +# +# based on debhelper check, +# Copyright (C) 1999 Joey Hess +# Copyright (C) 2000 Sean 'Shaleh' Perry +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2007 Russ Allbery +# Copyright (C) 2013-2018 Bastien ROUCARIES +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Examples; + +use v5.20; +use warnings; +use utf8; + +use List::SomeUtils qw(any); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has group_ships_examples => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my @processables = $self->group->get_installables; + + # assume shipped examples if there is a package so named + return 1 + if any { $_->name =~ m{-examples$} } @processables; + + my @shipped = map { @{$_->installed->sorted_list} } @processables; + + # Check each package for a directory (or symlink) called "examples". + return 1 + if any { m{^usr/share/doc/(.+/)?examples/?$} } @shipped; + + return 0; + } +); + +sub visit_patched_files { + my ($self, $item) = @_; + + # some installation files must be present; see Bug#972614 + $self->pointed_hint('package-does-not-install-examples', $item->pointer) + if $item->basename eq 'examples' + && $item->dirname !~ m{(?:^|/)(?:vendor|third_party)/} + && $self->group->get_installables + && !$self->group_ships_examples; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Executable.pm b/lib/Lintian/Check/Executable.pm new file mode 100644 index 0000000..37fcb67 --- /dev/null +++ b/lib/Lintian/Check/Executable.pm @@ -0,0 +1,59 @@ +# executable -- lintian check script -*- perl -*- +# +# Copyright (C) 1998 Richard Braakman +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Executable; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + $self->pointed_hint('executable-not-elf-or-script', $item->pointer) + if $item->is_executable + && $item->file_type !~ / ^ [^,]* \b ELF \b /msx + && !$item->is_script + && !$item->is_hardlink + && $item->name !~ m{^ usr(?:/X11R6)?/man/ }x + && $item->name !~ m/ [.]exe $/x # mono convention + && $item->name !~ m/ [.]jar $/x; # Debian Java policy 2.2 + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Architecture.pm b/lib/Lintian/Check/Fields/Architecture.pm new file mode 100644 index 0000000..caa5814 --- /dev/null +++ b/lib/Lintian/Check/Fields/Architecture.pm @@ -0,0 +1,132 @@ +# fields/architecture -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Architecture; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::Compare; +use List::SomeUtils qw(any); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; + +has installable_architecture => (is => 'rw', default => $EMPTY); + +sub installable { + my ($self) = @_; + + my @installable_architectures + = $self->processable->fields->trimmed_list('Architecture'); + return + unless @installable_architectures; + + for my $installable_architecture (@installable_architectures) { + $self->hint('arch-wildcard-in-binary-package', + $installable_architecture) + if $self->data->architectures->is_wildcard( + $installable_architecture); + } + + $self->hint('too-many-architectures', (sort @installable_architectures)) + if @installable_architectures > 1; + + my $installable_architecture = $installable_architectures[0]; + + $self->hint('aspell-package-not-arch-all') + if $self->processable->name =~ /^aspell-[a-z]{2}(?:-.*)?$/ + && $installable_architecture ne 'all'; + + $self->hint('documentation-package-not-architecture-independent') + if $self->processable->name =~ /-docs?$/ + && $installable_architecture ne 'all'; + + return; +} + +sub always { + my ($self) = @_; + + my @installable_architectures + = $self->processable->fields->trimmed_list('Architecture'); + for my $installable_architecture (@installable_architectures) { + + $self->hint('unknown-architecture', $installable_architecture) + unless $self->data->architectures->is_release_architecture( + $installable_architecture) + || $self->data->architectures->is_wildcard($installable_architecture) + || $installable_architecture eq 'all' + || ( + $installable_architecture eq 'source' + && ( $self->processable->type eq 'changes' + || $self->processable->type eq 'buildinfo') + ); + } + + # check for magic installable architecture combinations + if (@installable_architectures > 1) { + + my $magic_error = 0; + + if (any { $_ eq 'all' } @installable_architectures) { + $magic_error++ + unless any { $self->processable->type eq $_ } + qw(source changes buildinfo); + } + + my $anylc = List::Compare->new(\@installable_architectures, ['any']); + if ($anylc->get_intersection) { + + my @errorset = $anylc->get_Lonly; + + # Allow 'all' to be present in source packages as well + # (#626775) + @errorset = grep { $_ ne 'all' } @errorset + if any { $self->processable->type eq $_ } + qw(source changes buildinfo); + + $magic_error++ + if @errorset; + } + + $self->hint('magic-arch-in-arch-list') if $magic_error; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Bugs.pm b/lib/Lintian/Check/Fields/Bugs.pm new file mode 100644 index 0000000..6485650 --- /dev/null +++ b/lib/Lintian/Check/Fields/Bugs.pm @@ -0,0 +1,62 @@ +# fields/bugs -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Bugs; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub always { + my ($self) = @_; + + my $fields = $self->processable->fields; + + return + unless $fields->declares('Bugs'); + + my $bugs = $fields->unfolded_value('Bugs'); + + $self->hint('redundant-bugs-field') + if $bugs =~ m{^debbugs://bugs.debian.org/?$}i; + + $self->hint('bugs-field-does-not-refer-to-debian-infrastructure', $bugs) + unless $bugs =~ m{\.debian\.org} + || $self->processable->name =~ /[-]dbgsym$/; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/BuiltUsing.pm b/lib/Lintian/Check/Fields/BuiltUsing.pm new file mode 100644 index 0000000..5da9475 --- /dev/null +++ b/lib/Lintian/Check/Fields/BuiltUsing.pm @@ -0,0 +1,72 @@ +# fields/built-using -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::BuiltUsing; + +use v5.20; +use warnings; +use utf8; + +use Lintian::Relation; +use Lintian::Util qw($PKGNAME_REGEX $PKGVERSION_REGEX); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub always { + my ($self) = @_; + + my $processable = $self->processable; + + return + unless $processable->fields->declares('Built-Using'); + + my $built_using = $processable->fields->value('Built-Using'); + + my $built_using_rel = Lintian::Relation->new->load($built_using); + $built_using_rel->visit( + sub { + my ($package) = @_; + if ($package !~ /^$PKGNAME_REGEX \(= $PKGVERSION_REGEX\)$/) { + $self->hint('invalid-value-in-built-using-field', $package); + return 1; + } + return 0; + }, + Lintian::Relation::VISIT_OR_CLAUSE_FULL + | Lintian::Relation::VISIT_STOP_FIRST_MATCH + ); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/ChangedBy.pm b/lib/Lintian/Check/Fields/ChangedBy.pm new file mode 100644 index 0000000..4f58b1b --- /dev/null +++ b/lib/Lintian/Check/Fields/ChangedBy.pm @@ -0,0 +1,66 @@ +# changed-by -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2017-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020 Felix Lechner +# +# This program is free software. It is distributed 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::ChangedBy; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub changes { + my ($self) = @_; + + # Changed-By is optional in Policy, but if set, must be + # syntactically correct. It's also used by dak. + return + unless $self->processable->fields->declares('Changed-By'); + + my $changed_by = $self->processable->fields->value('Changed-By'); + + my $DERIVATIVE_CHANGED_BY + = $self->data->load('common/derivative-changed-by',qr/\s*~~\s*/); + + for my $regex ($DERIVATIVE_CHANGED_BY->all) { + + next + if $changed_by =~ /$regex/; + + my $explanation = $DERIVATIVE_CHANGED_BY->value($regex); + $self->hint('changed-by-invalid-for-derivative', + $changed_by, "($explanation)"); + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Checksums.pm b/lib/Lintian/Check/Fields/Checksums.pm new file mode 100644 index 0000000..2ea745e --- /dev/null +++ b/lib/Lintian/Check/Fields/Checksums.pm @@ -0,0 +1,53 @@ +# fields/checksums -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Checksums; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $processable = $self->processable; + + $self->hint('no-strong-digests-in-dsc') + unless $processable->fields->declares('Checksums-Sha256'); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Deb822.pm b/lib/Lintian/Check/Fields/Deb822.pm new file mode 100644 index 0000000..d68fa6c --- /dev/null +++ b/lib/Lintian/Check/Fields/Deb822.pm @@ -0,0 +1,89 @@ +# fields/deb822 -- lintian check script -*- perl -*- +# +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Deb822; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Syntax::Keyword::Try; + +use Lintian::Deb822; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $SECTION => qq{\N{SECTION SIGN}}; + +my @SOURCE_DEB822 = qw(debian/control); + +sub source { + my ($self) = @_; + + for my $location (@SOURCE_DEB822) { + + my $item = $self->processable->patched->resolve_path($location); + return + unless defined $item; + + my $deb822 = Lintian::Deb822->new; + + my @sections; + try { + @sections = $deb822->read_file($item->unpacked_path) + + } catch { + next; + } + + my $count = 1; + for my $section (@sections) { + + for my $field_name ($section->names) { + + my $field_value = $section->value($field_name); + + my $position = $section->position($field_name); + my $pointer = $item->pointer($position); + + $self->pointed_hint('trimmed-deb822-field', $pointer, + $SECTION . $count, + $field_name, $field_value); + } + + } continue { + $count++; + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Derivatives.pm b/lib/Lintian/Check/Fields/Derivatives.pm new file mode 100644 index 0000000..4f42765 --- /dev/null +++ b/lib/Lintian/Check/Fields/Derivatives.pm @@ -0,0 +1,88 @@ +# fields/derivatives -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Derivatives; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +const my $HYPHEN => q{-}; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has DERIVATIVE_FIELDS => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my %fields; + + my $data= $self->data->load('fields/derivative-fields',qr/\s*\~\~\s*/); + + for my $key ($data->all) { + + my $value = $data->value($key); + my ($regexp, $explanation) = split(/\s*\~\~\s*/, $value, 2); + $fields{$key} = { + 'regexp' => qr/$regexp/, + 'explanation' => $explanation, + }; + } + + return \%fields; + } +); + +sub source { + my ($self) = @_; + + my $processable = $self->processable; + + for my $field (keys %{$self->DERIVATIVE_FIELDS}) { + + my $val = $processable->fields->value($field) || $HYPHEN; + my $data = $self->DERIVATIVE_FIELDS->{$field}; + + $self->hint('invalid-field-for-derivative', + "$field: $val ($data->{'explanation'})") + if $val !~ m/$data->{'regexp'}/; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Description.pm b/lib/Lintian/Check/Fields/Description.pm new file mode 100644 index 0000000..9bfd5bc --- /dev/null +++ b/lib/Lintian/Check/Fields/Description.pm @@ -0,0 +1,323 @@ +# fields/description -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Description; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +use Lintian::Spelling qw(check_spelling check_spelling_picky); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +# Compared to a lower-case string, so it must be all lower-case +const my $DH_MAKE_PERL_TEMPLATE => +'this description was automagically extracted from the module by dh-make-perl'; + +const my $EMPTY => q{}; +const my $SLASH => q{/}; +const my $DOUBLE_COLON => q{::}; + +const my $MAXIMUM_WIDTH => 80; + +sub spelling_tag_emitter { + my ($self, @orig_args) = @_; + return sub { + return $self->hint(@orig_args, @_); + }; +} + +sub installable { + my ($self) = @_; + + my $pkg = $self->processable->name; + my $type = $self->processable->type; + my $processable = $self->processable; + my $group = $self->group; + + my $tabs = 0; + my $template = 0; + my $unindented_list = 0; + + return + unless $processable->fields->declares('Description'); + + my $full_description= $processable->fields->untrimmed_value('Description'); + + $full_description =~ m/^([^\n]*)\n(.*)$/s; + my ($synopsis, $extended) = ($1, $2); + unless (defined $synopsis) { + # The first line will always be completely stripped but + # continuations may have leading whitespace. Therefore we + # have to strip $full_description to restore this property, + # when we use it as a fall-back value of the synopsis. + $synopsis = $full_description; + + # trim both ends + $synopsis =~ s/^\s+|\s+$//g; + + $extended = $EMPTY; + } + + $extended //= $EMPTY; + + if ($synopsis =~ m/^\s*$/) { + $self->hint('description-synopsis-is-empty'); + } else { + if ($synopsis =~ m/^\Q$pkg\E\b/i) { + $self->hint('description-starts-with-package-name'); + } + if ($synopsis =~ m/^(an?|the)\s/i) { + $self->hint('description-synopsis-starts-with-article'); + } + if ($synopsis =~ m/(.*\.)(?:\s*$|\s+\S+)/i) { + $self->hint('synopsis-is-a-sentence',"\"$synopsis\"") + unless $1 =~ m/\s+etc\.$/ + or $1 =~ m/\s+e\.?g\.$/ + or $1 =~ m/(?<!\.)\.\.\.$/; + } + if ($synopsis =~ m/\t/) { + $self->hint('description-contains-tabs') unless $tabs++; + } + + $self->hint('odd-mark-in-description', + 'comma not followed by whitespace (synopsis)') + if $synopsis =~ /,[^\s\d]/; + + if ($synopsis =~ m/^missing\s*$/i) { + $self->hint('description-is-debmake-template') unless $template++; + } elsif ($synopsis =~ m/<insert up to 60 chars description>/) { + $self->hint('description-is-dh_make-template') unless $template++; + } + if ($synopsis !~ m/\s/) { + $self->hint('description-too-short', $synopsis); + } + my $pkg_fmt = lc $pkg; + my $synopsis_fmt = lc $synopsis; + # made a fuzzy match + $pkg_fmt =~ s/[-_]/ /g; + $synopsis_fmt =~ s{[-_/\\]}{ }g; + $synopsis_fmt =~ s/\s+/ /g; + if ($pkg_fmt eq $synopsis_fmt) { + $self->hint('description-is-pkg-name', $synopsis); + } + + $self->hint('synopsis-too-long') + if length $synopsis > $MAXIMUM_WIDTH; + } + + my $PLANNED_FEATURES= $self->data->load('description/planned-features'); + + my $flagged_homepage; + my @lines = split(/\n/, $extended); + + # count starts for extended description + my $position = 1; + for my $line (@lines) { + next + if $line =~ /^ \.\s*$/; + + if ($position == 1) { + my $firstline = lc $line; + my $lsyn = lc $synopsis; + if ($firstline =~ /^\Q$lsyn\E$/) { + $self->hint('description-synopsis-is-duplicated', + "line $position"); + } else { + $firstline =~ s/[^a-zA-Z0-9]+//g; + $lsyn =~ s/[^a-zA-Z0-9]+//g; + if ($firstline eq $lsyn) { + $self->hint('description-synopsis-is-duplicated', + "line $position"); + } + } + } + + if ($line =~ /^ \.\s*\S/ || $line =~ /^ \s+\.\s*$/) { + $self->hint('description-contains-invalid-control-statement', + "line $position"); + } elsif ($line =~ /^ [\-\*]/) { + # Print it only the second time. Just one is not enough to be sure that + # it's a list, and after the second there's no need to repeat it. + $self->hint('possible-unindented-list-in-extended-description', + "line $position") + if $unindented_list++ == 2; + } + + if ($line =~ /\t/) { + $self->hint('description-contains-tabs', "line $position") + unless $tabs++; + } + + if ($line =~ m{^\s*Homepage: <?https?://}i) { + $self->hint('description-contains-homepage', "line $position"); + $flagged_homepage = 1; + } + + if ($PLANNED_FEATURES->matches_any($line, 'i')) { + $self->hint('description-mentions-planned-features', + "(line $position)"); + } + + $self->hint('odd-mark-in-description', + "comma not followed by whitespace (line $position)") + if $line =~ /,[^\s\d]/; + + $self->hint('description-contains-dh-make-perl-template', + "line $position") + if lc($line) =~ / \Q$DH_MAKE_PERL_TEMPLATE\E /msx; + + my $first_person = $line; + my %seen; + while ($first_person + =~ m/(?:^|\s)(I|[Mm]y|[Oo]urs?|mine|myself|me|us|[Ww]e)(?:$|\s)/) { + my $word = $1; + $first_person =~ s/\Q$word//; + $self->hint('using-first-person-in-description', + "line $position: $word") + unless $seen{$word}++; + } + + if ($position == 1) { + # checks for the first line of the extended description: + if ($line =~ /^ \s/) { + $self->hint('description-starts-with-leading-spaces', + "line $position"); + } + if ($line =~ /^\s*missing\s*$/i) { + $self->hint('description-is-debmake-template',"line $position") + unless $template++; + } elsif ( + $line =~ /<insert long description, indented with spaces>/) { + $self->hint('description-is-dh_make-template',"line $position") + unless $template++; + } + } + + $self->hint('extended-description-line-too-long', "line $position") + if length $line > $MAXIMUM_WIDTH; + + } continue { + ++$position; + } + + if ($type ne 'udeb') { + if (@lines == 0) { + # Ignore debug packages with empty "extended" description + # "debug symbols for pkg foo" is generally descriptive + # enough. + $self->hint('extended-description-is-empty') + unless $processable->is_debug_package; + + } elsif (@lines < 2 && $synopsis !~ /(?:dummy|transition)/i) { + $self->hint('extended-description-is-probably-too-short') + unless $processable->is_transitional + || $processable->is_meta_package + || $pkg =~ m{-dbg\Z}xsm; + + } elsif ($extended =~ /^ \.\s*\n|\n \.\s*\n \.\s*\n|\n \.\s*\n?$/) { + $self->hint('extended-description-contains-empty-paragraph'); + } + } + + # Check for a package homepage in the description and no Homepage + # field. This is less accurate and more of a guess than looking + # for the old Homepage: convention in the body. + unless ($processable->fields->declares('Homepage') or $flagged_homepage) { + if ( + $extended =~ m{homepage|webpage|website|url|upstream|web\s+site + |home\s+page|further\s+information|more\s+info + |official\s+site|project\s+home}xi + && $extended =~ m{\b(https?://[a-z0-9][^>\s]+)}i + ) { + $self->hint('description-possibly-contains-homepage', $1); + } elsif ($extended =~ m{\b(https?://[a-z0-9][^>\s]+)>?\.?\s*\z}i) { + $self->hint('description-possibly-contains-homepage', $1); + } + } + + if ($synopsis) { + check_spelling( + $self->data, + $synopsis, + $group->spelling_exceptions, + $self->spelling_tag_emitter( + 'spelling-error-in-description-synopsis') + ); + # Auto-generated dbgsym packages will use the package name in + # their synopsis. Unfortunately, some package names trigger a + # capitalization error, such as "dbus" -> "D-Bus". Therefore, + # we exempt auto-generated packages from this check. + check_spelling_picky( + $self->data, + $synopsis, + $self->spelling_tag_emitter( + 'capitalization-error-in-description-synopsis') + ) unless $processable->is_auto_generated; + } + + if ($extended) { + check_spelling( + $self->data,$extended, + $group->spelling_exceptions, + $self->spelling_tag_emitter('spelling-error-in-description') + ); + check_spelling_picky($self->data, $extended, + $self->spelling_tag_emitter('capitalization-error-in-description') + ); + } + + if ($pkg =~ /^lib(.+)-perl$/) { + my $mod = $1; + my @mod_path_elements = split(/-/, $mod); + $mod = join($DOUBLE_COLON, map {ucfirst} @mod_path_elements); + my $mod_lc = lc($mod); + + my $pm_found = 0; + my $pmpath = join($SLASH, @mod_path_elements).'.pm'; + my $pm = $mod_path_elements[-1].'.pm'; + + for my $filepath (@{$processable->installed->sorted_list}) { + if ($filepath =~ m{\Q$pmpath\E\z|/\Q$pm\E\z}i) { + $pm_found = 1; + last; + } + } + + $self->hint('perl-module-name-not-mentioned-in-description', $mod) + if (index(lc($extended), $mod_lc) < 0 and $pm_found); + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Distribution.pm b/lib/Lintian/Check/Fields/Distribution.pm new file mode 100644 index 0000000..85390dc --- /dev/null +++ b/lib/Lintian/Check/Fields/Distribution.pm @@ -0,0 +1,167 @@ +# fields/distribution -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2017-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020 Felix Lechner +# +# This program is free software. It is distributed 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Distribution; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(any none); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; +const my $SPACE => q{ }; + +sub changes { + my ($self) = @_; + + my @distributions + = $self->processable->fields->trimmed_list('Distribution'); + + $self->hint('multiple-distributions-in-changes-file', + join($SPACE, @distributions)) + if @distributions > 1; + + my @targets = grep { $_ ne 'UNRELEASED' } @distributions; + + # Strip common "extensions" for distributions + # (except sid and experimental, where they would + # make no sense) + my %major; + for my $target (@targets) { + + my $reduced = $target; + $reduced =~ s{- (?:backports(?:-(?:sloppy|staging))? + |lts + |proposed(?:-updates)? + |updates + |security + |volatile + |fasttrack)$}{}xsm; + + $major{$target} = $reduced; + } + + my $KNOWN_DISTS = $self->data->load('changes-file/known-dists'); + + my @unknown = grep { !$KNOWN_DISTS->recognizes($major{$_}) } @targets; + $self->hint('bad-distribution-in-changes-file', $_) for @unknown; + + my @new_version = qw(sid unstable experimental); + my $upload_lc = List::Compare->new(\@targets, \@new_version); + + my @regular = $upload_lc->get_intersection; + my @special = $upload_lc->get_Lonly; + + # from Parse/DebianChangelog.pm + # the changelog entries in the changes file are in a + # different format than in the changelog, so the standard + # parsers don't work. We just need to know if there is + # info for more than 1 entry, so we just copy part of the + # parse code here + my $changes = $self->processable->fields->value('Changes'); + + # count occurrences + my @changes_versions + = ($changes =~/^(?: \.)?\s*\S+\s+\(([^\(\)]+)\)\s+\S+/mg); + + my $version = $self->processable->fields->value('Version'); + my $distnumber; + my $bpoversion; + if ($version=~ /~bpo(\d+)\+(\d+)(\+salsaci(\+\d+)*)?$/) { + $distnumber = $1; + $bpoversion = $2; + + $self->hint('upload-has-backports-version-number', $version, $_) + for @regular; + } + + my @backports = grep { /backports/ } @targets; + for my $target (@backports) { + + $self->hint('backports-upload-has-incorrect-version-number', + $version, $target) + if (!defined $distnumber || !defined $bpoversion) + || ($major{$target} eq 'squeeze' && $distnumber ne '60') + || ($target eq 'wheezy-backports' && $distnumber ne '70') + || ($target eq 'wheezy-backports-sloppy' && $distnumber ne '7') + || ($major{$target} eq 'jessie' && $distnumber ne '8'); + + # for a ~bpoXX+2 or greater version, there + # probably will be only a single changelog entry + $self->hint('backports-changes-missing') + if ($bpoversion // 0) < 2 && @changes_versions == 1; + } + + my $first_line = $changes; + + # advance to first non-empty line + $first_line =~ s/^\s+//s; + + my $multiple; + if ($first_line =~ /^\s*\S+\s+\([^\(\)]+\)([^;]+);/){ + $multiple = $1; + } + + my @changesdists = split($SPACE, $multiple // $EMPTY); + return + unless @changesdists; + + # issue only when not mentioned in the Distribution field + if ((any { $_ eq 'UNRELEASED' } @changesdists) + && none { $_ eq 'UNRELEASED' } @distributions) { + + $self->hint('unreleased-changes'); + return; + } + + my $mismatch_lc = List::Compare->new(\@distributions, \@changesdists); + my @from_distribution = $mismatch_lc->get_Lonly; + my @from_changes = $mismatch_lc->get_Ronly; + + if (@from_distribution || @from_changes) { + + if (any { $_ eq 'experimental' } @from_changes) { + $self->hint('distribution-and-experimental-mismatch'); + + } else { + $self->hint('distribution-and-changes-mismatch', + join($SPACE, @from_distribution, @from_changes)); + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/DmUploadAllowed.pm b/lib/Lintian/Check/Fields/DmUploadAllowed.pm new file mode 100644 index 0000000..6670587 --- /dev/null +++ b/lib/Lintian/Check/Fields/DmUploadAllowed.pm @@ -0,0 +1,60 @@ +# fields/dm-upload-allowed -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::DmUploadAllowed; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub always { + my ($self) = @_; + + my $fields = $self->processable->fields; + + return + unless $fields->declares('DM-Upload-Allowed'); + + $self->hint('dm-upload-allowed-is-obsolete'); + + my $dmupload = $fields->unfolded_value('DM-Upload-Allowed'); + + $self->hint('malformed-dm-upload-allowed', $dmupload) + unless $dmupload eq 'yes'; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Empty.pm b/lib/Lintian/Check/Fields/Empty.pm new file mode 100644 index 0000000..184acd3 --- /dev/null +++ b/lib/Lintian/Check/Fields/Empty.pm @@ -0,0 +1,49 @@ +# fields/empty -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Empty; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub always { + my ($self) = @_; + + my @all = $self->processable->fields->names; + my @empty = grep { !length $self->processable->fields->value($_) } @all; + + $self->hint('empty-field', $_) for @empty; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Essential.pm b/lib/Lintian/Check/Fields/Essential.pm new file mode 100644 index 0000000..87d43c3 --- /dev/null +++ b/lib/Lintian/Check/Fields/Essential.pm @@ -0,0 +1,79 @@ +# fields/essential -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Essential; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $fields = $self->processable->fields; + + $self->hint('essential-in-source-package') + if $fields->declares('Essential'); + + return; +} + +sub always { + my ($self) = @_; + + my $fields = $self->processable->fields; + + return + unless $fields->declares('Essential'); + + my $essential = $fields->unfolded_value('Essential'); + + unless ($essential eq 'yes' || $essential eq 'no') { + $self->hint('unknown-essential-value'); + return; + } + + $self->hint('essential-no-not-needed') if $essential eq 'no'; + + my $KNOWN_ESSENTIAL = $self->data->load('fields/essential'); + + $self->hint('new-essential-package') + if $essential eq 'yes' + && !$KNOWN_ESSENTIAL->recognizes($self->processable->name); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Format.pm b/lib/Lintian/Check/Fields/Format.pm new file mode 100644 index 0000000..2d7494a --- /dev/null +++ b/lib/Lintian/Check/Fields/Format.pm @@ -0,0 +1,78 @@ +# fields/format -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Format; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +my @supported_source_formats = (qr/1\.0/, qr/3\.0\s*\((quilt|native)\)/); + +sub source { + my ($self) = @_; + + return + unless $self->processable->fields->declares('Format'); + + my $format = $self->processable->fields->unfolded_value('Format'); + + my $supported = 0; + for my $f (@supported_source_formats){ + + $supported = 1 + if $format =~ /^\s*$f\s*\z/; + } + + $self->hint('unsupported-source-format', $format) unless $supported; + + return; +} + +sub changes { + my ($self) = @_; + + my $format = $self->processable->fields->unfolded_value('Format'); + + # without a Format field something is wrong + unless (length $format) { + $self->hint('malformed-changes-file'); + return; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Homepage.pm b/lib/Lintian/Check/Fields/Homepage.pm new file mode 100644 index 0000000..6e2ae87 --- /dev/null +++ b/lib/Lintian/Check/Fields/Homepage.pm @@ -0,0 +1,101 @@ +# fields/homepage -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Homepage; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + return + if $self->processable->native; + + my $debian_control = $self->processable->debian_control; + + my @binaries_with_homepage_field + = grep { $debian_control->installable_fields($_)->declares('Homepage') } + $debian_control->installables; + + if (!$self->processable->fields->declares('Homepage')) { + + $self->hint('homepage-in-binary-package', $_) + for @binaries_with_homepage_field; + } + + $self->hint('no-homepage-field') + unless @binaries_with_homepage_field + || $self->processable->fields->declares('Homepage'); + + return; +} + +sub always { + my ($self) = @_; + + my $fields = $self->processable->fields; + + return + unless $fields->declares('Homepage'); + + my $homepage = $fields->unfolded_value('Homepage'); + + my $orig = $fields->value('Homepage'); + + if ($homepage =~ /^<(?:UR[LI]:)?.*>$/i) { + $self->hint('superfluous-clutter-in-homepage', $orig); + $homepage = substr($homepage, 1, length($homepage) - 2); + } + + require URI; + my $uri = URI->new($homepage); + + # not an absolute URI or (most likely) an invalid protocol + $self->hint('bad-homepage', $orig) + unless $uri->scheme && $uri->scheme =~ /^(?:ftp|https?|gopher)$/; + + my $BAD_HOMEPAGES = $self->data->load('fields/bad-homepages'); + + foreach my $line ($BAD_HOMEPAGES->all) { + my ($tag, $re) = split(/\s*~~\s*/, $line); + $self->hint($tag, $orig) if $homepage =~ m/$re/; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/InstallerMenuItem.pm b/lib/Lintian/Check/Fields/InstallerMenuItem.pm new file mode 100644 index 0000000..2b799d3 --- /dev/null +++ b/lib/Lintian/Check/Fields/InstallerMenuItem.pm @@ -0,0 +1,59 @@ +# fields/installer-menu-item -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::InstallerMenuItem; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub udeb { + my ($self) = @_; + + my $fields = $self->processable->fields; + + #---- Installer-Menu-Item (udeb) + + return + unless $fields->declares('Installer-Menu-Item'); + + my $menu_item = $fields->unfolded_value('Installer-Menu-Item'); + + $self->hint('bad-menu-item', $menu_item) unless $menu_item =~ /^\d+$/; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Length.pm b/lib/Lintian/Check/Fields/Length.pm new file mode 100644 index 0000000..e9765bd --- /dev/null +++ b/lib/Lintian/Check/Fields/Length.pm @@ -0,0 +1,86 @@ +# fields/length -- lintian check script -*- perl -*- +# +# Copyright (C) 2019 Sylvestre Ledru +# Copyright (C) 2019-2020 Chris Lamb <lamby@debian.org> +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Length; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::Compare; +use List::SomeUtils qw(any); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $MAXIMUM_LENGTH => 5_000; + +my @ALLOWED_FIELDS = qw( + Build-Ids + Description + Package-List + Installed-Build-Depends + Checksums-Sha256 +); + +sub always { + my ($self) = @_; + + return + if any { $self->processable->type eq $_ } qw(changes buildinfo); + + # all fields + my @all = $self->processable->fields->names; + + # longer than maximum + my @long= grep { + length $self->processable->fields->untrimmed_value($_)> $MAXIMUM_LENGTH + }@all; + + # filter allowed fields + my $allowedlc = List::Compare->new(\@long, \@ALLOWED_FIELDS); + my @too_long = $allowedlc->get_Lonly; + + for my $name (@too_long) { + + my $length = length $self->processable->fields->value($name); + + $self->hint('field-too-long', $name, + "($length chars > $MAXIMUM_LENGTH)"); + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/MailAddress.pm b/lib/Lintian/Check/Fields/MailAddress.pm new file mode 100644 index 0000000..02fd5f1 --- /dev/null +++ b/lib/Lintian/Check/Fields/MailAddress.pm @@ -0,0 +1,150 @@ +# fields/mail-address -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2020 Felix Lechner +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::MailAddress; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Data::Validate::Domain; +use Email::Address::XS; +use List::SomeUtils qw(any all); +use List::UtilsBy qw(uniq_by); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $QA_GROUP_PHRASE => 'Debian QA Group'; +const my $QA_GROUP_ADDRESS => 'packages@qa.debian.org'; +const my $ARROW => q{ -> }; + +# list of addresses known to bounce messages from role accounts +my @KNOWN_BOUNCE_ADDRESSES = qw( + ubuntu-devel-discuss@lists.ubuntu.com +); + +sub always { + my ($self) = @_; + + my @singles = qw(Maintainer Changed-By); + my @groups = qw(Uploaders); + + my @singles_present + = grep { $self->processable->fields->declares($_) } @singles; + my @groups_present + = grep { $self->processable->fields->declares($_) } @groups; + + my %parsed; + for my $role (@singles_present, @groups_present) { + + my $value = $self->processable->fields->value($role); + $parsed{$role} = [Email::Address::XS->parse($value)]; + } + + for my $role (keys %parsed) { + + my @invalid = grep { !$_->is_valid } @{$parsed{$role}}; + $self->hint('malformed-contact', $role, $_->original)for @invalid; + + my @valid = grep { $_->is_valid } @{$parsed{$role}}; + my @unique = uniq_by { $_->format } @valid; + + $self->check_single_address($role, $_) for @unique; + } + + for my $role (@singles_present) { + $self->hint('too-many-contacts', $role, + $self->processable->fields->value($role)) + if @{$parsed{$role}} > 1; + } + + for my $role (@groups_present) { + my @valid = grep { $_->is_valid } @{$parsed{$role}}; + my @addresses = map { $_->address } @valid; + + my %count; + $count{$_}++ for @addresses; + my @duplicates = grep { $count{$_} > 1 } keys %count; + + $self->hint('duplicate-contact', $role, $_) for @duplicates; + } + + return; +} + +sub check_single_address { + my ($self, $role, $parsed) = @_; + + $self->hint('mail-contact', $role, $parsed->format); + + unless (all { length } ($parsed->address, $parsed->user, $parsed->host)) { + $self->hint('incomplete-mail-address', $role, $parsed->format); + return; + } + + $self->hint('bogus-mail-host', $role, $parsed->address) + unless is_domain($parsed->host, {domain_disable_tld_validation => 1}); + + $self->hint('mail-address-loops-or-bounces',$role, $parsed->address) + if any { $_ eq $parsed->address } @KNOWN_BOUNCE_ADDRESSES; + + unless (length $parsed->phrase) { + $self->hint('no-phrase', $role, $parsed->format); + return; + } + + $self->hint('root-in-contact', $role, $parsed->format) + if $parsed->user eq 'root' || $parsed->phrase eq 'root'; + + # Debian QA Group + $self->hint('faulty-debian-qa-group-phrase', + $role, $parsed->phrase . $ARROW . $QA_GROUP_PHRASE) + if $parsed->address eq $QA_GROUP_ADDRESS + && $parsed->phrase ne $QA_GROUP_PHRASE; + + $self->hint('faulty-debian-qa-group-address', + $role, $parsed->address . $ARROW . $QA_GROUP_ADDRESS) + if ( $parsed->phrase =~ /\bdebian\s+qa\b/i + && $parsed->address ne $QA_GROUP_ADDRESS) + || $parsed->address eq 'debian-qa@lists.debian.org'; + + $self->hint('mailing-list-on-alioth', $role, $parsed->address) + if $parsed->host eq 'lists.alioth.debian.org'; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Maintainer.pm b/lib/Lintian/Check/Fields/Maintainer.pm new file mode 100644 index 0000000..7267092 --- /dev/null +++ b/lib/Lintian/Check/Fields/Maintainer.pm @@ -0,0 +1,84 @@ +# fields/maintainer -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2020 Felix Lechner +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Maintainer; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + return + unless $self->processable->fields->declares('Maintainer'); + + my $maintainer = $self->processable->fields->value('Maintainer'); + + my $is_list = $maintainer =~ /\@lists(?:\.alioth)?\.debian\.org\b/; + + $self->hint('no-human-maintainers') + if $is_list && !$self->processable->fields->declares('Uploaders'); + + return; +} + +sub changes { + my ($self) = @_; + + my $source = $self->group->source; + return + unless defined $source; + + my $changes_maintainer = $self->processable->fields->value('Maintainer'); + my $changes_distribution + = $self->processable->fields->value('Distribution'); + + my $source_maintainer = $source->fields->value('Maintainer'); + + my $KNOWN_DISTS = $self->data->load('changes-file/known-dists'); + + # not for derivatives; https://wiki.ubuntu.com/DebianMaintainerField + $self->hint('inconsistent-maintainer', + $changes_maintainer . ' (changes vs. source) ' .$source_maintainer) + if $changes_maintainer ne $source_maintainer + && $KNOWN_DISTS->recognizes($changes_distribution); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Maintainer/Team.pm b/lib/Lintian/Check/Fields/Maintainer/Team.pm new file mode 100644 index 0000000..b068d9f --- /dev/null +++ b/lib/Lintian/Check/Fields/Maintainer/Team.pm @@ -0,0 +1,90 @@ +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Maintainer::Team; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Email::Address::XS; +use List::SomeUtils qw(uniq first_value); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $ARROW => qq{ \N{RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK} }; + +my %team_names = ( + 'debian-go@lists.debian.org' => 'golang', + 'debian-clojure@lists.debian.org' => 'clojure', + 'pkg-java-maintainers@lists.alioth.debian.org' => 'java', + 'pkg-javascript-maintainers@lists.alioth.debian.org' => 'javascript', + 'pkg-perl-maintainers@lists.alioth.debian.org' => 'perl', + 'team+python@tracker.debian.org' => 'python' +); + +sub source { + my ($self) = @_; + + my $maintainer = $self->processable->fields->value('Maintainer'); + return + unless length $maintainer; + + my $parsed = Email::Address::XS->parse($maintainer); + return + unless $parsed->is_valid; + + return + unless length $parsed->address; + + my $team = $team_names{$parsed->address}; + return + unless length $team; + + return + if $self->name_contains($team); + + my @other_teams = uniq grep { $_ ne $team } values %team_names; + + my $name_suggests = first_value { $self->name_contains($_) } @other_teams; + return + unless length $name_suggests; + + $self->hint('wrong-team', $team . $ARROW . $name_suggests) + unless $name_suggests eq $team; + + return; +} + +sub name_contains { + my ($self, $string) = @_; + + return $self->processable->name =~ m{ \b \Q$string\E \b }sx; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/MultiArch.pm b/lib/Lintian/Check/Fields/MultiArch.pm new file mode 100644 index 0000000..5b42f9f --- /dev/null +++ b/lib/Lintian/Check/Fields/MultiArch.pm @@ -0,0 +1,138 @@ +# fields/multi-arch -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::MultiArch; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(uniq any); +use Unicode::UTF8 qw(decode_utf8); + +use Lintian::IPC::Run3 qw(safe_qx); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $SPACE => q{ }; + +sub source { + my ($self) = @_; + + my $pkg = $self->processable->name; + my $processable = $self->processable; + + for my $bin ($processable->debian_control->installables) { + + next + unless ($processable->debian_control->installable_fields($bin) + ->value('Multi-Arch')) eq 'same'; + + my $wildcard = $processable->debian_control->installable_fields($bin) + ->value('Architecture'); + my @arches = split( + $SPACE, + decode_utf8( + safe_qx( + 'dpkg-architecture', '--match-wildcard', + $wildcard, '--list-known' + ) + ) + ); + + # include original wildcard + push(@arches, $wildcard); + + for my $port (uniq @arches) { + + my $specific = $processable->patched->resolve_path( + "debian/$bin.lintian-overrides.$port"); + next + unless defined $specific; + + $self->pointed_hint( + 'multi-arch-same-package-has-arch-specific-overrides', + $specific->pointer); + } + } + + return; +} + +sub installable { + my ($self) = @_; + + my $fields = $self->processable->fields; + + if ($self->processable->name =~ /^x?fonts-/) { + + my $multi = $fields->value('Multi-Arch') || 'no'; + + $self->hint('font-package-not-multi-arch-foreign') + unless any { $multi eq $_ } qw(foreign allowed); + } + + return + unless $fields->declares('Multi-Arch'); + + my $multi = $fields->unfolded_value('Multi-Arch'); + + if ($fields->declares('Architecture')) { + + my $architecture = $fields->unfolded_value('Architecture'); + + $self->hint('illegal-multi-arch-value', $architecture, $multi) + if $architecture eq 'all' && $multi eq 'same'; + } + + return; +} + +sub always { + my ($self) = @_; + + my $fields = $self->processable->fields; + + return + unless $fields->declares('Multi-Arch'); + + my $multi = $fields->unfolded_value('Multi-Arch'); + + $self->hint('unknown-multi-arch-value', $self->processable->name, $multi) + unless any { $multi eq $_ } qw(no foreign allowed same); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/MultiLine.pm b/lib/Lintian/Check/Fields/MultiLine.pm new file mode 100644 index 0000000..ca31cd5 --- /dev/null +++ b/lib/Lintian/Check/Fields/MultiLine.pm @@ -0,0 +1,89 @@ +# fields/multi-line -- lintian check script -*- perl -*- +# +# Copyright (C) 2019 Felix Lechner +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::MultiLine; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::Compare; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $NEWLINE => qq{\n}; + +# based on policy 5.6 +my @always_single = ( + qw(Architecture Bugs Changed-By Closes Date Distribution Dm-Upload-Allowed), + qw(Essential Format Homepage Installed-Size Installer-Menu-Item Maintainer), + qw(Multi-Arch Origin Package Priority Section Source Standards-Version), + qw(Subarchitecture Urgency Version) +); + +my @package_relations + = ( + qw(Depends Pre-Depends Recommends Suggests Conflicts Provides Enhances Replaces Breaks) + ); + +sub always { + my ($self) = @_; + + my @banned = @always_single; + + # for package relations, multi-line only in source (policy 7.1) + push(@banned, @package_relations) + unless $self->processable->type eq 'source'; + + my @present = $self->processable->fields->names; + + my $single_lc = List::Compare->new(\@present, \@banned); + my @enforce = $single_lc->get_intersection; + + for my $name (@enforce) { + + my $value = $self->processable->fields->untrimmed_value($name); + + # remove a final newline, if any + $value =~ s/\n$//; + + # check if fields have newlines in them + $self->hint('multiline-field', $name) + if index($value, $NEWLINE) >= 0; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Origin.pm b/lib/Lintian/Check/Fields/Origin.pm new file mode 100644 index 0000000..4d36793 --- /dev/null +++ b/lib/Lintian/Check/Fields/Origin.pm @@ -0,0 +1,57 @@ +# fields/origin -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Origin; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub always { + my ($self) = @_; + + my $fields = $self->processable->fields; + + return + unless $fields->declares('Origin'); + + my $origin = $fields->unfolded_value('Origin'); + + $self->hint('redundant-origin-field') if lc($origin) eq 'debian'; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Package.pm b/lib/Lintian/Check/Fields/Package.pm new file mode 100644 index 0000000..2ce436f --- /dev/null +++ b/lib/Lintian/Check/Fields/Package.pm @@ -0,0 +1,61 @@ +# fields/package -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Package; + +use v5.20; +use warnings; +use utf8; + +use Lintian::Util qw($PKGNAME_REGEX); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub installable { + my ($self) = @_; + + return + unless $self->processable->fields->declares('Package'); + + my $name = $self->processable->fields->unfolded_value('Package'); + + $self->hint('bad-package-name') unless $name =~ /^$PKGNAME_REGEX$/i; + + $self->hint('package-not-lowercase') if $name =~ /[A-Z]/; + + $self->hint('unusual-documentation-package-name') if $name =~ /-docs$/; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/PackageRelations.pm b/lib/Lintian/Check/Fields/PackageRelations.pm new file mode 100644 index 0000000..eeb11c0 --- /dev/null +++ b/lib/Lintian/Check/Fields/PackageRelations.pm @@ -0,0 +1,794 @@ +# fields/package-relations -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2019-2020 Chris Lamb <lamby@debian.org> +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::PackageRelations; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Dpkg::Version qw(version_check); +use List::SomeUtils qw(any); + +use Lintian::Relation; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; +const my $EQUAL => q{=}; +const my $VERTICAL_BAR => q{|}; + +# Still in the archive but shouldn't be the primary Emacs dependency. +my @obsolete_emacs_versions = qw(21 22 23); +my @emacs_flavors = ($EMPTY, qw(-el -gtk -nox -lucid)); +my %known_obsolete_emacs; +for my $version (@obsolete_emacs_versions) { + for my $flavor (@emacs_flavors) { + + my $package = 'emacs' . $version . $flavor; + $known_obsolete_emacs{$package} = 1; + } +} + +my %known_libstdcs = map { $_ => 1 } qw( + libstdc++2.9-glibc2.1 + libstdc++2.10 + libstdc++2.10-glibc2.2 + libstdc++3 + libstdc++3.0 + libstdc++4 + libstdc++5 + libstdc++6 + lib64stdc++6 +); + +my %known_tcls = map { $_ => 1 } qw( + tcl74 + tcl8.0 + tcl8.2 + tcl8.3 + tcl8.4 + tcl8.5 +); + +my %known_tclxs = map { $_ => 1 } qw( + tclx76 + tclx8.0.4 + tclx8.2 + tclx8.3 + tclx8.4 +); + +my %known_tks = map { $_ => 1 } qw( + tk40 + tk8.0 + tk8.2 + tk8.3 + tk8.4 + tk8.5 +); + +my %known_libpngs = map { $_ => 1 } qw( + libpng12-0 + libpng2 + libpng3 +); + +my @known_java_pkg = map { qr/$_/ } ( + 'default-j(?:re|dk)(?:-headless)?', + # java-runtime and javaX-runtime alternatives (virtual) + 'java\d*-runtime(?:-headless)?', + # openjdk-X and sun-javaX + '(openjdk-|sun-java)\d+-j(?:re|dk)(?:-headless)?', + 'gcj-(?:\d+\.\d+-)?jre(?:-headless)?', 'gcj-(?:\d+\.\d+-)?jdk', # gcj + 'gij', + 'java-gcj-compat(?:-dev|-headless)?', # deprecated/transitional packages + 'kaffe', 'cacao', 'jamvm', + 'classpath', # deprecated packages (removed in Squeeze) +); + +# Python development packages that are used almost always just for building +# architecture-dependent modules. Used to check for unnecessary build +# dependencies for architecture-independent source packages. +our $PYTHON_DEV = join(' | ', + qw(python3-dev python3-all-dev), + map { "python$_-dev:any" } qw(2.7 3 3.7 3.8 3.9)); + +sub installable { + my ($self) = @_; + + my $pkg = $self->processable->name; + my $type = $self->processable->type; + my $processable = $self->processable; + my $group = $self->group; + + my $KNOWN_ESSENTIAL = $self->data->load('fields/essential'); + my $KNOWN_TOOLCHAIN = $self->data->load('fields/toolchain'); + my $KNOWN_METAPACKAGES = $self->data->load('fields/metapackages'); + + my $DH_ADDONS = $self->data->debhelper_addons; + my %DH_ADDONS_VALUES + = map { $_ => 1 } map { $DH_ADDONS->installed_by($_) } $DH_ADDONS->all; + + my $OBSOLETE_PACKAGES + = $self->data->load('fields/obsolete-packages',qr/\s*=>\s*/); + + my $VIRTUAL_PACKAGES= $self->data->load('fields/virtual-packages'); + + my $javalib = 0; + my $replaces = $processable->relation('Replaces'); + my %nag_once; + $javalib = 1 if($pkg =~ m/^lib.*-java$/); + for my $field ( + qw(Depends Pre-Depends Recommends Suggests Conflicts Provides Enhances Replaces Breaks) + ) { + next + unless $processable->fields->declares($field); + + # get data and clean it + my $data = $processable->fields->unfolded_value($field); + my $javadep = 0; + + my (@seen_libstdcs, @seen_tcls, @seen_tclxs,@seen_tks, @seen_libpngs); + + my $is_dep_field + = any { $field eq $_ } qw(Depends Pre-Depends Recommends Suggests); + + $self->hint('alternates-not-allowed', $field) + if ($data =~ /\|/ && !$is_dep_field); + $self->check_field($field, $data) if $is_dep_field; + + for my $dep (split /\s*,\s*/, $data) { + my (@alternatives, @seen_obsolete_packages); + push @alternatives, [_split_dep($_), $_] + for (split /\s*\|\s*/, $dep); + + if ($is_dep_field) { + push @seen_libstdcs, $alternatives[0][0] + if defined $known_libstdcs{$alternatives[0][0]}; + push @seen_tcls, $alternatives[0][0] + if defined $known_tcls{$alternatives[0][0]}; + push @seen_tclxs, $alternatives[0][0] + if defined $known_tclxs{$alternatives[0][0]}; + push @seen_tks, $alternatives[0][0] + if defined $known_tks{$alternatives[0][0]}; + push @seen_libpngs, $alternatives[0][0] + if defined $known_libpngs{$alternatives[0][0]}; + } + + # Only for (Pre-)?Depends. + $self->hint('virtual-package-depends-without-real-package-depends', + "$field: $alternatives[0][0]") + if ( + $VIRTUAL_PACKAGES->recognizes($alternatives[0][0]) + && ($field eq 'Depends' || $field eq 'Pre-Depends') + && ($pkg ne 'base-files' || $alternatives[0][0] ne 'awk') + # ignore phpapi- dependencies as adding an + # alternative, real, package breaks its purpose + && $alternatives[0][0] !~ m/^phpapi-/ + ); + + # Check defaults for transitions. Here, we only care + # that the first alternative is current. + $self->hint('depends-on-old-emacs', "$field: $alternatives[0][0]") + if ( $is_dep_field + && $known_obsolete_emacs{$alternatives[0][0]}); + + for my $part_d (@alternatives) { + my ($d_pkg, $d_march, $d_version, undef, undef, $rest, + $part_d_orig) + = @{$part_d}; + + $self->hint('invalid-versioned-provides', $part_d_orig) + if ( $field eq 'Provides' + && $d_version->[0] + && $d_version->[0] ne $EQUAL); + + $self->hint('bad-provided-package-name', $d_pkg) + if $d_pkg !~ /^[a-z0-9][-+\.a-z0-9]+$/; + + $self->hint('breaks-without-version', $part_d_orig) + if ( $field eq 'Breaks' + && !$d_version->[0] + && !$VIRTUAL_PACKAGES->recognizes($d_pkg) + && !$replaces->satisfies($part_d_orig)); + + $self->hint('conflicts-with-version', $part_d_orig) + if ($field eq 'Conflicts' && $d_version->[0]); + + $self->hint('obsolete-relation-form', "$field: $part_d_orig") + if ($d_version && any { $d_version->[0] eq $_ }('<', '>')); + + $self->hint('bad-version-in-relation', "$field: $part_d_orig") + if ($d_version->[0] && !version_check($d_version->[1])); + + $self->hint('package-relation-with-self', + "$field: $part_d_orig") + if ($pkg eq $d_pkg) + && (!$d_march) + && ( $field ne 'Conflicts' + && $field ne 'Replaces' + && $field ne 'Provides'); + + $self->hint('bad-relation', "$field: $part_d_orig") if $rest; + + push @seen_obsolete_packages, [$part_d_orig, $d_pkg] + if ( $OBSOLETE_PACKAGES->recognizes($d_pkg) + && $is_dep_field); + + $self->hint('depends-on-metapackage', "$field: $part_d_orig") + if ( $KNOWN_METAPACKAGES->recognizes($d_pkg) + && !$KNOWN_METAPACKAGES->recognizes($pkg) + && !$processable->is_transitional + && !$processable->is_meta_package + && $is_dep_field); + + # diffutils is a special case since diff was + # renamed to diffutils, so a dependency on + # diffutils effectively is a versioned one. + $self->hint( + 'depends-on-essential-package-without-using-version', + "$field: $part_d_orig") + if ( $KNOWN_ESSENTIAL->recognizes($d_pkg) + && !$d_version->[0] + && $is_dep_field + && $d_pkg ne 'diffutils' + && $d_pkg ne 'dash'); + + $self->hint('package-depends-on-an-x-font-package', + "$field: $part_d_orig") + if ( $field =~ /^(?:Pre-)?Depends$/ + && $d_pkg =~ /^xfont.*/ + && $d_pkg ne 'xfonts-utils' + && $d_pkg ne 'xfonts-encodings'); + + $self->hint('depends-on-packaging-dev',$field) + if (($field =~ /^(?:Pre-)?Depends$/|| $field eq 'Recommends') + && $d_pkg eq 'packaging-dev' + && !$processable->is_transitional + && !$processable->is_meta_package); + + $self->hint('needless-suggest-recommend-libservlet-java', + "$d_pkg") + if (($field eq 'Recommends' || $field eq 'Suggests') + && $d_pkg =~ m/libservlet[\d\.]+-java/); + + $self->hint('needlessly-depends-on-awk', $field) + if ( $d_pkg eq 'awk' + && !$d_version->[0] + && $is_dep_field + && $pkg ne 'base-files'); + + $self->hint('depends-on-libdb1-compat', $field) + if ( $d_pkg eq 'libdb1-compat' + && $pkg !~ /^libc(?:6|6.1|0.3)/ + && $field =~ /^(?:Pre-)?Depends$/); + + $self->hint('depends-on-python-minimal', $field,) + if ( $d_pkg =~ /^python[\d.]*-minimal$/ + && $is_dep_field + && $pkg !~ /^python[\d.]*-minimal$/); + + $self->hint('doc-package-depends-on-main-package', $field) + if ("$d_pkg-doc" eq $pkg + && $field =~ /^(?:Pre-)?Depends$/); + + $self->hint( + 'package-relation-with-perl-modules', "$field: $d_pkg" + # matches "perl-modules" (<= 5.20) as well as + # perl-modules-5.xx (>> 5.20) + ) + if $d_pkg =~ /^perl-modules/ + && $field ne 'Replaces' + && $processable->source_name ne 'perl'; + + $self->hint('depends-exclusively-on-makedev', $field,) + if ( $field eq 'Depends' + && $d_pkg eq 'makedev' + && @alternatives == 1); + + $self->hint('lib-recommends-documentation', + "$field: $part_d_orig") + if ( $field eq 'Recommends' + && $pkg =~ m/^lib/ + && $pkg !~ m/-(?:dev|docs?|tools|bin)$/ + && $part_d_orig =~ m/-docs?$/); + + $self->hint('binary-package-depends-on-toolchain-package', + "$field: $part_d_orig") + if $KNOWN_TOOLCHAIN->recognizes($d_pkg) + && $is_dep_field + && $pkg !~ /^dh-/ + && $pkg !~ /-(?:source|src)$/ + && !$processable->is_transitional + && !$processable->is_meta_package + && !$DH_ADDONS_VALUES{$pkg}; + + # default-jdk-doc must depend on openjdk-X-doc (or + # classpath-doc) to be useful; other packages + # should depend on default-jdk-doc if they want + # the Java Core API. + $self->hint('depends-on-specific-java-doc-package',$field) + if ( + $is_dep_field + && $pkg ne 'default-jdk-doc' + && ( $d_pkg eq 'classpath-doc' + || $d_pkg =~ /openjdk-\d+-doc/) + ); + + if ($javalib && $field eq 'Depends'){ + foreach my $reg (@known_java_pkg){ + if($d_pkg =~ m/$reg/){ + $javadep++; + last; + } + + } + } + } + + for my $d (@seen_obsolete_packages) { + my ($dep, $pkg_name) = @{$d}; + my $replacement = $OBSOLETE_PACKAGES->value($pkg_name) + // $EMPTY; + $replacement = ' => ' . $replacement + if $replacement ne $EMPTY; + if ($pkg_name eq $alternatives[0][0] + or scalar @seen_obsolete_packages== scalar @alternatives) { + $self->hint( + 'depends-on-obsolete-package', + "$field: $dep${replacement}" + ); + } else { + $self->hint( + 'ored-depends-on-obsolete-package', + "$field: $dep${replacement}" + ); + } + } + + # Only emit the tag if all the alternatives are + # JVM/JRE/JDKs + # - assume that <some-lib> | openjdk-X-jre-headless + # makes sense for now. + if (scalar(@alternatives) == $javadep + && !exists $nag_once{'needless-dependency-on-jre'}){ + $nag_once{'needless-dependency-on-jre'} = 1; + $self->hint('needless-dependency-on-jre'); + } + } + $self->hint('package-depends-on-multiple-libstdc-versions', + @seen_libstdcs) + if (scalar @seen_libstdcs > 1); + $self->hint('package-depends-on-multiple-tcl-versions', @seen_tcls) + if (scalar @seen_tcls > 1); + $self->hint('package-depends-on-multiple-tclx-versions', @seen_tclxs) + if (scalar @seen_tclxs > 1); + $self->hint('package-depends-on-multiple-tk-versions', @seen_tks) + if (scalar @seen_tks > 1); + $self->hint('package-depends-on-multiple-libpng-versions', + @seen_libpngs) + if (scalar @seen_libpngs > 1); + } + + # If Conflicts or Breaks is set, make sure it's not inconsistent with + # the other dependency fields. + for my $conflict (qw/Conflicts Breaks/) { + next + unless $processable->fields->declares($conflict); + + for my $field (qw(Depends Pre-Depends Recommends Suggests)) { + next + unless $processable->fields->declares($field); + + my $relation = $processable->relation($field); + for my $package (split /\s*,\s*/, + $processable->fields->value($conflict)) { + + $self->hint('conflicts-with-dependency', $field, $package) + if $relation->satisfies($package); + } + } + } + + return; +} + +sub source { + my ($self) = @_; + + my $pkg = $self->processable->name; + my $type = $self->processable->type; + my $processable = $self->processable; + my $group = $self->group; + + my $KNOWN_ESSENTIAL = $self->data->load('fields/essential'); + my $KNOWN_METAPACKAGES = $self->data->load('fields/metapackages'); + my $NO_BUILD_DEPENDS= $self->data->load('fields/no-build-depends'); + my $known_build_essential + = $self->data->load('fields/build-essential-packages'); + my $KNOWN_BUILD_PROFILES= $self->data->load('fields/build-profiles'); + + my $OBSOLETE_PACKAGES + = $self->data->load('fields/obsolete-packages',qr/\s*=>\s*/); + + my $VIRTUAL_PACKAGES= $self->data->load('fields/virtual-packages'); + + my @binpkgs = $processable->debian_control->installables; + + #Get number of arch-indep packages: + my $arch_indep_packages = 0; + my $arch_dep_packages = 0; + + for my $binpkg (@binpkgs) { + my $arch = $processable->debian_control->installable_fields($binpkg) + ->value('Architecture'); + + if ($arch eq 'all') { + $arch_indep_packages++; + } else { + $arch_dep_packages++; + } + } + + $self->hint('build-depends-indep-without-arch-indep') + if ( $processable->fields->declares('Build-Depends-Indep') + && $arch_indep_packages == 0); + + $self->hint('build-depends-arch-without-arch-dependent-binary') + if ( $processable->fields->declares('Build-Depends-Arch') + && $arch_dep_packages == 0); + + my %depend; + for my $field ( + qw(Build-Depends Build-Depends-Indep Build-Depends-Arch Build-Conflicts Build-Conflicts-Indep Build-Conflicts-Arch) + ) { + if ($processable->fields->declares($field)) { + + my $is_dep_field = any { $field eq $_ } + qw(Build-Depends Build-Depends-Indep Build-Depends-Arch); + + # get data and clean it + my $data = $processable->fields->unfolded_value($field); + + $self->check_field($field, $data); + $depend{$field} = $data; + + for my $dep (split /\s*,\s*/, $data) { + my (@alternatives, @seen_obsolete_packages); + push @alternatives, [_split_dep($_), $_] + for (split /\s*\|\s*/, $dep); + + $self->hint( + 'virtual-package-depends-without-real-package-depends', + "$field: $alternatives[0][0]") + if ( $VIRTUAL_PACKAGES->recognizes($alternatives[0][0]) + && $is_dep_field); + + for my $part_d (@alternatives) { + my ($d_pkg, undef, $d_version, $d_arch, $d_restr, + $rest,$part_d_orig) + = @{$part_d}; + + for my $arch (@{$d_arch->[0]}) { + $self->hint('invalid-arch-string-in-source-relation', + $arch, "[$field: $part_d_orig]") + if $arch eq 'all' + || ( + !$self->data->architectures + ->is_release_architecture( + $arch) + && !$self->data->architectures->is_wildcard($arch) + ); + } + + for my $restrlist (@{$d_restr}) { + for my $prof (@{$restrlist}) { + $prof =~ s/^!//; + $self->hint( + 'invalid-profile-name-in-source-relation', + "$prof [$field: $part_d_orig]" + ) + unless $KNOWN_BUILD_PROFILES->recognizes($prof) + or $prof =~ /^pkg\.[a-z0-9][a-z0-9+.-]+\../; + } + } + + if ( $d_pkg =~ /^openjdk-\d+-doc$/ + or $d_pkg eq 'classpath-doc'){ + $self->hint( + 'build-depends-on-specific-java-doc-package', + $d_pkg); + } + + if ($d_pkg eq 'java-compiler'){ + $self->hint( + 'build-depends-on-an-obsolete-java-package', + $d_pkg); + } + + if ( $d_pkg =~ /^libdb\d+\.\d+.*-dev$/ + and $is_dep_field) { + $self->hint('build-depends-on-versioned-berkeley-db', + "$field:$d_pkg"); + } + + $self->hint('conflicting-negation-in-source-relation', + "$field: $part_d_orig") + if ( $d_arch + && $d_arch->[1] != 0 + && $d_arch->[1] ne @{ $d_arch->[0] }); + + $self->hint('depends-on-packaging-dev', $field) + if ($d_pkg eq 'packaging-dev'); + + $self->hint('build-depends-on-build-essential', $field) + if ($d_pkg eq 'build-essential'); + + $self->hint( +'build-depends-on-build-essential-package-without-using-version', + "$d_pkg [$field: $part_d_orig]" + ) + if ($known_build_essential->recognizes($d_pkg) + && !$d_version->[1]); + + $self->hint( +'build-depends-on-essential-package-without-using-version', + "$field: $part_d_orig" + ) + if ( $KNOWN_ESSENTIAL->recognizes($d_pkg) + && !$d_version->[0] + && $d_pkg ne 'dash'); + push @seen_obsolete_packages, [$part_d_orig, $d_pkg] + if ( $OBSOLETE_PACKAGES->recognizes($d_pkg) + && $is_dep_field); + + $self->hint('build-depends-on-metapackage', + "$field: $part_d_orig") + if ( $KNOWN_METAPACKAGES->recognizes($d_pkg) + and $is_dep_field); + + $self->hint('build-depends-on-non-build-package', + "$field: $part_d_orig") + if ( $NO_BUILD_DEPENDS->recognizes($d_pkg) + and $is_dep_field); + + $self->hint('build-depends-on-1-revision', + "$field: $part_d_orig") + if ( $d_version->[0] eq '>=' + && $d_version->[1] =~ /-1$/ + && $is_dep_field); + + $self->hint('bad-relation', "$field: $part_d_orig") + if $rest; + + $self->hint('bad-version-in-relation', + "$field: $part_d_orig") + if ($d_version->[0] + && !version_check($d_version->[1])); + + $self->hint( + 'package-relation-with-perl-modules', + "$field: $part_d_orig" + # matches "perl-modules" (<= 5.20) as well as + # perl-modules-5.xx (>> 5.20) + ) + if $d_pkg =~ /^perl-modules/ + && $processable->source_name ne 'perl'; + } + + my $all_obsolete = 0; + $all_obsolete = 1 + if scalar @seen_obsolete_packages == @alternatives; + for my $d (@seen_obsolete_packages) { + my ($dep, $pkg_name) = @{$d}; + my $replacement = $OBSOLETE_PACKAGES->value($pkg_name) + // $EMPTY; + + $replacement = ' => ' . $replacement + if $replacement ne $EMPTY; + if ( $pkg_name eq $alternatives[0][0] + or $all_obsolete) { + $self->hint('build-depends-on-obsolete-package', + "$field: $dep${replacement}"); + } else { + $self->hint('ored-build-depends-on-obsolete-package', + "$field: $dep${replacement}"); + } + } + } + } + } + + # Check for redundancies. + my @to_check = ( + ['Build-Depends'], + ['Build-Depends', 'Build-Depends-Indep'], + ['Build-Depends', 'Build-Depends-Arch'] + ); + + for my $fields (@to_check) { + my $relation = Lintian::Relation->new->logical_and( + map { $processable->relation($_) }@{$fields}); + + for my $redundant_set ($relation->redundancies) { + + $self->hint( + 'redundant-build-prerequisites', + join(', ', sort @{$redundant_set}) + ); + } + } + + # Make sure build dependencies and conflicts are consistent. + my $build_all = $processable->relation('Build-Depends-All'); + + for my $field ( + qw{Build-Conflicts Build-Conflicts-Indep Build-Conflicts-Arch}) { + + my @conflicts= $processable->fields->trimmed_list($field, qr{\s*,\s*}); + my @contradictions = grep { $build_all->satisfies($_) } @conflicts; + + my $position = $processable->fields->position($field); + my $pointer = $processable->debian_control->item->pointer($position); + + $self->pointed_hint('build-conflicts-with-build-dependency', + $pointer, $field, $_) + for @contradictions; + } + + my (@arch_dep_pkgs, @dbg_pkgs); + for my $installable ($group->get_installables) { + + if ($installable->name =~ m/-dbg$/) { + push(@dbg_pkgs, $installable); + + } elsif ($installable->fields->value('Architecture') ne 'all'){ + push(@arch_dep_pkgs, $installable); + } + } + + my $dstr = join($VERTICAL_BAR, map { quotemeta($_->name) } @arch_dep_pkgs); + my $depregex = qr/^(?:$dstr)$/; + for my $dbg_proc (@dbg_pkgs) { + my $deps = $processable->binary_relation($dbg_proc->name, 'strong'); + my $missing = 1; + $missing = 0 + if $deps->matches($depregex, Lintian::Relation::VISIT_PRED_NAME); + if ($missing && $dbg_proc->is_transitional) { + # If it is a transitional package, allow it to depend + # on another -dbg instead. + $missing = 0 + if $deps->matches(qr/-dbg \Z/xsm, + Lintian::Relation::VISIT_PRED_NAME); + } + $self->hint('dbg-package-missing-depends', $dbg_proc->name) + if $missing; + } + + # Check for a python*-dev build dependency in source packages that + # build only arch: all packages. + if ($arch_dep_packages == 0 and $build_all->satisfies($PYTHON_DEV)) { + $self->hint('build-depends-on-python-dev-with-no-arch-any'); + } + + my $bdepends = $processable->relation('Build-Depends'); + + # libmodule-build-perl + # matches() instead of satisfies() because of possible OR relation + $self->hint('libmodule-build-perl-needs-to-be-in-build-depends') + if $processable->relation('Build-Depends-Indep') + ->equals('libmodule-build-perl', Lintian::Relation::VISIT_PRED_NAME) + && !$bdepends->equals('libmodule-build-perl', + Lintian::Relation::VISIT_PRED_NAME); + + # libmodule-build-tiny-perl + $self->hint('libmodule-build-tiny-perl-needs-to-be-in-build-depends') + if $processable->relation('Build-Depends-Indep') + ->satisfies('libmodule-build-tiny-perl') + && !$bdepends->satisfies('libmodule-build-tiny-perl:any'); + + return; +} + +# splits "foo:bar (>= 1.2.3) [!i386 ia64] <stage1 !nocheck> <cross>" into +# ( "foo", "bar", [ ">=", "1.2.3" ], [ [ "i386", "ia64" ], 1 ], [ [ "stage1", "!nocheck" ] , [ "cross" ] ], "" ) +# ^^^ ^^ +# count of negated arches, if ! was given || +# rest (should always be "" for valid dependencies) +sub _split_dep { + my $dep = shift; + my ($pkg, $dmarch, $version, $darch, $restr) + = ($EMPTY, $EMPTY, [$EMPTY,$EMPTY], [[], 0], []); + + if ($dep =~ s/^\s*([^<\s\[\(]+)\s*//) { + ($pkg, $dmarch) = split(/:/, $1, 2); + $dmarch //= $EMPTY; # Ensure it is defined (in case there is no ":") + } + + if (length $dep) { + if ($dep + =~ s/\s* \( \s* (<<|<=|>=|>>|[=<>]) \s* ([^\s(]+) \s* \) \s*//x) { + @{$version} = ($1, $2); + } + if ($dep && $dep =~ s/\s*\[([^\]]+)\]\s*//) { + my $t = $1; + $darch->[0] = [split /\s+/, $t]; + my $negated = 0; + for my $arch (@{ $darch->[0] }) { + $negated++ if $arch =~ s/^!//; + } + $darch->[1] = $negated; + } + while ($dep && $dep =~ s/\s*<([^>]+)>\s*//) { + my $t = $1; + push(@{$restr}, [split /\s+/, $t]); + } + } + + return ($pkg, $dmarch, $version, $darch, $restr, $dep); +} + +sub check_field { + my ($self, $field, $data) = @_; + + my $processable = $self->processable; + + my $has_default_mta + = $processable->relation($field) + ->equals('default-mta', Lintian::Relation::VISIT_PRED_NAME); + my $has_mail_transport_agent = $processable->relation($field) + ->equals('mail-transport-agent', Lintian::Relation::VISIT_PRED_NAME); + + $self->hint('default-mta-dependency-not-listed-first',"$field: $data") + if $processable->relation($field) + ->matches(qr/\|\s+default-mta/, Lintian::Relation::VISIT_OR_CLAUSE_FULL); + + if ($has_default_mta) { + $self->hint( + 'default-mta-dependency-does-not-specify-mail-transport-agent', + "$field: $data") + unless $has_mail_transport_agent; + } elsif ($has_mail_transport_agent) { + $self->hint( + 'mail-transport-agent-dependency-does-not-specify-default-mta', + "$field: $data") + unless $has_default_mta; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/PackageType.pm b/lib/Lintian/Check/Fields/PackageType.pm new file mode 100644 index 0000000..a8defcd --- /dev/null +++ b/lib/Lintian/Check/Fields/PackageType.pm @@ -0,0 +1,58 @@ +# fields/package_type -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::PackageType; + +use v5.20; +use warnings; +use utf8; + +use Lintian::Util qw($PKGNAME_REGEX); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub installable { + my ($self) = @_; + + return + unless $self->processable->fields->declares('Package-Type'); + + my $type = $self->processable->fields->value('Package-Type'); + + $self->hint('explicit-default-in-package-type') + if $type eq 'deb'; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Priority.pm b/lib/Lintian/Check/Fields/Priority.pm new file mode 100644 index 0000000..91fa6bb --- /dev/null +++ b/lib/Lintian/Check/Fields/Priority.pm @@ -0,0 +1,82 @@ +# fields/priority -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Priority; + +use v5.20; +use warnings; +use utf8; + +use List::SomeUtils qw(any); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub always { + my ($self) = @_; + + my $fields = $self->processable->fields; + + return + unless $fields->declares('Priority'); + + my $priority = $fields->unfolded_value('Priority'); + + if ($self->processable->type eq 'source' + || !$self->processable->is_auto_generated) { + + $self->hint('priority-extra-is-replaced-by-priority-optional') + if $priority eq 'extra'; + + # Re-map to optional to avoid an additional warning from + # lintian + $priority = 'optional' + if $priority eq 'extra'; + } + + my $KNOWN_PRIOS = $self->data->load('fields/priorities'); + + $self->hint('unknown-priority', $priority) + unless $KNOWN_PRIOS->recognizes($priority); + + $self->hint('excessive-priority-for-library-package', $priority) + if $self->processable->name =~ /^lib/ + && $self->processable->name !~ /-bin$/ + && $self->processable->name !~ /^libc[0-9.]+$/ + && (any { $_ eq $self->processable->fields->value('Section') } + qw(libdevel libs)) + && (any { $_ eq $priority } qw(required important standard)); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Recommended.pm b/lib/Lintian/Check/Fields/Recommended.pm new file mode 100644 index 0000000..2c780b8 --- /dev/null +++ b/lib/Lintian/Check/Fields/Recommended.pm @@ -0,0 +1,142 @@ +# fields/recommended -- lintian check script -*- perl -*- +# +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Recommended; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Path::Tiny; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $AT => q{@}; + +# policy section 5.2 states unequivocally that the two fields Section +# and Priority are recommended not only in the source paragraph, but +# also in the binary paragraphs. + +# in the author's opinion, however, it does not make sense to flag them +# there because the same two fields in the source paragraph provide the +# default for the fields in the binary package paragraph. + +# moreover, such duplicate tags would then trigger the tag +# binary-control-field-duplicates-source elsewhere, which would be +# super confusing + +# policy 5.2 +my @DEBIAN_CONTROL_SOURCE = qw(Section Priority); +my @DEBIAN_CONTROL_INSTALLABLE = qw(); # Section Priority + +# policy 5.3 +my @INSTALLATION_CONTROL = qw(Section Priority); + +# policy 5.4 +my @DSC = qw(Package-List); + +# policy 5.5 +my @CHANGES = qw(Urgency); + +sub source { + my ($self) = @_; + + my $fields = $self->processable->fields; + my @missing_dsc = grep { !$fields->declares($_) } @DSC; + + my $dscfile = path($self->processable->path)->basename; + $self->hint('recommended-field', $dscfile, $_) for @missing_dsc; + + my $debian_control = $self->processable->debian_control; + my $control_item = $debian_control->item; + + # look at d/control source paragraph + my $source_fields = $debian_control->source_fields; + + my @missing_control_source + = grep { !$source_fields->declares($_) }@DEBIAN_CONTROL_SOURCE; + + my $source_position = $source_fields->position; + my $source_pointer = $control_item->pointer($source_position); + + $self->pointed_hint('recommended-field', $source_pointer, + '(in section for source)', $_) + for @missing_control_source; + + # look at d/control installable paragraphs + for my $installable ($debian_control->installables) { + + my $installable_fields + = $debian_control->installable_fields($installable); + + my @missing_control_installable + = grep {!$installable_fields->declares($_)} + @DEBIAN_CONTROL_INSTALLABLE; + + my $installable_position = $installable_fields->position; + my $installable_pointer= $control_item->pointer($installable_position); + + $self->pointed_hint('recommended-field', $installable_pointer, + "(in section for $installable)", $_) + for @missing_control_installable; + } + + return; +} + +sub installable { + my ($self) = @_; + + my $fields = $self->processable->fields; + + my @missing_installation_control + = grep { !$fields->declares($_) } @INSTALLATION_CONTROL; + + my $debfile = path($self->processable->path)->basename; + $self->hint('recommended-field', $debfile, $_) + for @missing_installation_control; + + return; +} + +sub changes { + my ($self) = @_; + + my $fields = $self->processable->fields; + + my @missing_changes = grep { !$fields->declares($_) } @CHANGES; + + my $changesfile = path($self->processable->path)->basename; + $self->hint('recommended-field', $changesfile, $_) for @missing_changes; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Required.pm b/lib/Lintian/Check/Fields/Required.pm new file mode 100644 index 0000000..3b5213f --- /dev/null +++ b/lib/Lintian/Check/Fields/Required.pm @@ -0,0 +1,144 @@ +# fields/required -- lintian check script -*- perl -*- +# +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Required; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(all); +use Path::Tiny; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $AT => q{@}; + +# policy 5.2 +my @DEBIAN_CONTROL_SOURCE = qw(Source Maintainer Standards-Version); +my @DEBIAN_CONTROL_INSTALLABLE = qw(Package Architecture Description); + +# policy 5.3 +my @INSTALLATION_CONTROL + = qw(Package Version Architecture Maintainer Description); + +# policy 5.4 +my @DSC = qw(Format Source Version Maintainer Standards-Version + Checksums-Sha1 Checksums-Sha256 Files); + +# policy 5.5 +# Binary and Description were removed, see Bug#963524 +my @CHANGES = qw(Format Date Source Architecture Version Distribution + Maintainer Changes Checksums-Sha1 Checksums-Sha256 Files); + +sub source { + my ($self) = @_; + + my $debian_control = $self->processable->debian_control; + + # policy 5.6.11 + if (all { $debian_control->installable_package_type($_) eq 'udeb' } + $debian_control->installables) { + @DEBIAN_CONTROL_SOURCE + = grep { $_ ne 'Standards-Version' } @DEBIAN_CONTROL_SOURCE; + @DSC = grep { $_ ne 'Standards-Version' } @DSC; + } + + my $fields = $self->processable->fields; + my @missing_dsc = grep { !$fields->declares($_) } @DSC; + + my $dscfile = path($self->processable->path)->basename; + $self->hint('required-field', $dscfile, $_) for @missing_dsc; + + my $control_item = $debian_control->item; + + # look at d/control source paragraph + my $source_fields = $debian_control->source_fields; + + my @missing_control_source + = grep { !$source_fields->declares($_) }@DEBIAN_CONTROL_SOURCE; + + my $source_position = $source_fields->position; + my $source_pointer = $control_item->pointer($source_position); + + $self->pointed_hint('required-field', $source_pointer, + '(in section for source)', $_) + for @missing_control_source; + + # look at d/control installable paragraphs + for my $installable ($debian_control->installables) { + + my $installable_fields + = $debian_control->installable_fields($installable); + + my @missing_control_installable + = grep {!$installable_fields->declares($_)} + @DEBIAN_CONTROL_INSTALLABLE; + + my $installable_position = $installable_fields->position; + my $installable_pointer= $control_item->pointer($installable_position); + + $self->pointed_hint('required-field', $installable_pointer, + "(in section for $installable)", $_) + for @missing_control_installable; + } + + return; +} + +sub installable { + my ($self) = @_; + + my $fields = $self->processable->fields; + + my @missing_installation_control + = grep { !$fields->declares($_) } @INSTALLATION_CONTROL; + + my $debfile = path($self->processable->path)->basename; + $self->hint('required-field', $debfile, $_) + for @missing_installation_control; + + return; +} + +sub changes { + my ($self) = @_; + + my $fields = $self->processable->fields; + + my @missing_changes = grep { !$fields->declares($_) } @CHANGES; + + my $changesfile = path($self->processable->path)->basename; + $self->hint('required-field', $changesfile, $_) for @missing_changes; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Section.pm b/lib/Lintian/Check/Fields/Section.pm new file mode 100644 index 0000000..f0373a9 --- /dev/null +++ b/lib/Lintian/Check/Fields/Section.pm @@ -0,0 +1,140 @@ +# fields/section -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Section; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; + +our %KNOWN_ARCHIVE_PARTS + = map { $_ => 1 } qw(non-free contrib non-free-firmware); + +sub udeb { + my ($self) = @_; + + my $section = $self->processable->fields->unfolded_value('Section'); + + $self->hint('wrong-section-for-udeb', $section) + unless $section eq 'debian-installer'; + + return; +} + +sub always { + my ($self) = @_; + + my $pkg = $self->processable->name; + + return + unless $self->processable->fields->declares('Section'); + + my $KNOWN_SECTIONS = $self->data->sections; + + # Mapping of package names to section names + my $NAME_SECTION_MAPPINGS + = $self->data->load('fields/name_section_mappings',qr/\s*=>\s*/); + + my $section = $self->processable->fields->unfolded_value('Section'); + + return + if $self->processable->type eq 'udeb'; + + my @parts = split(m{/}, $section, 2); + + my $division; + $division = $parts[0] + if @parts > 1; + + my $fraction = $parts[-1]; + + if (defined $division) { + $self->hint('unknown-section', $section) + unless $KNOWN_ARCHIVE_PARTS{$division}; + } + + if ($fraction eq 'unknown' && !length $division) { + $self->hint('section-is-dh_make-template'); + } else { + $self->hint('unknown-section', $section) + unless $KNOWN_SECTIONS->recognizes($fraction); + } + + # Check package name <-> section. oldlibs is a special case; let + # anything go there. + if ($fraction ne 'oldlibs') { + + for my $pattern ($NAME_SECTION_MAPPINGS->all()) { + + my $want = $NAME_SECTION_MAPPINGS->value($pattern); + + next + unless $pkg =~ m{$pattern}x; + + unless ($fraction eq $want) { + + my $better + = (defined $division ? "$division/" : $EMPTY) . $want; + $self->hint('wrong-section-according-to-package-name', + "$section => $better"); + } + + last; + } + } + + if ($fraction eq 'debug') { + + $self->hint('wrong-section-according-to-package-name', $section) + if $pkg !~ /-dbg(?:sym)?$/; + } + + if ($self->processable->is_transitional) { + + my $priority = $self->processable->fields->unfolded_value('Priority'); + + $self->hint('transitional-package-not-oldlibs-optional', + "$fraction/$priority") + unless $priority eq 'optional' && $fraction eq 'oldlibs'; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Source.pm b/lib/Lintian/Check/Fields/Source.pm new file mode 100644 index 0000000..455bba3 --- /dev/null +++ b/lib/Lintian/Check/Fields/Source.pm @@ -0,0 +1,99 @@ +# fields/source -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Source; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::Util qw($PKGNAME_REGEX); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $UNDERSCORE => q{_}; + +sub source { + my ($self) = @_; + + my $fields = $self->processable->fields; + + # required in source packages, but dpkg-source already refuses to unpack + # without this field (and fields depends on unpacked) + return + unless $fields->declares('Source'); + + my $source = $fields->unfolded_value('Source'); + + my $basename = path($self->processable->path)->basename; + my ($stem) = split($UNDERSCORE, $basename, 2); + + die encode_utf8( + "Source field does not match package name $source != $stem") + if $source ne $stem; + + $self->hint('source-field-malformed', $source) + if $source !~ /^[a-z0-9][-+\.a-z0-9]+\z/; + + return; +} + +sub always { + my ($self) = @_; + + # treated separately above + return + if $self->processable->type eq 'source'; + + my $fields = $self->processable->fields; + + # optional in binary packages + return + unless $fields->declares('Source'); + + my $source = $fields->unfolded_value('Source'); + + $self->hint('source-field-malformed', $source) + unless $source =~ m{^ $PKGNAME_REGEX + \s* + # Optional Version e.g. (1.0) + (?:\((?:\d+:)?(?:[-\.+:a-zA-Z0-9~]+?)(?:-[\.+a-zA-Z0-9~]+)?\))?\s*$}x; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/StandardsVersion.pm b/lib/Lintian/Check/Fields/StandardsVersion.pm new file mode 100644 index 0000000..482dd74 --- /dev/null +++ b/lib/Lintian/Check/Fields/StandardsVersion.pm @@ -0,0 +1,164 @@ +# fields/standards-version -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2008-2009 Russ Allbery +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::StandardsVersion; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Date::Parse qw(str2time); +use List::SomeUtils qw(any first_value); +use POSIX qw(strftime); +use Sort::Versions; +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; +const my $DOT => q{.}; + +const my $MAXIMUM_COMPONENTS_ANALYZED => 3; + +const my $DATE_ONLY => '%Y-%m-%d'; +const my $DATE_AND_TIME => '%Y-%m-%d %H:%M:%S UTC'; + +sub source { + my ($self) = @_; + + return + unless $self->processable->fields->declares('Standards-Version'); + + my $compliance_standard + = $self->processable->fields->value('Standards-Version'); + + my @compliance_components = split(/[.]/, $compliance_standard); + if (@compliance_components < $MAXIMUM_COMPONENTS_ANALYZED + || any { !/^\d+$/ } @compliance_components) { + + $self->hint('invalid-standards-version', $compliance_standard); + return; + } + + $self->hint('standards-version', $compliance_standard); + + my ($compliance_major, $compliance_minor, $compliance_patch) + = @compliance_components; + my $compliance_normalized + = $compliance_major. $DOT. $compliance_minor. $DOT. $compliance_patch; + + my $policy_releases = $self->data->policy_releases; + my $latest_standard = $policy_releases->latest_version; + + my ($latest_major, $latest_minor, $latest_patch) + = ((split(/[.]/, $latest_standard))[0..$MAXIMUM_COMPONENTS_ANALYZED]); + + # a fourth digit is a non-normative change in policy + my $latest_normalized + = $latest_major . $DOT . $latest_minor . $DOT . $latest_patch; + + my $changelog_epoch; + my $distribution; + + my ($entry) = @{$self->processable->changelog->entries}; + if (defined $entry) { + $changelog_epoch = $entry->Timestamp; + $distribution = $entry->Distribution; + } + + # assume recent date if there is no changelog; activates most tags + $changelog_epoch //= $policy_releases->epoch($latest_standard); + $distribution //= $EMPTY; + + unless ($policy_releases->is_known($compliance_standard)) { + + # could be newer + if (versioncmp($compliance_standard, $latest_standard) == 1) { + + $self->hint('newer-standards-version', + "$compliance_standard (current is $latest_normalized)") + unless $distribution =~ /backports/; + + } else { + $self->hint('invalid-standards-version', $compliance_standard); + } + + return; + } + + my $compliance_epoch = $policy_releases->epoch($compliance_standard); + + my $changelog_date = strftime($DATE_ONLY, gmtime $changelog_epoch); + my $compliance_date = strftime($DATE_ONLY, gmtime $compliance_epoch); + + my $changelog_timestamp= strftime($DATE_AND_TIME, gmtime $changelog_epoch); + my $compliance_timestamp + = strftime($DATE_AND_TIME, gmtime $compliance_epoch); + + # catch packages dated prior to release of their standard + if ($compliance_epoch > $changelog_epoch) { + + # show precision if needed + my $warp_illustration = "($changelog_date < $compliance_date)"; + $warp_illustration = "($changelog_timestamp < $compliance_timestamp)" + if $changelog_date eq $compliance_date; + + $self->hint('timewarp-standards-version', $warp_illustration) + unless $distribution eq 'UNRELEASED'; + } + + my @newer_versions = List::SomeUtils::before { + $policy_releases->epoch($_) <= $compliance_epoch + } + @{$policy_releases->ordered_versions}; + + # a fourth digit is a non-normative change in policy + my @newer_normative_versions + = grep { /^ \d+ [.] \d+ [.] \d+ (?:[.] 0)? $/sx } @newer_versions; + + my @newer_normative_epochs + = map { $policy_releases->epoch($_) } @newer_normative_versions; + + my @normative_epochs_then_known + = grep { $_ <= $changelog_epoch } @newer_normative_epochs; + + my $outdated_illustration + = "$compliance_standard (released $compliance_date) (current is $latest_normalized)"; + + # use normative to prevent tag changes on minor new policy edits + $self->hint('out-of-date-standards-version', $outdated_illustration) + if @normative_epochs_then_known; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Style.pm b/lib/Lintian/Check/Fields/Style.pm new file mode 100644 index 0000000..fe82d22 --- /dev/null +++ b/lib/Lintian/Check/Fields/Style.pm @@ -0,0 +1,84 @@ +# fields/style -- lintian check script -*- perl -*- +# +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Style; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +# the fields in d/control provide the values for many fields elsewhere +sub source { + my ($self) = @_; + + my $debian_control = $self->processable->debian_control; + my $control_item = $debian_control->item; + + # look at d/control source paragraph + my $source_fields = $debian_control->source_fields; + + $self->check_style($source_fields, $control_item); + + for my $installable ($debian_control->installables) { + + # look at d/control installable paragraphs + my $installable_fields + = $debian_control->installable_fields($installable); + + $self->check_style($installable_fields, $control_item); + } + + return; +} + +sub check_style { + my ($self, $fields, $item) = @_; + + for my $name ($fields->names) { + + # title-case the field name + my $standard = lc $name; + $standard =~ s/\b(\w)/\U$1/g; + + # capitalize up to three letters after an X, if followed by hyphen + $standard =~ s/^(X[SBC]{1,3})-/\U$1-/i; + + my $position = $fields->position($name); + my $pointer = $item->pointer($position); + + $self->pointed_hint('cute-field', $pointer, "$name vs $standard") + unless $name eq $standard; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Subarchitecture.pm b/lib/Lintian/Check/Fields/Subarchitecture.pm new file mode 100644 index 0000000..185f601 --- /dev/null +++ b/lib/Lintian/Check/Fields/Subarchitecture.pm @@ -0,0 +1,55 @@ +# fields/subarchitecture -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Subarchitecture; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub always { + my ($self) = @_; + + my $fields = $self->processable->fields; + + #---- Subarchitecture (udeb) + + # may trigger unfolding tag + my $subarch = $fields->unfolded_value('Subarchitecture'); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/TerminalControl.pm b/lib/Lintian/Check/Fields/TerminalControl.pm new file mode 100644 index 0000000..0d2b02b --- /dev/null +++ b/lib/Lintian/Check/Fields/TerminalControl.pm @@ -0,0 +1,62 @@ +# fields/terminal-control -- lintian check script -*- perl -*- +# +# Copyright (C) 2020 Felix Lechner +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::TerminalControl; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $ESCAPE => qq{\033}; + +sub always { + my ($self) = @_; + + my @names = $self->processable->fields->names; + + # fields that contain ESC characters + my @escaped + = grep { index($self->processable->fields->value($_), $ESCAPE) >= 0 } + @names; + + $self->hint('ansi-escape', $_, $self->processable->fields->value($_)) + for @escaped; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Trimmed.pm b/lib/Lintian/Check/Fields/Trimmed.pm new file mode 100644 index 0000000..24777f7 --- /dev/null +++ b/lib/Lintian/Check/Fields/Trimmed.pm @@ -0,0 +1,52 @@ +# fields/trimmed -- lintian check script -*- perl -*- +# +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Trimmed; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub always { + my ($self) = @_; + + my @all = $self->processable->fields->names; + + for my $name (@all) { + + my $value = $self->processable->fields->value($name); + $self->hint('trimmed-field', $name, $value); + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Unknown.pm b/lib/Lintian/Check/Fields/Unknown.pm new file mode 100644 index 0000000..79a0ddd --- /dev/null +++ b/lib/Lintian/Check/Fields/Unknown.pm @@ -0,0 +1,86 @@ +# fields/unknown -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Unknown; + +use v5.20; +use warnings; +use utf8; + +use Path::Tiny; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +# Whitelist of XS-* source fields +my %source_field_whitelist = ( + 'Autobuild' => 1, + 'Go-Import-Path' => 1, + 'Ruby-Versions' => 1, +); + +sub source { + my ($self) = @_; + + my $KNOWN_SOURCE_FIELDS= $self->data->load('common/source-fields'); + my @unknown= $self->processable->fields->extra($KNOWN_SOURCE_FIELDS->all); + + # The grep filter is a workaround for #1014885 and #1029471 + $self->hint('unknown-field', $_) + for grep { !exists($source_field_whitelist{$_}) } @unknown; + + return; +} + +sub binary { + my ($self) = @_; + + my $KNOWN_BINARY_FIELDS= $self->data->load('fields/binary-fields'); + my @unknown= $self->processable->fields->extra($KNOWN_BINARY_FIELDS->all); + + $self->hint('unknown-field', $_)for @unknown; + + return; +} + +sub udeb { + my ($self) = @_; + + my $KNOWN_UDEB_FIELDS = $self->data->load('fields/udeb-fields'); + my @unknown = $self->processable->fields->extra($KNOWN_UDEB_FIELDS->all); + + $self->hint('unknown-field', $_)for @unknown; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Uploaders.pm b/lib/Lintian/Check/Fields/Uploaders.pm new file mode 100644 index 0000000..bfad0c4 --- /dev/null +++ b/lib/Lintian/Check/Fields/Uploaders.pm @@ -0,0 +1,71 @@ +# fields/uploaders -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Uploaders; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub always { + my ($self) = @_; + + return + unless $self->processable->fields->declares('Uploaders'); + + my $uploaders = $self->processable->fields->value('Uploaders'); + + # Note, not expected to hit on uploaders anymore, as dpkg + # now strips newlines for the .dsc, and the newlines don't + # hurt in debian/control + + # check for empty field see #783628 + if ($uploaders =~ /,\s*,/) { + $self->hint('uploader-name-missing','you have used a double comma'); + $uploaders =~ s/,\s*,/,/g; + } + + if ($self->processable->fields->declares('Maintainer')) { + + my $maintainer = $self->processable->fields->value('Maintainer'); + + $self->hint('maintainer-also-in-uploaders') + if $uploaders =~ m/\Q$maintainer/; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Urgency.pm b/lib/Lintian/Check/Fields/Urgency.pm new file mode 100644 index 0000000..7e87309 --- /dev/null +++ b/lib/Lintian/Check/Fields/Urgency.pm @@ -0,0 +1,60 @@ +# fields/urgency -- lintian check script -*- perl -*- + +# Copyright (C) 2020 Felix Lechner +# +# This program is free software. It is distributed 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Urgency; + +use v5.20; +use warnings; +use utf8; + +use List::SomeUtils qw(any); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub changes { + my ($self) = @_; + + return + unless $self->processable->fields->declares('Urgency'); + + my $urgency = $self->processable->fields->value('Urgency'); + + # translate to lowercase + my $lowercase = lc $urgency; + + # discard anything after the first word + $lowercase =~ s/ .*//; + + $self->hint('bad-urgency-in-changes-file', $urgency) + unless any { $lowercase =~ $_ } qw(low medium high critical emergency); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Vcs.pm b/lib/Lintian/Check/Fields/Vcs.pm new file mode 100644 index 0000000..8bf7858 --- /dev/null +++ b/lib/Lintian/Check/Fields/Vcs.pm @@ -0,0 +1,378 @@ +# fields/vcs -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2019 Chris Lamb <lamby@debian.org> +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Vcs; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(any); + +const my $EMPTY => q{}; +const my $QUESTION_MARK => q{?}; + +const my $NOT_EQUALS => q{!=}; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +my %VCS_EXTRACT = ( + Browser => sub { return @_;}, + Arch => sub { return @_;}, + Bzr => sub { return @_;}, + # cvs rootdir followed by optional module name: + Cvs => sub { return shift =~ /^(.+?)(?:\s+(\S*))?$/;}, + Darcs => sub { return @_;}, + # hg uri followed by optional -b branchname + Hg => sub { return shift =~ /^(.+?)(?:\s+-b\s+(\S*))?$/;}, + # git uri followed by optional "[subdir]", "-b branchname" etc. + Git => sub { + return shift =~ /^(.+?)(?:(?:\s+\[(\S*)\])?(?:\s+-b\s+(\S*))?){0,2}$/; + }, + Svn => sub { return @_;}, + # New "mtn://host?branch" uri or deprecated "host branch". + Mtn => sub { return shift =~ /^(.+?)(?:\s+\S+)?$/;}, +); + +my %VCS_CANONIFY = ( + Browser => sub { + $_[0] =~ s{https?://svn\.debian\.org/wsvn/} + {https://anonscm.debian.org/viewvc/}; + $_[0] =~ s{https?\Q://git.debian.org/?p=\E} + {https://anonscm.debian.org/git/}; + $_[0] =~ s{https?\Q://bzr.debian.org/loggerhead/\E} + {https://anonscm.debian.org/loggerhead/}; + $_[0] =~ s{https?\Q://salsa.debian.org/\E([^/]+/[^/]+)\.git/?$} + {https://salsa.debian.org/$1}; + + if ($_[0] =~ m{https?\Q://anonscm.debian.org/viewvc/\E}xsm) { + if ($_[0] =~ s{\?(.*[;\&])?op=log(?:[;\&](.*))?\Z}{}xsm) { + my (@keep) = ($1, $2, $3); + my $final = join($EMPTY, grep {defined} @keep); + + $_[0] .= $QUESTION_MARK . $final + if $final ne $EMPTY; + + $_[1] = 'vcs-field-bitrotted'; + } + } + }, + Cvs => sub { + if ( + $_[0] =~ s{\@(?:cvs\.alioth|anonscm)\.debian\.org:/cvsroot/} + {\@anonscm.debian.org:/cvs/} + ) { + $_[1] = 'vcs-field-bitrotted'; + } + $_[0]=~ s{\@\Qcvs.alioth.debian.org:/cvs/}{\@anonscm.debian.org:/cvs/}; + }, + Arch => sub { + $_[0] =~ s{https?\Q://arch.debian.org/arch/\E} + {https://anonscm.debian.org/arch/}; + }, + Bzr => sub { + $_[0] =~ s{https?\Q://bzr.debian.org/\E} + {https://anonscm.debian.org/bzr/}; + $_[0] =~ s{https?\Q://anonscm.debian.org/bzr/bzr/\E} + {https://anonscm.debian.org/bzr/}; + }, + Git => sub { + if ( + $_[0] =~ s{git://(?:git|anonscm)\.debian\.org/~} + {https://anonscm.debian.org/git/users/} + ) { + $_[1] = 'vcs-git-uses-invalid-user-uri'; + } + $_[0] =~ s{(https?://.*?\.git)(?:\.git)+$}{$1}; + $_[0] =~ s{https?\Q://git.debian.org/\E(?:git/?)?} + {https://anonscm.debian.org/git/}; + $_[0] =~ s{https?\Q://anonscm.debian.org/git/git/\E} + {https://anonscm.debian.org/git/}; + $_[0] =~ s{\Qgit://git.debian.org/\E(?:git/?)?} + {https://anonscm.debian.org/git/}; + $_[0] =~ s{\Qgit://anonscm.debian.org/git/\E} + {https://anonscm.debian.org/git/}; + $_[0] =~ s{https?\Q://salsa.debian.org/\E([^/]+/[^/\.]+)(?!\.git)$} + {https://salsa.debian.org/$1.git}; + }, + Hg => sub { + $_[0] =~ s{https?\Q://hg.debian.org/\E} + {https://anonscm.debian.org/hg/}; + $_[0] =~ s{https?\Q://anonscm.debian.org/hg/hg/\E} + {https://anonscm.debian.org/hg/}; + }, + Svn => sub { + $_[0] =~ s{\Qsvn://cvs.alioth.debian.org/\E} + {svn://anonscm.debian.org/}; + $_[0] =~ s{\Qsvn://svn.debian.org/\E} + {svn://anonscm.debian.org/}; + $_[0] =~ s{\Qsvn://anonscm.debian.org/svn/\E} + {svn://anonscm.debian.org/}; + }, +); + +# Valid URI formats for the Vcs-* fields +# currently only checks the protocol, not the actual format of the URI +my %VCS_RECOMMENDED_URIS = ( + Browser => qr{^https?://}, + Arch => qr{^https?://}, + Bzr => qr{^(?:lp:|(?:nosmart\+)?https?://)}, + Cvs => qr{^:(?:pserver:|ext:_?anoncvs)}, + Darcs => qr{^https?://}, + Hg => qr{^https?://}, + Git => qr{^(?:git|https?|rsync)://}, + Svn => qr{^(?:svn|(?:svn\+)?https?)://}, + Mtn => qr{^mtn://}, +); + +my %VCS_VALID_URIS = ( + Arch => qr{^https?://}, + Bzr => qr{^(?:sftp|(?:bzr\+)?ssh)://}, + Cvs => qr{^(?:-d\s*)?:(?:ext|pserver):}, + Hg => qr{^ssh://}, + Git => qr{^(?:git\+)?ssh://|^[\w.]+@[a-zA-Z0-9.]+:[/a-zA-Z0-9.]}, + Svn => qr{^(?:svn\+)?ssh://}, + Mtn => qr{^[\w.-]+$}, +); + +has VCS_HOSTERS_BY_PATTERN => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my %vcs_hosters_by_pattern; + + my $KNOWN_VCS_HOSTERS + = $self->data->load('fields/vcs-hosters',qr/\s*~~\s*/); + + for my $pattern ($KNOWN_VCS_HOSTERS->all) { + + my @known_hosters + = split(m{,}, $KNOWN_VCS_HOSTERS->value($pattern)); + $vcs_hosters_by_pattern{$pattern} = \@known_hosters; + } + + return \%vcs_hosters_by_pattern; + } +); + +sub always { + my ($self) = @_; + + my $type = $self->processable->type; + my $processable = $self->processable; + + # team-maintained = maintainer or uploaders field contains a mailing list + my $is_teammaintained = 0; + my $team_email = $EMPTY; + # co-maintained = maintained by an informal group of people, + # i. e. >= 1 uploader and not team-maintained + my $is_comaintained = 0; + my $is_maintained_by_individual = 1; + my $num_uploaders = 0; + for my $field (qw(Maintainer Uploaders)) { + + next + unless $processable->fields->declares($field); + + my $maintainer = $processable->fields->unfolded_value($field); + + if ($maintainer =~ /\b(\S+\@lists(?:\.alioth)?\.debian\.org)\b/ + || $maintainer =~ /\b(\S+\@tracker\.debian\.org)\b/) { + $is_teammaintained = 1; + $team_email = $1; + $is_maintained_by_individual = 0; + } + + if ($field eq 'Uploaders') { + + # check for empty field see #783628 + $maintainer =~ s/,\s*,/,/g + if $maintainer =~ m/,\s*,/; + + my @uploaders = map { split /\@\S+\K\s*,\s*/ } + split />\K\s*,\s*/, $maintainer; + + $num_uploaders = scalar @uploaders; + + if (@uploaders) { + $is_comaintained = 1 + unless $is_teammaintained; + $is_maintained_by_individual = 0; + } + + } + } + + $self->hint('package-is-team-maintained', $team_email, + "(with $num_uploaders uploaders)") + if $is_teammaintained; + $self->hint('package-is-co-maintained', "(with $num_uploaders uploaders)") + if $is_comaintained; + $self->hint('package-is-maintained-by-individual') + if $is_maintained_by_individual; + + my %seen_vcs; + for my $platform (keys %VCS_EXTRACT) { + + my $splitter = $VCS_EXTRACT{$platform}; + + my $fieldname = "Vcs-$platform"; + my $maintainer = $processable->fields->value('Maintainer'); + + next + unless $processable->fields->declares($fieldname); + + my $uri = $processable->fields->unfolded_value($fieldname); + + my @parts = $splitter->($uri); + if (not @parts or not $parts[0]) { + $self->hint('vcs-field-uses-unknown-uri-format', $platform, $uri); + } else { + if ( $VCS_RECOMMENDED_URIS{$platform} + and $parts[0] !~ $VCS_RECOMMENDED_URIS{$platform}) { + if ( $VCS_VALID_URIS{$platform} + and $parts[0] =~ $VCS_VALID_URIS{$platform}) { + $self->hint('vcs-field-uses-not-recommended-uri-format', + $platform, $uri); + } else { + $self->hint('vcs-field-uses-unknown-uri-format', + $platform,$uri); + } + } + + $self->hint('vcs-field-has-unexpected-spaces', $platform, $uri) + if (any { $_ and /\s/} @parts); + + $self->hint('vcs-field-uses-insecure-uri', $platform, $uri) + if $parts[0] =~ m{^(?:git|(?:nosmart\+)?http|svn)://} + || $parts[0] =~ m{^(?:lp|:pserver):}; + } + + if ($VCS_CANONIFY{$platform}) { + + my $canonicalized = $parts[0]; + my $tag = 'vcs-field-not-canonical'; + + foreach my $canonify ($VCS_CANONIFY{$platform}) { + $canonify->($canonicalized, $tag); + } + + $self->hint($tag, $platform, $parts[0], $canonicalized) + unless $canonicalized eq $parts[0]; + } + + if ($platform eq 'Browser') { + + $self->hint('vcs-browser-links-to-empty-view', $uri) + if $uri =~ /rev=0&sc=0/; + + } else { + $self->hint('vcs', lc $platform); + $self->hint('vcs-uri', $platform, $uri); + $seen_vcs{$platform}++; + + for my $pattern (keys %{$self->VCS_HOSTERS_BY_PATTERN}) { + + # warn once + my $known_hoster + = @{$self->VCS_HOSTERS_BY_PATTERN->{$pattern}}[0]; + + $self->hint('vcs-field-mismatch', + "Vcs-$platform", $NOT_EQUALS, "Vcs-$known_hoster",$uri) + if $uri =~ m/^ $pattern /xi + && $platform ne $known_hoster + && $platform ne 'Browser'; + } + } + + if ($uri =~ m{//(.+)\.debian\.org/}) { + + $self->hint('vcs-obsolete-in-debian-infrastructure', + $platform, $uri) + unless $1 =~ m{^(?:salsa|.*\.dgit)$}; + + } + + # orphaned + if ($maintainer =~ /packages\@qa.debian.org/ && $platform ne 'Browser') + { + if ($uri =~ m{//(?:.+)\.debian\.org/}) { + + $self->hint('orphaned-package-maintained-in-private-space', + $fieldname, $uri) + unless $uri =~ m{//salsa\.debian\.org/debian/} + || $uri =~ m{//git\.dgit\.debian\.org/}; + + } else { + + $self->hint( + 'orphaned-package-not-maintained-in-debian-infrastructure', + $fieldname, $uri + ); + } + } + } + + $self->hint('vcs-fields-use-more-than-one-vcs', + (sort map { lc } keys %seen_vcs)) + if keys %seen_vcs > 1; + + $self->hint('co-maintained-package-with-no-vcs-fields') + if $type eq 'source' + and ($is_comaintained or $is_teammaintained) + and not %seen_vcs; + + # Check for missing Vcs-Browser headers + unless ($processable->fields->declares('Vcs-Browser')) { + + for my $pattern (keys %{$self->VCS_HOSTERS_BY_PATTERN}) { + + # warn once + my $platform = @{$self->VCS_HOSTERS_BY_PATTERN->{$pattern}}[0]; + + my $fieldname = "Vcs-$platform"; + my $url = $processable->fields->value($fieldname); + + $self->hint('missing-vcs-browser-field', $fieldname, $url) + if $url =~ m/^ $pattern /xi; + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Version.pm b/lib/Lintian/Check/Fields/Version.pm new file mode 100644 index 0000000..77ee0f9 --- /dev/null +++ b/lib/Lintian/Check/Fields/Version.pm @@ -0,0 +1,100 @@ +# fields/version -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2021 Felix Lechner +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Version; + +use v5.20; +use warnings; +use utf8; + +use Dpkg::Version; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub always { + my ($self) = @_; + + my $fields = $self->processable->fields; + + return + unless $fields->declares('Version'); + + my $version = $fields->unfolded_value('Version'); + + my $dversion = Dpkg::Version->new($version); + unless ($dversion->is_valid) { + $self->hint('bad-version-number', $version); + return; + } + + my ($epoch, $upstream, $debian) + = ($dversion->epoch, $dversion->version, $dversion->revision); + + # Dpkg::Version sets the debian revision to 0 if there is + # no revision. So we need to check if the raw version + # ends with "-0". + $self->hint('debian-revision-is-zero', $version) + if $version =~ /-0$/; + + my $ubuntu; + if($debian =~ /^(?:[^.]+)(?:\.[^.]+)?(?:\.[^.]+)?(\..*)?$/){ + my $extra = $1; + if ( + defined $extra + && $debian =~ m{\A + (?:[^.]+ubuntu[^.]+)(?:\.\d+){1,3}(\..*)? + \Z}xsm + ) { + $ubuntu = 1; + $extra = $1; + } + + $self->hint('debian-revision-not-well-formed', $version) + if defined $extra; + + } else { + $self->hint('debian-revision-not-well-formed', $version); + } + + if ($self->processable->type eq 'source') { + + $self->hint('binary-nmu-debian-revision-in-source', $version) + if ($debian =~ /^[^.-]+\.[^.-]+\./ && !$ubuntu) + || $version =~ /\+b\d+$/; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Version/Derivative.pm b/lib/Lintian/Check/Fields/Version/Derivative.pm new file mode 100644 index 0000000..9385fa4 --- /dev/null +++ b/lib/Lintian/Check/Fields/Version/Derivative.pm @@ -0,0 +1,82 @@ +# fields/version/derivative -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2021 Felix Lechner +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Version::Derivative; + +use v5.20; +use warnings; +use utf8; + +use Dpkg::Version; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $fields = $self->processable->fields; + + return + unless $fields->declares('Version'); + + my $version = $fields->unfolded_value('Version'); + + my $dversion = Dpkg::Version->new($version); + return + unless $dversion->is_valid; + + my ($epoch, $upstream, $debian) + = ($dversion->epoch, $dversion->version, $dversion->revision); + + my $DERIVATIVE_VERSIONS + = $self->data->load('fields/derivative-versions',qr/\s*~~\s*/); + + unless ($self->processable->native) { + + for my $pattern ($DERIVATIVE_VERSIONS->all) { + + next + if $version =~ m/$pattern/; + + my $explanation = $DERIVATIVE_VERSIONS->value($pattern); + + $self->hint('invalid-version-number-for-derivative', + $version,"($explanation)"); + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Version/Repack/Count.pm b/lib/Lintian/Check/Fields/Version/Repack/Count.pm new file mode 100644 index 0000000..c793385 --- /dev/null +++ b/lib/Lintian/Check/Fields/Version/Repack/Count.pm @@ -0,0 +1,65 @@ +# fields/version/repack/count -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2021 Kentaro Hayashi +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Version::Repack::Count; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + # repack counts in native packages are dealt with elsewhere + return + if $self->processable->native; + + my $fields = $self->processable->fields; + + return + unless $fields->declares('Version'); + + my $version = $fields->unfolded_value('Version'); + + $self->hint('anticipated-repack-count', $version) + if $version =~ m{ dfsg [01] - }x; + + $self->hint('dot-before-repack-count', $version) + if $version =~ / dfsg [.] \d+ /x; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Version/Repack/Native.pm b/lib/Lintian/Check/Fields/Version/Repack/Native.pm new file mode 100644 index 0000000..6ca1602 --- /dev/null +++ b/lib/Lintian/Check/Fields/Version/Repack/Native.pm @@ -0,0 +1,63 @@ +# fields/version/repack/native -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2021 Felix Lechner +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Version::Repack::Native; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $fields = $self->processable->fields; + + return + unless $fields->declares('Version'); + + my $version = $fields->unfolded_value('Version'); + + # Checks for the dfsg convention for repackaged upstream + # source. Only check these against the source package to not + # repeat ourselves too much. + $self->hint('dfsg-version-in-native-package', $version) + if $version =~ /dfsg/ + && $self->processable->native; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Version/Repack/Period.pm b/lib/Lintian/Check/Fields/Version/Repack/Period.pm new file mode 100644 index 0000000..12e8928 --- /dev/null +++ b/lib/Lintian/Check/Fields/Version/Repack/Period.pm @@ -0,0 +1,60 @@ +# fields/version/repack/period -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2021 Felix Lechner +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Version::Repack::Period; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $fields = $self->processable->fields; + + return + unless $fields->declares('Version'); + + my $version = $fields->unfolded_value('Version'); + + $self->hint('dfsg-version-with-period', $version) + if $version =~ m{ [.] dfsg }x + && !$self->processable->native; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Version/Repack/Tilde.pm b/lib/Lintian/Check/Fields/Version/Repack/Tilde.pm new file mode 100644 index 0000000..206b288 --- /dev/null +++ b/lib/Lintian/Check/Fields/Version/Repack/Tilde.pm @@ -0,0 +1,60 @@ +# fields/version/repack/tilde -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2021 Kentaro Hayashi +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Version::Repack::Tilde; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $fields = $self->processable->fields; + + return + unless $fields->declares('Version'); + + my $version = $fields->unfolded_value('Version'); + + $self->hint('dfsg-version-with-tilde', $version) + if $version =~ /~dfsg/ + && !$self->processable->native; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fields/Version/Repack/Typo.pm b/lib/Lintian/Check/Fields/Version/Repack/Typo.pm new file mode 100644 index 0000000..c466df2 --- /dev/null +++ b/lib/Lintian/Check/Fields/Version/Repack/Typo.pm @@ -0,0 +1,64 @@ +# fields/version/repack/typo -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2021 Felix Lechner +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fields::Version::Repack::Typo; + +use v5.20; +use warnings; +use utf8; + +use Dpkg::Version qw(version_check); + +use Lintian::Relation::Version qw(versions_compare); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $fields = $self->processable->fields; + + return + unless $fields->declares('Version'); + + my $version = $fields->unfolded_value('Version'); + + $self->hint('dfsg-version-misspelled', $version) + if $version =~ /dsfg/ + && !$self->processable->native; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Architecture.pm b/lib/Lintian/Check/Files/Architecture.pm new file mode 100644 index 0000000..70cab47 --- /dev/null +++ b/lib/Lintian/Check/Files/Architecture.pm @@ -0,0 +1,105 @@ +# files/architecture -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Architecture; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has TRIPLETS => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $DEB_HOST_MULTIARCH= $self->data->architectures->deb_host_multiarch; + my %triplets = map { $DEB_HOST_MULTIARCH->{$_} => $_ } + keys %{$DEB_HOST_MULTIARCH}; + + return \%triplets; + } +); + +has depends_on_architecture => (is => 'rw', default => 0); + +sub visit_installed_files { + my ($self, $item) = @_; + + # for directories + if ($item->name =~ m{^(?:usr/)?lib/([^/]+)/$}) { + + my $potential_triplet = $1; + + if (exists $self->TRIPLETS->{$potential_triplet}) { + + my $from_triplet = $self->TRIPLETS->{$potential_triplet}; + my $port = $self->processable->fields->value('Architecture'); + + $self->pointed_hint('triplet-dir-and-architecture-mismatch', + $item->pointer, "is for $from_triplet instead of $port") + unless $from_triplet eq $port; + } + } + + # for files + if ($item->dirname =~ m{^(?:usr)?/lib/([^/]+)/$}) { + + my $potential_triplet = $1; + + $self->depends_on_architecture(1) + if exists $self->TRIPLETS->{$potential_triplet}; + } + + $self->depends_on_architecture(1) + if $item->is_file + && $item->size > 0 + && $item->file_type !~ m/^very short file/ + && $item->file_type !~ m/\bASCII text\b/ + && $item->name !~ m{^usr/share/}; + + return; +} + +sub installable { + my ($self) = @_; + + $self->hint('package-contains-no-arch-dependent-files') + if !$self->depends_on_architecture + && $self->processable->fields->value('Architecture') ne 'all' + && $self->processable->type ne 'udeb' + && !$self->processable->is_transitional + && !$self->processable->is_meta_package; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Artifact.pm b/lib/Lintian/Check/Files/Artifact.pm new file mode 100644 index 0000000..5344cfc --- /dev/null +++ b/lib/Lintian/Check/Files/Artifact.pm @@ -0,0 +1,140 @@ +# files/artifact -- lintian check script -*- perl -*- +# +# based on debhelper check, +# Copyright (C) 1999 Joey Hess +# Copyright (C) 2000 Sean 'Shaleh' Perry +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2007 Russ Allbery +# Copyright (C) 2013-2018 Bastien ROUCARIES +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Artifact; + +use v5.20; +use warnings; +use utf8; + +use List::SomeUtils qw(first_value); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +# Directory checks. These regexes match a directory that shouldn't be in the +# source package and associate it with a tag (minus the leading +# source-contains or debian-adds). Note that only one of these regexes +# should trigger for any single directory. +my @directory_checks = ( + [qr{^(.+/)?CVS/?$} => 'cvs-control-dir'], + [qr{^(.+/)?\.svn/?$} => 'svn-control-dir'], + [qr{^(.+/)?\.bzr/?$} => 'bzr-control-dir'], + [qr{^(.+/)?\{arch\}/?$} => 'arch-control-dir'], + [qr{^(.+/)?\.arch-ids/?$} => 'arch-control-dir'], + [qr{^(.+/)?,,.+/?$} => 'arch-control-dir'], + [qr{^(.+/)?\.git/?$} => 'git-control-dir'], + [qr{^(.+/)?\.hg/?$} => 'hg-control-dir'], + [qr{^(.+/)?\.be/?$} => 'bts-control-dir'], + [qr{^(.+/)?\.ditrack/?$} => 'bts-control-dir'], + + # Special case (can only be triggered for diffs) + [qr{^(.+/)?\.pc/?$} => 'quilt-control-dir'], +); + +# File checks. These regexes match files that shouldn't be in the source +# package and associate them with a tag (minus the leading source-contains or +# debian-adds). Note that only one of these regexes should trigger for any +# given file. +my @file_checks = ( + [qr{^(.+/)?svn-commit\.(.+\.)?tmp$} => 'svn-commit-file'], + [qr{^(.+/)?svk-commit.+\.tmp$} => 'svk-commit-file'], + [qr{^(.+/)?\.arch-inventory$} => 'arch-inventory-file'], + [qr{^(.+/)?\.hgtags$} => 'hg-tags-file'], + [qr{^(.+/)?\.\#(.+?)\.\d+(\.\d+)*$} => 'cvs-conflict-copy'], + [qr{^(.+/)?(.+?)\.(r[1-9]\d*)$} => 'svn-conflict-file'], + [qr{\.(orig|rej)$} => 'patch-failure-file'], + [qr{((^|/)[^/]+\.swp|~)$} => 'editor-backup-file'], +); + +sub source { + my ($self) = @_; + + my @added_by_debian; + my $prefix; + if ($self->processable->native) { + + @added_by_debian = @{$self->processable->patched->sorted_list}; + $prefix = 'source-contains'; + + } else { + my $patched = $self->processable->patched; + my $orig = $self->processable->orig; + + @added_by_debian + = grep { !defined $orig->lookup($_->name) } @{$patched->sorted_list}; + + # remove root quilt control folder and all paths in it + # created when 3.0 (quilt) source packages are unpacked + @added_by_debian = grep { $_->name !~ m{^.pc/} } @added_by_debian + if $self->processable->source_format eq '3.0 (quilt)'; + + my @common_items + = grep { defined $orig->lookup($_->name) } @{$patched->sorted_list}; + my @touched_by_debian + = grep { $_->md5sum ne $orig->lookup($_->name)->md5sum } + @common_items; + + $self->hint('no-debian-changes') + unless @added_by_debian || @touched_by_debian; + + $prefix = 'debian-adds'; + } + + # ignore lintian test set; should use automatic loop in the future + @added_by_debian = grep { $_->name !~ m{^t/} } @added_by_debian + if $self->processable->source_name eq 'lintian'; + + my @directories = grep { $_->is_dir } @added_by_debian; + for my $directory (@directories) { + + my $rule = first_value { $directory->name =~ /$_->[0]/s } + @directory_checks; + $self->pointed_hint("${prefix}-$rule->[1]", $directory->pointer) + if defined $rule; + } + + my @files = grep { $_->is_file } @added_by_debian; + for my $item (@files) { + + my $rule = first_value { $item->name =~ /$_->[0]/s } @file_checks; + $self->pointed_hint("${prefix}-$rule->[1]", $item->pointer) + if defined $rule; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Banned.pm b/lib/Lintian/Check/Files/Banned.pm new file mode 100644 index 0000000..81b5ae7 --- /dev/null +++ b/lib/Lintian/Check/Files/Banned.pm @@ -0,0 +1,113 @@ +# files/banned -- lintian check script -*- perl -*- +# +# based on debhelper check, +# Copyright (C) 1999 Joey Hess +# Copyright (C) 2000 Sean 'Shaleh' Perry +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2007 Russ Allbery +# Copyright (C) 2013-2018 Bastien ROUCARIES +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Banned; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(any); +use Unicode::UTF8 qw(encode_utf8); + +const my $MD5SUM_DATA_FIELDS => 5; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub _md5sum_based_lintian_data { + my ($self, $filename) = @_; + + my $data = $self->data->load($filename,qr/\s*\~\~\s*/); + + my %md5sum_data; + + for my $md5sum ($data->all) { + + my $value = $data->value($md5sum); + + my ($sha1, $sha256, $name, $reason, $link) + = split(/ \s* ~~ \s* /msx, $value, $MD5SUM_DATA_FIELDS); + + die encode_utf8("Syntax error in $filename $.") + if any { !defined } ($sha1, $sha256, $name, $reason, $link); + + $md5sum_data{$md5sum} = { + 'sha1' => $sha1, + 'sha256' => $sha256, + 'name' => $name, + 'reason' => $reason, + 'link' => $link, + }; + } + + return \%md5sum_data; +} + +has NON_DISTRIBUTABLE_FILES => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return $self->_md5sum_based_lintian_data( + 'cruft/non-distributable-files'); + } +); + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + my $banned = $self->NON_DISTRIBUTABLE_FILES->{$item->md5sum}; + if (defined $banned) { + my $usualname = $banned->{'name'}; + my $reason = $banned->{'reason'}; + my $link = $banned->{'link'}; + + $self->pointed_hint( + 'license-problem-md5sum-non-distributable-file', + $item->pointer, "usual name is $usualname.", + $reason, "See also $link." + ); + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Banned/CompiledHelp.pm b/lib/Lintian/Check/Files/Banned/CompiledHelp.pm new file mode 100644 index 0000000..efb5eee --- /dev/null +++ b/lib/Lintian/Check/Files/Banned/CompiledHelp.pm @@ -0,0 +1,58 @@ +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 1999 Joey Hess +# Copyright (C) 2000 Sean 'Shaleh' Perry +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2007 Russ Allbery +# Copyright (C) 2013-2018 Bastien ROUCARIES +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Banned::CompiledHelp; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + # .chm files are usually generated by non-free software + $self->pointed_hint('source-contains-prebuilt-ms-help-file',$item->pointer) + if $item->basename =~ /\.chm$/i + && $item->file_type eq 'MS Windows HtmlHelp Data' + && $item->bytes !~ / Halibut, /msx; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Banned/Lenna.pm b/lib/Lintian/Check/Files/Banned/Lenna.pm new file mode 100644 index 0000000..3bfcb2c --- /dev/null +++ b/lib/Lintian/Check/Files/Banned/Lenna.pm @@ -0,0 +1,109 @@ +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 1999 Joey Hess +# Copyright (C) 2000 Sean 'Shaleh' Perry +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2007 Russ Allbery +# Copyright (C) 2013-2018 Bastien ROUCARIES +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Banned::Lenna; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +# known bad files +has LENNA_BLACKLIST => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my %blacklist; + + my $data = $self->data->load('files/banned/lenna/blacklist', + qr/ \s* ~~ \s* /x); + + for my $md5sum ($data->all) { + + my $value = $data->value($md5sum); + + my ($sha1, $sha256, $name, $link) + = split(/ \s* ~~ \s* /msx, $value); + + $blacklist{$md5sum} = { + 'sha1' => $sha1, + 'sha256' => $sha256, + 'name' => $name, + 'link' => $link, + }; + } + + return \%blacklist; + } +); + +# known good files +has LENNA_WHITELIST => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return $self->data->load('files/banned/lenna/whitelist'); + } +); + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + return + unless $item->file_type =~ /\bimage\b/i + || $item->file_type =~ /^Matlab v\d+ mat/i + || $item->file_type =~ /\bbitmap\b/i + || $item->file_type =~ /^PDF Document\b/i + || $item->file_type =~ /^Postscript Document\b/i; + + return + if $self->LENNA_WHITELIST->recognizes($item->md5sum); + + # Lena Soderberg image + $self->pointed_hint('license-problem-non-free-img-lenna', $item->pointer) + if $item->basename =~ / ( \b | _ ) lenn?a ( \b | _ ) /ix + || exists $self->LENNA_BLACKLIST->{$item->md5sum}; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Bugs.pm b/lib/Lintian/Check/Files/Bugs.pm new file mode 100644 index 0000000..69432de --- /dev/null +++ b/lib/Lintian/Check/Files/Bugs.pm @@ -0,0 +1,50 @@ +# files/bugs -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Bugs; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_dir; + + $self->pointed_hint('package-contains-bts-control-dir', $item->pointer) + if $item->name =~ m{/\.(?:be|ditrack)/?$}; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/BuildPath.pm b/lib/Lintian/Check/Files/BuildPath.pm new file mode 100644 index 0000000..e6c73af --- /dev/null +++ b/lib/Lintian/Check/Files/BuildPath.pm @@ -0,0 +1,55 @@ +# files/build-path -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::BuildPath; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + my $BUILD_PATH_REGEX + = $self->data->load('files/build-path-regex', qr/~~~~~/); + + for my $pattern ($BUILD_PATH_REGEX->all) { + + $self->pointed_hint('dir-or-file-in-build-tree', $item->pointer) + if $item->name =~ m{$pattern}xms + && $self->processable->source_name ne 'sbuild' + && $self->processable->source_name ne 'pbuilder'; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Compressed.pm b/lib/Lintian/Check/Files/Compressed.pm new file mode 100644 index 0000000..d64807f --- /dev/null +++ b/lib/Lintian/Check/Files/Compressed.pm @@ -0,0 +1,80 @@ +# files/compressed -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Compressed; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +const my $VERTICAL_BAR => q{|}; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +# an OR (|) regex of all compressed extension +has COMPRESS_FILE_EXTENSIONS_OR_ALL => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $COMPRESS_FILE_EXTENSIONS + = $self->data->load('files/compressed-file-extensions',qr/\s+/); + + my $text = join($VERTICAL_BAR, + map { quotemeta }$COMPRESS_FILE_EXTENSIONS->all); + + return qr/$text/; + } +); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + my $regex = $self->COMPRESS_FILE_EXTENSIONS_OR_ALL; + + # see tag duplicated-compressed-file + my $DUPLICATED_COMPRESSED_FILE_REGEX= qr/^(.+)\.$regex$/; + + # both compressed and uncompressed present + if ($item->name =~ $DUPLICATED_COMPRESSED_FILE_REGEX) { + + $self->pointed_hint('compressed-duplicate', $item->pointer) + if $self->processable->installed->lookup($1); + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Compressed/Bz2.pm b/lib/Lintian/Check/Files/Compressed/Bz2.pm new file mode 100644 index 0000000..25c8bc1 --- /dev/null +++ b/lib/Lintian/Check/Files/Compressed/Bz2.pm @@ -0,0 +1,57 @@ +# files/compressed/bz2 -- lintian check script -*- perl -*- + +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Compressed::Bz2; + +use v5.20; +use warnings; +use utf8; + +use Lintian::IPC::Run3 qw(safe_qx); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + if ($item->name =~ /\.bz2$/si) { + + safe_qx('bzip2', '--test', $item->unpacked_path); + + $self->pointed_hint('broken-bz2', $item->pointer) + if $?; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Compressed/Gz.pm b/lib/Lintian/Check/Files/Compressed/Gz.pm new file mode 100644 index 0000000..6290247 --- /dev/null +++ b/lib/Lintian/Check/Files/Compressed/Gz.pm @@ -0,0 +1,113 @@ +# files/compressed/gz -- lintian check script -*- perl -*- + +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Compressed::Gz; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Time::Piece; + +use Lintian::IPC::Run3 qw(safe_qx); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +# get timestamp of first member; https://tools.ietf.org/html/rfc1952.html#page-5 +const my $GZIP_HEADER_SIZE => 8; + +has changelog_timestamp => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + # remains 0 if there is no timestamp + my $changelog = $self->processable->changelog; + if (defined $changelog) { + + my ($entry) = @{$changelog->entries}; + return $entry->Timestamp + if $entry && $entry->Timestamp; + } + + return 0; + } +); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + if ($item->name =~ /\.gz$/si) { + + safe_qx('gzip', '--test', $item->unpacked_path); + + $self->pointed_hint('broken-gz', $item->pointer) + if $?; + } + + # gzip files + if ($item->file_type =~ /gzip compressed/) { + + my $bytes = $item->magic($GZIP_HEADER_SIZE); + my (undef, $gziptime) = unpack('VV', $bytes); + + if (defined $gziptime && $gziptime != 0) { + + # see https://bugs.debian.org/762105 + my $time_from_build = $gziptime - $self->changelog_timestamp; + if ($time_from_build > 0) { + + my $architecture + = $self->processable->fields->value('Architecture'); + my $multiarch + = $self->processable->fields->value('Multi-Arch') || 'no'; + + if ($multiarch eq 'same' && $item->name !~ /\Q$architecture\E/) + { + $self->pointed_hint( + 'gzip-file-is-not-multi-arch-same-safe', + $item->pointer); + + } else { + $self->pointed_hint('package-contains-timestamped-gzip', + $item->pointer,gmtime($gziptime)->datetime); + } + } + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Compressed/Lz.pm b/lib/Lintian/Check/Files/Compressed/Lz.pm new file mode 100644 index 0000000..defed97 --- /dev/null +++ b/lib/Lintian/Check/Files/Compressed/Lz.pm @@ -0,0 +1,77 @@ +# files/compressed/lz -- lintian check script -*- perl -*- + +# Copyright (C) 2020 Chris Lamb +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Compressed::Lz; + +use v5.20; +use warnings; +use utf8; + +use List::SomeUtils qw(first_value); + +use Lintian::IPC::Run3 qw(safe_qx); +use Lintian::Util qw(locate_executable); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has lzip_command => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $command = first_value { locate_executable($_) } qw(lzip clzip); + + return $command; + } +); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + my $command = $self->lzip_command; + return + unless length $command; + + if ($item->name =~ /\.lz$/si) { + + safe_qx($command, '--test', $item->unpacked_path); + + $self->pointed_hint('broken-lz', $item->pointer) + if $?; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Compressed/Lzma.pm b/lib/Lintian/Check/Files/Compressed/Lzma.pm new file mode 100644 index 0000000..2f49853 --- /dev/null +++ b/lib/Lintian/Check/Files/Compressed/Lzma.pm @@ -0,0 +1,57 @@ +# files/compressed/lzma -- lintian check script -*- perl -*- + +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Compressed::Lzma; + +use v5.20; +use warnings; +use utf8; + +use Lintian::IPC::Run3 qw(safe_qx); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + if ($item->name =~ /\.lzma$/si) { + + safe_qx('lzma', '--test', $item->unpacked_path); + + $self->pointed_hint('broken-lzma', $item->pointer) + if $?; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Compressed/Lzo.pm b/lib/Lintian/Check/Files/Compressed/Lzo.pm new file mode 100644 index 0000000..5e6cdca --- /dev/null +++ b/lib/Lintian/Check/Files/Compressed/Lzo.pm @@ -0,0 +1,57 @@ +# files/compressed/lzo -- lintian check script -*- perl -*- + +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Compressed::Lzo; + +use v5.20; +use warnings; +use utf8; + +use Lintian::IPC::Run3 qw(safe_qx); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + if ($item->name =~ /\.lzo$/si) { + + safe_qx('lzop', '--test', $item->unpacked_path); + + $self->pointed_hint('broken-lzo', $item->pointer) + if $?; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Compressed/Xz.pm b/lib/Lintian/Check/Files/Compressed/Xz.pm new file mode 100644 index 0000000..6f3c6a0 --- /dev/null +++ b/lib/Lintian/Check/Files/Compressed/Xz.pm @@ -0,0 +1,57 @@ +# files/compressed/xz -- lintian check script -*- perl -*- + +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Compressed::Xz; + +use v5.20; +use warnings; +use utf8; + +use Lintian::IPC::Run3 qw(safe_qx); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + if ($item->name =~ /\.xz$/si) { + + safe_qx('xz', '--test', $item->unpacked_path); + + $self->pointed_hint('broken-xz', $item->pointer) + if $?; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Compressed/Zip.pm b/lib/Lintian/Check/Files/Compressed/Zip.pm new file mode 100644 index 0000000..68b9395 --- /dev/null +++ b/lib/Lintian/Check/Files/Compressed/Zip.pm @@ -0,0 +1,62 @@ +# files/compressed/zip -- lintian check script -*- perl -*- + +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Compressed::Zip; + +use v5.20; +use warnings; +use utf8; + +use Lintian::IPC::Run3 qw(safe_qx); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + if ($item->name =~ /\.zip$/si) { + + # maybe rewrite with Archive::Zip + + # may prompt for password with -t; piping yes '' does not work + safe_qx('unzip', '-l', $item->unpacked_path); + + $self->pointed_hint('broken-zip', $item->pointer) + if $?; + + # should issue a tag for encrypted members, see Bug#935292 + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/ConfigScripts.pm b/lib/Lintian/Check/Files/ConfigScripts.pm new file mode 100644 index 0000000..b5df56c --- /dev/null +++ b/lib/Lintian/Check/Files/ConfigScripts.pm @@ -0,0 +1,108 @@ +# files/config-scripts -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::ConfigScripts; + +use v5.20; +use warnings; +use utf8; + +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::SlidingWindow; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + my $architecture = $self->processable->fields->value('Architecture'); + my $multiarch = $self->processable->fields->value('Multi-Arch') || 'no'; + + # check old style config scripts + if ( $item->name =~ m{^usr/bin/} + && $item->name =~ m/-config$/ + && $item->is_script + && $item->is_regular_file) { + + # try to find some indication of + # config file (read only one block) + + open(my $fd, '<:raw', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $sfd = Lintian::SlidingWindow->new; + $sfd->handle($fd); + + my $block = $sfd->readwindow; + + # some common stuff found in config file + if ( + $block + && ( $block =~ / flag /msx + || $block =~ m{ /include/ }msx + || $block =~ / pkg-config /msx) + ) { + + $self->pointed_hint('old-style-config-script', $item->pointer); + + # could be ok but only if multi-arch: no + if ($multiarch ne 'no' || $architecture eq 'all') { + + # check multi-arch path + my $DEB_HOST_MULTIARCH + = $self->data->architectures->deb_host_multiarch; + for my $madir (values %{$DEB_HOST_MULTIARCH}) { + + next + unless $block =~ m{\W\Q$madir\E(\W|$)}xms; + + # allow files to begin with triplet if it matches arch + next + if $item->basename =~ m{^\Q$madir\E}xms; + + my $tag_name = 'old-style-config-script-multiarch-path'; + $tag_name .= '-arch-all' + if $architecture eq 'all'; + + $self->pointed_hint($tag_name, $item->pointer, + 'full text contains architecture specific dir',$madir); + + last; + } + } + } + + close $fd; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Contents.pm b/lib/Lintian/Check/Files/Contents.pm new file mode 100644 index 0000000..472c419 --- /dev/null +++ b/lib/Lintian/Check/Files/Contents.pm @@ -0,0 +1,150 @@ +# files/contents -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Contents; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(any); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; +const my $SLASH => q{/}; +const my $ARROW => q{ -> }; + +my $SENSIBLE_REGEX + = qr{(?<!-)(?:select-editor|sensible-(?:browser|editor|pager))\b}; + +# with this Moo default, maintainer scripts are also checked +has switched_locations => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my @files + = grep { $_->is_file } @{$self->processable->installed->sorted_list}; + + my @commands = grep { $_->name =~ m{^(?:usr/)?s?bin/} } @files; + + my %switched_locations; + for my $command (@commands) { + + my @variants = map { $_ . $SLASH . $command->basename } + qw(bin sbin usr/bin usr/sbin); + my @confused = grep { $_ ne $command->name } @variants; + + $switched_locations{$_} = $command->name for @confused; + } + + return \%switched_locations; + } +); + +sub build_path { + my ($self) = @_; + + my $buildinfo = $self->group->buildinfo; + + return $EMPTY + unless $buildinfo; + + return $buildinfo->fields->value('Build-Path'); +} + +sub check_item { + my ($self, $item) = @_; + + return + unless $item->is_file; + + unless ($self->processable->relation('all')->satisfies('sensible-utils') + || $self->processable->source_name eq 'sensible-utils') { + + my $sensible = $item->mentions_in_operation($SENSIBLE_REGEX); + $self->pointed_hint('missing-depends-on-sensible-utils', + $item->pointer, $sensible) + if length $sensible; + } + + unless ($self->processable->fields->value('Section') eq 'debian-installer' + || any { $_ eq $self->processable->source_name } qw(base-files dpkg)) { + + $self->pointed_hint('uses-dpkg-database-directly', $item->pointer) + if length $item->mentions_in_operation(qr{/var/lib/dpkg}); + } + + # if we have a /usr/sbin/foo, check for references to /usr/bin/foo + my %switched_locations = %{$self->switched_locations}; + for my $confused (keys %switched_locations) { + + # may not work as expected on ELF due to ld's SHF_MERGE + # but word boundaries are also superior in strings spanning multiple commands + my $correct = $switched_locations{$confused}; + $self->pointed_hint('bin-sbin-mismatch', $item->pointer, + $confused . $ARROW . $correct) + if length $item->mentions_in_operation(qr{ \B / \Q$confused\E \b }x); + } + + if (length $self->build_path) { + my $escaped_path = quotemeta($self->build_path); + $self->pointed_hint('file-references-package-build-path', + $item->pointer) + if $item->bytes_match(qr{$escaped_path}); + } + + return; +} + +sub visit_installed_files { + my ($self, $item) = @_; + + $self->check_item($item); + + return; +} + +sub visit_control_files { + my ($self, $item) = @_; + + return + unless $item->is_maintainer_script; + + $self->check_item($item); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Contents/LineLength.pm b/lib/Lintian/Check/Files/Contents/LineLength.pm new file mode 100644 index 0000000..63f38ca --- /dev/null +++ b/lib/Lintian/Check/Files/Contents/LineLength.pm @@ -0,0 +1,140 @@ +# files/contents/line-length -- lintian check script -*- perl -*- + +# Copyright (C) 1999 Joey Hess +# Copyright (C) 2000 Sean 'Shaleh' Perry +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2007 Russ Allbery +# Copyright (C) 2013-2018 Bastien ROUCARIES +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Contents::LineLength; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::UtilsBy qw(max_by); +use Unicode::UTF8 qw(encode_utf8 decode_utf8 valid_utf8); + +const my $GREATER_THAN => q{>}; +const my $VERTICAL_BAR => q{|}; + +const my $VERY_LONG => 512; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +# an OR (|) regex of all compressed extension +has BINARY_FILE_EXTENSIONS_OR_ALL => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $BINARY_FILE_EXTENSIONS + = $self->data->load('files/binary-file-extensions',qr/\s+/); + my $COMPRESSED_FILE_EXTENSIONS + = $self->data->load('files/compressed-file-extensions',qr/\s+/); + + my $text = join( + $VERTICAL_BAR, + ( + map { quotemeta } $BINARY_FILE_EXTENSIONS->all, + $COMPRESSED_FILE_EXTENSIONS->all + ) + ); + + return qr/$text/i; + } +); + +sub visit_patched_files { + my ($self, $item) = @_; + + # Skip if no regular file + return + unless $item->is_regular_file; + + # Skip if file has a known binary, XML or JSON suffix. + my $pattern = $self->BINARY_FILE_EXTENSIONS_OR_ALL; + return + if $item->basename + =~ qr{ [.] ($pattern | xml | sgml | svg | jsonl?) \s* $}x; + + # Skip if we can't open it. + return + unless $item->is_open_ok; + + # Skip if file is a REUSE license (LICENSES/**.txt), which are + # canonically provided with long lines rather than being hard-wrapped. + return + if $item->name =~ m{^ LICENSES/ .* [.] txt $}x; + + # Skip if file is detected to be an image or JSON. + return + if $item->file_type =~ m{image|bitmap|JSON}; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my %line_lengths; + + my $position = 1; + while (my $line = <$fd>) { + # Skip SQL insert and select statements + next if ($line =~ /^(INSERT|SELECT)\s/i + and $item->basename =~ /sql/i); + + # count codepoints, if possible + $line = decode_utf8($line) + if valid_utf8($line); + + $line_lengths{$position} = length $line; + + } continue { + ++$position; + } + + close $fd; + + my $longest = max_by { $line_lengths{$_} } keys %line_lengths; + + return + unless defined $longest; + + my $pointer = $item->pointer($longest); + + $self->pointed_hint('very-long-line-length-in-source-file', + $pointer, $line_lengths{$longest}, $GREATER_THAN, $VERY_LONG) + if $line_lengths{$longest} > $VERY_LONG; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Date.pm b/lib/Lintian/Check/Files/Date.pm new file mode 100644 index 0000000..3b1f479 --- /dev/null +++ b/lib/Lintian/Check/Files/Date.pm @@ -0,0 +1,66 @@ +# files/date -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Date; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +# value from dak CVS: Dinstall::PastCutOffYear +const my $DINSTALL_CUTOFF_YEAR => 1975; + +has ALLOWED_ANCIENT_FILES => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return $self->data->load('files/allowed-ancient-files'); + } +); + +sub visit_installed_files { + my ($self, $item) = @_; + + my ($year) = ($item->date =~ /^(\d{4})/); + + $self->pointed_hint('package-contains-ancient-file', + $item->pointer, $item->date) + if $year <= $DINSTALL_CUTOFF_YEAR + && !$self->ALLOWED_ANCIENT_FILES->matches_any($item->name); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Debug.pm b/lib/Lintian/Check/Files/Debug.pm new file mode 100644 index 0000000..9eead27 --- /dev/null +++ b/lib/Lintian/Check/Files/Debug.pm @@ -0,0 +1,55 @@ +# files/debug -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Debug; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has warned_already => (is => 'rw', default => 0); + +sub visit_installed_files { + my ($self, $item) = @_; + + if ($item->name =~ m{^usr/lib/debug/\S}) { + + $self->pointed_hint('debug-suffix-not-dbg', $item->pointer) + if !$self->processable->is_debug_package + && !$self->warned_already; + + $self->warned_already(1); + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/DebugPackages.pm b/lib/Lintian/Check/Files/DebugPackages.pm new file mode 100644 index 0000000..7f83816 --- /dev/null +++ b/lib/Lintian/Check/Files/DebugPackages.pm @@ -0,0 +1,50 @@ +# files/debug-packages -- lintian check script -*- perl -*- + +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::DebugPackages; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + $self->pointed_hint('non-debug-file-in-debug-package', $item->pointer) + if $item->is_file + && $item->name !~ /\.debug$/ + && $self->processable->is_debug_package + && $self->processable->is_auto_generated; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Desktop.pm b/lib/Lintian/Check/Files/Desktop.pm new file mode 100644 index 0000000..fca3006 --- /dev/null +++ b/lib/Lintian/Check/Files/Desktop.pm @@ -0,0 +1,57 @@ +# files/desktop -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Desktop; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + # .desktop files + # People have placed them everywhere, but nowadays the + # consensus seems to be to stick to the fd.org standard + # drafts, which says that .desktop files intended for + # menus should be placed in $XDG_DATA_DIRS/applications. + # The default for $XDG_DATA_DIRS is + # /usr/local/share/:/usr/share/, according to the + # basedir-spec on fd.org. As distributor, we should only + # allow /usr/share. + + $self->pointed_hint('desktop-file-in-wrong-dir', $item->pointer) + if $item->name =~ m{^usr/share/gnome/apps/.*\.desktop$}; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Duplicates.pm b/lib/Lintian/Check/Files/Duplicates.pm new file mode 100644 index 0000000..b1dc809 --- /dev/null +++ b/lib/Lintian/Check/Files/Duplicates.pm @@ -0,0 +1,88 @@ +# files/duplicates -- lintian check script -*- perl -*- + +# Copyright (C) 2011 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Duplicates; + +use v5.20; +use warnings; +use utf8; + +use List::SomeUtils qw(any); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has md5map => (is => 'rw', default => sub{ {} }); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_regular_file; + + # Ignore empty files; in some cases (e.g. python) a file is + # required even if it is empty and we are never looking at a + # substantial gain in such a case. Also see #632789 + return + unless $item->size; + + my $calculated = $item->md5sum; + return + unless defined $calculated; + + return + unless $item->name =~ m{\A usr/share/doc/}xsm; + + $self->md5map->{$calculated} //= []; + + push(@{$self->md5map->{$calculated}}, $item); + + return; +} + +sub installable { + my ($self) = @_; + + for my $md5 (keys %{$self->md5map}){ + my @files = @{ $self->md5map->{$md5} }; + + next + if scalar @files < 2; + + if (any { m/changelog/i} @files) { + $self->hint('duplicate-changelog-files', (sort @files)); + + } else { + $self->hint('duplicate-files', (sort @files)); + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/EmptyDirectories.pm b/lib/Lintian/Check/Files/EmptyDirectories.pm new file mode 100644 index 0000000..52079cb --- /dev/null +++ b/lib/Lintian/Check/Files/EmptyDirectories.pm @@ -0,0 +1,67 @@ +# files/empty-directories -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::EmptyDirectories; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_dir; + + # skip base-files, which is a very special case. + return + if $self->processable->name eq 'base-files'; + + # ignore /var, which may hold dynamic data packages create, and /etc, + # which may hold configuration files generated by maintainer scripts + return + if $item->name =~ m{^var/} || $item->name =~ m{^etc/}; + + # Empty Perl directories are an ExtUtils::MakeMaker artifact that + # will be fixed in Perl 5.10, and people can cause more problems + # by trying to fix it, so just ignore them. + return + if $item->name =~ m{^usr/lib/(?:[^/]+/)?perl5/$} + || $item->name eq 'usr/share/perl5/'; + + # warn about empty directories + $self->pointed_hint('package-contains-empty-directory', $item->pointer) + if scalar $item->children == 0; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/EmptyPackage.pm b/lib/Lintian/Check/Files/EmptyPackage.pm new file mode 100644 index 0000000..5b23846 --- /dev/null +++ b/lib/Lintian/Check/Files/EmptyPackage.pm @@ -0,0 +1,159 @@ +# files/empty-package -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2019 Chris Lamb <lamby@debian.org> +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::EmptyPackage; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +# Common files stored in /usr/share/doc/$pkg that aren't sufficient to +# consider the package non-empty. +has STANDARD_FILES => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return $self->data->load('files/standard-files'); + } +); + +has is_empty => (is => 'rw', default => 1); +has is_dummy => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + # check if package is empty + return 1 + if $self->processable->is_transitional + || $self->processable->is_meta_package; + + return 0; + } +); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $self->is_empty; + + return + if $self->is_dummy; + + # ignore directories + return + if $item->is_dir; + + my $pkg = $self->processable->name; + my $ppkg = quotemeta($self->processable->name); + + # skip if file is outside /usr/share/doc/$pkg directory + if ($item->name !~ m{^usr/share/doc/\Q$pkg\E}) { + + # - except if it is a lintian override. + return + if $item->name =~ m{\A + # Except for: + usr/share/ (?: + # lintian overrides + lintian/overrides/$ppkg(?:\.gz)? + # reportbug scripts/utilities + | bug/$ppkg(?:/(?:control|presubj|script))? + )\Z}xsm; + + $self->is_empty(0); + + return; + } + + # skip if /usr/share/doc/$pkg has files in a subdirectory + if ($item->name =~ m{^usr/share/doc/\Q$pkg\E/[^/]+/}) { + + $self->is_empty(0); + + return; + } + + # skip /usr/share/doc/$pkg symlinks. + return + if $item->name eq "usr/share/doc/$pkg"; + + # For files directly in /usr/share/doc/$pkg, if the + # file isn't one of the uninteresting ones, the + # package isn't empty. + return + if $self->STANDARD_FILES->recognizes($item->basename); + + # ignore all READMEs + return + if $item->basename =~ m/^README(?:\..*)?$/i; + + my $pkg_arch = $self->processable->architecture; + unless ($pkg_arch eq 'all') { + + # binNMU changelog (debhelper) + return + if $item->basename eq "changelog.Debian.${pkg_arch}.gz"; + } + + # buildinfo file (dh-buildinfo) + return + if $item->basename eq "buildinfo_${pkg_arch}.gz"; + + $self->is_empty(0); + + return; +} + +sub installable { + my ($self) = @_; + + return + if $self->is_dummy; + + if ($self->is_empty) { + + $self->hint('empty-binary-package') + if $self->processable->type eq 'binary'; + + $self->hint('empty-udeb-package') + if $self->processable->type eq 'udeb'; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Encoding.pm b/lib/Lintian/Check/Files/Encoding.pm new file mode 100644 index 0000000..f175401 --- /dev/null +++ b/lib/Lintian/Check/Files/Encoding.pm @@ -0,0 +1,125 @@ +# files/encoding -- lintian check script -*- perl -*- + +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Encoding; + +use v5.20; +use warnings; +use utf8; + +use IO::Uncompress::Gunzip qw(gunzip $GunzipError); +use Unicode::UTF8 qw(valid_utf8 encode_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->name =~ m{^debian/}; + + return + unless $item->is_file; + + return + unless $item->file_type =~ /text$/; + + if ($item->name =~ m{^debian/patches/}) { + + my $bytes = $item->bytes; + return + unless length $bytes; + + my ($header)= split(/^---/m, $bytes, 2); + + $self->pointed_hint('national-encoding', $item->pointer,'DEP-3 header') + unless valid_utf8($header); + + } else { + $self->pointed_hint('national-encoding', $item->pointer) + unless $item->is_valid_utf8; + } + + return; +} + +sub visit_control_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + return + unless $item->file_type =~ /text$/ || $item->is_script; + + $self->pointed_hint('national-encoding', $item->pointer) + unless $item->is_valid_utf8; + + return; +} + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + # this checks debs; most other nat'l encoding tags are for source + # Bug#796170 also suggests limiting paths and including gzip files + + # return + # unless $item->name =~ m{^(?:usr/)?s?bin/} + # || $item->name =~ m{^usr/games/} + # || $item->name =~ m{\.(?:p[myl]|php|rb|tcl|sh|txt)(?:\.gz)?$} + # || $item->name =~ m{^usr/share/doc}; + + if ($item->file_type =~ /text$/) { + + $self->pointed_hint('national-encoding', $item->pointer) + unless $item->is_valid_utf8; + } + + # for man pages also look at compressed files + if ( $item->name =~ m{^usr/share/man/} + && $item->file_type =~ /gzip compressed/) { + + my $bytes; + + my $path = $item->unpacked_path; + gunzip($path => \$bytes) + or die encode_utf8("gunzip $path failed: $GunzipError"); + + $self->pointed_hint('national-encoding', $item->pointer) + unless valid_utf8($bytes); + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Generated.pm b/lib/Lintian/Check/Files/Generated.pm new file mode 100644 index 0000000..35c88d5 --- /dev/null +++ b/lib/Lintian/Check/Files/Generated.pm @@ -0,0 +1,83 @@ +# files/generated -- lintian check script -*- perl -*- + +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Generated; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +const my $DOUBLE_QUOTE => q{"}; + +with 'Lintian::Check'; + +sub visit_patched_files { + my ($self, $item) = @_; + + # check all patched source files except the Debian patches + return + if $item->name =~ m{^ debian/patches/ }x; + + return + unless $item->is_open_ok; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $position = 1; + while (my $line = <$fd>) { + + if ($line + =~m{ ( This [ ] file [ ] (?: is | was ) [ ] autogenerated ) }xi + || $line + =~ m{ ( DO [ ] NOT [ ] EDIT [ ] (?: THIS [ ] FILE [ ] )? BY [ ] HAND ) }xi + ) { + + my $marker = $1; + + $self->pointed_hint( + 'generated-file', + $item->pointer($position), + $DOUBLE_QUOTE . $marker . $DOUBLE_QUOTE + ); + } + + } continue { + ++$position; + } + + close $fd; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/HardLinks.pm b/lib/Lintian/Check/Files/HardLinks.pm new file mode 100644 index 0000000..f115897 --- /dev/null +++ b/lib/Lintian/Check/Files/HardLinks.pm @@ -0,0 +1,57 @@ +# files/hard-links -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::HardLinks; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_hardlink; + + my $target_dir = $item->link; + $target_dir =~ s{[^/]*$}{}; + + # link always sorts after target; hard links are calibrated + $self->pointed_hint('package-contains-hardlink', $item->pointer, + 'pointing to:', $item->link) + if $item->name =~ m{^etc/} + || $item->link =~ m{^etc/} + || $item->name !~ m{^\Q$target_dir\E[^/]*$}; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Hierarchy/Links.pm b/lib/Lintian/Check/Files/Hierarchy/Links.pm new file mode 100644 index 0000000..2402b5d --- /dev/null +++ b/lib/Lintian/Check/Files/Hierarchy/Links.pm @@ -0,0 +1,83 @@ +# files/symbolic-links/broken -- lintian check script -*- perl -*- +# +# Copyright (C) 2020 Felix Lechner +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Hierarchy::Links; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use File::Basename; +use List::SomeUtils qw(any first_value); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; +const my $SLASH => q{/}; +const my $ARROW => q{ -> }; + +sub visit_installed_files { + my ($self, $item) = @_; + + # symbolic links only + return + unless $item->is_symlink; + + my $target = $item->link_normalized; + return + unless defined $target; + + my @ldconfig_folders = @{$self->data->architectures->ldconfig_folders}; + + my $origin_dirname= first_value { $item->dirname eq $_ } @ldconfig_folders; + + # look only at links originating in common ld.so load paths + return + unless length $origin_dirname; + + my $target_dirname + = first_value { (dirname($target) . $SLASH) eq $_ } @ldconfig_folders; + $target_dirname //= $EMPTY; + + # no subfolders + $self->pointed_hint('ldconfig-escape', $item->pointer, $target) + unless length $target_dirname; + + my @multiarch= values %{$self->data->architectures->deb_host_multiarch}; + + $self->pointed_hint('architecture-escape', $item->pointer, $target) + if (any { basename($origin_dirname) eq $_ } @multiarch) + && (any { $target_dirname eq "$_/" } qw{lib usr/lib usr/local/lib}); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Hierarchy/MergedUsr.pm b/lib/Lintian/Check/Files/Hierarchy/MergedUsr.pm new file mode 100644 index 0000000..ebd0d1c --- /dev/null +++ b/lib/Lintian/Check/Files/Hierarchy/MergedUsr.pm @@ -0,0 +1,48 @@ +# files/hierarchy/merged-usr -- lintian check script -*- perl -*- +# +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Hierarchy::MergedUsr; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + $self->pointed_hint('unmerged-usr', $item->pointer) + if $item->is_file + && $item->name =~ m{^(?:lib|bin|sbin)}; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Hierarchy/PathSegments.pm b/lib/Lintian/Check/Files/Hierarchy/PathSegments.pm new file mode 100644 index 0000000..b9e5535 --- /dev/null +++ b/lib/Lintian/Check/Files/Hierarchy/PathSegments.pm @@ -0,0 +1,57 @@ +# files/hierarchy/path-segments -- lintian check script -*- perl -*- +# +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Hierarchy::PathSegments; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_dir; + + my @segments = split(m{/}, $item->name); + return + unless @segments; + + my $final = $segments[-1]; + my $count = scalar grep { $final eq $_ } @segments; + + $self->pointed_hint('repeated-path-segment', $item->pointer, $final) + if $count > 1; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Hierarchy/Standard.pm b/lib/Lintian/Check/Files/Hierarchy/Standard.pm new file mode 100644 index 0000000..e00955b --- /dev/null +++ b/lib/Lintian/Check/Files/Hierarchy/Standard.pm @@ -0,0 +1,262 @@ +# files/hierarchy/standard -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Hierarchy::Standard; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub _is_tmp_path { + my ($path) = @_; + + return 1 + if $path =~ m{^tmp/.} + || $path =~ m{^(?:var|usr)/tmp/.} + || $path =~ m{^/dev/shm/}; + + return 0; +} + +sub visit_installed_files { + my ($self, $item) = @_; + + if ($item->name =~ m{^etc/opt/.}) { + + # /etc/opt + $self->pointed_hint('dir-or-file-in-etc-opt', $item->pointer); + + } elsif ($item->name =~ m{^usr/local/\S+}) { + # /usr/local + if ($item->is_dir) { + $self->pointed_hint('dir-in-usr-local', $item->pointer); + } else { + $self->pointed_hint('file-in-usr-local', $item->pointer); + } + + } elsif ($item->name =~ m{^usr/share/[^/]+$}) { + # /usr/share + $self->pointed_hint('file-directly-in-usr-share', $item->pointer) + if $item->is_file; + + } elsif ($item->name =~ m{^usr/bin/}) { + # /usr/bin + $self->pointed_hint('subdir-in-usr-bin', $item->pointer) + if $item->is_dir + && $item->name =~ m{^usr/bin/.} + && $item->name !~ m{^usr/bin/(?:X11|mh)/}; + + } elsif ($self->processable->type ne 'udeb' + && $item->name =~ m{^usr/[^/]+/$}) { + + # /usr subdirs + if ($item->name=~ m{^usr/(?:dict|doc|etc|info|man|adm|preserve)/}) { + # FSSTND dirs + $self->pointed_hint('FSSTND-dir-in-usr', $item->pointer); + } elsif ( + $item->name !~ m{^usr/(?:X11R6|X386| + bin|games|include| + lib| + local|sbin|share| + src|spool|tmp)/}x + ) { + # FHS dirs + if ($item->name =~ m{^usr/lib(?<libsuffix>64|x?32)/}) { + my $libsuffix = $+{libsuffix}; + # eglibc exception is due to FHS. Other are + # transitional, waiting for full + # implementation of multi-arch. Note that we + # allow (e.g.) "lib64" packages to still use + # these dirs, since their use appears to be by + # intention. + unless ($self->processable->source_name =~ m/^e?glibc$/ + or $self->processable->name =~ m/^lib$libsuffix/) { + + $self->pointed_hint('non-multi-arch-lib-dir', + $item->pointer); + } + } else { + # see Bug#834607 + $self->pointed_hint('non-standard-dir-in-usr', $item->pointer) + unless $item->name =~ m{^usr/libexec/}; + } + + } + + # unless $item =~ m,^usr/[^/]+-linuxlibc1/,; was tied + # into print above... + # Make an exception for the altdev dirs, which will go + # away at some point and are not worth moving. + } + + # /var subdirs + elsif ($self->processable->type ne 'udeb' + && $item->name =~ m{^var/[^/]+/$}) { + + if ($item->name =~ m{^var/(?:adm|catman|named|nis|preserve)/}) { + # FSSTND dirs + $self->pointed_hint('FSSTND-dir-in-var', $item->pointer); + + } elsif ($self->processable->name eq 'base-files' + && $item->name =~ m{^var/(?:backups|local)/}) { + # base-files is special + # ignore + + } elsif ( + $item->name !~ m{\A var/ + (?: account|lib|cache|crash|games + |lock|log|opt|run|spool|state + |tmp|www|yp)/ + }xsm + ) { + # FHS dirs with exception in Debian policy + $self->pointed_hint('non-standard-dir-in-var', $item->pointer); + } + + } elsif ($self->processable->type ne 'udeb' + && $item->name =~ m{^var/lib/games/.}) { + $self->pointed_hint('non-standard-dir-in-var', $item->pointer); + + } elsif ($self->processable->type ne 'udeb' + && $item->name =~ m{^var/lock/.}) { + # /var/lock + $self->pointed_hint('dir-or-file-in-var-lock', $item->pointer); + + } elsif ($self->processable->type ne 'udeb' + && $item->name =~ m{^var/run/.}) { + # /var/run + $self->pointed_hint('dir-or-file-in-var-run', $item->pointer); + + } elsif ($self->processable->type ne 'udeb' && $item->name =~ m{^run/.}) { + $self->pointed_hint('dir-or-file-in-run', $item->pointer); + + } elsif ($item->name =~ m{^var/www/\S+}) { + # /var/www + # Packages are allowed to create /var/www since it's + # historically been the default document root, but they + # shouldn't be installing stuff under that directory. + $self->pointed_hint('dir-or-file-in-var-www', $item->pointer); + + } elsif ($item->name =~ m{^opt/.}) { + # /opt + $self->pointed_hint('dir-or-file-in-opt', $item->pointer); + + } elsif ($item->name =~ m{^hurd/}) { + return; + + } elsif ($item->name =~ m{^servers/}) { + return; + + } elsif ($item->name =~ m{^home/.}) { + # /home + $self->pointed_hint('dir-or-file-in-home', $item->pointer); + + } elsif ($item->name =~ m{^root/.}) { + $self->pointed_hint('dir-or-file-in-home', $item->pointer); + + } elsif (_is_tmp_path($item->name)) { + # /tmp, /var/tmp, /usr/tmp + $self->pointed_hint('dir-or-file-in-tmp', $item->pointer); + + } elsif ($item->name =~ m{^mnt/.}) { + # /mnt + $self->pointed_hint('dir-or-file-in-mnt', $item->pointer); + + } elsif ($item->name =~ m{^bin/}) { + # /bin + $self->pointed_hint('subdir-in-bin', $item->pointer) + if $item->is_dir && $item->name =~ m{^bin/.}; + + } elsif ($item->name =~ m{^srv/.}) { + # /srv + $self->pointed_hint('dir-or-file-in-srv', $item->pointer); + + }elsif ( + $item->name =~ m{^[^/]+/$} + && $item->name !~ m{\A (?: + bin|boot|dev|etc|home|lib + |mnt|opt|root|run|sbin|srv|sys + |tmp|usr|var) / + }xsm + ) { + # FHS directory? + + # Make an exception for the base-files package here and + # other similar packages because they install a slew of + # top-level directories for setting up the base system. + # (Specifically, /cdrom, /floppy, /initrd, and /proc are + # not mentioned in the FHS). + if ($item->name =~ m{^lib(?<libsuffix>64|x?32)/}) { + my $libsuffix = $+{libsuffix}; + + # see comments for ^usr/lib(?'libsuffix'64|x?32) + $self->pointed_hint('non-multi-arch-lib-dir', $item->pointer) + unless $self->processable->source_name =~ m/^e?glibc$/ + || $self->processable->name =~ m/^lib$libsuffix/; + + } else { + $self->pointed_hint('non-standard-toplevel-dir', $item->pointer) + unless $self->processable->name eq 'base-files' + || $self->processable->name eq 'hurd' + || $self->processable->name eq 'hurd-udeb' + || $self->processable->name =~ /^rootskel(?:-bootfloppy)?/; + } + } + + # compatibility symlinks should not be used + $self->pointed_hint('use-of-compat-symlink', $item->pointer) + if $item->name =~ m{^usr/(?:spool|tmp)/} + || $item->name =~ m{^usr/(?:doc|bin)/X11/} + || $item->name =~ m{^var/adm/}; + + # any files + $self->pointed_hint('file-in-unusual-dir', $item->pointer) + unless $item->is_dir + || $self->processable->type eq 'udeb' + || $item->name =~ m{^usr/(?:bin|dict|doc|games| + include|info|lib(?:x?32|64)?| + man|sbin|share|src|X11R6)/}x + || $item->name =~ m{^lib(?:x?32|64)?/(?:modules/|libc5-compat/)?} + || $item->name =~ m{^var/(?:games|lib|www|named)/} + || $item->name =~ m{^(?:bin|boot|dev|etc|sbin)/} + # non-FHS, but still usual + || $item->name =~ m{^usr/[^/]+-linux[^/]*/} + || $item->name =~ m{^usr/libexec/} # FHS 3.0 / #834607 + || $item->name =~ m{^usr/iraf/} + # not allowed, but tested individually + || $item->name =~ m{\A (?: + build|home|mnt|opt|root|run|srv + |(?:(?:usr|var)/)?tmp)|var/www/}xsm; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/IeeeData.pm b/lib/Lintian/Check/Files/IeeeData.pm new file mode 100644 index 0000000..0c2ba68 --- /dev/null +++ b/lib/Lintian/Check/Files/IeeeData.pm @@ -0,0 +1,79 @@ +# files/ieee-data -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::IeeeData; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +const my $VERTICAL_BAR => q{|}; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +# an OR (|) regex of all compressed extension +has COMPRESS_FILE_EXTENSIONS_OR_ALL => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $COMPRESS_FILE_EXTENSIONS + = $self->data->load('files/compressed-file-extensions',qr/\s+/); + + my $text = join($VERTICAL_BAR, + map { quotemeta }$COMPRESS_FILE_EXTENSIONS->all); + + return qr/$text/; + } +); + +sub visit_installed_files { + my ($self, $item) = @_; + + my $regex = $self->COMPRESS_FILE_EXTENSIONS_OR_ALL; + + if ( $item->is_regular_file + && $item->name + =~ m{/(?:[^/]-)?(?:oui|iab)(?:\.(txt|idx|db))?(?:\.$regex)?\Z}x) { + + # see #785662 + if ($item->name =~ / oui /msx || $item->name =~ / iab /msx) { + + $self->pointed_hint('package-installs-ieee-data', $item->pointer) + unless $self->processable->source_name eq 'ieee-data'; + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Includes.pm b/lib/Lintian/Check/Files/Includes.pm new file mode 100644 index 0000000..ec10bb8 --- /dev/null +++ b/lib/Lintian/Check/Files/Includes.pm @@ -0,0 +1,69 @@ +# files/includes -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Includes; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw{any}; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +# case insensitive regular expressions for overly generic paths +const my @GENERIC_PATHS => ('^ util[s]? [.]h $'); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + my $consumed = $item->name; + return + unless $consumed =~ s{^usr/include/}{}; + + my @multiarch_folders + = values %{$self->data->architectures->deb_host_multiarch}; + + for my $tuple (@multiarch_folders) { + + last + if $consumed =~ s{^$tuple/}{}; + } + + $self->pointed_hint('header-has-overly-generic-name', $item->pointer) + if any { $consumed =~ m{ $_ }isx } @GENERIC_PATHS; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Init.pm b/lib/Lintian/Check/Files/Init.pm new file mode 100644 index 0000000..25ff77d --- /dev/null +++ b/lib/Lintian/Check/Files/Init.pm @@ -0,0 +1,79 @@ +# files/init -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Init; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(none); + +const my $NOT_EQUAL => q{!=}; + +const my $EXECUTABLE_PERMISSIONS => oct(755); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + # /etc/init + $self->pointed_hint('package-installs-deprecated-upstart-configuration', + $item->pointer) + if $item->name =~ m{^etc/init/\S}; + + # /etc/init.d + $self->pointed_hint( + 'non-standard-file-permissions-for-etc-init.d-script', + $item->pointer, + $item->octal_permissions, + $NOT_EQUAL, + sprintf('%04o', $EXECUTABLE_PERMISSIONS) + ) + if $item->name =~ m{^etc/init\.d/\S} + && $item->name !~ m{^etc/init\.d/(?:README|skeleton)$} + && $item->operm != $EXECUTABLE_PERMISSIONS + && $item->is_file; + + # /etc/rc.d && /etc/rc?.d + $self->pointed_hint('package-installs-into-etc-rc.d', $item->pointer) + if $item->name =~ m{^etc/rc(?:\d|S)?\.d/\S} + && (none { $self->processable->name eq $_ } qw(sysvinit file-rc)) + && $self->processable->type ne 'udeb'; + + # /etc/rc.boot + $self->pointed_hint('package-installs-into-etc-rc.boot', $item->pointer) + if $item->name =~ m{^etc/rc\.boot/\S}; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/LdSo.pm b/lib/Lintian/Check/Files/LdSo.pm new file mode 100644 index 0000000..2f0b9c1 --- /dev/null +++ b/lib/Lintian/Check/Files/LdSo.pm @@ -0,0 +1,48 @@ +# files/ld-so -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::LdSo; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + $self->pointed_hint('package-modifies-ld.so-search-path', $item->pointer) + if $item->name =~ m{^etc/ld\.so\.conf\.d/.+$} + && $self->processable->name !~ /^libc/; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Licenses.pm b/lib/Lintian/Check/Files/Licenses.pm new file mode 100644 index 0000000..5ca61e4 --- /dev/null +++ b/lib/Lintian/Check/Files/Licenses.pm @@ -0,0 +1,112 @@ +# files/licenses -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Licenses; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + # license files + if ( + $item->basename =~ m{ \A + # Look for commonly used names for license files + (?: copying | licen[cs]e | l?gpl | bsd | artistic ) + # ... possibly followed by a version + [v0-9._-]* + (?:\. .* )? \Z + }xsmi + # Ignore some common extensions for source or compiled + # extension files. There was at least one file named + # "license.el". These are probably license-displaying + # code, not license files. Also ignore executable files + # in general. This means we get false-negatives for + # licenses files marked executable, but these will trigger + # a warning about being executable. (See #608866) + # + # Another exception is made for .html and .php because + # preserving working links is more important than saving + # some bytes, and because a package had an HTML form for + # licenses called like that. Another exception is made + # for various picture formats since those are likely to + # just be simply pictures. + # + # DTD files are excluded at the request of the Mozilla + # suite maintainers. Zope products include license files + # for runtime display. underXXXlicense.docbook files are + # from KDE. + # + # Ignore extra license files in examples, since various + # package building software includes example packages with + # licenses. + && !$item->is_executable + && $item->name !~ m{ \. (?: + # Common "non-license" file extensions... + el|[ch]|cc|p[ylmc]|[hu]i|p_hi|html|php|rb|xpm + |png|jpe?g|gif|svg|dtd|mk|lisp|yml|rs|ogg|xbm + ) \Z}xsm + && $item->name !~ m{^usr/share/zope/Products/.*\.(?:dtml|pt|cpt)$} + && $item->name !~ m{/under\S+License\.docbook$} + && $item->name !~ m{^usr/share/doc/[^/]+/examples/} + # liblicense has a manpage called license + && $item->name !~ m{^usr/share/man/(?:[^/]+/)?man\d/} + # liblicense (again) + && $item->name !~ m{^usr/share/pyshared-data/} + # Rust crate unmodified upstream sources + && $item->name !~ m{^usr/share/cargo/registry/} + # Some GNOME/GTK software uses these to show the "license + # header". + && $item->name !~ m{ + ^usr/share/(?:gnome/)?help/[^/]+/[^/]+/license\.page$ + }x + # base-files (which is required to ship them) + && $item->name !~ m{^usr/share/common-licenses/[^/]+$} + && !length($item->link) + # Sphinx includes various license files + && $item->name !~ m{/_sources/license(?:\.rst)?\.txt$}i + ) { + + # okay, we cannot rule it out based on file name; but if + # it is an elf or a static library, we also skip it. (In + # case you hadn't guessed; liblicense) + + $self->pointed_hint('extra-license-file', $item->pointer) + unless $item->file_type =~ m/^[^,]*\bELF\b/ + || $item->file_type =~ m/\bcurrent ar archive\b/; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Locales.pm b/lib/Lintian/Check/Files/Locales.pm new file mode 100644 index 0000000..e645a83 --- /dev/null +++ b/lib/Lintian/Check/Files/Locales.pm @@ -0,0 +1,204 @@ +# files/locales -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2013 Niels Thykier <niels@thykier.net> +# Copyright (C) 2019 Adam D. Barratt <adam@adam-barratt.org.uk> +# Copyright (C) 2021 Felix Lechner +# +# Based in part on a shell script that was: +# Copyright (C) 2010 Raphael Geissert <atomo64@gmail.com> +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Locales; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use JSON::MaybeXS; +use List::SomeUtils qw(first_value); +use Path::Tiny; + +const my $EMPTY => q{}; + +const my $ARROW => q{->}; + +const my $RESERVED => $EMPTY; +const my $SPECIAL => q{S}; + +const my %CONFUSING_LANGUAGES => ( + # Albanian is sq, not al: + 'al' => 'sq', + # Chinese is zh, not cn: + 'cn' => 'zh', + # Czech is cs, not cz: + 'cz' => 'cs', + # Danish is da, not dk: + 'dk' => 'da', + # Greek is el, not gr: + 'gr' => 'el', + # Indonesian is id, not in: + 'in' => 'id', +); + +const my %CONFUSING_COUNTRIES => ( + # UK != GB + 'en_UK' => 'en_GB', +); +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has ISO639_3_by_alpha3 => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + local $ENV{LC_ALL} = 'C'; + + my $bytes = path('/usr/share/iso-codes/json/iso_639-3.json')->slurp; + my $json = decode_json($bytes); + + my %iso639_3; + for my $entry (@{$json->{'639-3'}}) { + + my $alpha_3 = $entry->{alpha_3}; + + $iso639_3{$alpha_3} = $entry; + } + + return \%iso639_3; + } +); + +has LOCALE_CODES => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + local $ENV{LC_ALL} = 'C'; + + my %CODES; + for my $entry (values %{$self->ISO639_3_by_alpha3}) { + + my $type = $entry->{type}; + + # https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=692548#10 + next + if $type eq $RESERVED || $type eq $SPECIAL; + + # also have two letters, ISO 639-1 + my $two_letters; + $two_letters = $entry->{alpha_2} + if exists $entry->{alpha_2}; + + $CODES{$two_letters} = $EMPTY + if length $two_letters; + + # three letters, ISO 639-2 + my $three_letters = $entry->{alpha_3}; + + # a value indicates that two letters are preferred + $CODES{$three_letters} = $two_letters || $EMPTY; + } + + return \%CODES; + } +); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_dir; + + return + unless $item->name =~ m{^ usr/share/locale/ ([^/]+) / $}x; + + my $folder = $1; + + # without encoding + my ($with_country) = split(m/[.@]/, $folder); + + # special exception + return + if $with_country eq 'l10n'; + + # without country code + my ($two_or_three, $country) = split(m/_/, $with_country); + + $country //= $EMPTY; + + return + unless length $two_or_three; + + # check some common language errors + if (exists $CONFUSING_LANGUAGES{$two_or_three}) { + + my $fixed = $folder; + $fixed =~ s{^ $two_or_three }{$CONFUSING_LANGUAGES{$two_or_three}}x; + + $self->pointed_hint('incorrect-locale-code', $item->pointer, $folder, + $ARROW,$fixed); + return; + } + + # check some common country errors + if (exists $CONFUSING_COUNTRIES{$with_country}) { + + my $fixed = $folder; + $fixed =~ s{^ $with_country }{$CONFUSING_COUNTRIES{$with_country}}x; + + $self->pointed_hint('incorrect-locale-code', $item->pointer, $folder, + $ARROW,$fixed); + return; + } + + # check known codes + if (exists $self->LOCALE_CODES->{$two_or_three}) { + + my $replacement = $self->LOCALE_CODES->{$two_or_three}; + return + unless length $replacement; + + # a value indicates that two letters are preferred + my $fixed = $folder; + $fixed =~ s{^ $two_or_three }{$replacement}x; + + $self->pointed_hint('incorrect-locale-code', $item->pointer, $folder, + $ARROW,$fixed); + + return; + } + + $self->pointed_hint('unknown-locale-code', $item->pointer, $folder); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Missing.pm b/lib/Lintian/Check/Files/Missing.pm new file mode 100644 index 0000000..4c6eda5 --- /dev/null +++ b/lib/Lintian/Check/Files/Missing.pm @@ -0,0 +1,50 @@ +# files/missing -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Missing; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + if ( $item->is_dir + && $item->faux) { + + $self->pointed_hint('missing-intermediate-directory', $item->pointer); + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/MultiArch.pm b/lib/Lintian/Check/Files/MultiArch.pm new file mode 100644 index 0000000..5d6a2f0 --- /dev/null +++ b/lib/Lintian/Check/Files/MultiArch.pm @@ -0,0 +1,111 @@ +# files/multi-arch -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::MultiArch; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has TRIPLETS => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $DEB_HOST_MULTIARCH= $self->data->architectures->deb_host_multiarch; + my %triplets = map { $DEB_HOST_MULTIARCH->{$_} => $_ } + keys %{$DEB_HOST_MULTIARCH}; + + return \%triplets; + } +); + +my %PATH_DIRECTORIES = map { $_ => 1 } qw( + bin/ sbin/ usr/bin/ usr/sbin/ usr/games/ ); + +has has_public_executable => (is => 'rw', default => 0); +has has_public_shared_library => (is => 'rw', default => 0); + +sub visit_installed_files { + my ($self, $item) = @_; + + my $architecture = $self->processable->fields->value('Architecture'); + my $multiarch = $self->processable->fields->value('Multi-Arch') || 'no'; + + my $DEB_HOST_MULTIARCH= $self->data->architectures->deb_host_multiarch; + my $multiarch_dir = $DEB_HOST_MULTIARCH->{$architecture}; + + if ( !$item->is_dir + && defined $multiarch_dir + && $multiarch eq 'foreign' + && $item->name =~ m{^usr/lib/\Q$multiarch_dir\E/(.*)$}) { + + my $tail = $1; + + $self->pointed_hint('multiarch-foreign-cmake-file', $item->pointer) + if $tail =~ m{^cmake/.+\.cmake$}; + + $self->pointed_hint('multiarch-foreign-pkgconfig', $item->pointer) + if $tail =~ m{^pkgconfig/[^/]+\.pc$}; + + $self->pointed_hint('multiarch-foreign-static-library', $item->pointer) + if $tail =~ m{^lib[^/]+\.a$}; + } + + if (exists($PATH_DIRECTORIES{$item->dirname})) { + $self->has_public_executable(1); + } + + if ($item->name =~ m{^(?:usr/)?lib/(?:([^/]+)/)?lib[^/]*\.so$}) { + $self->has_public_shared_library(1) + if (!defined($1) || exists $self->TRIPLETS->{$1}); + } + + return; +} + +sub installable { + my ($self) = @_; + + my $architecture = $self->processable->fields->value('Architecture'); + my $multiarch = $self->processable->fields->value('Multi-Arch') || 'no'; + + $self->hint('multiarch-foreign-shared-library') + if $architecture ne 'all' + and $multiarch eq 'foreign' + and $self->has_public_shared_library + and not $self->has_public_executable; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Names.pm b/lib/Lintian/Check/Files/Names.pm new file mode 100644 index 0000000..a6b022c --- /dev/null +++ b/lib/Lintian/Check/Files/Names.pm @@ -0,0 +1,163 @@ +# files/names -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Names; + +use v5.20; +use warnings; +use utf8; + +use List::Compare; +use Unicode::UTF8 qw(valid_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +my %PATH_DIRECTORIES = map { $_ => 1 } qw( + bin/ sbin/ usr/bin/ usr/sbin/ usr/games/ ); + +sub visit_installed_files { + my ($self, $item) = @_; + + # unusual characters + $self->pointed_hint('file-name-ends-in-whitespace', $item->pointer) + if $item->name =~ /\s+\z/; + + $self->pointed_hint('star-file', $item->pointer) + if $item->name =~ m{/\*\z}; + + $self->pointed_hint('hyphen-file', $item->pointer) + if $item->name =~ m{/-\z}; + + $self->pointed_hint('file-name-contains-wildcard-character',$item->pointer) + if $item->name =~ m{[*?]}; + + $self->pointed_hint('package-contains-compiled-glib-schema',$item->pointer) + if $item->name + =~ m{^ usr/share/ glib-[^/]+ /schemas/ gschemas[.]compiled $}x; + + $self->pointed_hint('package-contains-file-in-etc-skel', $item->pointer) + if $item->dirname =~ m{^etc/skel/} + && $item->basename + !~ m{^ [.]bashrc | [.]bash_logout | [.]m?kshrc | [.]profile $}x; + + $self->pointed_hint('package-contains-file-in-usr-share-hal', + $item->pointer) + if $item->dirname =~ m{^usr/share/hal/}; + + $self->pointed_hint('package-contains-icon-cache-in-generic-dir', + $item->pointer) + if $item->name eq 'usr/share/icons/hicolor/icon-theme.cache'; + + $self->pointed_hint('package-contains-python-dot-directory',$item->pointer) + if $item->dirname + =~ m{^ usr/lib/python[^/]+ / (?:dist|site)-packages / }x + && $item->name =~ m{ / [.][^/]+ / }x; + + $self->pointed_hint('package-contains-python-coverage-file',$item->pointer) + if $item->basename eq '.coverage'; + + $self->pointed_hint('package-contains-python-doctree-file', $item->pointer) + if $item->basename =~ m{ [.]doctree (?:[.]gz)? $}x; + + $self->pointed_hint( + 'package-contains-python-header-in-incorrect-directory', + $item->pointer) + if $item->dirname =~ m{^ usr/include/python3[.][01234567]/ }x + && $item->name =~ m{ [.]h $}x; + + $self->pointed_hint('package-contains-python-hypothesis-example', + $item->pointer) + if $item->dirname =~ m{ /[.]hypothesis/examples/ }x; + + $self->pointed_hint('package-contains-python-tests-in-global-namespace', + $item->pointer) + if $item->name + =~ m{^ usr/lib/python[^\/]+ / (?:dist|site)-packages / test_.+[.]py $}x; + + $self->pointed_hint('package-contains-sass-cache-directory',$item->pointer) + if $item->name =~ m{ / [.]sass-cache / }x; + + $self->pointed_hint('package-contains-eslint-config-file', $item->pointer) + if $item->basename =~ m{^ [.]eslintrc }x; + + $self->pointed_hint('package-contains-npm-ignore-file', $item->pointer) + if $item->basename eq '.npmignore'; + + if (exists($PATH_DIRECTORIES{$item->dirname})) { + + $self->pointed_hint('file-name-in-PATH-is-not-ASCII', $item->pointer) + if $item->basename !~ m{\A [[:ascii:]]++ \Z}xsm; + + $self->pointed_hint('zero-byte-executable-in-path', $item->pointer) + if $item->is_regular_file + and $item->is_executable + and $item->size == 0; + + } elsif (!valid_utf8($item->name)) { + $self->pointed_hint('shipped-file-without-utf8-name', $item->pointer); + } + + return; +} + +sub source { + my ($self) = @_; + + unless ($self->processable->native) { + + my @orig_non_utf8 = grep { !valid_utf8($_->name) } + @{$self->processable->orig->sorted_list}; + + $self->pointed_hint('upstream-file-without-utf8-name', $_->pointer) + for @orig_non_utf8; + } + + my @patched = map { $_->name } @{$self->processable->patched->sorted_list}; + my @orig = map { $_->name } @{$self->processable->orig->sorted_list}; + + my $lc= List::Compare->new(\@patched, \@orig); + my @created = $lc->get_Lonly; + + my @non_utf8 = grep { !valid_utf8($_) } @created; + + # exclude quilt directory + my @maintainer_fault = grep { !m{^.pc/} } @non_utf8; + + if ($self->processable->native) { + $self->hint('native-source-file-without-utf8-name', $_) + for @maintainer_fault; + + } else { + $self->hint('patched-file-without-utf8-name', $_)for @maintainer_fault; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/NonFree.pm b/lib/Lintian/Check/Files/NonFree.pm new file mode 100644 index 0000000..32e5e7f --- /dev/null +++ b/lib/Lintian/Check/Files/NonFree.pm @@ -0,0 +1,142 @@ +# files/non-free -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 1999 Joey Hess +# Copyright (C) 2000 Sean 'Shaleh' Perry +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2007 Russ Allbery +# Copyright (C) 2013-2018 Bastien ROUCARIES +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::NonFree; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(any); +use Unicode::UTF8 qw(encode_utf8); + +const my $MD5SUM_DATA_FIELDS => 5; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub _md5sum_based_lintian_data { + my ($self, $filename) = @_; + + my $data = $self->data->load($filename,qr/\s*\~\~\s*/); + + my %md5sum_data; + + for my $md5sum ($data->all) { + + my $value = $data->value($md5sum); + + my ($sha1, $sha256, $name, $reason, $link) + = split(/ \s* ~~ \s* /msx, $value, $MD5SUM_DATA_FIELDS); + + die encode_utf8("Syntax error in $filename $.") + if any { !defined } ($sha1, $sha256, $name, $reason, $link); + + $md5sum_data{$md5sum} = { + 'sha1' => $sha1, + 'sha256' => $sha256, + 'name' => $name, + 'reason' => $reason, + 'link' => $link, + }; + } + + return \%md5sum_data; +} + +has NON_FREE_FILES => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return $self->_md5sum_based_lintian_data('cruft/non-free-files'); + } +); + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + # skip packages that declare non-free contents + return + if $self->processable->is_non_free; + + my $nonfree = $self->NON_FREE_FILES->{$item->md5sum}; + if (defined $nonfree) { + my $usualname = $nonfree->{'name'}; + my $reason = $nonfree->{'reason'}; + my $link = $nonfree->{'link'}; + + $self->pointed_hint( + 'license-problem-md5sum-non-free-file', + $item->pointer, "usual name is $usualname.", + $reason, "See also $link." + ); + } + + return; +} + +# A list of known non-free flash executables +my @flash_nonfree = ( + qr/(?i)dewplayer(?:-\w+)?\.swf$/, + qr/(?i)(?:mp3|flv)player\.swf$/, + # Situation needs to be clarified: + # qr,(?i)multipleUpload\.swf$, + # qr,(?i)xspf_jukebox\.swf$, +); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + # skip packages that declare non-free contents + return + if $self->processable->is_non_free; + + # non-free .swf files + $self->pointed_hint('non-free-flash', $item->pointer) + if any { $item->name =~ m{/$_} } @flash_nonfree; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/ObsoletePaths.pm b/lib/Lintian/Check/Files/ObsoletePaths.pm new file mode 100644 index 0000000..b1d2ddd --- /dev/null +++ b/lib/Lintian/Check/Files/ObsoletePaths.pm @@ -0,0 +1,92 @@ +# files/obsolete-paths -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::ObsoletePaths; + +use v5.20; +use warnings; +use utf8; + +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has OBSOLETE_PATHS => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my %obsolete; + + my $data = $self->data->load('files/obsolete-paths',qr/\s*\->\s*/); + + for my $key ($data->all) { + + my $value = $data->value($key); + + my ($newdir, $moreinfo) = split(/\s*\~\~\s*/, $value, 2); + + $obsolete{$key} = { + 'newdir' => $newdir, + 'moreinfo' => $moreinfo, + 'match' => qr/$key/x, + 'olddir' => $key, + }; + } + + return \%obsolete; + } +); + +sub visit_installed_files { + my ($self, $item) = @_; + + # check for generic obsolete path + for my $obsolete_path (keys %{$self->OBSOLETE_PATHS}) { + + my $obs_data = $self->OBSOLETE_PATHS->{$obsolete_path}; + my $oldpathmatch = $obs_data->{'match'}; + + if ($item->name =~ m{$oldpathmatch}) { + + my $oldpath = $obs_data->{'olddir'}; + my $newpath = $obs_data->{'newdir'}; + my $moreinfo = $obs_data->{'moreinfo'}; + + $self->pointed_hint('package-installs-into-obsolete-dir', + $item->pointer,": $oldpath -> $newpath", $moreinfo); + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Openpgp.pm b/lib/Lintian/Check/Files/Openpgp.pm new file mode 100644 index 0000000..dc421df --- /dev/null +++ b/lib/Lintian/Check/Files/Openpgp.pm @@ -0,0 +1,51 @@ +# files/openpgp -- lintian check script -*- perl -*- + +# Copyright (C) 2022 Guillem Jover <guillem@debian.org> +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Openpgp; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + $self->pointed_hint('openpgp-file-has-implementation-specific-extension', + $item->pointer) + if $item->name =~ m{\.gpg$}; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Ownership.pm b/lib/Lintian/Check/Files/Ownership.pm new file mode 100644 index 0000000..bbea4b9 --- /dev/null +++ b/lib/Lintian/Check/Files/Ownership.pm @@ -0,0 +1,74 @@ +# files/ownership -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Ownership; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $SLASH => q{/}; + +const my $MAXIMUM_LOW_RESERVED => 99; +const my $MAXIMUM_HIGH_RESERVED => 64_999; +const my $MINIMUM_HIGH_RESERVED => 60_000; +const my $NOBODY => 65_534; + +sub visit_installed_files { + my ($self, $item) = @_; + + $self->pointed_hint('wrong-file-owner-uid-or-gid', $item->pointer, + $item->uid . $SLASH . $item->gid) + if out_of_bounds($item->uid) + || out_of_bounds($item->gid); + + return; +} + +sub out_of_bounds { + my ($id) = @_; + + return 0 + if $id <= $MAXIMUM_LOW_RESERVED; + + return 0 + if $id == $NOBODY; + + return 0 + if $id >= $MINIMUM_HIGH_RESERVED + && $id <= $MAXIMUM_HIGH_RESERVED; + + return 1; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/P11Kit.pm b/lib/Lintian/Check/Files/P11Kit.pm new file mode 100644 index 0000000..a128fa0 --- /dev/null +++ b/lib/Lintian/Check/Files/P11Kit.pm @@ -0,0 +1,54 @@ +# files/p11-kit -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::P11Kit; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + if ( + $item->name =~ m{^usr/share/p11-kit/modules/.} + && $item->name !~ m{\A usr/share/p11-kit/modules/ + [[:alnum:]][[:alnum:]_.-]*\.module\Z + }xsm + ) { + $self->pointed_hint('incorrect-naming-of-pkcs11-module', + $item->pointer); + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Pam.pm b/lib/Lintian/Check/Files/Pam.pm new file mode 100644 index 0000000..c02cd4b --- /dev/null +++ b/lib/Lintian/Check/Files/Pam.pm @@ -0,0 +1,50 @@ +# files/pam -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Pam; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + # /etc/pam.conf + $self->pointed_hint('config-file-reserved', $item->pointer, + 'by libpam-runtime') + if $item->name =~ m{^etc/pam.conf$} + && $self->processable->name ne 'libpam-runtime'; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Permissions.pm b/lib/Lintian/Check/Files/Permissions.pm new file mode 100644 index 0000000..30cff5b --- /dev/null +++ b/lib/Lintian/Check/Files/Permissions.pm @@ -0,0 +1,249 @@ +# files/permissions -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Permissions; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Path::Tiny; + +const my $NOT_EQUAL => q{!=}; + +const my $STANDARD_EXECUTABLE => oct(755); +const my $SETGID_EXECUTABLE => oct(4754); +const my $SET_USER_ID => oct(4000); +const my $SET_GROUP_ID => oct(2000); + +const my $STANDARD_FILE => oct(644); +const my $BACKUP_NINJA_FILE => oct(600); +const my $SUDOERS_FILE => oct(440); +const my $GAME_DATA => oct(664); + +const my $STANDARD_FOLDER => oct(755); +const my $GAME_FOLDER => oct(2775); +const my $VAR_LOCAL_FOLDER => oct(2775); +const my $VAR_LOCK_FOLDER => oct(1777); +const my $USR_SRC_FOLDER => oct(2775); + +const my $WORLD_READABLE => oct(444); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has component => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return path($self->processable->path)->basename; + } +); + +has linked_against_libvga => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my %linked_against_libvga; + + for my $item (@{$self->processable->installed->sorted_list}) { + + for my $library (@{$item->elf->{NEEDED} // []}){ + + $linked_against_libvga{$item->name} = 1 + if $library =~ m{^ libvga[.]so[.] }x; + } + } + + return \%linked_against_libvga; + } +); + +sub visit_installed_files { + my ($self, $item) = @_; + + if ($item->is_file) { + + if ( + $item->is_executable + && $item->identity eq 'root/games' + && ( !$item->is_setgid + || !$item->all_bits_set($STANDARD_EXECUTABLE)) + ) { + + $self->pointed_hint( + 'non-standard-game-executable-perm', + $item->pointer, + $item->octal_permissions, + $NOT_EQUAL, + sprintf('%04o', $SET_GROUP_ID | $STANDARD_EXECUTABLE) + ); + + return; + } + + $self->pointed_hint('executable-is-not-world-readable', + $item->pointer, $item->octal_permissions) + if $item->is_executable + && !$item->all_bits_set($WORLD_READABLE); + + if ($item->is_setuid || $item->is_setgid) { + + $self->pointed_hint('non-standard-setuid-executable-perm', + $item->pointer, $item->octal_permissions) + unless (($item->operm & ~($SET_USER_ID | $SET_GROUP_ID)) + == $STANDARD_EXECUTABLE) + || $item->operm == $SETGID_EXECUTABLE; + } + + # allow anything with suid in the name + return + if ($item->is_setuid || $item->is_setgid) + && $self->processable->name =~ / -suid /msx; + + # program is using svgalib + return + if $item->is_setuid + && !$item->is_setgid + && $item->owner eq 'root' + && exists $self->linked_against_libvga->{$item->name}; + + # program is a setgid game + return + if $item->is_setgid + && !$item->is_setuid + && $item->group eq 'games' + && $item->name =~ m{^ usr/ (?:lib/)? games/ \S+ }msx; + + if ($item->is_setuid || $item->is_setgid) { + $self->pointed_hint( + 'elevated-privileges', $item->pointer, + $item->octal_permissions, $item->identity + ); + + return; + } + + if ( $item->is_executable + && $item->operm != $STANDARD_EXECUTABLE) { + + $self->pointed_hint('non-standard-executable-perm', + $item->pointer, $item->octal_permissions, $NOT_EQUAL, + sprintf('%04o', $STANDARD_EXECUTABLE)); + + return; + } + + if (!$item->is_executable) { + + # game data + return + if $item->operm == $GAME_DATA + && $item->identity eq 'root/games' + && $item->name =~ m{^ var/ (?:lib/)? games/ \S+ }msx; + + # GNAT compiler wants read-only Ada library information. + if ( $item->name =~ m{^ usr/lib/ .* [.]ali $}msx + && $item->operm != $WORLD_READABLE) { + + $self->pointed_hint('bad-permissions-for-ali-file', + $item->pointer); + + return; + } + + # backupninja expects configurations files to be oct(600) + return + if $item->operm == $BACKUP_NINJA_FILE + && $item->name =~ m{^ etc/backup.d/ }msx; + + if ($item->name =~ m{^ etc/sudoers.d/ }msx) { + + # sudo requires sudoers files to be mode oct(440) + $self->pointed_hint( + 'bad-perm-for-file-in-etc-sudoers.d',$item->pointer, + $item->octal_permissions, $NOT_EQUAL, + sprintf('%04o', $SUDOERS_FILE) + )unless $item->operm == $SUDOERS_FILE; + + return; + } + + $self->pointed_hint( + 'non-standard-file-perm', $item->pointer, + $item->octal_permissions, $NOT_EQUAL, + sprintf('%04o', $STANDARD_FILE) + )unless $item->operm == $STANDARD_FILE; + } + + } + + if ($item->is_dir) { + + # game directory with setgid bit + return + if $item->operm == $GAME_FOLDER + && $item->identity eq 'root/games' + && $item->name =~ m{^ var/ (?:lib/)? games/ \S+ }msx; + + # shipping files here triggers warnings elsewhere + return + if $item->operm == $VAR_LOCK_FOLDER + && $item->identity eq 'root/root' + && ( $item->name =~ m{^ (?:var/)? tmp/ }msx + || $item->name eq 'var/lock/'); + + # shipping files here triggers warnings elsewhere + return + if $item->operm == $VAR_LOCAL_FOLDER + && $item->identity eq 'root/staff' + && $item->name eq 'var/local/'; + + # /usr/src created by base-files + return + if $item->operm == $USR_SRC_FOLDER + && $item->identity eq 'root/src' + && $item->name eq 'usr/src/'; + + $self->pointed_hint( + 'non-standard-dir-perm', $item->pointer, + $item->octal_permissions, $NOT_EQUAL, + sprintf('%04o', $STANDARD_FOLDER) + )unless $item->operm == $STANDARD_FOLDER; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Permissions/UsrLib.pm b/lib/Lintian/Check/Files/Permissions/UsrLib.pm new file mode 100644 index 0000000..e465310 --- /dev/null +++ b/lib/Lintian/Check/Files/Permissions/UsrLib.pm @@ -0,0 +1,54 @@ +# files/permissions/usr-lib -- lintian check script -*- perl -*- + +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Permissions::UsrLib; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + # see Bug#959037 for details + return + if $self->processable->type eq 'udeb'; + + return + unless $item->name =~ m{^usr/lib/}; + + $self->pointed_hint('executable-in-usr-lib', $item->pointer) + if $item->is_file && $item->is_executable; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Pkgconfig.pm b/lib/Lintian/Check/Files/Pkgconfig.pm new file mode 100644 index 0000000..b2d555b --- /dev/null +++ b/lib/Lintian/Check/Files/Pkgconfig.pm @@ -0,0 +1,121 @@ +# files/pkgconfig -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Pkgconfig; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::SlidingWindow; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; + +has PKG_CONFIG_BAD_REGEX => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return $self->data->load('files/pkg-config-bad-regex',qr/~~~~~/); + } +); + +sub visit_installed_files { + my ($self, $item) = @_; + + my $architecture = $self->processable->fields->value('Architecture'); + + # arch-indep pkgconfig + if ( $item->is_regular_file + && $item->name=~ m{^usr/(lib(/[^/]+)?|share)/pkgconfig/[^/]+\.pc$}){ + + my $prefix = $1; + my $pkg_config_arch = $2 // $EMPTY; + $pkg_config_arch =~ s{\A/}{}ms; + + $self->pointed_hint('pkg-config-unavailable-for-cross-compilation', + $item->pointer) + if $prefix eq 'lib'; + + open(my $fd, '<:raw', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $sfd = Lintian::SlidingWindow->new; + $sfd->handle($fd); + + BLOCK: + while (my $block = $sfd->readwindow) { + # remove comment line + $block =~ s/\#\V*//gsm; + # remove continuation line + $block =~ s/\\\n/ /gxsm; + # check if pkgconfig file include path point to + # arch specific dir + + my $DEB_HOST_MULTIARCH + = $self->data->architectures->deb_host_multiarch; + for my $madir (values %{$DEB_HOST_MULTIARCH}) { + + next + if $pkg_config_arch eq $madir; + + if ($block =~ m{\W\Q$madir\E(\W|$)}xms) { + + $self->pointed_hint('pkg-config-multi-arch-wrong-dir', + $item->pointer, + 'full text contains architecture specific dir',$madir); + + last; + } + } + + for my $pattern ($self->PKG_CONFIG_BAD_REGEX->all) { + + while($block =~ m{$pattern}xmsg) { + + my $context = $1; + + $self->pointed_hint('pkg-config-bad-directive', + $item->pointer,$context); + } + } + } + close($fd); + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/PrivacyBreach.pm b/lib/Lintian/Check/Files/PrivacyBreach.pm new file mode 100644 index 0000000..8d75623 --- /dev/null +++ b/lib/Lintian/Check/Files/PrivacyBreach.pm @@ -0,0 +1,420 @@ +# files/privacy-breach -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::PrivacyBreach; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::SlidingWindow; + +const my $BLOCKSIZE => 16_384; +const my $EMPTY => q{}; + +const my $PRIVACY_BREAKER_WEBSITES_FIELDS => 3; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has PRIVACY_BREAKER_WEBSITES => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my %website; + + my $data + = $self->data->load('files/privacy-breaker-websites',qr/\s*\~\~/); + + for my $key ($data->all) { + + my $value = $data->value($key); + + my ($pattern, $tag, $suggest) + = split(/ \s* ~~ \s* /msx, + $value,$PRIVACY_BREAKER_WEBSITES_FIELDS); + + $tag //= $EMPTY; + + # trim both ends + $tag =~ s/^\s+|\s+$//g; + + $tag = $key + unless length $tag; + + $website{$key} = { + 'tag' => $tag, + 'regexp' => qr/$pattern/xsm, + }; + + $website{$key}{'suggest'} = $suggest + if defined $suggest; + } + + return \%website; + } +); + +has PRIVACY_BREAKER_FRAGMENTS => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my %fragment; + + my $data + = $self->data->load('files/privacy-breaker-fragments',qr/\s*\~\~/); + + for my $key ($data->all) { + + my $value = $data->value($key); + + my ($pattern, $tag) = split(/\s*\~\~\s*/, $value, 2); + + $fragment{$key} = { + 'keyword' => $key, + 'regex' => qr/$pattern/xsm, + 'tag' => $tag, + }; + } + + return \%fragment; + } +); + +has PRIVACY_BREAKER_TAG_ATTR => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my %attribute; + + my $data + = $self->data->load('files/privacy-breaker-tag-attr',qr/\s*\~\~\s*/); + + for my $key ($data->all) { + + my $value = $data->value($key); + + my ($keywords,$pattern) = split(/\s*\~\~\s*/, $value, 2); + + $pattern =~ s/&URL/(?:(?:ht|f)tps?:)?\/\/[^"\r\n]*/g; + + my @keywordlist; + + my @keywordsorraw = split(/\s*\|\|\s*/,$keywords); + + for my $keywordor (@keywordsorraw) { + my @keywordsandraw = split(/\s*&&\s*/,$keywordor); + push(@keywordlist, \@keywordsandraw); + } + + $attribute{$key} = { + 'keywords' => \@keywordlist, + 'regex' => qr/$pattern/xsm, + }; + } + + return \%attribute; + } +); + +sub detect_privacy_breach { + my ($self, $file) = @_; + + my %privacybreachhash; + + return + unless $file->is_regular_file; + + open(my $fd, '<:raw', $file->unpacked_path) + or die encode_utf8('Cannot open ' . $file->unpacked_path); + + my $sfd = Lintian::SlidingWindow->new; + $sfd->handle($fd); + $sfd->blocksize($BLOCKSIZE); + $sfd->blocksub(sub { $_ = lc; }); + + while (my $lowercase = $sfd->readwindow) { + # strip comments + for my $x (qw(<!--(?!\[if).*?--\s*> /\*(?!@cc_on).*?\*/)) { + $lowercase =~ s/$x//gs; + } + + # keep sorted; otherwise 'exists' below produces inconsistent output + for my $keyword (sort keys %{$self->PRIVACY_BREAKER_FRAGMENTS}) { + + if ($lowercase =~ / \Q$keyword\E /msx) { + my $keyvalue= $self->PRIVACY_BREAKER_FRAGMENTS->{$keyword}; + my $regex = $keyvalue->{'regex'}; + + if ($lowercase =~ m{($regex)}) { + my $capture = $1; + my $breaker_tag = $keyvalue->{'tag'}; + + unless (exists $privacybreachhash{'tag-'.$breaker_tag}){ + + $privacybreachhash{'tag-'.$breaker_tag} = 1; + + $self->pointed_hint($breaker_tag, $file->pointer, + "(choke on: $capture)"); + } + } + } + } + + for my $x ( + qw(src="http src="ftp src="// data-href="http data-href="ftp + data-href="// codebase="http codebase="ftp codebase="// data="http + data="ftp data="// poster="http poster="ftp poster="// <link @import) + ) { + next + unless $lowercase =~ / \Q$x\E /msx; + + $self->detect_generic_privacy_breach($lowercase, + \%privacybreachhash,$file); + + last; + } + } + + close($fd); + return; +} + +# According to html norm src attribute is used by tags: +# +# audio(v5+), embed (v5+), iframe (v4), frame, img, input, script, source, track(v5), video (v5) +# Add other tags with src due to some javascript code: +# div due to div.js +# div data-href due to jquery +# css with @import +sub detect_generic_privacy_breach { + my ($self, $block, $privacybreachhash, $file) = @_; + my %matchedkeyword; + + # now check generic tag + TYPE: + for my $type (sort keys %{$self->PRIVACY_BREAKER_TAG_ATTR}) { + my $keyvalue = $self->PRIVACY_BREAKER_TAG_ATTR->{$type}; + my $keywords = $keyvalue->{'keywords'}; + + my $orblockok = 0; + ORBLOCK: + for my $keywordor (@{$keywords}) { + ANDBLOCK: + for my $keyword (@{$keywordor}) { + + my $thiskeyword = $matchedkeyword{$keyword}; + if(!defined($thiskeyword)) { + if ($block =~ / \Q$keyword\E /msx) { + $matchedkeyword{$keyword} = 1; + $orblockok = 1; + }else { + $matchedkeyword{$keyword} = 0; + $orblockok = 0; + next ORBLOCK; + } + } + if($matchedkeyword{$keyword} == 0) { + $orblockok = 0; + next ORBLOCK; + }else { + $orblockok = 1; + } + } + if($orblockok == 1) { + last ORBLOCK; + } + } + if($orblockok == 0) { + next TYPE; + } + + my $regex = $keyvalue->{'regex'}; + + while($block=~m{$regex}g){ + $self->check_tag_url_privacy_breach($1, $2, $3,$privacybreachhash, + $file); + } + } + return; +} + +sub is_localhost { + my ($urlshort) = @_; + if( $urlshort =~ m{^(?:[^/]+@)?localhost(?:[:][^/]+)?/}i + || $urlshort =~ m{^(?:[^/]+@)?::1(?:[:][^/]+)?/}i + || $urlshort =~ m{^(?:[^/]+@)?127(?:\.\d{1,3}){3}(?:[:][^/]+)?/}i) { + return 1; + }else { + return 0; + } +} + +sub check_tag_url_privacy_breach { + my ($self, $fulltag, $tagattr, $url,$privacybreachhash, $file) = @_; + + my $website = $url; + # detect also "^//" trick + $website =~ s{^"?(?:(?:ht|f)tps?:)?//}{}; + $website =~ s/"?$//; + + if (is_localhost($website)){ + # do nothing ok + return; + } + + # reparse fulltag for rel + if ($tagattr eq 'link') { + + my $rel = $fulltag; + $rel =~ m{<link + (?:\s[^>]+)? \s+ + rel="([^"\r\n]*)" + [^>]* + >}xismog; + my $relcontent = $1; + + if (defined($relcontent)) { + # See, for example, https://www.w3schools.com/tags/att_link_rel.asp + my %allowed = ( + 'alternate' => 1, # #891301 + 'author' => 1, # #891301 + 'bookmark' => 1, # #746656 + 'canonical' => 1, # #762753 + 'copyright' => 1, # #902919 + 'edituri' => 1, # #902919 + 'generator' => 1, # #891301 + 'generator-home' => 1, # texinfo + 'help' => 1, # #891301 + 'license' => 1, # #891301 + 'next' => 1, # #891301 + 'prev' => 1, # #891301 + 'schema.dct' => 1, # #736992 + 'search' => 1, # #891301 + ); + + return + if ($allowed{$relcontent}); + + if ($relcontent eq 'alternate') { + my $type = $fulltag; + $type =~ m{<link + (?:\s[^>]+)? \s+ + type="([^"\r\n]*)" + [^>]* + >}xismog; + my $typecontent = $1; + if($typecontent eq 'application/rdf+xml') { + # see #79991 + return; + } + } + } + } + + # False positive + # legal.xml file of gnome + # could be replaced by a link to local file but not really a privacy breach + if( $file->basename eq 'legal.xml' + && $tagattr eq 'link' + && $website =~ m{^creativecommons.org/licenses/}) { + + return; + } + + # In Mallard XML, <link> is a clickable anchor that will not be + # followed automatically. + if( $file->basename =~ '.xml$' + && $tagattr eq 'link' + && $file->bytes=~ qr{ xmlns="http://projectmallard\.org/1\.0/"}) { + + return; + } + + # track well known site + for my $breaker (sort keys %{$self->PRIVACY_BREAKER_WEBSITES}) { + + my $value = $self->PRIVACY_BREAKER_WEBSITES->{$breaker}; + my $regex = $value->{'regexp'}; + + if ($website =~ m{$regex}mxs) { + + unless (exists $privacybreachhash->{'tag-'.$breaker}) { + + my $tag = $value->{'tag'}; + my $suggest = $value->{'suggest'} // $EMPTY; + + $privacybreachhash->{'tag-'.$breaker}= 1; + $self->pointed_hint($tag, $file->pointer, $suggest, "($url)"); + } + + # do not go to generic case + return; + } + } + + # generic case + unless (exists $privacybreachhash->{'tag-generic-'.$website}){ + + $self->pointed_hint('privacy-breach-generic', $file->pointer, + "[$fulltag]","($url)"); + $privacybreachhash->{'tag-generic-'.$website} = 1; + } + + return; +} + +sub visit_installed_files { + my ($self, $file) = @_; + + # html/javascript + if ( $file->is_file + && $file->name =~ m/\.(?:x?html?\d?|js|xht|xml|css)$/i) { + + if( $self->processable->source_name eq 'josm' + and $file->basename eq 'defaultpresets.xml') { + # false positive + + } else { + $self->detect_privacy_breach($file); + } + } + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Scripts.pm b/lib/Lintian/Check/Files/Scripts.pm new file mode 100644 index 0000000..3dff34e --- /dev/null +++ b/lib/Lintian/Check/Files/Scripts.pm @@ -0,0 +1,57 @@ +# files/scripts -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Scripts; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + # language extensions + if ( + $item->name =~ m{\A + (?:usr/)?(?:s?bin|games)/[^/]+\. + (?:p[ly]|php|rb|[bc]?sh|tcl) + \Z}xsm + ) { + $self->pointed_hint('script-with-language-extension', $item->pointer); + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Sgml.pm b/lib/Lintian/Check/Files/Sgml.pm new file mode 100644 index 0000000..fd4ace2 --- /dev/null +++ b/lib/Lintian/Check/Files/Sgml.pm @@ -0,0 +1,48 @@ +# files/sgml -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Sgml; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + # /usr/lib/sgml + $self->pointed_hint('file-in-usr-lib-sgml', $item->pointer) + if $item->name =~ m{^usr/lib/sgml/\S}; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/SourceMissing.pm b/lib/Lintian/Check/Files/SourceMissing.pm new file mode 100644 index 0000000..6ae9f03 --- /dev/null +++ b/lib/Lintian/Check/Files/SourceMissing.pm @@ -0,0 +1,286 @@ +# files/source-missing -- lintian check script -*- perl -*- +# +# based on debhelper check, +# Copyright (C) 1999 Joey Hess +# Copyright (C) 2000 Sean 'Shaleh' Perry +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2007 Russ Allbery +# Copyright (C) 2013-2018 Bastien ROUCARIES +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::SourceMissing; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use File::Basename qw(basename); +use List::SomeUtils qw(first_value); +use List::UtilsBy qw(max_by); + +# very long line lengths +const my $VERY_LONG_LINE_LENGTH => 512; + +const my $EMPTY => q{}; +const my $DOLLAR => q{$}; +const my $DOT => q{.}; +const my $DOUBLE_DOT => q{..}; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + return + if $item->dirname =~ m{^debian/missing-sources/}; + + # prebuilt-file or forbidden file type + $self->pointed_hint('source-contains-prebuilt-wasm-binary', $item->pointer) + if $item->file_type =~ m{^WebAssembly \s \(wasm\) \s binary \s module}x; + + $self->pointed_hint('source-contains-prebuilt-windows-binary', + $item->pointer) + if $item->file_type + =~ m{\b(?:PE(?:32|64)|(?:MS-DOS|COM)\s executable)\b}x; + + $self->pointed_hint('source-contains-prebuilt-silverlight-object', + $item->pointer) + if $item->file_type =~ m{^Zip \s archive \s data}x + && $item->name =~ m{(?i)\.xac$}x; + + if ($item->file_type =~ m{^python \s \d(\.\d+)? \s byte-compiled}x) { + + $self->pointed_hint('source-contains-prebuilt-python-object', + $item->pointer); + + $self->pointed_hint('source-is-missing', $item->pointer) + unless $self->find_source($item, + {'.py' => '(?i)(?:\.cpython-\d{2}|\.pypy)?\.py[co]$'}); + } + + if ($item->file_type =~ m{\bELF\b}x) { + $self->pointed_hint('source-contains-prebuilt-binary', $item->pointer); + + my %patterns = map { + $_ => +'(?i)(?:[\.-](?:bin|elf|e|hs|linux\d+|oo?|or|out|so(?:\.\d+)*)|static|_o\.golden)?$' + } qw(.asm .c .cc .cpp .cxx .f .F .i .ml .rc .S); + + $self->pointed_hint('source-is-missing', $item->pointer) + unless $self->find_source($item, \%patterns); + } + + if ($item->file_type =~ m{^Macromedia \s Flash}x) { + + $self->pointed_hint('source-contains-prebuilt-flash-object', + $item->pointer); + + $self->pointed_hint('source-is-missing', $item->pointer) + unless $self->find_source($item, {'.as' => '(?i)\.swf$'}); + } + + if ( $item->file_type =~ m{^Composite \s Document \s File}x + && $item->name =~ m{(?i)\.fla$}x) { + + $self->pointed_hint('source-contains-prebuilt-flash-project', + $item->pointer); + + $self->pointed_hint('source-is-missing', $item->pointer) + unless $self->find_source($item, {'.as' => '(?i)\.fla$'}); + } + + # see #745152 + # Be robust check also .js + if ($item->basename eq 'deployJava.js') { + if ( + lc $item->decoded_utf8 + =~ m/(?:\A|\v)\s*var\s+deployJava\s*=\s*function/xmsi) { + + $self->pointed_hint('source-is-missing', $item->pointer) + unless $self->find_source($item, + {'.txt' => '(?i)\.js$', $EMPTY => $EMPTY}); + + return; + } + } + + # do not forget to change also $JS_EXT in file.pm + if ($item->name + =~ m{(?i)[-._](?:compiled|compressed|lite|min|pack(?:ed)?|prod|umd|yc)\.js$}x + ) { + + $self->pointed_hint('source-contains-prebuilt-javascript-object', + $item->pointer); + my %patterns = map { + $_ => +'(?i)(?:[-._](?:compiled|compressed|lite|min|pack(?:ed)?|prod|umd|yc))?\.js$' + } qw(.js _orig.js .js.orig .src.js -src.js .debug.js -debug.js -nc.js); + + $self->pointed_hint('source-is-missing', $item->pointer) + unless $self->find_source($item, \%patterns); + + return; + } + + my @lines = split(/\n/, $item->bytes); + my %line_length; + my %semicolon_count; + + my $position = 1; + for my $line (@lines) { + + $line_length{$position} = length $line; + $semicolon_count{$position} = ($line =~ tr/;/;/); + + } continue { + ++$position; + } + + my $longest = max_by { $line_length{$_} } keys %line_length; + my $most = max_by { $semicolon_count{$_} } keys %semicolon_count; + + return + if !defined $longest || $line_length{$longest} <= $VERY_LONG_LINE_LENGTH; + + if ($item->basename =~ m{\.js$}i) { + + $self->pointed_hint('source-contains-prebuilt-javascript-object', + $item->pointer); + + # Check for missing source. It will check + # for the source file in well known directories + $self->pointed_hint('source-is-missing', $item->pointer) + unless $self->find_source( + $item, + { + '.debug.js' => '(?i)\.js$', + '-debug.js' => '(?i)\.js$', + $EMPTY => $EMPTY + } + ); + } + + if ($item->basename =~ /\.(?:x?html?\d?|xht)$/i) { + + # html file + $self->pointed_hint('source-is-missing', $item->pointer) + unless $self->find_source($item, {'.fragment.js' => $DOLLAR}); + } + + return; +} + +sub find_source { + my ($self, $item, $patternref) = @_; + + $patternref //= {}; + + return undef + unless $item->is_regular_file; + + return undef + if $self->processable->is_non_free; + + my %patterns = %{$patternref}; + + my @alternatives; + for my $replacement (keys %patterns) { + + my $newname = $item->basename; + + # empty pattern would repeat the last regex compiled + my $pattern = $patterns{$replacement}; + $newname =~ s/$pattern/$replacement/ + if length $pattern; + + push(@alternatives, $newname) + if length $newname; + } + + my $index = $self->processable->patched; + my @candidates; + + # add standard locations + push(@candidates, + $index->resolve_path('debian/missing-sources/' . $item->name)); + push(@candidates, + $index->resolve_path('debian/missing-sources/' . $item->basename)); + + my $dirname = $item->dirname; + my $parentname = basename($dirname); + + my @absolute = ( + # libtool + '.libs', + ".libs/$dirname", + # mathjax + 'unpacked', + # for missing source set in debian + 'debian', + 'debian/missing-sources', + "debian/missing-sources/$dirname" + ); + + for my $absolute (@absolute) { + push(@candidates, $index->resolve_path("$absolute/$_")) + for @alternatives; + } + + my @relative = ( + # likely in current dir + $DOT, + # for binary object built by libtool + $DOUBLE_DOT, + # maybe in src subdir + './src', + # maybe in ../src subdir + '../src', + "../../src/$parentname", + # emscripten + './flash-src/src/net/gimite/websocket', + ); + + for my $relative (@relative) { + push(@candidates, $item->resolve_path("$relative/$_")) + for @alternatives; + } + + my @found = grep { defined } @candidates; + + # careful with behavior around empty arrays + my $source = first_value { $_->name ne $item->name } @found; + + return $source; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Special.pm b/lib/Lintian/Check/Files/Special.pm new file mode 100644 index 0000000..7a59006 --- /dev/null +++ b/lib/Lintian/Check/Files/Special.pm @@ -0,0 +1,50 @@ +# files/special -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Special; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + if $item->is_file || $item->is_dir || $item->is_symlink; + + $self->pointed_hint('special-file', $item->pointer, + sprintf('%04o',$item->operm)); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/SymbolicLinks.pm b/lib/Lintian/Check/Files/SymbolicLinks.pm new file mode 100644 index 0000000..0edcde2 --- /dev/null +++ b/lib/Lintian/Check/Files/SymbolicLinks.pm @@ -0,0 +1,229 @@ +# files/symbolic-links -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::SymbolicLinks; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $SLASH => q{/}; +const my $DOT => q{.}; +const my $DOUBLE_DOT => q{..}; +const my $VERTICAL_BAR => q{|}; +const my $ARROW => q{->}; + +# an OR (|) regex of all compressed extension +has COMPRESS_FILE_EXTENSIONS_OR_ALL => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $COMPRESS_FILE_EXTENSIONS + = $self->data->load('files/compressed-file-extensions',qr/\s+/); + + my $text = join($VERTICAL_BAR, + (map { quotemeta } $COMPRESS_FILE_EXTENSIONS->all)); + + return qr/$text/; + } +); + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->is_symlink; + + # absolute links cannot be resolved + if ($item->link =~ m{^/}) { + + # allow /dev/null link target for masked systemd service files + $self->pointed_hint('absolute-symbolic-link-target-in-source', + $item->pointer, $item->link) + unless $item->link eq '/dev/null'; + } + + # some relative links cannot be resolved inside the source + $self->pointed_hint('wayward-symbolic-link-target-in-source', + $item->pointer, $item->link) + unless defined $_->link_normalized || $item->link =~ m{^/}; + + return; +} + +sub is_tmp_path { + my ($path) = @_; + + return 1 + if $path =~ m{^tmp/.} + || $path =~ m{^(?:var|usr)/tmp/.} + || $path =~ m{^/dev/shm/}; + + return 0; +} + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_symlink; + + my $mylink = $item->link; + $self->pointed_hint('symlink-has-double-slash', $item->pointer,$item->link) + if $mylink =~ s{//+}{/}g; + + $self->pointed_hint('symlink-ends-with-slash', $item->pointer, $item->link) + if $mylink =~ s{(.)/$}{$1}; + + # determine top-level directory of file + $item->name =~ m{^/?([^/]*)}; + my $filetop = $1; + + if ($mylink =~ m{^/([^/]*)}) { + my $flinkname = substr($mylink,1); + # absolute link, including link to / + # determine top-level directory of link + my $linktop = $1; + + if ($self->processable->type ne 'udeb' and $filetop eq $linktop) { + # absolute links within one toplevel directory are _not_ ok! + $self->pointed_hint('absolute-symlink-in-top-level-folder', + $item->pointer, $item->link); + } + + my $BUILD_PATH_REGEX + = $self->data->load('files/build-path-regex',qr/~~~~~/); + + for my $pattern ($BUILD_PATH_REGEX->all) { + + $self->pointed_hint('symlink-target-in-build-tree', + $item->pointer, $mylink) + if $flinkname =~ m{$pattern}xms; + } + + $self->pointed_hint('symlink-target-in-tmp', $item->pointer,$mylink) + if is_tmp_path($flinkname); + + # Any other case is already definitely non-recursive + $self->pointed_hint('symlink-is-self-recursive', $item->pointer, + $item->link) + if $mylink eq $SLASH; + + } else { + # relative link, we can assume from here that the link + # starts nor ends with / + + my @filecomponents = split(m{/}, $item->name); + # chop off the name of the symlink + pop @filecomponents; + + my @linkcomponents = split(m{/}, $mylink); + + # handle `../' at beginning of $item->link + my ($lastpop, $linkcomponent); + while ($linkcomponent = shift @linkcomponents) { + if ($linkcomponent eq $DOT) { + $self->pointed_hint('symlink-contains-spurious-segments', + $item->pointer, $item->link) + unless $mylink eq $DOT; + next; + } + last if $linkcomponent ne $DOUBLE_DOT; + if (@filecomponents) { + $lastpop = pop @filecomponents; + } else { + $self->pointed_hint('symlink-has-too-many-up-segments', + $item->pointer, $item->link); + goto NEXT_LINK; + } + } + + if (!defined $linkcomponent) { + # After stripping all starting .. components, nothing left + $self->pointed_hint('symlink-is-self-recursive', $item->pointer, + $item->link); + } + + # does the link go up and then down into the same + # directory? (lastpop indicates there was a backref + # at all, no linkcomponent means the symlink doesn't + # get up anymore) + if ( defined $lastpop + && defined $linkcomponent + && $linkcomponent eq $lastpop) { + $self->pointed_hint('lengthy-symlink', $item->pointer,$item->link); + } + + unless (@filecomponents) { + # we've reached the root directory + if ( ($self->processable->type ne 'udeb') + && (!defined $linkcomponent) + || ($filetop ne $linkcomponent)) { + + # relative link into other toplevel directory. + # this hits a relative symbolic link in the root too. + $self->pointed_hint('relative-symlink', $item->pointer, + $item->link); + } + } + + # check additional segments for mistakes like `foo/../bar/' + foreach (@linkcomponents) { + if ($_ eq $DOUBLE_DOT || $_ eq $DOT) { + $self->pointed_hint('symlink-contains-spurious-segments', + $item->pointer, $item->link); + last; + } + } + } + NEXT_LINK: + + my $pattern = $self->COMPRESS_FILE_EXTENSIONS_OR_ALL; + + # symlink pointing to a compressed file + if ($item->link =~ qr{ [.] ($pattern) \s* $}x) { + + my $extension = $1; + + # symlink has correct extension? + $self->pointed_hint('compressed-symlink-with-wrong-ext', + $item->pointer, $item->link) + unless $item->name =~ qr{[.]$extension\s*$}; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/SymbolicLinks/Broken.pm b/lib/Lintian/Check/Files/SymbolicLinks/Broken.pm new file mode 100644 index 0000000..39ae2d2 --- /dev/null +++ b/lib/Lintian/Check/Files/SymbolicLinks/Broken.pm @@ -0,0 +1,119 @@ +# files/symbolic-links/broken -- lintian check script -*- perl -*- +# +# Copyright (C) 2011 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::SymbolicLinks::Broken; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use File::Basename qw(dirname); +use List::SomeUtils qw(any); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; +const my $ASTERISK => q{*}; + +has wildcard_links => (is => 'rw', default => sub{ [] }); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_symlink; + + # target relative to the package root + my $path = $item->link_normalized; + + # unresolvable link + unless (defined $path) { + + $self->pointed_hint('package-contains-unsafe-symlink', $item->pointer); + return; + } + + # will always have links to the package root (although + # self-recursive and possibly not very useful) + return + if $path eq $EMPTY; + + # If it contains a "*" it probably a bad + # ln -s target/*.so link expansion. We do not bother looking + # for other broken symlinks as people keep adding new special + # cases and it is not worth it. + push(@{$self->wildcard_links}, $item) + if index($item->link, $ASTERISK) >= 0; + + return; +} + +sub installable { + my ($self) = @_; + + return + unless @{$self->wildcard_links}; + + # get prerequisites from same source package + my @prerequisites + = @{$self->group->direct_dependencies($self->processable)}; + + for my $item (@{$self->wildcard_links}){ + + # target relative to the package root + my $path = $item->link_normalized; + + # destination is in the package + next + if $self->processable->installed->lookup($path) + || $self->processable->installed->lookup("$path/"); + + # does the link point to any prerequisites in same source package + next + if + any {$_->installed->lookup($path) || $_->installed->lookup("$path/")} + @prerequisites; + + # link target + my $target = $item->link; + + # strip leading slashes for reporting + $target =~ s{^/+}{}; + + # nope - not found in any of our direct dependencies. Ergo it is + # a broken "ln -s target/*.so link" expansion. + $self->pointed_hint('package-contains-broken-symlink-wildcard', + $item->pointer, $target); + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Unicode/Trojan.pm b/lib/Lintian/Check/Files/Unicode/Trojan.pm new file mode 100644 index 0000000..5c4f2e1 --- /dev/null +++ b/lib/Lintian/Check/Files/Unicode/Trojan.pm @@ -0,0 +1,134 @@ +# files/unicode/trojan -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Unicode::Trojan; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Unicode::UTF8 qw(decode_utf8 encode_utf8 valid_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $DOUBLE_QUOTE => q{"}; + +const my %NAMES_BY_CHARACTER => ( + qq{\N{ARABIC LETTER MARK}} => 'ARABIC LETTER MARK', # U+061C + qq{\N{LEFT-TO-RIGHT MARK}} => 'LEFT-TO-RIGHT MARK', # U+200E + qq{\N{RIGHT-TO-LEFT MARK}} => 'RIGHT-TO-LEFT MARK', # U+200F + qq{\N{LEFT-TO-RIGHT EMBEDDING}} => 'LEFT-TO-RIGHT EMBEDDING', # U+202A + qq{\N{RIGHT-TO-LEFT EMBEDDING}} => 'RIGHT-TO-LEFT EMBEDDING', # U+202B + qq{\N{POP DIRECTIONAL FORMATTING}} =>'POP DIRECTIONAL FORMATTING', # U+202C + qq{\N{LEFT-TO-RIGHT OVERRIDE}} => 'LEFT-TO-RIGHT OVERRIDE', # U+202D + qq{\N{RIGHT-TO-LEFT OVERRIDE}} => 'RIGHT-TO-LEFT OVERRIDE', # U+202E + qq{\N{LEFT-TO-RIGHT ISOLATE}} => 'LEFT-TO-RIGHT ISOLATE', # U+2066 + qq{\N{RIGHT-TO-LEFT ISOLATE}} => 'RIGHT-TO-LEFT ISOLATE', # U+2067 + qq{\N{FIRST STRONG ISOLATE}} => 'FIRST STRONG ISOLATE', # U+2068 + qq{\N{POP DIRECTIONAL ISOLATE}} => 'POP DIRECTIONAL ISOLATE', # U+2069 +); + +sub visit_patched_files { + my ($self, $item) = @_; + + $self->check_for_trojan($item); + + return; +} + +sub visit_installed_files { + my ($self, $item) = @_; + + $self->check_for_trojan($item); + + return; +} + +sub check_for_trojan { + my ($self, $item) = @_; + + if (valid_utf8($item->name)) { + + my $decoded_name = decode_utf8($item->name); + + # all file names + for my $character (keys %NAMES_BY_CHARACTER) { + + $self->pointed_hint( + 'unicode-trojan', + $item->pointer, + 'File name', + sprintf('U+%vX', $character), + $DOUBLE_QUOTE. $NAMES_BY_CHARACTER{$character}. $DOUBLE_QUOTE + ) if $decoded_name =~ m{\Q$character\E}; + } + } + + return + unless $item->is_script; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $position = 1; + while (my $line = <$fd>) { + + chomp $line; + + next + unless valid_utf8($line); + + my $decoded = decode_utf8($line); + + my $pointer = $item->pointer($position); + + for my $character (keys %NAMES_BY_CHARACTER) { + + $self->pointed_hint( + 'unicode-trojan', + $pointer, + 'Contents', + sprintf('U+%vX', $character), + $DOUBLE_QUOTE. $NAMES_BY_CHARACTER{$character}. $DOUBLE_QUOTE + )if $decoded =~ m{\Q$character\E}; + } + + } continue { + ++$position; + } + + close $fd; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Unwanted.pm b/lib/Lintian/Check/Files/Unwanted.pm new file mode 100644 index 0000000..779e4f5 --- /dev/null +++ b/lib/Lintian/Check/Files/Unwanted.pm @@ -0,0 +1,55 @@ +# files/unwanted -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Unwanted; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + $self->pointed_hint('backup-file-in-package', $item->pointer) + if $item->name =~ /~$/ + || $item->name =~ m{\#[^/]+\#$} + || $item->name =~ m{/\.[^/]+\.swp$}; + + $self->pointed_hint('nfs-temporary-file-in-package', $item->pointer) + if $item->name =~ m{/\.nfs[^/]+$}; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/UsrMerge.pm b/lib/Lintian/Check/Files/UsrMerge.pm new file mode 100644 index 0000000..be5a06d --- /dev/null +++ b/lib/Lintian/Check/Files/UsrMerge.pm @@ -0,0 +1,53 @@ +# files/usr-merge -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::UsrMerge; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + my $quotedpath = quotemeta($item->name); + + $self->pointed_hint('package-contains-usr-unmerged-pathnames', + $item->pointer) + if $item->name =~ m{^(?:bin|sbin|lib.*)/.+$} + && !$item->is_symlink + && !$item->is_dir + && $item->link !~ m{^usr/$quotedpath$}; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Files/Vcs.pm b/lib/Lintian/Check/Files/Vcs.pm new file mode 100644 index 0000000..2f5b8f5 --- /dev/null +++ b/lib/Lintian/Check/Files/Vcs.pm @@ -0,0 +1,113 @@ +# files/vcs -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Files::Vcs; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +const my $VERTICAL_BAR => q{|}; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +# an OR (|) regex of all vcs files +has VCS_PATTERNS_ORED => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my @vcs_patterns; + + my $COMPRESS_FILE_EXTENSIONS + = $self->data->load('files/compressed-file-extensions',qr/\s+/); + + my @quoted_extension_patterns + = map { quotemeta } $COMPRESS_FILE_EXTENSIONS->all; + my $ored_extension_patterns= ored_patterns(@quoted_extension_patterns); + + my $VCS_CONTROL_PATTERNS + = $self->data->load('files/vcs-control-files', qr/\s+/); + + for my $pattern ($VCS_CONTROL_PATTERNS->all) { + $pattern =~ s/\$[{]COMPRESS_EXT[}]/(?:$ored_extension_patterns)/g; + push(@vcs_patterns, $pattern); + } + + my $ored_vcs_patterns = ored_patterns(@vcs_patterns); + + return $ored_vcs_patterns; + } +); + +sub ored_patterns { + my (@patterns) = @_; + + my @protected = map { "(?:$_)" } @patterns; + + my $ored = join($VERTICAL_BAR, @protected); + + return $ored; +} + +sub visit_installed_files { + my ($self, $item) = @_; + + if ($item->is_file) { + + my $pattern = $self->VCS_PATTERNS_ORED; + + $self->pointed_hint('package-contains-vcs-control-file',$item->pointer) + if $item->name =~ m{$pattern}x + && $item->name !~ m{^usr/share/cargo/registry/}; + + if ($item->name =~ m/svn-commit.*\.tmp$/) { + $self->pointed_hint('svn-commit-file-in-package', $item->pointer); + } + + if ($item->name =~ m/svk-commit.+\.tmp$/) { + $self->pointed_hint('svk-commit-file-in-package', $item->pointer); + } + + } elsif ($item->is_dir) { + + $self->pointed_hint('package-contains-vcs-control-dir', $item->pointer) + if $item->name =~ m{/CVS/?$} + || $item->name =~ m{/\.(?:svn|bzr|git|hg)/?$} + || $item->name =~ m{/\.arch-ids/?$} + || $item->name =~ m{/\{arch\}/?$}; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fonts.pm b/lib/Lintian/Check/Fonts.pm new file mode 100644 index 0000000..edb5c5c --- /dev/null +++ b/lib/Lintian/Check/Fonts.pm @@ -0,0 +1,92 @@ +# fonts -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fonts; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(any); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $SPACE => q{ }; +const my $LEFT_PARENTHESIS => q{(}; +const my $RIGHT_PARENTHESIS => q{)}; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + return + unless $item->basename + =~ m{ [\w-]+ [.] (?:[to]tf | pfb | woff2? | eot) (?:[.]gz)? $}ix; + + my $font = $item->basename; + + my $FONT_PACKAGES = $self->data->fonts; + + my @declared_shippers = $FONT_PACKAGES->installed_by($font); + + if (@declared_shippers) { + + # Fonts in xfonts-tipa are really shipped by tipa. + my @renamed + = map { $_ eq 'xfonts-tipa' ? 'tipa' : $_ } @declared_shippers; + + my $list + = $LEFT_PARENTHESIS + . join($SPACE, (sort @renamed)) + . $RIGHT_PARENTHESIS; + + $self->pointed_hint('duplicate-font-file', $item->pointer, 'also in', + $list) + unless (any { $_ eq $self->processable->name } @renamed) + || $self->processable->type eq 'udeb'; + + } else { + unless ($item->name =~ m{^usr/lib/R/site-library/}) { + + $self->pointed_hint('font-in-non-font-package', $item->pointer) + unless $self->processable->name =~ m/^(?:[ot]tf|t1|x?fonts)-/; + + $self->pointed_hint('font-outside-font-dir', $item->pointer) + unless $item->name =~ m{^usr/share/fonts/}; + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fonts/Opentype.pm b/lib/Lintian/Check/Fonts/Opentype.pm new file mode 100644 index 0000000..9ea5dac --- /dev/null +++ b/lib/Lintian/Check/Fonts/Opentype.pm @@ -0,0 +1,95 @@ +# fonts/opentype -- lintian check script -*- perl -*- + +# Copyright (C) 2019 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fonts::Opentype; + +use v5.20; +use warnings; +use utf8; +use autodie qw(open); + +use Const::Fast; +use Font::TTF::Font; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $SPACE => q{ }; +const my $COMMA => q{,}; + +const my $PERMISSIONS_MASK => 0x0f; +const my $NEVER_EMBED_FLAG => 0x02; +const my $PRINT_PREVIEW_ONLY_FLAG => 0x04; +const my $EDIT_ONLY_FLAG => 0x08; + +sub visit_installed_files { + my ($self, $file) = @_; + + return + unless $file->is_file; + + return + unless $file->file_type =~ /^OpenType font data/; + + $self->pointed_hint('opentype-font-wrong-filename', $file->pointer) + unless $file->name =~ /\.otf$/i; + + my $font = Font::TTF::Font->open($file->unpacked_path); + + my $os2 = defined $font ? $font->{'OS/2'} : undef; + my $table = defined $os2 ? $os2->read : undef; + my $fs_type = defined $table ? $table->{fsType} : undef; + + $font->release + if defined $font; + + return + unless defined $fs_type; + + my @clauses; + + my $permissions = $fs_type & $PERMISSIONS_MASK; + push(@clauses, 'never embed') + if $permissions & $NEVER_EMBED_FLAG; + push(@clauses, 'preview/print only') + if $permissions & $PRINT_PREVIEW_ONLY_FLAG; + push(@clauses, 'edit only') + if $permissions & $EDIT_ONLY_FLAG; + + my $terms; + $terms = join($COMMA . $SPACE, @clauses) + if @clauses; + + $self->pointed_hint('opentype-font-prohibits-installable-embedding', + $file->pointer, "($terms)") + if length $terms; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fonts/Postscript/Type1.pm b/lib/Lintian/Check/Fonts/Postscript/Type1.pm new file mode 100644 index 0000000..280eb8f --- /dev/null +++ b/lib/Lintian/Check/Fonts/Postscript/Type1.pm @@ -0,0 +1,130 @@ +# fonts/postscript/type1 -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fonts::Postscript::Type1; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Encode qw(decode); +use Syntax::Keyword::Try; + +use Lintian::IPC::Run3 qw(safe_qx); + +use Moo; +use namespace::clean; + +const my $SPACE => q{ }; +const my $COLON => q{:}; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + return + unless $item->file_type =~ m/PostScript Type 1 font program data/; + + my @command = ('t1disasm', $item->unpacked_path); + my $bytes = safe_qx(@command); + + my $output; + try { + # iso-8859-1 works too, but the Font 1 standard could be older + $output = decode('cp1252', $bytes, Encode::FB_CROAK); + + } catch { + die 'In file ' . $item->name . $COLON . $SPACE . $@; + } + + my @lines = split(/\n/, $output); + + my $foundadobeline = 0; + + for my $line (@lines) { + + if ($foundadobeline) { + if ( + $line =~ m{\A [%\s]* + All\s*Rights\s*Reserved\.?\s* + \Z}xsmi + ) { + $self->pointed_hint( + 'license-problem-font-adobe-copyrighted-fragment', + $item->pointer); + + last; + } + } + + $foundadobeline = 1 + if $line =~ m{\A + [%\s]*Copyright\s*\(c\) \s* + 19\d{2}[\-\s]19\d{2}\s* + Adobe\s*Systems\s*Incorporated\.?\s*\Z}xsmi; + +# If copy pasted from black book they are +# copyright adobe a few line before the only +# place where the startlock is documented is +# in the black book copyrighted fragment +# +# 2023-06-05: this check has been adjusted because +# Adobe's type hint code[1] (including Flex[2]) became +# open source[3] with an Apache-2.0 license[4] as +# committed on 2014-09-19, making that check a false +# positive[7]. +# +# We continue to check for copyrighted code that is not +# available under an open source license from the origin +# publication, "Adobe Type 1 Font Format"[5][6]. +# +# [1] - https://github.com/adobe-type-tools/afdko/blob/2bf85cf44a64148353b24db17e0cc41ede5493b1/FDK/Tools/Programs/public/lib/source/t1write/t1write_hintothers.h +# [2] - https://github.com/adobe-type-tools/afdko/blob/2bf85cf44a64148353b24db17e0cc41ede5493b1/FDK/Tools/Programs/public/lib/source/t1write/t1write_flexothers.h +# [3] - https://www.mail-archive.com/debian-bugs-dist@lists.debian.org/msg1375813.html +# [4] - https://github.com/adobe-type-tools/afdko/blob/2bf85cf44a64148353b24db17e0cc41ede5493b1/LICENSE.txt +# [5] - https://adobe-type-tools.github.io/font-tech-notes/pdfs/T1_SPEC.pdf +# [6] - https://lccn.loc.gov/90042516 +# [7] - https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=1029555 + if ($line =~ m/UniqueID\s*6859/) { + + $self->pointed_hint( + 'license-problem-font-adobe-copyrighted-fragment-no-credit', + $item->pointer); + + last; + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Fonts/Truetype.pm b/lib/Lintian/Check/Fonts/Truetype.pm new file mode 100644 index 0000000..71e120a --- /dev/null +++ b/lib/Lintian/Check/Fonts/Truetype.pm @@ -0,0 +1,95 @@ +# fonts/truetype -- lintian check script -*- perl -*- + +# Copyright (C) 2019 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Fonts::Truetype; + +use v5.20; +use warnings; +use utf8; +use autodie qw(open); + +use Const::Fast; +use Font::TTF::Font; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $SPACE => q{ }; +const my $COMMA => q{,}; + +const my $PERMISSIONS_MASK => 0x0f; +const my $NEVER_EMBED_FLAG => 0x02; +const my $PRINT_PREVIEW_ONLY_FLAG => 0x04; +const my $EDIT_ONLY_FLAG => 0x08; + +sub visit_installed_files { + my ($self, $file) = @_; + + return + unless $file->is_file; + + return + unless $file->file_type =~ /^TrueType Font data/; + + $self->pointed_hint('truetype-font-wrong-filename', $file->pointer) + unless $file->name =~ /\.ttf$/i; + + my $font = Font::TTF::Font->open($file->unpacked_path); + + my $os2 = defined $font ? $font->{'OS/2'} : undef; + my $table = defined $os2 ? $os2->read : undef; + my $fs_type = defined $table ? $table->{fsType} : undef; + + $font->release + if defined $font; + + return + unless defined $fs_type; + + my @clauses; + + my $permissions = $fs_type & $PERMISSIONS_MASK; + push(@clauses, 'never embed') + if $permissions & $NEVER_EMBED_FLAG; + push(@clauses, 'preview/print only') + if $permissions & $PRINT_PREVIEW_ONLY_FLAG; + push(@clauses, 'edit only') + if $permissions & $EDIT_ONLY_FLAG; + + my $terms; + $terms = join($COMMA . $SPACE, @clauses) + if @clauses; + + $self->pointed_hint('truetype-font-prohibits-installable-embedding', + $file->pointer, "($terms)") + if length $terms; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/ForeignOperatingSystems.pm b/lib/Lintian/Check/ForeignOperatingSystems.pm new file mode 100644 index 0000000..7f9fd7d --- /dev/null +++ b/lib/Lintian/Check/ForeignOperatingSystems.pm @@ -0,0 +1,63 @@ +# foreign-operating-systems -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::ForeignOperatingSystems; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + # Windows development files + $self->pointed_hint('windows-devel-file-in-package', $item->pointer) + if $item->name =~ m{/.+\.(?:vcproj|sln|ds[pw])(?:\.gz)?$} + && $item->name !~ m{^usr/share/doc/}; + + # autogenerated databases from other OSes + $self->pointed_hint('windows-thumbnail-database-in-package',$item->pointer) + if $item->name =~ m{/Thumbs\.db(?:\.gz)?$}i; + + $self->pointed_hint('macos-ds-store-file-in-package', $item->pointer) + if $item->name =~ m{/\.DS_Store(?:\.gz)?$}; + + $self->pointed_hint('macos-resource-fork-file-in-package', $item->pointer) + if $item->name =~ m{/\._[^_/][^/]*$} + && $item->name !~ m/\.swp$/; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Games.pm b/lib/Lintian/Check/Games.pm new file mode 100644 index 0000000..f9ca58a --- /dev/null +++ b/lib/Lintian/Check/Games.pm @@ -0,0 +1,90 @@ +# games -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Games; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + # non-games-specific data in games subdirectory + if ($item->name=~ m{^usr/share/games/(?:applications|mime|icons|pixmaps)/} + && !$item->is_dir) { + + $self->pointed_hint('global-data-in-games-directory', $item->pointer); + } + + return; +} + +sub dir_counts { + my ($self, $filename) = @_; + + my $item = $self->processable->installed->lookup($filename); + + return 0 + unless $item; + + return scalar $item->children; +} + +sub installable { + my ($self) = @_; + + my $section = $self->processable->fields->value('Section'); + + # section games but nothing in /usr/games + # any binary counts to avoid game-data false positives: + my $games = $self->dir_counts('usr/games/'); + my $other = $self->dir_counts('bin/') + $self->dir_counts('usr/bin/'); + + if ($other) { + if ($section =~ m{games$}) { + + if ($games) { + $self->hint('package-section-games-but-has-usr-bin'); + + } else { + $self->hint('package-section-games-but-contains-no-game'); + } + } + + } elsif ($games > 0 and $section !~ m{games$}) { + $self->hint('game-outside-section'); + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/GroupChecks.pm b/lib/Lintian/Check/GroupChecks.pm new file mode 100644 index 0000000..79150a1 --- /dev/null +++ b/lib/Lintian/Check/GroupChecks.pm @@ -0,0 +1,282 @@ +# group-checks -- lintian check script -*- perl -*- + +# Copyright (C) 2011 Niels Thykier <niels@thykier.net> +# Copyright (C) 2018 Chris Lamb <lamby@debian.org> +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::GroupChecks; + +use v5.20; +use warnings; +use utf8; + +use List::SomeUtils qw(any); + +use Lintian::Relation; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $group = $self->group; + + ## To find circular dependencies, we will first generate Strongly + ## Connected Components using Tarjan's algorithm + ## + ## We are not using DepMap, because it cannot tell how the circles + ## are made - only that there exists at least 1 circle. + + # The packages a.k.a. nodes + my (@nodes, %edges, $sccs); + my @installables = grep { $_->type ne 'udeb' } $group->get_installables; + + $self->check_file_overlap(@installables); + + for my $installable (@installables) { + + my $deps = $group->direct_dependencies($installable); + if (scalar @{$deps} > 0) { + # it depends on another package - it can cause + # a circular dependency + my $pname = $installable->name; + push @nodes, $pname; + $edges{$pname} = [map { $_->name } @{$deps}]; + $self->check_multiarch($installable, $deps); + } + } + + # Bail now if we do not have at least two packages depending + # on some other package from this source. + return if scalar @nodes < 2; + + $sccs= Lintian::Check::GroupChecks::Graph->new(\@nodes, \%edges)->tarjans; + + for my $comp (@{$sccs}) { + # It takes two to tango... erh. make a circular dependency. + next if scalar @{$comp} < 2; + + $self->hint('intra-source-package-circular-dependency', + (sort @{$comp})); + } + + return; +} + +sub check_file_overlap { + my ($self, @processables) = @_; + + # make a local copy to be modified + my @remaining = @processables; + + # avoids checking the same combo twice + while (@remaining > 1) { + + # avoids checking the same combo twice + my $one = shift @remaining; + + my @provides_one = $one->fields->trimmed_list('Provides', qr{,}); + my $relation_one = Lintian::Relation->new->load( + join(' | ', $one->name, @provides_one)); + + for my $two (@remaining) { + + # poor man's work-around for "Multi-arch: same" + next + if $one->name eq $two->name; + + my @provides_two = $two->fields->trimmed_list('Provides', qr{,}); + my $relation_two = Lintian::Relation->new->load( + join(' | ', $two->name, @provides_two)); + + # $two conflicts/replaces with $one + next + if $two->relation('Conflicts')->satisfies($relation_one); + next + if $two->relation('Replaces')->satisfies($one->name); + + # $one conflicts/replaces with $two + next + if $one->relation('Conflicts')->satisfies($relation_two); + next + if $one->relation('Replaces')->satisfies($two->name); + + for my $one_file (@{$one->installed->sorted_list}) { + + my $name = $one_file->name; + + $name =~ s{/$}{}; + my $two_file = $two->installed->lookup($name) + // $two->installed->lookup("$name/"); + next + unless defined $two_file; + + next + if $one_file->is_dir && $two_file->is_dir; + + $self->hint('binaries-have-file-conflict', + sort($one->name, $two->name), $name); + } + } + } + + return; +} + +sub check_multiarch { + my ($self, $processable, $deps) = @_; + + my $KNOWN_DBG_PACKAGE= $self->data->load('common/dbg-pkg',qr/\s*\~\~\s*/); + + my $ma = $processable->fields->value('Multi-Arch') || 'no'; + if ($ma eq 'same') { + for my $dep (@{$deps}) { + my $dma = $dep->fields->value('Multi-Arch') || 'no'; + if ($dma eq 'same' or $dma eq 'foreign') { + 1; # OK + } else { + $self->hint( + 'dependency-is-not-multi-archified', + join(q{ }, + $processable->name, 'depends on', + $dep->name, "(multi-arch: $dma)") + ); + } + } + } elsif ($ma ne 'same' + and ($processable->fields->value('Section') || 'none') + =~ m{(?:^|/)debug$}) { + # Debug package that isn't M-A: same, exploit that (non-debug) + # dependencies is (almost certainly) a package for which the + # debug carries debug symbols. + for my $dep (@{$deps}) { + my $dma = $dep->fields->value('Multi-Arch') || 'no'; + if ($dma eq 'same' + && ($dep->fields->value('Section') || 'none') + !~ m{(?:^|/)debug$}){ + + # Debug package isn't M-A: same, but depends on a + # package that is from same source that isn't a debug + # package and that is M-A same. Thus it is not + # possible to install debug symbols for all + # (architecture) variants of the binaries. + $self->hint( + 'debug-package-for-multi-arch-same-pkg-not-coinstallable', + $processable->name . ' => ' . $dep->name + ) + unless any { $processable->name =~ m/$_/xms } + $KNOWN_DBG_PACKAGE->all; + } + } + } + return; +} + +## Encapsulate Tarjan's algorithm in a class/object to keep +## the run sub somewhat sane. Allow this "extra" package as +## it is not a proper subclass. +#<<< no Perl tidy (it breaks the no critic comment) +package Lintian::Check::GroupChecks::Graph; ## no critic (Modules::ProhibitMultiplePackages) +#>>> + +use Const::Fast; + +const my $EMPTY => q{}; + +sub new { + my ($type, $nodes, $edges) = @_; + my $self = { nodes => $nodes, edges => $edges}; + bless $self, $type; + return $self; +} + +sub tarjans { + my ($self) = @_; + my $nodes = $self->{nodes}; + $self->{index} = 0; + $self->{scc} = []; + $self->{stack} = []; + $self->{on_stack} = {}; + # The information for each node: + # $self->{node_info}{$node}[X], where X is: + # 0 => index + # 1 => low_index + $self->{node_info} = {}; + for my $node (@{$nodes}) { + $self->_tarjans_sc($node) + unless defined $self->{node_info}{$node}; + } + return $self->{scc}; +} + +sub _tarjans_sc { + my ($self, $node) = @_; + my $index = $self->{index}; + my $stack = $self->{stack}; + my $ninfo = [$index, $index]; + my $on_stack = $self->{on_stack}; + $self->{node_info}{$node} = $ninfo; + $index++; + $self->{index} = $index; + push(@{$stack}, $node); + $on_stack->{$node} = 1; + + foreach my $neighbour (@{ $self->{edges}{$node} }){ + my $nb_info; + $nb_info = $self->{node_info}{$neighbour}; + if (!defined $nb_info){ + # First time visit + $self->_tarjans_sc($neighbour); + # refresh $nb_info + $nb_info = $self->{node_info}{$neighbour}; + # min($node.low_index, $neigh.low_index) + $ninfo->[1] = $nb_info->[1] if $nb_info->[1] < $ninfo->[1]; + } elsif (exists $on_stack->{$neighbour}) { + # Node is in this component + # min($node.low_index, $neigh.index) + $ninfo->[1] = $nb_info->[0] if $nb_info->[0] < $ninfo->[1]; + } + } + if ($ninfo->[0] == $ninfo->[1]){ + # the "root" node - create the SSC. + my $component = []; + my $scc = $self->{scc}; + my $elem = $EMPTY; + + do { + $elem = pop @{$stack}; + delete $on_stack->{$elem}; + push(@{$component}, $elem); + + } until $node eq $elem; + + push(@{$scc}, $component); + } + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/HugeUsrShare.pm b/lib/Lintian/Check/HugeUsrShare.pm new file mode 100644 index 0000000..0043586 --- /dev/null +++ b/lib/Lintian/Check/HugeUsrShare.pm @@ -0,0 +1,98 @@ +# huge-usr-share -- lintian check script -*- perl -*- + +# Copyright (C) 2004 Jeroen van Wolffelaar <jeroen@wolffelaar.nl> +# Copyright (C) 2018 Chris Lamb <lamby@debian.org> +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::HugeUsrShare; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +# Threshold in kB of /usr/share to trigger this warning. Consider that the +# changelog alone can be quite big, and cannot be moved away. +const my $KIB_SIZE_FACTOR => 1024; +const my $THRESHOLD_SIZE_SOFT => 4096; +const my $THRESHOLD_SIZE_HARD => 8192; +const my $PERCENT => 100; +const my $THRESHOLD_PERCENTAGE => 50; + +has total_size => (is => 'rw', default => 0); +has usrshare_size => (is => 'rw', default => 0); + +sub visit_installed_files { + my ($self, $file) = @_; + + return + unless $file->is_regular_file; + + # space taken up by package + $self->total_size($self->total_size + $file->size); + + # space taken up in /usr/share. + $self->usrshare_size($self->usrshare_size + $file->size) + if $file =~ m{^usr/share/}; + + return; +} + +sub installable { + my ($self) = @_; + + # skip architecture-dependent packages. + my $arch = $self->processable->fields->value('Architecture'); + return + if $arch eq 'all'; + + # meaningless; prevents division by zero + return + if $self->total_size == 0; + + # convert the totals to kilobytes. + my $size = sprintf('%.0f', $self->total_size / $KIB_SIZE_FACTOR); + my $size_usrshare + = sprintf('%.0f', $self->usrshare_size / $KIB_SIZE_FACTOR); + my $percentage + = sprintf('%.0f', ($self->usrshare_size / $self->total_size) * $PERCENT); + + $self->hint( + 'arch-dep-package-has-big-usr-share', + "${size_usrshare}kB $percentage%" + ) + if ( $percentage > $THRESHOLD_PERCENTAGE + && $size_usrshare > $THRESHOLD_SIZE_SOFT) + || $size_usrshare > $THRESHOLD_SIZE_HARD; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Images.pm b/lib/Lintian/Check/Images.pm new file mode 100644 index 0000000..47021d1 --- /dev/null +++ b/lib/Lintian/Check/Images.pm @@ -0,0 +1,49 @@ +# images -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Images; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + $self->pointed_hint('image-file-in-usr-lib', $item->pointer) + if $item->name =~ m{^usr/lib/} + && $item->name =~ m{\.(?:bmp|gif|jpe?g|png|tiff|x[pb]m)$} + && !length $item->link; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Images/Filenames.pm b/lib/Lintian/Check/Images/Filenames.pm new file mode 100644 index 0000000..d728cc6 --- /dev/null +++ b/lib/Lintian/Check/Images/Filenames.pm @@ -0,0 +1,126 @@ +# images/filenames -- lintian check script -*- perl -*- + +# Copyright (C) 2019 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Images::Filenames; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +my @image_formats = ( + { + name => 'PNG', + file_type => qr/^PNG image data/, + good_name => sub { $_[0] =~ /\.(?:png|PNG)$/ } + }, + { + name => 'JPEG', + file_type => qr/^JPEG image data/, + good_name => sub { $_[0] =~ /\.(?:jpe?g|JPE?G)$/ } + }, + { + name => 'GIF', + file_type => qr/^GIF image data/, + good_name => sub { $_[0] =~ /\.(?:gif|GIF)$/ } + }, + { + name => 'TIFF', + file_type => qr/^TIFF image data/, + good_name => sub { $_[0] =~ /\.(?:tiff?|TIFF?)$/ } + }, + { + name => 'XPM', + file_type => qr/^X pixmap image/, + good_name => sub { $_[0] =~ /\.(?:xpm|XPM)$/ } + }, + { + name => 'Netpbm', + file_type => qr/^Netpbm image data/, + good_name => sub { $_[0] =~ /\.(?:p[bgpn]m|P[BGPN]M)$/ } + }, + { + name => 'SVG', + file_type => qr/^SVG Scalable Vector Graphics image/, + good_name => sub { $_[0] =~ /\.(?:svg|SVG)$/ } + }, +); + +# ICO format developed into a container and may contain PNG + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + my $our_format; + + for my $format (@image_formats) { + + if ($item->file_type =~ $format->{file_type}) { + $our_format = $format; + last; + } + } + + # not an image + return + unless $our_format; + + return + if $our_format->{good_name}->($item->name); + + my $conflicting_format; + + my @other_formats = grep { $_ != $our_format } @image_formats; + for my $format (@other_formats) { + + if ($format->{good_name}->($item->name)) { + $conflicting_format = $format; + last; + } + } + + if ($conflicting_format) { + + $self->pointed_hint('image-file-has-conflicting-name', + $item->pointer, '(is ' . $our_format->{name} . ')') + unless $our_format->{good_name}->($item->name); + + } else { + $self->pointed_hint('image-file-has-unexpected-name', + $item->pointer, '(is ' . $our_format->{name} . ')'); + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Images/Thumbnails.pm b/lib/Lintian/Check/Images/Thumbnails.pm new file mode 100644 index 0000000..c8cc430 --- /dev/null +++ b/lib/Lintian/Check/Images/Thumbnails.pm @@ -0,0 +1,56 @@ +# images/thumbnails -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Images::Thumbnails; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + if ( $item->is_dir + && $item->name =~ m{/\.xvpics/?$}) { + + $self->pointed_hint('package-contains-xvpics-dir', $item->pointer); + } + + if ( $item->is_dir + && $item->name =~ m{/\.thumbnails/?$}) { + + $self->pointed_hint('package-contains-thumbnails-dir', $item->pointer); + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Includes/ConfigH.pm b/lib/Lintian/Check/Includes/ConfigH.pm new file mode 100644 index 0000000..b854a31 --- /dev/null +++ b/lib/Lintian/Check/Includes/ConfigH.pm @@ -0,0 +1,56 @@ +# includes/config-h -- lintian check script -*- perl -*- + +# Copyright (C) 2019 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Includes::ConfigH; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + return + unless $item->name =~ m{^ usr/include/ }x; + + return + unless $item->name =~ m{ /config.h $}x; + + $self->hint('package-name-defined-in-config-h', $item->name) + if $item->bytes =~ m{ \b PACKAGE_NAME \b }x; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/InitD.pm b/lib/Lintian/Check/InitD.pm new file mode 100644 index 0000000..304c186 --- /dev/null +++ b/lib/Lintian/Check/InitD.pm @@ -0,0 +1,733 @@ +# init.d -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz +# Copyright (C) 2016-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::InitD; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use File::Basename qw(dirname); +use List::Compare; +use List::SomeUtils qw(any none); +use Unicode::UTF8 qw(encode_utf8); + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $DOLLAR => q{$}; + +const my $RUN_LEVEL_6 => 6; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +# A list of valid LSB keywords. The value is 0 if optional and 1 if required. +my %LSB_KEYWORDS = ( + provides => 1, + 'required-start' => 1, + 'required-stop' => 1, + 'should-start' => 0, + 'should-stop' => 0, + 'default-start' => 1, + 'default-stop' => 1, + # These two are actually optional, but we mark + # them as required and give them a weaker tag if + # they are missing. + 'short-description' => 1, + 'description' => 1 +); + +# These init script names should probably not be used in dependencies. +# Instead, the corresponding virtual facility should be used. +# +# checkroot is not included here since cryptsetup needs the root file system +# mounted but not any other local file systems and therefore correctly depends +# on checkroot. There may be other similar situations. +my %implied_dependencies = ( + 'mountall' => $DOLLAR . 'local_fs', + 'mountnfs' => $DOLLAR . 'remote_fs', + + 'hwclock' => $DOLLAR . 'time', + 'portmap' => $DOLLAR . 'portmap', + 'named' => $DOLLAR . 'named', + 'bind9' => $DOLLAR . 'named', + 'networking' => $DOLLAR . 'network', + 'syslog' => $DOLLAR . 'syslog', + 'rsyslog' => $DOLLAR . 'syslog', + 'sysklogd' => $DOLLAR . 'syslog' +); + +# Regex to match names of init.d scripts; it is a bit more lax than +# package names (e.g. allows "_"). We do not allow it to start with a +# "dash" to avoid confusing it with a command-line option (also, +# update-rc.d does not allow this). +our $INITD_NAME_REGEX = qr/[\w\.\+][\w\-\.\+]*/; + +my $OPTS_R = qr/-\S+\s*/; +my $ACTION_R = qr/\w+/; +my $EXCLUDE_R = qr/if\s+\[\s+-x\s+\S*update-rc\.d/; + +sub installable { + my ($self) = @_; + + my $pkg = $self->processable->name; + my $processable = $self->processable; + + my $initd_dir = $processable->installed->resolve_path('etc/init.d/'); + my $postinst = $processable->control->lookup('postinst'); + my $preinst = $processable->control->lookup('preinst'); + my $postrm = $processable->control->lookup('postrm'); + my $prerm = $processable->control->lookup('prerm'); + + my (%initd_postinst, %initd_postrm); + + # These will never be regular initscripts. (see #918459, #933383 + # and #941140 etc.) + return + if $pkg eq 'initscripts' + || $pkg eq 'sysvinit'; + + # read postinst control file + if ($postinst and $postinst->is_file and $postinst->is_open_ok) { + + open(my $fd, '<', $postinst->unpacked_path) + or die encode_utf8('Cannot open ' . $postinst->unpacked_path); + + my $position = 1; + while (my $line = <$fd>) { + + next + if $line =~ /$EXCLUDE_R/; + + $line =~ s/\#.*$//; + + next + unless $line =~ m{^(?:.+;|^\s*system[\s\(\']+)?\s*update-rc\.d\s+ + (?:$OPTS_R)*($INITD_NAME_REGEX)\s+($ACTION_R)}x; + + my ($name,$opt) = ($1,$2); + next + if $opt eq 'remove'; + + my $pointer = $postinst->pointer($position); + + if ($initd_postinst{$name}++ == 1) { + + $self->pointed_hint('duplicate-updaterc.d-calls-in-postinst', + $pointer, $name); + next; + } + + $self->pointed_hint( + 'output-of-updaterc.d-not-redirected-to-dev-null', + $pointer, $name) + unless $line =~ m{>\s*/dev/null}; + + } continue { + ++$position; + } + + close $fd; + } + + # read preinst control file + if ($preinst and $preinst->is_file and $preinst->is_open_ok) { + + open(my $fd, '<', $preinst->unpacked_path) + or die encode_utf8('Cannot open ' . $preinst->unpacked_path); + + my $position = 1; + while (my $line = <$fd>) { + + next + if $line =~ /$EXCLUDE_R/; + + $line =~ s/\#.*$//; + next + unless $line =~ m{update-rc\.d \s+ + (?:$OPTS_R)*($INITD_NAME_REGEX) \s+ + ($ACTION_R)}x; + + my $name = $1; + my $option = $2; + next + if $option eq 'remove'; + + my $pointer = $preinst->pointer($position); + + $self->pointed_hint('preinst-calls-updaterc.d', + $pointer, $name, $option); + + } continue { + ++$position; + } + + close $fd; + } + + # read postrm control file + if ($postrm and $postrm->is_file and $postrm->is_open_ok) { + + open(my $fd, '<', $postrm->unpacked_path) + or die encode_utf8('Cannot open ' . $postrm->unpacked_path); + + my $position = 1; + while (my $line = <$fd>) { + + next + if $line =~ /$EXCLUDE_R/; + + $line =~ s/\#.*$//; + + next + unless $line =~ /update-rc\.d\s+(?:$OPTS_R)*($INITD_NAME_REGEX)/; + + my $name = $1; + + my $pointer = $postrm->pointer($position); + + if ($initd_postrm{$name}++ == 1) { + + $self->pointed_hint('duplicate-updaterc.d-calls-in-postrm', + $pointer, $name); + next; + } + + $self->pointed_hint( + 'output-of-updaterc.d-not-redirected-to-dev-null', + $pointer, $name) + unless $line =~ m{>\s*/dev/null}; + + } continue { + ++$position; + } + + close $fd; + } + + # read prerm control file + if ($prerm and $prerm->is_file and $prerm->is_open_ok) { + + open(my $fd, '<', $prerm->unpacked_path) + or die encode_utf8('Cannot open ' . $prerm->unpacked_path); + + my $position = 1; + while (my $line = <$fd>) { + + next + if $line =~ /$EXCLUDE_R/; + + $line =~ s/\#.*$//; + + next + unless $line =~ /update-rc\.d\s+(?:$OPTS_R)*($INITD_NAME_REGEX)/; + + my $name = $1; + + my $pointer = $prerm->pointer($position); + + $self->pointed_hint('prerm-calls-updaterc.d', $pointer, $name); + + } continue { + ++$position; + } + + close $fd; + } + + # init.d scripts have to be removed in postrm + for (keys %initd_postinst) { + if ($initd_postrm{$_}) { + delete $initd_postrm{$_}; + } else { + + $self->pointed_hint( + 'postrm-does-not-call-updaterc.d-for-init.d-script', + $postrm->pointer, "etc/init.d/$_"); + } + } + + for (keys %initd_postrm) { + $self->pointed_hint('postrm-contains-additional-updaterc.d-calls', + $postrm->pointer, "etc/init.d/$_"); + } + + for my $initd_file (keys %initd_postinst) { + + my $item; + $item = $initd_dir->child($initd_file) + if $initd_dir; + + unless ( + (defined $item && $item->resolve_path) + ||( defined $item + && $item->is_symlink + && $item->link eq '/lib/init/upstart-job') + ) { + + $self->hint('init.d-script-not-included-in-package', + "etc/init.d/$initd_file"); + + next; + } + + # init.d scripts have to be marked as conffiles unless they're + # symlinks. + $self->hint('init.d-script-not-marked-as-conffile', + "etc/init.d/$initd_file") + if !defined $item + || ( !$processable->declared_conffiles->is_known($item->name) + && !$item->is_symlink); + + # Check if file exists in package and check the script for + # other issues if it was included in the package. + $self->check_init($item); + } + $self->check_defaults; + + return + unless defined $initd_dir && $initd_dir->is_dir; + + # files actually installed in /etc/init.d should match our list :-) + for my $script ($initd_dir->children) { + + next + if !$script->is_dir + && (any {$script->basename eq $_}qw(README skeleton rc rcS)); + + my $tag_name = 'script-in-etc-init.d-not-registered-via-update-rc.d'; + + # In an upstart system, such as Ubuntu, init scripts are symlinks to + # upstart-job which are not registered with update-rc.d. + $tag_name= 'upstart-job-in-etc-init.d-not-registered-via-update-rc.d' + if $script->is_symlink + && $script->link eq '/lib/init/upstart-job'; + + # If $initd_postinst is true for this script, we already + # checked the syntax in the above loop. Check the syntax of + # unregistered scripts so that we get more complete Lintian + # coverage in the first pass. + unless ($initd_postinst{$script->basename}) { + + $self->pointed_hint($tag_name, $script->pointer); + $self->check_init($script); + } + } + + return; +} + +sub check_init { + my ($self, $item) = @_; + + my $processable = $self->processable; + + # In an upstart system, such as Ubuntu, init scripts are symlinks to + # upstart-job. It doesn't make sense to check the syntax of upstart-job, + # so skip the checks of the init script itself in that case. + return + if $item->is_symlink + && $item->link eq '/lib/init/upstart-job'; + + return + unless $item->is_open_ok; + + my %saw_command; + my %value_by_lsb_keyword; + my $in_file_test = 0; + my $needs_fs = 0; + + if ($item->interpreter eq '/lib/init/init-d-script') { + $saw_command{$_} = 1 for qw{start stop restart force-reload status}; + } + + $self->pointed_hint('init.d-script-uses-usr-interpreter', + $item->pointer(1), $item->interpreter) + if $item->interpreter =~ m{^ /usr/ }x; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $position = 1; + while (my $line = <$fd>) { + + $self->pointed_hint('init.d-script-contains-skeleton-template-content', + $item->pointer($position)) + if $line =~ m{Please remove the "Author" lines|Example initscript}; + + if ($line =~ m/^\#\#\# BEGIN INIT INFO/) { + + if (defined $value_by_lsb_keyword{BEGIN}) { + + $self->pointed_hint('init.d-script-has-duplicate-lsb-section', + $item->pointer($position)); + next; + } + + $value_by_lsb_keyword{BEGIN} = [1]; + my $final; + + # We have an LSB keyword section. Parse it and save the data + # in %value_by_lsb_keyword for analysis. + while (my $other_line = <$fd>) { + + # nested while + ++$position; + + if ($other_line =~ /^\#\#\# END INIT INFO/) { + $value_by_lsb_keyword{END} = [1]; + last; + + } elsif ($other_line !~ /^\#/) { + $self->pointed_hint( + 'init.d-script-has-unterminated-lsb-section', + $item->pointer($position)); + last; + + } elsif ($other_line =~ /^\# ([a-zA-Z-]+):\s*(.*?)\s*$/) { + + my $keyword = lc $1; + my $value = $2 // $EMPTY; + + $self->pointed_hint( + 'init.d-script-has-duplicate-lsb-keyword', + $item->pointer($position), $keyword) + if defined $value_by_lsb_keyword{$keyword}; + + $self->pointed_hint( + 'init.d-script-has-unknown-lsb-keyword', + $item->pointer($position), $keyword) + unless exists $LSB_KEYWORDS{$keyword} + || $keyword =~ /^x-/; + + $value_by_lsb_keyword{$keyword} = [split($SPACE, $value)]; + $final = $keyword; + + } elsif ($other_line =~ /^\#(\t| )/ + && $final eq 'description') { + + my $value = $other_line; + $value =~ s/^\#\s*//; + $value_by_lsb_keyword{description} .= $SPACE . $value; + + } else { + $self->pointed_hint('init.d-script-has-bad-lsb-line', + $item->pointer($position)); + } + } + } + + # Pretty dummy way to handle conditionals, but should be enough + # for simple init scripts + $in_file_test = 1 + if $line + =~ m{ \b if \s+ .*? (?:test|\[) (?: \s+ \! )? \s+ - [efr] \s+ }x; + + $in_file_test = 0 + if $line =~ m{ \b fi \b }x; + + if ( !$in_file_test + && $line =~ m{^\s*\.\s+["'"]?(/etc/default/[\$\w/-]+)}){ + my $sourced = $1; + + $self->pointed_hint('init.d-script-sourcing-without-test', + $item->pointer($position), $sourced); + } + + # Some init.d scripts source init-d-script, since (e.g.) + # kFreeBSD does not allow shell scripts as interpreters. + if ($line =~ m{\. /lib/init/init-d-script}) { + $saw_command{$_} = 1 + for qw{start stop restart force-reload status}; + } + + # This should be more sophisticated: ignore heredocs, ignore quoted + # text and the arguments to echo, etc. + $needs_fs = 1 + if $line =~ m{^[^\#]*/var/}; + + while ($line =~ s/^[^\#]*?(start|stop|restart|force-reload|status)//) { + $saw_command{$1} = 1; + } + + # nested while + } continue { + ++$position; + } + + close $fd; + + # Make sure all of the required keywords are present. + if (!defined $value_by_lsb_keyword{BEGIN}) { + $self->pointed_hint('init.d-script-missing-lsb-section', + $item->pointer); + + } else { + for my $keyword (keys %LSB_KEYWORDS) { + + if ($LSB_KEYWORDS{$keyword} + && !defined $value_by_lsb_keyword{$keyword}) { + + if ($keyword eq 'short-description') { + $self->pointed_hint( + 'init.d-script-missing-lsb-short-description', + $item->pointer); + + } elsif ($keyword eq 'description') { + next; + + } else { + $self->pointed_hint('init.d-script-missing-lsb-keyword', + $item->pointer, $keyword); + } + } + } + } + + # Check the runlevels. + my %start; + + for my $runlevel (@{$value_by_lsb_keyword{'default-start'} // []}) { + + if ($runlevel =~ /^[sS0-6]$/) { + + $start{lc $runlevel} = 1; + + $self->pointed_hint('init.d-script-starts-in-stop-runlevel', + $item->pointer, $runlevel) + if $runlevel eq '0' + || $runlevel eq '6'; + + } else { + $self->pointed_hint('init.d-script-has-bad-start-runlevel', + $item->pointer, $runlevel); + } + } + + # No script should start at one of the 2-5 runlevels but not at + # all of them + my $start = join($SPACE, (sort grep { /^[2-5]$/ } keys %start)); + + if (length($start) > 0 and $start ne '2 3 4 5') { + my @missing = grep { !exists $start{$_} } qw(2 3 4 5); + + $self->pointed_hint('init.d-script-missing-start', $item->pointer, + @missing); + } + + my %stop; + + for my $runlevel (@{$value_by_lsb_keyword{'default-stop'} // []}) { + + if ($runlevel =~ /^[sS0-6]$/) { + + $stop{$runlevel} = 1 + unless $runlevel =~ /[sS2-5]/; + + $self->pointed_hint('init.d-script-has-conflicting-start-stop', + $item->pointer, $runlevel) + if exists $start{$runlevel}; + + $self->pointed_hint('init-d-script-stops-in-s-runlevel', + $item->pointer) + if $runlevel =~ /[sS]/; + + } else { + $self->pointed_hint('init.d-script-has-bad-stop-runlevel', + $item->pointer, $runlevel); + } + } + + if (none { $item->basename eq $_ } qw(killprocs sendsigs halt reboot)) { + + my @required = (0, 1, $RUN_LEVEL_6); + my $stop_lc = List::Compare->new(\@required, [keys %stop]); + + my @have_some = $stop_lc->get_intersection; + my @missing = $stop_lc->get_Lonly; + + # Scripts that stop in any of 0, 1, or 6 probably should stop in all + # of them, with some special exceptions. + $self->pointed_hint('init.d-script-possible-missing-stop', + $item->pointer, (sort @missing)) + if @have_some + && @missing + && (%start != 1 || !exists $start{s}); + } + + my $provides_self = 0; + for my $facility (@{$value_by_lsb_keyword{'provides'} // []}) { + + $self->pointed_hint('init.d-script-provides-virtual-facility', + $item->pointer, $facility) + if $facility =~ /^\$/; + + $provides_self = 1 + if $item->basename =~/^\Q$facility\E(?:.sh)?$/; + } + + $self->pointed_hint('init.d-script-does-not-provide-itself',$item->pointer) + if defined $value_by_lsb_keyword{'provides'} + && !$provides_self; + + # Separately check Required-Start and Required-Stop, since while they're + # similar, they're not quite identical. This could use some further + # restructuring by pulling the regexes out as data tied to start/stop and + # remote/local and then combining the loops. + if (@{$value_by_lsb_keyword{'default-start'} // []}) { + + my @required = @{$value_by_lsb_keyword{'required-start'} // []}; + + if ($needs_fs) { + if (none { /^\$(?:local_fs|remote_fs|all)\z/ } @required) { + + $self->pointed_hint( + 'init.d-script-missing-dependency-on-local_fs', + $item->pointer, 'required-start'); + } + } + } + + if (@{$value_by_lsb_keyword{'default-stop'} // []}) { + + my @required = @{$value_by_lsb_keyword{'required-stop'} // []}; + + if ($needs_fs) { + if (none { /^(?:\$(?:local|remote)_fs|\$all|umountn?fs)\z/ } + @required) { + + $self->pointed_hint( + 'init.d-script-missing-dependency-on-local_fs', + $item->pointer, 'required-stop'); + } + } + } + + my $VIRTUAL_FACILITIES= $self->data->virtual_initd_facilities; + + # Check syntax rules that apply to all of the keywords. + for + my $keyword (qw(required-start should-start required-stop should-stop)){ + for my $prerequisite (@{$value_by_lsb_keyword{$keyword} // []}) { + + if (exists $implied_dependencies{$prerequisite}) { + + $self->pointed_hint('non-virtual-facility-in-initd-script', + $item->pointer, + "$prerequisite -> $implied_dependencies{$prerequisite}"); + + } elsif ($keyword =~ m/^required-/ && $prerequisite =~ m/^\$/) { + + $self->pointed_hint( + 'init.d-script-depends-on-unknown-virtual-facility', + $item->pointer, $prerequisite) + unless ($VIRTUAL_FACILITIES->recognizes($prerequisite)); + } + + $self->pointed_hint( + 'init.d-script-depends-on-all-virtual-facility', + $item->pointer, $keyword) + if $prerequisite =~ m/^\$all$/; + } + } + + my @required_commands = qw{start stop restart force-reload}; + my $command_lc + = List::Compare->new(\@required_commands, [keys %saw_command]); + my @missing_commands = $command_lc->get_Lonly; + + # all tags included in file? + $self->pointed_hint('init.d-script-does-not-implement-required-option', + $item->pointer, $_) + for @missing_commands; + + $self->pointed_hint('init.d-script-does-not-implement-status-option', + $item->pointer) + unless $saw_command{'status'}; + + return; +} + +sub check_defaults { + my ($self) = @_; + + my $processable = $self->processable; + + my $dir = $processable->installed->resolve_path('etc/default/'); + return + unless $dir && $dir->is_dir; + + for my $item ($dir->children) { + + return + unless $item->is_open_ok; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $position = 1; + while (my $line = <$fd>) { + + $self->pointed_hint('init.d-script-should-always-start-service', + $item->pointer($position)) + if $line + =~ m{^ \s* [#]* \s* (?:[A-Z]_)? (?:ENABLED|DISABLED|[A-Z]*RUN | (?:NO_)? START) = }x; + + } continue { + ++$position; + } + + close $fd; + } + + return; +} + +sub visit_installed_files { + my ($self, $item) = @_; + + if ($item =~ m{etc/sv/([^/]+)/$}) { + + my $service = $1; + my $runfile + = $self->processable->installed->resolve_path( + "etc/sv/${service}/run"); + + $self->pointed_hint( + 'directory-in-etc-sv-directory-without-executable-run-script', + $item->pointer, $runfile) + unless defined $runfile && $runfile->is_executable; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/InitD/MaintainerScript.pm b/lib/Lintian/Check/InitD/MaintainerScript.pm new file mode 100644 index 0000000..b44d103 --- /dev/null +++ b/lib/Lintian/Check/InitD/MaintainerScript.pm @@ -0,0 +1,147 @@ +# init-d/maintainer-script -- lintian check script -*- perl -*- +# +# Copyright (C) 1998 Richard Braakman +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::InitD::MaintainerScript; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; + +sub visit_control_files { + my ($self, $item) = @_; + + return + unless $item->is_maintainer_script; + + return + unless length $item->interpreter; + + return + unless $item->is_open_ok; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $stashed = $EMPTY; + + my $saw_init = 0; + my $saw_invoke = 0; + + my $position = 1; + while (my $possible_continuation = <$fd>) { + + chomp $possible_continuation; + + # skip empty lines + next + if $possible_continuation =~ /^\s*$/; + + # skip comment lines + next + if $possible_continuation =~ /^\s*\#/; + + my $no_comment = remove_comments($possible_continuation); + + # Concatenate lines containing continuation character (\) + # at the end + if ($no_comment =~ s{\\$}{}) { + + $stashed .= $no_comment; + + next; + } + + my $line = $stashed . $no_comment; + $stashed = $EMPTY; + # Collect information about init script invocations to + # catch running init scripts directly rather than through + # invoke-rc.d. Since the script is allowed to run the + # init script directly if invoke-rc.d doesn't exist, only + # tag direct invocations where invoke-rc.d is never used + # in the same script. Lots of false negatives, but + # hopefully not many false positives. + $saw_init = $position + if $line =~ m{^\s*/etc/init\.d/(?:\S+)\s+[\"\']?(?:\S+)[\"\']?}; + + $saw_invoke = $position + if $line =~ m{^\s*invoke-rc\.d\s+}; + + } continue { + ++$position; + } + + if ($saw_init && !$saw_invoke) { + + my $pointer = $item->pointer($saw_init); + + $self->pointed_hint('maintainer-script-calls-init-script-directly', + $pointer); + } + + return; +} + +sub remove_comments { + my ($line) = @_; + + return $line + unless length $line; + + my $simplified = $line; + + # Remove quoted strings so we can more easily ignore comments + # inside them + $simplified =~ s/(^|[^\\](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g; + $simplified =~ s/(^|[^\\](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g; + + # If the remaining string contains what looks like a comment, + # eat it. In either case, swap the unmodified script line + # back in for processing (if required) and return it. + if ($simplified =~ m/(?:^|[^[\\])[\s\&;\(\)](\#.*$)/) { + + my $comment = $1; + + # eat comment + $line =~ s/\Q$comment\E//; + } + + return $line; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Fortran/Gfortran.pm b/lib/Lintian/Check/Languages/Fortran/Gfortran.pm new file mode 100644 index 0000000..6479d8a --- /dev/null +++ b/lib/Lintian/Check/Languages/Fortran/Gfortran.pm @@ -0,0 +1,94 @@ +# languages/fortran/gfortran -- lintian check script -*- perl -*- + +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Fortran::Gfortran; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Unicode::UTF8 qw(encode_utf8); + +const my $NEWLINE => qq{\n}; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + # file-info would be great, but files are zipped + return + unless $item->name =~ m{\.mod$}; + + return + unless $item->name =~ m{^usr/lib/}; + + # do not look at flang, grub or libreoffice modules + return + if $item->name =~ m{/flang-\d+/} + || $item->name =~ m{^usr/lib/grub} + || $item->name =~ m{^usr/lib/libreoffice}; + + return + unless $item->is_file + && $item->is_open_ok + && $item->file_type =~ /\bgzip compressed\b/; + + my $module_version; + + open(my $fd, '<:gzip', $item->unpacked_path) + or die encode_utf8( + 'Cannot open gz file ' . $item->unpacked_path . $NEWLINE); + + while (my $line = <$fd>) { + next + if $line =~ /^\s*$/; + + ($module_version) = ($line =~ /^GFORTRAN module version '(\d+)'/); + last; + } + + close $fd; + + unless (length $module_version) { + $self->pointed_hint('gfortran-module-does-not-declare-version', + $item->pointer); + return; + } + + my $depends = $self->processable->fields->value('Depends'); + $self->pointed_hint('missing-prerequisite-for-gfortran-module', + $item->pointer) + unless $depends =~ /\bgfortran-mod-$module_version\b/; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Golang/BuiltUsing.pm b/lib/Lintian/Check/Languages/Golang/BuiltUsing.pm new file mode 100644 index 0000000..79095d3 --- /dev/null +++ b/lib/Lintian/Check/Languages/Golang/BuiltUsing.pm @@ -0,0 +1,68 @@ +# languages/golang/built-using -- lintian check script -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Golang::BuiltUsing; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + return + unless $self->processable->relation('Build-Depends') + ->satisfies('golang-go | golang-any'); + + my $control = $self->processable->debian_control; + + for my $installable ($control->installables) { + my $installable_fields= $control->installable_fields($installable); + + my $control_item= $self->processable->debian_control->item; + my $position = $installable_fields->position('Package'); + + $self->pointed_hint( + 'missing-built-using-field-for-golang-package', + $control_item->pointer($position), + "(in section for $installable)" + ) + if $installable_fields->value('Built-Using') + !~ m{ \$ [{] misc:Built-Using [}] }x + && $installable_fields->value('Architecture') ne 'all'; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Golang/ImportPath.pm b/lib/Lintian/Check/Languages/Golang/ImportPath.pm new file mode 100644 index 0000000..210696b --- /dev/null +++ b/lib/Lintian/Check/Languages/Golang/ImportPath.pm @@ -0,0 +1,56 @@ +# languages/golang/import-path -- lintian check script -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Golang::ImportPath; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + return + unless $self->processable->relation('Build-Depends') + ->satisfies('golang-go | golang-any'); + + my $control = $self->processable->debian_control; + my $source_fields = $control->source_fields; + + $self->hint('missing-xs-go-import-path-for-golang-package') + unless $source_fields->declares('XS-Go-Import-Path'); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Java.pm b/lib/Lintian/Check/Languages/Java.pm new file mode 100644 index 0000000..4b26512 --- /dev/null +++ b/lib/Lintian/Check/Languages/Java.pm @@ -0,0 +1,315 @@ +# languages/java -- lintian check script -*- perl -*- + +# Copyright (C) 2011 Vincent Fourmond +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Java; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use File::Basename; +use List::SomeUtils qw(any none); + +use Lintian::Util qw(normalize_link_target $PKGNAME_REGEX $PKGVERSION_REGEX); + +const my $EMPTY => q{}; +const my $HYPHEN => q{-}; + +const my $ARROW => q{->}; + +const my $BYTE_CODE_VERSION_OFFSET => 44; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +our $CLASS_REGEX = qr/\.(?:class|cljc?)/; + +sub visit_patched_files { + my ($self, $item) = @_; + + my $java_info = $item->java_info; + return + unless scalar keys %{$java_info}; + + my $files = $java_info->{files}; + + $self->pointed_hint('source-contains-prebuilt-java-object', $item->pointer) + if any { m/$CLASS_REGEX$/i } keys %{$files}; + + return; +} + +sub installable { + my ($self) = @_; + + my $missing_jarwrapper = 0; + my $has_public_jars = 0; + my $jmajlow = $HYPHEN; + + my $depends = $self->processable->relation('strong')->to_string; + + # Remove all libX-java-doc packages to avoid thinking they are java libs + # - note the result may not be a valid dependency listing + $depends =~ s/lib[^\s,]+-java-doc//g; + + my @java_lib_depends = ($depends =~ m/\b(lib[^\s,]+-java)\b/g); + + my $JAVA_BYTECODES= $self->data->load('java/constants', qr/\s*=\s*/); + + # We first loop over jar files to find problems + + for my $item (@{$self->processable->installed->sorted_list}) { + + my $java_info = $item->java_info; + next + unless scalar keys %{$java_info}; + + my $files = $java_info->{files}; + my $manifest = $java_info->{manifest}; + my $jar_dir = dirname($item->name); + my $classes = 0; + my $datafiles = 1; + my $class_path = $EMPTY; + my $bsname = $EMPTY; + + if (exists $java_info->{error}) { + $self->pointed_hint('zip-parse-error', $item->pointer, + $java_info->{error}); + next; + } + + # The Java Policy says very little about requires for (jars in) JVMs + next + if $item->name =~ m{^usr/lib/jvm(?:-exports)?/[^/]+/}; + + # Ignore Mozilla's jar files, see #635495 + next + if $item->name =~ m{^usr/lib/xul(?:-ext|runner[^/]*+)/}; + + if ($item->name =~ m{^usr/share/java/[^/]+\.jar$}) { + $has_public_jars = 1; + + # java policy requires package version too; see Bug#976681 + $self->pointed_hint('bad-jar-name', $item->pointer) + unless basename($item->name) + =~ /^$PKGNAME_REGEX-$PKGVERSION_REGEX\.jar$/; + } + + # check for common code files like .class or .clj (Clojure files) + for my $class (grep { m/$CLASS_REGEX$/i } sort keys %{$files}){ + + my $module_version = $files->{$class}; + (my $src = $class) =~ s/\.[^.]+$/\.java/; + + $self->pointed_hint('jar-contains-source', $item->pointer, $src) + if %{$files}{$src}; + + $classes = 1; + + next + if $class =~ m/\.cljc?$/; + + # .class but no major version? + next + if $module_version eq $HYPHEN; + + if ($module_version + < $JAVA_BYTECODES->value('lowest-known-bytecode-version') + || $module_version + > $JAVA_BYTECODES->value('highest-known-bytecode-version')) { + + # First public major version was 45 (Java1), latest + # version is 55 (Java11). + $self->pointed_hint('unknown-java-class-version', + $item->pointer,$class, $ARROW, $module_version); + + # Skip the rest of this Jar. + last; + } + + # Collect the "lowest" Class version used. We assume that + # mixed class formats implies special compat code for certain + # JVM cases. + if ($jmajlow eq $HYPHEN) { + # first; + $jmajlow = $module_version; + + } else { + $jmajlow = $module_version + if $module_version < $jmajlow; + } + } + + $datafiles = 0 + if none { /\.(?:xml|properties|x?html|xhp)$/i } keys %{$files}; + + if ($item->is_executable) { + + $self->pointed_hint('executable-jar-without-main-class', + $item->pointer) + unless $manifest && $manifest->{'Main-Class'}; + + # Here, we need to check that the package depends on + # jarwrapper. + $missing_jarwrapper = 1 + unless $self->processable->relation('strong') + ->satisfies('jarwrapper'); + + } elsif ($item->name !~ m{^usr/share/}) { + + $self->pointed_hint('jar-not-in-usr-share', $item->pointer); + } + + $class_path = $manifest->{'Class-Path'}//$EMPTY if $manifest; + $bsname = $manifest->{'Bundle-SymbolicName'}//$EMPTY if $manifest; + + if ($manifest) { + if (!$classes) { + + # Eclipse / OSGi bundles are sometimes source bundles + # these do not ship classes but java files and other sources. + # Javadoc jars deployed in the Maven repository also do not ship + # classes but HTML files, images and CSS files + if ( + ( + $bsname !~ m/\.source$/ + && $item->name + !~ m{^usr/share/maven-repo/.*-javadoc\.jar} + && $item->name !~ m{\.doc(?:\.(?:user|isv))?_[^/]+.jar} + && $item->name !~ m{\.source_[^/]+.jar} + ) + || $class_path + ) { + $self->pointed_hint('codeless-jar', $item->pointer); + } + } + + } elsif ($classes) { + $self->pointed_hint('missing-manifest', $item->pointer); + } + + if ($class_path) { + # Only run the tests when a classpath is present + my @relative; + my @paths = split(m/\s++/, $class_path); + for my $p (@paths) { + if ($p) { + # Strip leading ./ + $p =~ s{^\./+}{}g; + if ($p !~ m{^(?:file://)?/} && $p =~ m{/}) { + my $target = normalize_link_target($jar_dir, $p); + my $tinfo; + # Can it be normalized? + next unless defined($target); + # Relative link to usr/share/java ? Works if + # we are depending of a Java library. + next + if $target =~ m{^usr/share/java/[^/]+.jar$} + && @java_lib_depends; + $tinfo= $self->processable->installed->lookup($target); + # Points to file or link in this package, + # which is sometimes easier than + # re-writing the classpath. + next + if defined $tinfo + and ($tinfo->is_symlink or $tinfo->is_file); + # Relative path with subdirectories. + push @relative, $p; + } + # @todo add an info tag for relative paths, to educate + # maintainers ? + } + } + + $self->pointed_hint('classpath-contains-relative-path', + $item->pointer, join(', ', @relative)) + if @relative; + } + + # Trigger a warning when a maven plugin lib is installed in + # /usr/share/java/ + $self->pointed_hint('maven-plugin-in-usr-share-java', $item->pointer) + if $has_public_jars + && $self->processable->name =~ /^lib.*maven.*plugin.*/ + && $item->name !~ m{^usr/share/maven-repo/.*\.jar}; + } + + $self->hint('missing-dep-on-jarwrapper') if $missing_jarwrapper; + + if ($jmajlow ne $HYPHEN) { + # Byte code numbers: + # 45-49 -> Java1 - Java5 (Always ok) + # 50 -> Java6 + # 51 -> Java7 + # 52 -> Java8 + # 53 -> Java9 + # 54 -> Java10 + # 55 -> Java11 + my $bad = 0; + + # If the lowest version used is greater than the requested + # limit, then flag it. + $bad = 1 + if $jmajlow > $JAVA_BYTECODES->value('default-bytecode-version'); + + # Technically we ought to do some checks with Java6 class + # files and dependencies/package types, but for now just skip + # that. (See #673276) + + if ($bad) { + # Map the Class version to a Java version. + my $java_version = $jmajlow - $BYTE_CODE_VERSION_OFFSET; + + $self->hint('incompatible-java-bytecode-format', + "Java$java_version version (Class format: $jmajlow)"); + } + } + + if ( !$has_public_jars + && !$self->processable->is_transitional + && $self->processable->name =~ /^lib[^\s,]+-java$/){ + + # Skip this if it installs a symlink in usr/share/java + my $java_dir + = $self->processable->installed->resolve_path('usr/share/java/'); + + my $has_jars = 0; + $has_jars = 1 + if $java_dir + && (any { $_->name =~ m{^[^/]+\.jar$} } $java_dir->children); + + $self->hint('javalib-but-no-public-jars') + unless $has_jars; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Java/Bytecode.pm b/lib/Lintian/Check/Languages/Java/Bytecode.pm new file mode 100644 index 0000000..14566a9 --- /dev/null +++ b/lib/Lintian/Check/Languages/Java/Bytecode.pm @@ -0,0 +1,58 @@ +# languages/java/bytecode -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Java::Bytecode; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $MAGIC_BYTE_SIZE => 4; + +sub visit_installed_files { + my ($self, $item) = @_; + + # .class (compiled Java files) + if ( $item->name =~ /\.class$/ + && $item->name !~ /(?:WEB-INF|demo|doc|example|sample|test)/) { + + my $magic = $item->magic($MAGIC_BYTE_SIZE); + + $self->pointed_hint('package-installs-java-bytecode', $item->pointer) + if $magic eq "\xCA\xFE\xBA\xBE"; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Javascript/Embedded.pm b/lib/Lintian/Check/Languages/Javascript/Embedded.pm new file mode 100644 index 0000000..9227187 --- /dev/null +++ b/lib/Lintian/Check/Languages/Javascript/Embedded.pm @@ -0,0 +1,149 @@ +# languages/javascript/embedded -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Javascript::Embedded; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +my %JS_MAGIC + = ('libjs-bootstrap' => qr{ var [ ] (?: Carousel | Typeahead ) }x,); + +my $JS_EXT + = qr{(?:(?i)[-._]?(?:compiled|lite|min|pack(?:ed)?|prod|umd|yc)?\.(js|css)(?:\.gz)?)$}; +my %JS_FILES = ( + 'ckeditor' => qr{(?i)/ckeditor} . $JS_EXT, + 'fckeditor' => qr{(?i)/fckeditor} . $JS_EXT, + 'libjs-async' => qr{(?i)/async} . $JS_EXT, + 'libjs-bootstrap' => qr{(?i)/bootstrap(?:-[\d\.]+)?} . $JS_EXT, + 'libjs-chai' => qr{(?i)/chai} . $JS_EXT, + 'libjs-cropper' => qr{(?i)/cropper(?:\.uncompressed)?} . $JS_EXT, + 'libjs-dojo-\w+' => qr{(?i)/(?:dojo|dijit)} . $JS_EXT, + 'libjs-excanvas' => qr{(?i)/excanvas(?:-r[0-9]+)?} . $JS_EXT, + 'libjs-jac' => qr{(?i)/jsjac} . $JS_EXT, + 'libjs-jquery' => qr{(?i)/jquery(?:-[\d\.]+)?} . $JS_EXT, + 'libjs-jquery-cookie' => qr{(?i)/jquery\.cookie} . $JS_EXT, + 'libjs-jquery-easing' => qr{(?i)/jquery\.easing} . $JS_EXT, + 'libjs-jquery-event-drag' => qr{(?i)/jquery\.event\.drap} . $JS_EXT, + 'libjs-jquery-event-drop' => qr{(?i)/jquery\.event\.drop} . $JS_EXT, + 'libjs-jquery-fancybox' => qr{(?i)/jquery\.fancybox} . $JS_EXT, + 'libjs-jquery-form' => qr{(?i)/jquery\.form} . $JS_EXT, + 'libjs-jquery-galleriffic' => qr{(?i)/jquery\.galleriffic} . $JS_EXT, + 'libjs-jquery-history' => qr{(?i)/jquery\.history} . $JS_EXT, + 'libjs-jquery-jfeed' => qr{(?i)/jquery\.jfeed} . $JS_EXT, + 'libjs-jquery-jush' => qr{(?i)/jquery\.jush} . $JS_EXT, + 'libjs-jquery-livequery' => qr{(?i)/jquery\.livequery} . $JS_EXT, + 'libjs-jquery-meiomask' => qr{(?i)/jquery\.meiomask} . $JS_EXT, + 'libjs-jquery-metadata' => qr{(?i)/jquery\.metadata} . $JS_EXT, + 'libjs-jquery-migrate-1' => qr{(?i)/jquery-migrate(?:-1[\d\.]*)} + . $JS_EXT, + 'libjs-jquery-mousewheel' => qr{(?i)/jquery\.mousewheel} . $JS_EXT, + 'libjs-jquery-opacityrollover' => qr{(?i)/jquery\.opacityrollover} + . $JS_EXT, + 'libjs-jquery-tablesorter' => qr{(?i)/jquery\.tablesorter} . $JS_EXT, + 'libjs-jquery-tipsy' => qr{(?i)/jquery\.tipsy} . $JS_EXT, + 'libjs-jquery-treetable' => qr{(?i)/jquery\.treetable} . $JS_EXT, + 'libjs-jquery-ui' => qr{(?i)/jquery[\.-](?:-[\d\.]+)?ui} + . $JS_EXT, + 'libjs-mocha' => qr{(?i)/mocha} . $JS_EXT, + 'libjs-mochikit' => qr{(?i)/mochikit} . $JS_EXT, + 'libjs-mootools' => +qr{(?i)/mootools(?:(?:\.v|-)[\d\.]+)?(?:-(?:(?:core(?:-server)?)|more)(?:-(?:yc|jm|nc))?)?} + . $JS_EXT, + 'libjs-mustache' => qr{(?i)/mustache} . $JS_EXT, +# libjs-normalize is provided by node-normalize.css but this is an implementation detail + 'libjs-normalize' => qr{(?i)/normalize(?:\.min)?\.css}, + 'libjs-prototype' => qr{(?i)/prototype(?:-[\d\.]+)?}. $JS_EXT, + 'libjs-raphael' => qr{(?i)/raphael(?:[\.-]min)?} . $JS_EXT, + 'libjs-scriptaculous' => qr{(?i)/scriptaculous} . $JS_EXT, + 'libjs-strophe' => qr{(?i)/strophe} . $JS_EXT, + 'libjs-underscore' => qr{(?i)/underscore} . $JS_EXT, + 'libjs-yui' => qr{(?i)/(?:yahoo|yui)-(?:dom-event)?} + . $JS_EXT, + # Disabled due to false positives. Needs a content check adding to verify + # that the file being checked is /the/ yahoo.js + # 'libjs-yui' => qr{(?i)/yahoo\.js(\.gz)?} . $JS_EXT, + 'jsmath' => qr{(?i)/jsMath(?:-fallback-\w+)?} + . $JS_EXT, + 'node-html5shiv' => qr{(?i)html5shiv(?:-printshiv)?} + . $JS_EXT, + 'sphinx' => + qr{(?i)/_static/(?:doctools|language_data|searchtools)} . $JS_EXT, + 'tinymce' => qr{(?i)/tiny_mce(?:_(?:popup|src))?} + . $JS_EXT, + 'libjs-lodash' => qr{(?i)lodash} . $JS_EXT, + 'node-pako' => + qr{(?i)pako(?:_(:?de|in)flate(?:.es\d+)?)(?:-[\d\.]+)?}. $JS_EXT, + 'node-jszip-utils' => qr{(?i)jszip-utils(?:-ie)?(?:-[\d\.]+)?} + . $JS_EXT, + 'node-jszip' => qr{(?i)jszip(?:-ie)?(?:-[\d\.]+)?} . $JS_EXT, + 'libjs-codemirror' => qr{(?i)codemirror} . $JS_EXT, + 'libjs-punycode' => qr{(?i)punycode(?:\.es\d+)?} . $JS_EXT, +# not yet available in unstable +# 'xinha' => qr{(?i)/(htmlarea|Xinha(Loader|Core))} . $JS_EXT, +); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + # ignore embedded jQuery libraries for Doxygen (#736360) + my $doxygen = $self->processable->installed->resolve_path( + $item->dirname . 'doxygen.css'); + return + if $item->basename eq 'jquery.js' + && defined $doxygen; + + # embedded javascript + for my $provider (keys %JS_FILES) { + + next + if $self->processable->name =~ /^$provider$/; + + next + unless $item->name =~ /$JS_FILES{$provider}/; + + next + if length $JS_MAGIC{$provider} + && !length $item->bytes_match($JS_MAGIC{$provider}); + + $self->pointed_hint('embedded-javascript-library', $item->pointer, + 'please use', $provider); + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Javascript/Nodejs.pm b/lib/Lintian/Check/Languages/Javascript/Nodejs.pm new file mode 100644 index 0000000..98a5d76 --- /dev/null +++ b/lib/Lintian/Check/Languages/Javascript/Nodejs.pm @@ -0,0 +1,262 @@ +# languages/javascript/nodejs -- lintian check script -*- perl -*- + +# Copyright (C) 2019-2020, Xavier Guimard <yadd@debian.org> +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Javascript::Nodejs; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use JSON::MaybeXS; +use List::SomeUtils qw(any none first_value); +use Path::Tiny; +use Syntax::Keyword::Try; +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::Relation; + +const my $SLASH => q{/}; +const my $DOT => q{.}; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $debian_control = $self->processable->debian_control; + + # debian/control check + my @testsuites + = split(m/\s*,\s*/,$debian_control->source_fields->value('Testsuite')); + + if (any { $_ eq 'autopkgtest-pkg-nodejs' } @testsuites) { + + my $item = $self->processable->patched->resolve_path( + 'debian/tests/pkg-js/test'); + if (defined $item) { + + $self->pointed_hint('pkg-js-autopkgtest-test-is-empty', + $item->pointer) + if none { /^[^#]*\w/m } $item->bytes; + + } else { + $self->hint('pkg-js-autopkgtest-test-is-missing'); + } + + # Ensure all files referenced in debian/tests/pkg-js/files exist + my $files + = $self->processable->patched->resolve_path( + 'debian/tests/pkg-js/files'); + if (defined $files) { + + my @patterns = path($files->unpacked_path)->lines; + + # trim leading and trailing whitespace + s/^\s+|\s+$//g for @patterns; + + my @notfound = grep { !$self->path_exists($_) } @patterns; + + $self->hint('pkg-js-autopkgtest-file-does-not-exist', $_) + for @notfound; + } + } + + # debian/rules check + my $droot = $self->processable->patched->resolve_path('debian/') + or return; + my $drules = $droot->child('rules') + or return; + + return + unless $drules->is_open_ok; + + open(my $rules_fd, '<', $drules->unpacked_path) + or die encode_utf8('Cannot open ' . $drules->unpacked_path); + + my $command_prefix_pattern = qr/\s+[@+-]?(?:\S+=\S+\s+)*/; + my ($seen_nodejs,$override_test,$seen_dh_dynamic); + my $bdepends = $self->processable->relation('Build-Depends-All'); + $seen_nodejs = 1 if $bdepends->satisfies('dh-sequence-nodejs'); + + while (my $line = <$rules_fd>) { + + # reconstitute splitted lines + while ($line =~ s/\\$// && defined(my $cont = <$rules_fd>)) { + $line .= $cont; + } + + # skip comments + next + if $line =~ /^\s*\#/; + + if ($line =~ m{^(?:$command_prefix_pattern)dh\s+}) { + $seen_dh_dynamic = 1 + if $line =~ /\$[({]\w/; + + while ($line =~ /\s--with(?:=|\s+)(['"]?)(\S+)\1/g) { + my @addons = split(m{,}, $2); + $seen_nodejs = 1 + if any { $_ eq 'nodejs' } @addons; + } + + } elsif ($line =~ /^([^:]*override_dh_[^:]*):/) { + $override_test = 1 + if $1 eq 'auto_test'; + } + } + + if( $seen_nodejs + && !$override_test + && !$seen_dh_dynamic) { + + # pkg-js-tools search build test in the following order + my @candidates = qw{debian/nodejs/test debian/tests/pkg-js/test}; + + my $item = first_value { defined } + map { $self->processable->patched->resolve_path($_) } @candidates; + + # Ensure test file contains something + if (defined $item) { + $self->pointed_hint('pkg-js-tools-test-is-empty', $item->pointer) + unless any { /^[^#]*\w/m } $item->bytes; + + } else { + $self->hint('pkg-js-tools-test-is-missing'); + } + } + + return; +} + +sub visit_installed_files { + my ($self, $item) = @_; + + return + if $item->is_dir; + + return + if $self->processable->name =~ /-dbg$/; + + # Warn if a file is installed in old nodejs root dir + $self->pointed_hint('nodejs-module-installed-in-usr-lib', $item->pointer) + if $item->name =~ m{^usr/lib/nodejs/.*}; + + # Warn if package is not installed in a subdirectory of nodejs root + # directories + $self->pointed_hint('node-package-install-in-nodejs-rootdir', + $item->pointer) + if $item->name + =~ m{^usr/(?:share|lib(?:/[^/]+)?)/nodejs/(?:package\.json|[^/]*\.js)$}; + + # Now we have to open package.json + return + unless $item->is_open_ok; + + # Return an error if a package-lock.json or a yanr.lock file is installed + $self->pointed_hint('nodejs-lock-file', $item->pointer) + if $item->name + =~ m{^usr/(?:share|lib(?:/[^/]+)?)/nodejs/([^/]+)(.*/)(package-lock\.json|yarn\.lock)$}; + + # Look only nodejs package.json files + return + unless $item->name + =~ m{^usr/(?:share|lib(?:/[^/]+)?)/nodejs/([^\@/]+|\@[^/]+/[^/]+)(.*/)package\.json$}; + + # First regexp arg: directory in /**/nodejs or @foo/bar when dir starts + # with '@', following npm registry policy + my $dirname = $1; + # Second regex arg: subpath in /**/nodejs/module/ (eg: node_modules/foo) + my $subpath = $2; + + my $declared = $self->processable->name; + my $version = $self->processable->fields->value('Version'); + $declared .= "( = $version)" + if length $version; + $version ||= '0-1'; + + my $provides + = $self->processable->relation('Provides')->logical_and($declared); + + my $content = $item->bytes; + + # Look only valid package.json files + my $pac; + try { + $pac = decode_json($content); + die + unless length $pac->{name}; + } catch { + return; + } + + # Store node module name & version (classification) + $self->pointed_hint('nodejs-module', $item->pointer, $pac->{name}, + $pac->{version} // 'undef'); + + # Warn if version is 0.0.0-development + $self->pointed_hint('nodejs-missing-version-override', + $item->pointer, $pac->{name}, $pac->{version}) + if $pac->{version} and $pac->{version} =~ /^0\.0\.0-dev/; + + # Warn if module name is not equal to nodejs directory + if ($subpath eq $SLASH && $dirname ne $pac->{name}) { + $self->pointed_hint('nodejs-module-installed-in-bad-directory', + $item->pointer, $pac->{name}, $dirname); + + } else { + # Else verify that module is declared at least in Provides: field + my $name = 'node-' . lc($pac->{name}); + # Normalize name following Debian policy + # (replace invalid characters by "-") + $name =~ s{[/_\@]}{-}g; + $name =~ s/-+/-/g; + + $self->pointed_hint('nodejs-module-not-declared', $item->pointer,$name) + if $subpath eq $SLASH + && !$provides->satisfies($name); + } + + return; +} + +sub path_exists { + my ($self, $expression) = @_; + + # replace asterisks with proper regex wildcard + $expression =~ s{ [*] }{[^/]*}gsx; + + return 1 + if any { m{^ $expression /? $}sx } + @{$self->processable->patched->sorted_list}; + + return 0; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Ocaml/ByteCode/Compiled.pm b/lib/Lintian/Check/Languages/Ocaml/ByteCode/Compiled.pm new file mode 100644 index 0000000..f916d68 --- /dev/null +++ b/lib/Lintian/Check/Languages/Ocaml/ByteCode/Compiled.pm @@ -0,0 +1,85 @@ +# languages/ocaml/byte-code/compiled -- lintian check script -*- perl -*- +# +# Copyright (C) 2009 Stephane Glondu +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Ocaml::ByteCode::Compiled; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has provided_o => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my %provided_o; + + for my $item (@{$self->processable->installed->sorted_list}) { + + for my $count (keys %{$item->ar_info}) { + + my $member = $item->ar_info->{$count}{name}; + next + unless length $member; + + # dirname ends in a slash + my $virtual_path = $item->dirname . $member; + + # Note: a .o may be legitimately in several different .a + $provided_o{$virtual_path} = $item->name; + } + } + + return \%provided_o; + } +); + +sub visit_installed_files { + my ($self, $item) = @_; + + my $no_extension = $item->basename; + $no_extension =~ s{ [.] [^.]+ $}{}x; + + # The .cmx counterpart: for each .cmx file, there must be a + # matching .o file, which can be there by itself, or embedded in a + # .a file in the same directory + # dirname ends with a slash + $self->pointed_hint('ocaml-dangling-cmx', $item->pointer) + if $item->name =~ m{ [.]cmx $}x + && !$item->parent_dir->child($no_extension . '.o') + && !exists $self->provided_o->{$item->dirname . $no_extension . '.o'}; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Ocaml/ByteCode/Interface.pm b/lib/Lintian/Check/Languages/Ocaml/ByteCode/Interface.pm new file mode 100644 index 0000000..8edeab1 --- /dev/null +++ b/lib/Lintian/Check/Languages/Ocaml/ByteCode/Interface.pm @@ -0,0 +1,63 @@ +# languages/ocaml/byte-code/interface -- lintian check script -*- perl -*- +# +# Copyright (C) 2009 Stephane Glondu +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Ocaml::ByteCode::Interface; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $LAST_ITEM => -1; + +sub visit_installed_files { + my ($self, $item) = @_; + + my $no_extension = $item->basename; + $no_extension =~ s{ [.] [^.]+ $}{}x; + + # for dune + my $interface_name = (split(/__/, $no_extension))[$LAST_ITEM]; + + # $somename.cmi should be shipped with $somename.mli or $somename.ml + $self->pointed_hint('ocaml-dangling-cmi', $item->pointer) + if $item->name =~ m{ [.]cmi $}x + && !$item->parent_dir->child($interface_name . '.mli') + && !$item->parent_dir->child(lc($interface_name) . '.mli') + && !$item->parent_dir->child($interface_name . '.ml') + && !$item->parent_dir->child(lc($interface_name) . '.ml'); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Ocaml/ByteCode/Library.pm b/lib/Lintian/Check/Languages/Ocaml/ByteCode/Library.pm new file mode 100644 index 0000000..965f134 --- /dev/null +++ b/lib/Lintian/Check/Languages/Ocaml/ByteCode/Library.pm @@ -0,0 +1,58 @@ +# languages/ocaml/byte-code/library -- lintian check script -*- perl -*- +# +# Copyright (C) 2009 Stephane Glondu +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Ocaml::ByteCode::Library; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + my $no_extension = $item->basename; + $no_extension =~ s{ [.] [^.]+ $}{}x; + + # For each .cmxa file, there must be a matching .a file (#528367) + $self->pointed_hint('ocaml-dangling-cmxa', $item->pointer) + if $item->name =~ m{ [.]cmxa $}x + && !$item->parent_dir->child($no_extension . '.a'); + + # $somename.cmo should usually not be shipped with $somename.cma + $self->pointed_hint('ocaml-stray-cmo', $item->pointer) + if $item->name =~ m{ [.]cma $}x + && $item->parent_dir->child($no_extension . '.cmo'); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Ocaml/ByteCode/Misplaced/Package.pm b/lib/Lintian/Check/Languages/Ocaml/ByteCode/Misplaced/Package.pm new file mode 100644 index 0000000..767f6b0 --- /dev/null +++ b/lib/Lintian/Check/Languages/Ocaml/ByteCode/Misplaced/Package.pm @@ -0,0 +1,126 @@ +# languages/ocaml/byte-code/misplaced/package -- lintian check script -*- perl -*- +# +# Copyright (C) 2009 Stephane Glondu +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Ocaml::ByteCode::Misplaced::Package; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(first_value); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; +const my $SLASH => q{/}; + +has development_files => (is => 'rw', default => sub { [] }); + +has is_dev_package => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + # is it a development package? + return 1 + if ( + $self->processable->name =~ m{ + (?: -dev + |\A camlp[45](?:-extra)? + |\A ocaml (?: + -nox + |-interp + |-compiler-libs + )? + )\Z}xsm + ); + + return 0; + } +); + +sub visit_installed_files { + my ($self, $item) = @_; + + # .cma, .cmo and .cmxs are excluded because they can be plugins + push(@{$self->development_files}, $item->name) + if $item->name =~ m{ [.] cm (?: i | xa? ) $}x; + + return; +} + +sub installable { + my ($self) = @_; + + my $count = scalar @{$self->development_files}; + my $plural = ($count == 1) ? $EMPTY : 's'; + + my $prefix = longest_common_prefix(@{$self->development_files}); + + # strip trailing slash + $prefix =~ s{ / $}{}x + unless $prefix eq $SLASH; + + # non-dev packages should not ship .cmi, .cmx or .cmxa files + $self->hint('ocaml-dev-file-in-nondev-package', + "$count file$plural in $prefix") + if $count > 0 + && !$self->is_dev_package; + + return; +} + +sub longest_common_prefix { + my (@paths) = @_; + + my %prefixes; + + for my $path (@paths) { + + my $truncated = $path; + + # first operation drops the file name + while ($truncated =~ s{ / [^/]* $}{}x) { + ++$prefixes{$truncated}; + } + } + + my @by_descending_length = reverse sort keys %prefixes; + + my $common = first_value { $prefixes{$_} == @paths } @by_descending_length; + + $common ||= $SLASH; + + return $common; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Ocaml/ByteCode/Misplaced/Path.pm b/lib/Lintian/Check/Languages/Ocaml/ByteCode/Misplaced/Path.pm new file mode 100644 index 0000000..68e4f4f --- /dev/null +++ b/lib/Lintian/Check/Languages/Ocaml/ByteCode/Misplaced/Path.pm @@ -0,0 +1,105 @@ +# languages/ocaml/byte-code/misplaced/path -- lintian check script -*- perl -*- +# +# Copyright (C) 2009 Stephane Glondu +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Ocaml::ByteCode::Misplaced::Path; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(first_value); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; +const my $SLASH => q{/}; + +has misplaced_files => (is => 'rw', default => sub { [] }); + +sub visit_installed_files { + my ($self, $item) = @_; + + # development files outside /usr/lib/ocaml (.cmi, .cmx, .cmxa) + return + if $item->name =~ m{^ usr/lib/ocaml/ }x; + + # .cma, .cmo and .cmxs are excluded because they can be plugins + push(@{$self->misplaced_files}, $item->name) + if $item->name =~ m{ [.] cm (?: i | xa? ) $}x; + + return; +} + +sub installable { + my ($self) = @_; + + my $count = scalar @{$self->misplaced_files}; + my $plural = ($count == 1) ? $EMPTY : 's'; + + my $prefix = longest_common_prefix(@{$self->misplaced_files}); + + # strip trailing slash + $prefix =~ s{ / $}{}x + unless $prefix eq $SLASH; + + $self->hint( + 'ocaml-dev-file-not-in-usr-lib-ocaml', + "$count file$plural in $prefix" + )if $count > 0; + + return; +} + +sub longest_common_prefix { + my (@paths) = @_; + + my %prefixes; + + for my $path (@paths) { + + my $truncated = $path; + + # first operation drops the file name + while ($truncated =~ s{ / [^/]* $}{}x) { + ++$prefixes{$truncated}; + } + } + + my @by_descending_length = reverse sort keys %prefixes; + + my $common = first_value { $prefixes{$_} == @paths } @by_descending_length; + + $common ||= $SLASH; + + return $common; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Ocaml/ByteCode/Plugin.pm b/lib/Lintian/Check/Languages/Ocaml/ByteCode/Plugin.pm new file mode 100644 index 0000000..ae14f6b --- /dev/null +++ b/lib/Lintian/Check/Languages/Ocaml/ByteCode/Plugin.pm @@ -0,0 +1,56 @@ +# languages/ocaml/byte-code/plugin -- lintian check script -*- perl -*- +# +# Copyright (C) 2009 Stephane Glondu +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Ocaml::ByteCode::Plugin; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + my $no_extension = $item->basename; + $no_extension =~ s{ [.] [^.]+ $}{}x; + + # For each .cmxs file, there must be a matching .cma or .cmo file + # (at least, in library packages) + $self->pointed_hint('ocaml-dangling-cmxs', $item->pointer) + if $item->name =~ m{ [.]cmxs $}x + && !$item->parent_dir->child($no_extension . '.cma') + && !$item->parent_dir->child($no_extension . '.cmo') + && $self->processable->name =~ /^lib/; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Ocaml/CustomExecutable.pm b/lib/Lintian/Check/Languages/Ocaml/CustomExecutable.pm new file mode 100644 index 0000000..8ebad48 --- /dev/null +++ b/lib/Lintian/Check/Languages/Ocaml/CustomExecutable.pm @@ -0,0 +1,59 @@ +# languages/ocaml/custom-executable -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2012 Kees Cook +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Ocaml::CustomExecutable; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + return + unless $item->file_type =~ /^ [^,]* \b ELF \b /x; + + # Check for OCaml custom executables (#498138) + $self->pointed_hint('ocaml-custom-executable', $item->pointer) + if $item->file_type =~ m{ \b not [ ] stripped \b }x + && $item->file_type =~ m{ \b executable \b }x + && $item->strings =~ m{^ Caml1999X0 [0-9] [0-9] $}mx; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Ocaml/Meta.pm b/lib/Lintian/Check/Languages/Ocaml/Meta.pm new file mode 100644 index 0000000..0a9976b --- /dev/null +++ b/lib/Lintian/Check/Languages/Ocaml/Meta.pm @@ -0,0 +1,67 @@ +# languages/ocaml/meta -- lintian check script -*- perl -*- +# +# Copyright (C) 2009 Stephane Glondu +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Ocaml::Meta; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has has_meta => (is => 'rw', default => 0); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->name =~ m{^ usr/lib/ocaml/ }x; + + # does the package provide a META file? + $self->has_meta(1) + if $item->name =~ m{ / META (?: [.] | $ ) }x; + + return; +} + +sub installable { + my ($self) = @_; + + my $prerequisites = $self->processable->relation('all'); + + # If there is a META file, ocaml-findlib should at least be suggested. + $self->hint('ocaml-meta-without-suggesting-findlib') + if $self->has_meta + && !$prerequisites->satisfies('ocaml-findlib:any'); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Perl.pm b/lib/Lintian/Check/Languages/Perl.pm new file mode 100644 index 0000000..c68af47 --- /dev/null +++ b/lib/Lintian/Check/Languages/Perl.pm @@ -0,0 +1,125 @@ +# languages/perl -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Perl; + +use v5.20; +use warnings; +use utf8; + +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has perl_sources_in_lib => (is => 'rw', default => sub { [] }); +has has_perl_binaries => (is => 'rw', default => 0); + +sub visit_installed_files { + my ($self, $item) = @_; + + # perllocal.pod + $self->pointed_hint('package-installs-perllocal-pod', $item->pointer) + if $item->name =~ m{^usr/lib/perl.*/perllocal.pod$}; + + # .packlist files + if ($item->name =~ m{^usr/lib/perl.*/.packlist$}) { + $self->pointed_hint('package-installs-packlist', $item->pointer); + + }elsif ($item->name =~ m{^usr/lib/(?:[^/]+/)?perl5/.*\.p[lm]$}) { + push @{$self->perl_sources_in_lib}, $item; + + }elsif ($item->name =~ m{^usr/lib/(?:[^/]+/)?perl5/.*\.(?:bs|so)$}) { + $self->has_perl_binaries(1); + } + + # perl modules + if ($item->name =~ m{^usr/(?:share|lib)/perl/\S}) { + + # check if it's the "perl" package itself + $self->pointed_hint('perl-module-in-core-directory', $item->pointer) + unless $self->processable->source_name eq 'perl'; + } + + # perl modules using old libraries + # we do the same check on perl scripts in checks/scripts + my $dep = $self->processable->relation('strong'); + if ( $item->is_file + && $item->name =~ /\.pm$/ + && !$dep->satisfies('libperl4-corelibs-perl | perl (<< 5.12.3-7)')) { + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $position = 1; + while (my $line = <$fd>) { + if ( + $line =~ m{ (?:do|require)\s+['"] # do/require + + # Huge list of perl4 modules... + (abbrev|assert|bigfloat|bigint|bigrat + |cacheout|complete|ctime|dotsh|exceptions + |fastcwd|find|finddepth|flush|getcwd|getopt + |getopts|hostname|importenv|look|newgetopt + |open2|open3|pwd|shellwords|stat|syslog + |tainted|termcap|timelocal|validate) + # ... so they end with ".pl" rather than ".pm" + \.pl['"] + }xsm + ) { + my $module = $1; + + $self->pointed_hint('perl-module-uses-perl4-libs-without-dep', + $item->pointer($position), "$module.pl"); + } + + } continue { + ++$position; + } + + close $fd; + } + + return; +} + +sub installable { + my ($self) = @_; + + unless ($self->has_perl_binaries) { + + $self->pointed_hint('package-installs-nonbinary-perl-in-usr-lib-perl5', + $_->pointer) + for @{$self->perl_sources_in_lib}; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Perl/Core/Provides.pm b/lib/Lintian/Check/Languages/Perl/Core/Provides.pm new file mode 100644 index 0000000..b0a3923 --- /dev/null +++ b/lib/Lintian/Check/Languages/Perl/Core/Provides.pm @@ -0,0 +1,83 @@ +# languages/perl/core/provides -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2021 Felix Lechner +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Perl::Core::Provides; + +use v5.20; +use warnings; +use utf8; + +use Dpkg::Version qw(version_check); + +use Lintian::Relation::Version qw(versions_compare); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub always { + my ($self) = @_; + + my $fields = $self->processable->fields; + + return + unless $fields->declares('Version'); + + my $version = $fields->unfolded_value('Version'); + + my $dversion = Dpkg::Version->new($version); + return + unless $dversion->is_valid; + + my ($epoch, $upstream, $debian) + = ($dversion->epoch, $dversion->version, $dversion->revision); + + my $PERL_CORE_PROVIDES= $self->data->load('fields/perl-provides', '\s+'); + + my $name = $fields->value('Package'); + + return + unless $PERL_CORE_PROVIDES->recognizes($name); + + my $core_version = $PERL_CORE_PROVIDES->value($name); + + my $no_revision = "$epoch:$upstream"; + return + unless version_check($no_revision); + + $self->hint('package-superseded-by-perl', "with $core_version") + if versions_compare($core_version, '>=', $no_revision); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Perl/Perl4/Prerequisites.pm b/lib/Lintian/Check/Languages/Perl/Perl4/Prerequisites.pm new file mode 100644 index 0000000..fb5e9be --- /dev/null +++ b/lib/Lintian/Check/Languages/Perl/Perl4/Prerequisites.pm @@ -0,0 +1,124 @@ +# languages/perl/perl4/prerequisites -- lintian check script -*- perl -*- +# +# Copyright (C) 1998 Richard Braakman +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Perl::Perl4::Prerequisites; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use File::Basename; +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::Relation; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +# check for obsolete perl libraries +const my $PERL4_PREREQUISITES => + 'libperl4-corelibs-perl:any | perl:any (<< 5.12.3-7)'; + +has satisfies_perl4_prerequisites => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return $self->processable->relation('strong') + ->satisfies($PERL4_PREREQUISITES); + } +); + +sub visit_installed_files { + my ($self, $item) = @_; + + # Consider /usr/src/ scripts as "documentation" + # - packages containing /usr/src/ tend to be "-source" .debs + # and usually come with overrides + # no checks necessary at all for scripts in /usr/share/doc/ + # unless they are examples + return + if ($item->name =~ m{^usr/share/doc/} || $item->name =~ m{^usr/src/}) + && $item->name !~ m{^usr/share/doc/[^/]+/examples/}; + + return + unless length $item->interpreter; + + my $basename = basename($item->interpreter); + return + unless $basename eq 'perl'; + + return + unless $item->is_open_ok; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $position = 1; + while (my $line = <$fd>) { + if ( + $line =~m{ (?:do|require)\s+['"] # do/require + + # Huge list of perl4 modules... + (abbrev|assert|bigfloat|bigint|bigrat + |cacheout|complete|ctime|dotsh|exceptions + |fastcwd|find|finddepth|flush|getcwd|getopt + |getopts|hostname|importenv|look|newgetopt + |open2|open3|pwd|shellwords|stat|syslog + |tainted|termcap|timelocal|validate) + # ... so they end with ".pl" rather than ".pm" + \.pl['"] + }xsm + ) { + + my $module = "$1.pl"; + + my $pointer = $item->pointer($position); + + $self->pointed_hint( + 'script-uses-perl4-libs-without-dep',$pointer, + "(does not satisfy $PERL4_PREREQUISITES)",$module + ) unless $self->satisfies_perl4_prerequisites; + + } + + } continue { + ++$position; + } + + close $fd; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Perl/Perl5.pm b/lib/Lintian/Check/Languages/Perl/Perl5.pm new file mode 100644 index 0000000..8b138ab --- /dev/null +++ b/lib/Lintian/Check/Languages/Perl/Perl5.pm @@ -0,0 +1,61 @@ +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 1999 Joey Hess +# Copyright (C) 2000 Sean 'Shaleh' Perry +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2007 Russ Allbery +# Copyright (C) 2013-2018 Bastien ROUCARIES +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Perl::Perl5; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + # Find mentioning of usr/lib/perl5 inside the packaging + $self->pointed_hint('mentions-deprecated-usr-lib-perl5-directory', + $item->pointer) + if $item->basename ne 'changelog' + && $item->name =~ m{^ debian/ }sx + && $item->name !~ m{^ debian/patches/ }sx + && $item->name !~ m{^ debian/ (?:.+\.)? install $}sx + && $item->bytes =~ m{^ [^#]* usr/lib/perl5 }msx; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Perl/Yapp.pm b/lib/Lintian/Check/Languages/Perl/Yapp.pm new file mode 100644 index 0000000..adf3605 --- /dev/null +++ b/lib/Lintian/Check/Languages/Perl/Yapp.pm @@ -0,0 +1,55 @@ +# languages/perl/yapp -- lintian check script -*- perl -*- +# +# Copyright (C) 2019 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Perl::Yapp; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->name =~ /\.pm$/; + + my $bytes = $item->bytes; + return + unless $bytes; + + $self->pointed_hint('source-contains-prebuilt-yapp-parser', $item->pointer) + if $bytes + =~ /^#\s+This file was generated using Parse::Yapp version [\d.]+/m; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Php.pm b/lib/Lintian/Check/Languages/Php.pm new file mode 100644 index 0000000..948a7a3 --- /dev/null +++ b/lib/Lintian/Check/Languages/Php.pm @@ -0,0 +1,53 @@ +# languages/php -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Php; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + # /etc/php/*/mods-available/*.ini + if ( $item->is_file + && $item->name =~ m{^etc/php/.*/mods-available/.+\.ini$}) { + + $self->pointed_hint('obsolete-comments-style-in-php-ini', + $item->pointer) + if $item->decoded_utf8 =~ /^\s*#/m; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Php/Composer.pm b/lib/Lintian/Check/Languages/Php/Composer.pm new file mode 100644 index 0000000..142c1e8 --- /dev/null +++ b/lib/Lintian/Check/Languages/Php/Composer.pm @@ -0,0 +1,93 @@ +# languages/php/composer -- lintian check script -*- perl -*- +# +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Php::Composer; + +use v5.20; +use warnings; +use utf8; + +use Lintian::Relation; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $control = $self->processable->debian_control; + my $source_fields = $control->source_fields; + + for my $field ( + qw(Build-Depends Build-Depends-Indep + Build-Conflicts Build-Conflicts-Indep) + ) { + next + unless $source_fields->declares($field); + + my $position = $source_fields->position($field); + my $pointer = $control->item->pointer($position); + + my $raw = $source_fields->value($field); + my $relation = Lintian::Relation->new->load($raw); + + my $condition = 'composer:any'; + + $self->pointed_hint('composer-prerequisite', $pointer, $field, + '(in source paragraph)') + if $relation->satisfies($condition); + } + + for my $installable ($control->installables) { + my $installable_fields = $control->installable_fields($installable); + + for my $field ( + qw(Pre-Depends Depends Recommends Suggests Breaks + Conflicts Provides Replaces Enhances) + ) { + next + unless $installable_fields->declares($field); + + my $position = $installable_fields->position($field); + my $pointer = $control->item->pointer($position); + + my $relation + = $self->processable->binary_relation($installable, $field); + + my $condition = 'composer:any'; + + $self->pointed_hint('composer-prerequisite', $pointer, $field, + "(in section for $installable)") + if $relation->satisfies($condition); + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Php/Embedded.pm b/lib/Lintian/Check/Languages/Php/Embedded.pm new file mode 100644 index 0000000..2287f09 --- /dev/null +++ b/lib/Lintian/Check/Languages/Php/Embedded.pm @@ -0,0 +1,92 @@ +# languages/php/embedded -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Php::Embedded; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +my $PHP_EXT = qr{(?i)\.(?:php|inc|dtd)$}; +my %PHP_FILES = ( + 'libphp-adodb' => qr{(?i)/adodb\.inc\.php$}, + 'smarty3?' => qr{(?i)/Smarty(?:_Compiler)?\.class\.php$}, + 'libphp-phpmailer' => qr{(?i)/class\.phpmailer(\.(?:php|inc))+$}, + 'phpsysinfo' => +qr{(?i)/phpsysinfo\.dtd|/class\.(?:Linux|(?:Open|Net|Free|)BSD)\.inc\.php$}, + 'php-openid' => qr{/Auth/(?:OpenID|Yadis/Yadis)\.php$}, + 'libphp-snoopy' => qr{(?i)/Snoopy\.class\.(?:php|inc)$}, + 'php-markdown' => qr{(?i)/markdown\.php$}, + 'php-geshi' => qr{(?i)/geshi\.php$}, + 'libphp-pclzip' =>qr{(?i)/(?:class[.-])?pclzip\.(?:inc|lib)?\.php$}, + 'libphp-phplayersmenu' => qr{(?i)/.*layersmenu.*/(lib/)?PHPLIB\.php$}, + 'libphp-phpsniff' => qr{(?i)/phpSniff\.(?:class|core)\.php$}, + 'libphp-jabber' => qr{(?i)/(?:class\.)?jabber\.php$}, + 'libphp-simplepie' => + qr{(?i)/(?:class[\.-])?simplepie(?:\.(?:php|inc))+$}, + 'libphp-jpgraph' => qr{(?i)/jpgraph\.php$}, + 'php-fpdf' => qr{(?i)/fpdf\.php$}, + 'php-getid3' => qr{(?i)/getid3\.(?:lib\.)?(?:\.(?:php|inc))+$}, + 'php-php-gettext' => qr{(?i)/(?<!pomo/)streams\.php$}, + 'libphp-magpierss' => qr{(?i)/rss_parse\.(?:php|inc)$}, + 'php-simpletest' => qr{(?i)/unit_tester\.php$}, + 'libsparkline-php' => qr{(?i)/Sparkline\.php$}, + 'libnusoap-php' => qr{(?i)/(?:class\.)?nusoap\.(?:php|inc)$}, + 'php-htmlpurifier' => qr{(?i)/HTMLPurifier\.php$}, + # not yet available in unstable:, + # 'libphp-ixr' => qr{(?i)/IXR_Library(?:\.inc|\.php)+$}, + # 'libphp-kses' => qr{(?i)/(?:class\.)?kses\.php$}, +); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + # embedded PHP + for my $provider (keys %PHP_FILES) { + + next + if $self->processable->name =~ /^$provider$/; + + next + unless $item->name =~ /$PHP_FILES{$provider}/; + + $self->pointed_hint('embedded-php-library', $item->pointer, + 'please use',$provider); + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Php/Pear.pm b/lib/Lintian/Check/Languages/Php/Pear.pm new file mode 100644 index 0000000..b73b268 --- /dev/null +++ b/lib/Lintian/Check/Languages/Php/Pear.pm @@ -0,0 +1,242 @@ +# langauges/php/pear -- lintian check script -*- perl -*- + +# Copyright (C) 2013 Mathieu Parent <math.parent@gmail.com> +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Php::Pear; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(none); +use Unicode::UTF8 qw(encode_utf8); + +const my $DOLLAR => q{$}; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + # Don't check package if it doesn't contain a .php file + if (none { $_->basename =~ m/\.php$/i && !$_->is_dir } + @{$self->processable->patched->sorted_list}){ + return; + } + + my $build_depends = $self->processable->relation('Build-Depends'); + my $package_type = 'unknown'; + + # PEAR or PECL package + my $package_xml = $self->processable->patched->lookup('package.xml'); + my $package2_xml = $self->processable->patched->lookup('package2.xml'); + + my $debian_control = $self->processable->debian_control; + + if (defined($package_xml) || defined($package2_xml)) { + # Checking source builddep + if (!$build_depends->satisfies('pkg-php-tools')) { + $self->hint('pear-package-without-pkg-php-tools-builddep'); + + } else { + # Checking first binary relations + my @binaries = $debian_control->installables; + my $binary = $binaries[0]; + + my $depends + = $self->processable->binary_relation($binary, 'Depends'); + my $recommends + = $self->processable->binary_relation($binary, 'Recommends'); + my $breaks= $self->processable->binary_relation($binary, 'Breaks'); + + $self->hint('pear-package-but-missing-dependency', 'Depends') + unless $depends->satisfies($DOLLAR . '{phppear:Debian-Depends}'); + + $self->hint('pear-package-but-missing-dependency','Recommends') + unless $recommends->satisfies( + $DOLLAR . '{phppear:Debian-Recommends}'); + + $self->hint('pear-package-but-missing-dependency', 'Breaks') + unless $breaks->satisfies($DOLLAR . '{phppear:Debian-Breaks}'); + + # checking description + my $description + = $debian_control->installable_fields($binary) + ->untrimmed_value('Description'); + + $self->hint( + 'pear-package-not-using-substvar', + $DOLLAR . '{phppear:summary}' + )if $description !~ /\$\{phppear:summary\}/; + + $self->hint( + 'pear-package-not-using-substvar', + $DOLLAR . '{phppear:description}' + )if $description !~ /\$\{phppear:description\}/; + + if (defined $package_xml && $package_xml->is_regular_file) { + + # Wild guess package type as in + # PEAR_PackageFile_v2::getPackageType() + open(my $package_xml_fd, '<', $package_xml->unpacked_path) + or die encode_utf8( + 'Cannot open ' . $package_xml->unpacked_path); + + while (my $line = <$package_xml_fd>) { + if ( + $line =~ m{\A \s* < + (php|extsrc|extbin|zendextsrc|zendextbin) + release \s* /? > }xsm + ) { + $package_type = $1; + last; + } + if ($line =~ /^\s*<bundle\s*\/?>/){ + $package_type = 'bundle'; + last; + } + } + + close $package_xml_fd; + + if ($package_type eq 'extsrc') { # PECL package + if (!$build_depends->satisfies('php-dev')) { + + $self->pointed_hint( + 'pecl-package-requires-build-dependency', + $package_xml->pointer,'php-dev'); + } + + if (!$build_depends->satisfies('dh-php')) { + $self->pointed_hint( + 'pecl-package-requires-build-dependency', + $package_xml->pointer,'dh-php'); + } + } + } + } + } + + # PEAR channel + my $channel_xml = $self->processable->patched->lookup('channel.xml'); + $self->pointed_hint('pear-channel-without-pkg-php-tools-builddep', + $channel_xml->pointer) + if defined $channel_xml + && !$build_depends->satisfies('pkg-php-tools'); + + # Composer package + my $composer_json = $self->processable->patched->lookup('composer.json'); + $self->pointed_hint('composer-package-without-pkg-php-tools-builddep', + $composer_json->pointer) + if defined $composer_json + && !($build_depends->satisfies('pkg-php-tools') + || $build_depends->satisfies('dh-sequence-phpcomposer')) + && !defined $package_xml + && !defined $package2_xml; + + # Check rules + if ( + $build_depends->satisfies('pkg-php-tools') + && ( defined $package_xml + || defined $package2_xml + || defined $channel_xml + || defined $composer_json) + ) { + my $rules = $self->processable->patched->resolve_path('debian/rules'); + if (defined $rules && $rules->is_open_ok) { + + my $has_buildsystem_phppear = 0; + my $has_addon_phppear = 0; + my $has_addon_phpcomposer= 0; + my $has_addon_php = 0; + + open(my $rules_fd, '<', $rules->unpacked_path) + or die encode_utf8('Cannot open ' . $rules->unpacked_path); + + while (my $line = <$rules_fd>) { + + while ($line =~ s/\\$// && defined(my $cont = <$rules_fd>)) { + $line .= $cont; + } + + next + if $line =~ /^\s*\#/; + + $has_buildsystem_phppear = 1 + if $line + =~ /^\t\s*dh\s.*--buildsystem(?:=|\s+)(?:\S+,)*phppear(?:,\S+)*\s/; + + $has_addon_phppear = 1 + if $line + =~ /^\t\s*dh\s.*--with(?:=|\s+)(?:\S+,)*phppear(?:,\S+)*\s/; + + $has_addon_phpcomposer = 1 + if $line + =~ /^\t\s*dh\s.*--with(?:=|\s+)(?:\S+,)*phpcomposer(?:,\S+)*\s/; + + $has_addon_php = 1 + if $line + =~ /^\t\s*dh\s.*--with(?:=|\s+)(?:\S+,)*php(?:,\S+)*\s/; + } + + close $rules_fd; + + if ( defined $package_xml + || defined $package2_xml + || defined $channel_xml) { + + $self->pointed_hint('missing-pkg-php-tools-buildsystem', + $rules->pointer, 'phppear') + unless $has_buildsystem_phppear; + + $self->pointed_hint('missing-pkg-php-tools-addon', + $rules->pointer, 'phppear') + unless $has_addon_phppear; + + $self->pointed_hint('missing-pkg-php-tools-addon', + $rules->pointer, 'php') + if $package_type eq 'extsrc' + && !$has_addon_php; + } + + if ( !defined $package_xml + && !defined $package2_xml + && defined $composer_json) { + + $self->pointed_hint('missing-pkg-php-tools-addon', + $rules->pointer, 'phpcomposer') + unless $has_addon_phpcomposer; + } + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Php/Pear/Embedded.pm b/lib/Lintian/Check/Languages/Php/Pear/Embedded.pm new file mode 100644 index 0000000..dfb1268 --- /dev/null +++ b/lib/Lintian/Check/Languages/Php/Pear/Embedded.pm @@ -0,0 +1,92 @@ +# languages/php/pear/embedded -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Php::Pear::Embedded; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +my $PEAR_MAGIC = qr{pear[/.]}; +my $PEAR_EXT = qr{(?i)\.php$}; +my %PEAR_FILES = ( + 'php-auth' => qr{/Auth} . $PEAR_EXT, + 'php-auth-http' => qr{/Auth/HTTP} . $PEAR_EXT, + 'php-benchmark' => qr{/Benchmark/(?:Timer|Profiler|Iterate)} + . $PEAR_EXT, + 'php-http' => qr{(?<!/Auth)/HTTP} . $PEAR_EXT, + 'php-cache' => qr{/Cache} . $PEAR_EXT, + 'php-cache-lite' => qr{/Cache/Lite} . $PEAR_EXT, + 'php-compat' => qr{/Compat} . $PEAR_EXT, + 'php-config' => qr{/Config} . $PEAR_EXT, + 'php-crypt-cbc' => qr{/CBC} . $PEAR_EXT, + 'php-date' => qr{/Date} . $PEAR_EXT, + 'php-db' => qr{(?<!/Container)/DB} . $PEAR_EXT, + 'php-file' => qr{(?<!/Container)/File} . $PEAR_EXT, + 'php-log' => + qr{(?:/Log/(?:file|error_log|null|syslog|sql\w*)|/Log)} . $PEAR_EXT, + 'php-mail' => qr{/Mail} . $PEAR_EXT, + 'php-mail-mime' => qr{(?i)/mime(Part)?} . $PEAR_EXT, + 'php-mail-mimedecode' => qr{/mimeDecode} . $PEAR_EXT, + 'php-net-ftp' => qr{/FTP} . $PEAR_EXT, + 'php-net-imap' => qr{(?<!/Container)/IMAP} . $PEAR_EXT, + 'php-net-ldap' => qr{(?<!/Container)/LDAP} . $PEAR_EXT, + 'php-net-smtp' => qr{/SMTP} . $PEAR_EXT, + 'php-net-socket' => qr{(?<!/FTP)/Socket} . $PEAR_EXT, +); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + # embedded PEAR + for my $provider (keys %PEAR_FILES) { + + next + if $self->processable->name =~ /^$provider$/; + + next + unless $item->name =~ /$PEAR_FILES{$provider}/; + + next + unless length $item->bytes_match($PEAR_MAGIC); + + $self->pointed_hint('embedded-pear-module', $item->pointer, + 'please use',$provider); + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Python.pm b/lib/Lintian/Check/Languages/Python.pm new file mode 100644 index 0000000..089fce4 --- /dev/null +++ b/lib/Lintian/Check/Languages/Python.pm @@ -0,0 +1,516 @@ +# languages/python -- lintian check script -*- perl -*- +# +# Copyright (C) 2016 Chris Lamb +# Copyright (C) 2020 Louis-Philippe Veronneau <pollo@debian.org> +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Python; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(any none); +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::Relation; +use Lintian::Relation::Version qw(versions_lte); + +const my $EMPTY => q{}; +const my $ARROW => q{ -> }; +const my $DOLLAR => q{$}; + +const my $PYTHON3_MAJOR => 3; +const my $PYTHON2_MIGRATION_MAJOR => 2; +const my $PYTHON2_MIGRATION_MINOR => 6; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +my @FIELDS = qw(Depends Pre-Depends Recommends Suggests); +my @IGNORE = qw(-dev$ -docs?$ -common$ -tools$); +my @PYTHON2 = qw(python2:any python2.7:any python2-dev:any); +my @PYTHON3 = qw(python3:any python3-dev:any); + +my %DJANGO_PACKAGES = ( + '^python3-django-' => 'python3-django', + '^python2?-django-' => 'python-django', +); + +my %REQUIRED_DEPENDS = ( + 'python2' => 'python2-minimal:any | python2:any', + 'python3' => 'python3-minimal:any | python3:any', +); + +my %MISMATCHED_SUBSTVARS = ( + '^python3-.+' => $DOLLAR . '{python:Depends}', + '^python2?-.+' => $DOLLAR . '{python3:Depends}', +); + +has ALLOWED_PYTHON_FILES => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return $self->data->load('files/allowed-python-files'); + } +); +has GENERIC_PYTHON_MODULES => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return $self->data->load('files/generic-python-modules'); + } +); + +my @VERSION_FIELDS = qw(X-Python-Version XS-Python-Version X-Python3-Version); + +has correct_location => (is => 'rw', default => sub { {} }); + +sub source { + my ($self) = @_; + + my @installable_names = $self->processable->debian_control->installables; + for my $installable_name (@installable_names) { + # Python 2 modules + if ($installable_name =~ /^python2?-(.*)$/) { + my $suffix = $1; + + next + if any { $installable_name =~ /$_/ } @IGNORE; + + next + if any { $_ eq "python3-${suffix}" } @installable_names; + + # Don't trigger if we ship any Python 3 module + next + if any { + $self->processable->binary_relation($_, 'all') + ->satisfies($DOLLAR . '{python3:Depends}') + }@installable_names; + + $self->hint('python-foo-but-no-python3-foo', $installable_name); + } + } + + my $build_all = $self->processable->relation('Build-Depends-All'); + $self->hint('build-depends-on-python-sphinx-only') + if $build_all->satisfies('python-sphinx') + && !$build_all->satisfies('python3-sphinx'); + + $self->hint( + 'alternatively-build-depends-on-python-sphinx-and-python3-sphinx') + if $self->processable->fields->value('Build-Depends') + =~ /\bpython-sphinx\s+\|\s+python3-sphinx\b/; + + my $debian_control = $self->processable->debian_control; + + # Mismatched substvars + for my $regex (keys %MISMATCHED_SUBSTVARS) { + my $substvar = $MISMATCHED_SUBSTVARS{$regex}; + + for my $installable_name ($debian_control->installables) { + + next + if any { $installable_name =~ /$_/ } @IGNORE; + + next + if $installable_name !~ qr/$regex/; + + $self->hint('mismatched-python-substvar', $installable_name, + $substvar) + if $self->processable->binary_relation($installable_name, 'all') + ->satisfies($substvar); + } + } + + my $VERSIONS = $self->data->load('python/versions', qr/\s*=\s*/); + + for my $field (@VERSION_FIELDS) { + + next + unless $debian_control->source_fields->declares($field); + + my $pyversion= $debian_control->source_fields->value($field); + + my @valid = ( + ['\d+\.\d+', '\d+\.\d+'],['\d+\.\d+'], + ['\>=\s*\d+\.\d+', '\<\<\s*\d+\.\d+'],['\>=\s*\d+\.\d+'], + ['current', '\>=\s*\d+\.\d+'],['current'], + ['all'] + ); + + my @pyversion = split(/\s*,\s*/, $pyversion); + + if ($pyversion =~ m/^current/) { + $self->hint('python-version-current-is-deprecated', $field); + } + + if (@pyversion > 2) { + if (any { !/^\d+\.\d+$/ } @pyversion) { + $self->hint('malformed-python-version', $field, $pyversion); + } + } else { + my $okay = 0; + for my $rule (@valid) { + if ( + $pyversion[0] =~ /^$rule->[0]$/ + && ( + ( + $pyversion[1] + && $rule->[1] + && $pyversion[1] =~ /^$rule->[1]$/ + ) + || (!$pyversion[1] && !$rule->[1]) + ) + ) { + $okay = 1; + last; + } + } + $self->hint('malformed-python-version', $field, $pyversion) + unless $okay; + } + + if ($pyversion =~ /\b(([23])\.\d+)$/) { + my ($v, $major) = ($1, $2); + my $old = $VERSIONS->value("old-python$major"); + my $ancient = $VERSIONS->value("ancient-python$major"); + + if (versions_lte($v, $ancient)) { + $self->hint('ancient-python-version-field', $field, $v); + } elsif (versions_lte($v, $old)) { + $self->hint('old-python-version-field', $field, $v); + } + } + } + + $self->hint('source-package-encodes-python-version') + if $self->processable->name =~ m/^python\d-/ + && $self->processable->name ne 'python3-defaults'; + + my $build_depends = Lintian::Relation->new; + $build_depends->load_norestriction( + $self->processable->fields->value('Build-Depends')); + + my $pyproject= $self->processable->patched->resolve_path('pyproject.toml'); + if (defined $pyproject && $pyproject->is_open_ok) { + + my %PYPROJECT_PREREQUISITES = ( + 'poetry.core.masonry.api' => 'python3-poetry-core:any', + 'flit_core.buildapi' => 'flit:any', + 'setuptools.build_meta' => 'python3-setuptools:any', + 'pdm.pep517.api' => 'python3-pdm-pep517:any', + 'hatchling.build' => 'python3-hatchling:any', + 'mesonpy' => 'python3-mesonpy:any', + 'sipbuild.api' => 'python3-sipbuild:any' + ); + + open(my $fd, '<', $pyproject->unpacked_path) + or die encode_utf8('Cannot open ' . $pyproject->unpacked_path); + + my $position = 1; + while (my $line = <$fd>) { + + my $pointer = $pyproject->pointer($position); + + # In theory, TOML only uses double quotes. In practice, that's not + # true and only matching for double quotes introduce false negatives + if ($line =~ m{^ \s* build-backend \s* = \s* "([^"]+)" }x + || $line =~ m{^ \s* build-backend \s* = \s* '([^"]+)' }x) { + + my $backend = $1; + + $self->pointed_hint('uses-poetry-cli', $pointer) + if $backend eq 'poetry.core.masonry.api' + && $build_depends->satisfies('python3-poetry:any') + && !$build_depends->satisfies('python3-poetry-core:any'); + + $self->pointed_hint('uses-pdm-cli', $pointer) + if $backend eq 'pdm.pep517.api' + && $build_depends->satisfies('python3-pdm:any') + && !$build_depends->satisfies('python3-pdm-pep517:any'); + + if (exists $PYPROJECT_PREREQUISITES{$backend}) { + + my $prerequisites = $PYPROJECT_PREREQUISITES{$backend} + . ', pybuild-plugin-pyproject:any'; + + $self->pointed_hint( + 'missing-prerequisite-for-pyproject-backend', + $pointer, $backend,"(does not satisfy $prerequisites)") + if !$build_all->satisfies($prerequisites); + } + } + + } continue { + ++$position; + } + + close $fd; + } + + return; +} + +sub visit_installed_files { + my ($self, $item) = @_; + + # .pyc/.pyo (compiled Python files) + # skip any file installed inside a __pycache__ directory + # - we have a separate check for that directory. + $self->pointed_hint('package-installs-python-bytecode', $item->pointer) + if $item->name =~ /\.py[co]$/ + && $item->name !~ m{/__pycache__/}; + + # __pycache__ (directory for pyc/pyo files) + $self->pointed_hint('package-installs-python-pycache-dir', $item->pointer) + if $item->is_dir + && $item->name =~ m{/__pycache__/}; + + if ( $item->is_file + && $item->name + =~ m{^usr/lib/debug/usr/lib/pyshared/(python\d?(?:\.\d+))/(.+)$}) { + + my $correct = "usr/lib/debug/usr/lib/pymodules/$1/$2"; + $self->pointed_hint('python-debug-in-wrong-location', + $item->pointer, "better: $correct"); + } + + # .egg (Python egg files) + $self->pointed_hint('package-installs-python-egg', $item->pointer) + if $item->name =~ /\.egg$/ + && ( $item->name =~ m{^usr/lib/python\d+(?:\.\d+/)} + || $item->name =~ m{^usr/lib/pyshared} + || $item->name =~ m{^usr/share/}); + + # /usr/lib/site-python + $self->pointed_hint('file-in-usr-lib-site-python', $item->pointer) + if $item->name =~ m{^usr/lib/site-python/\S}; + + # pythonX.Y extensions + if ( $item->name =~ m{^usr/lib/python\d\.\d/\S} + && $item->name !~ m{^usr/lib/python\d\.\d/(?:site|dist)-packages/}){ + + $self->pointed_hint('third-party-package-in-python-dir',$item->pointer) + unless $self->processable->source_name =~ m/^python(?:\d\.\d)?$/ + || $self->processable->source_name =~ m{\A python\d?- + (?:stdlib-extensions|profiler|old-doctools) \Z}xsm; + } + + # ---------------- Python file locations + # - The Python people kindly provided the following table. + # good: + # /usr/lib/python2.5/site-packages/ + # /usr/lib/python2.6/dist-packages/ + # /usr/lib/python2.7/dist-packages/ + # /usr/lib/python3/dist-packages/ + # + # bad: + # /usr/lib/python2.5/dist-packages/ + # /usr/lib/python2.6/site-packages/ + # /usr/lib/python2.7/site-packages/ + # /usr/lib/python3.*/*-packages/ + if ( + $item->name =~ m{\A + (usr/lib/debug/)? + usr/lib/python(\d+(?:\.\d+)?)/ + ((?:site|dist)-packages)/(.+) + \Z}xsm + ){ + my ($debug, $pyver, $actual_package_dir, $relative) = ($1, $2, $3, $4); + $debug //= $EMPTY; + + my ($pmaj, $pmin) = split(m{\.}, $pyver, 2); + $pmin //= 0; + + next + if $pmaj < $PYTHON2_MIGRATION_MAJOR; + + my ($module_name) = ($relative =~ m{^([^/]+)}); + + my $actual_python_libpath = "usr/lib/python$pyver/"; + my $specified_python_libpath = "usr/lib/python$pmaj/"; + + # for python 2.X, folder was python2.X and not python2 + $specified_python_libpath = $actual_python_libpath + if $pmaj < $PYTHON3_MAJOR; + + my $specified_package_dir = 'dist-packages'; + + # python 2.4 and 2.5 + $specified_package_dir = 'site-packages' + if $pmaj == $PYTHON2_MIGRATION_MAJOR + && $pmin < $PYTHON2_MIGRATION_MINOR; + + my $actual_module_path + = $debug. $actual_python_libpath. "$actual_package_dir/$module_name"; + my $specified_module_path + = $debug + . $specified_python_libpath + . "$specified_package_dir/$module_name"; + + $self->correct_location->{$actual_module_path} = $specified_module_path + unless $actual_module_path eq $specified_module_path; + + for my $regex ($self->GENERIC_PYTHON_MODULES->all) { + $self->pointed_hint('python-module-has-overly-generic-name', + $item->pointer, "($1)") + if $relative =~ m{^($regex)(?:\.py|/__init__\.py)$}i; + } + + $self->pointed_hint('unknown-file-in-python-module-directory', + $item->pointer) + if $item->is_file + && $relative eq $item->basename # "top-level" + &&!$self->ALLOWED_PYTHON_FILES->matches_any($item->basename, 'i'); + } + + return; +} + +sub installable { + my ($self) = @_; + + $self->hint( + 'python-module-in-wrong-location', + $_ . $ARROW . $self->correct_location->{$_} + )for keys %{$self->correct_location}; + + my $deps + = $self->processable->relation('all') + ->logical_and($self->processable->relation('Provides'), + $self->processable->name); + + my @entries + = $self->processable->changelog + ? @{$self->processable->changelog->entries} + : (); + + # Check for missing dependencies + if ($self->processable->name !~ /-dbg$/) { + for my $item (@{$self->processable->installed->sorted_list}) { + + if ( $item->is_file + && $item->name + =~ m{^usr/lib/(?<version>python[23])[\d.]*/(?:site|dist)-packages} + && !$deps->satisfies($REQUIRED_DEPENDS{$+{version}})) { + + $self->hint('python-package-missing-depends-on-python'); + + last; + } + } + } + + # Check for duplicate dependencies + for my $field (@FIELDS) { + my $dep = $self->processable->relation($field); + FIELD: for my $py2 (@PYTHON2) { + for my $py3 (@PYTHON3) { + + if ($dep->satisfies($py2) && $dep->satisfies($py3)) { + $self->hint('depends-on-python2-and-python3', + $field, "(satisfies $py2, $py3)"); + last FIELD; + } + } + } + } + + my $pkg = $self->processable->name; + + # Python 2 modules + $self->hint('new-package-should-not-package-python2-module', + $self->processable->name) + if $self->processable->name =~ / ^ python2? - /msx + && (none { $pkg =~ m{ $_ }x } @IGNORE) + && @entries == 1 + && $entries[0]->Changes + !~ / \b python [ ]? 2 (?:[.]x)? [ ] (?:variant|version) \b /imsx + && $entries[0]->Changes !~ / \Q$pkg\E /msx; + + # Python applications + if ($self->processable->name !~ /^python[23]?-/ + && (none { $_ eq $self->processable->name } @PYTHON2)) { + for my $field (@FIELDS) { + for my $dep (@PYTHON2) { + + $self->hint( + 'dependency-on-python-version-marked-for-end-of-life', + $field, "(satisfies $dep)") + if $self->processable->relation($field)->satisfies($dep); + } + } + } + + # Django modules + for my $regex (keys %DJANGO_PACKAGES) { + my $basepkg = $DJANGO_PACKAGES{$regex}; + + next + if $self->processable->name !~ /$regex/; + + next + if any { $self->processable->name =~ /$_/ } @IGNORE; + + $self->hint('django-package-does-not-depend-on-django', $basepkg) + unless $self->processable->relation('strong')->satisfies($basepkg); + } + + if ( + $self->processable->name =~ /^python([23]?)-/ + && (none { $self->processable->name =~ /$_/ } @IGNORE) + ) { + my $version = $1 || '2'; # Assume python-foo is a Python 2.x package + my @prefixes = ($version eq '2') ? 'python3' : qw(python python2); + + for my $field (@FIELDS) { + for my $prefix (@prefixes) { + + my $visit = sub { + my $rel = $_; + return if any { $rel =~ /$_/ } @IGNORE; + $self->hint( +'python-package-depends-on-package-from-other-python-variant', + "$field: $rel" + ) if /^$prefix-/; + }; + + $self->processable->relation($field) + ->visit($visit, Lintian::Relation::VISIT_PRED_NAME); + } + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Python/BogusPrerequisites.pm b/lib/Lintian/Check/Languages/Python/BogusPrerequisites.pm new file mode 100644 index 0000000..fe2df7f --- /dev/null +++ b/lib/Lintian/Check/Languages/Python/BogusPrerequisites.pm @@ -0,0 +1,88 @@ +# languages/python/bogus-prerequisites -- lintian check script -*- perl -*- +# +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Python::BogusPrerequisites; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub installable { + my ($self) = @_; + + $self->what_is_python($self->processable->source_name, + qw{Depends Pre-Depends Recommends}); + + return; +} + +sub source { + my ($self) = @_; + + $self->what_is_python($self->processable->name, + qw{Build-Depends Build-Depends-Indep Build-Depends-Arch}); + + return; +} + +sub what_is_python { + my ($self, $source, @fields) = @_; + + # see Bug#973011 + my @WHAT_IS_PYTHON = qw( + python-is-python2:any + python-dev-is-python2:any + python-is-python3:any + python-dev-is-python3:any + ); + + my %BOGUS_PREREQUISITES; + + unless ($source eq 'what-is-python') { + + for my $unwanted (@WHAT_IS_PYTHON) { + + $BOGUS_PREREQUISITES{$unwanted} + = [grep {$self->processable->relation($_)->satisfies($unwanted)} + @fields]; + } + } + + for my $unwanted (keys %BOGUS_PREREQUISITES) { + + $self->hint('bogus-python-prerequisite', $_, "(satisfies $unwanted)") + for @{$BOGUS_PREREQUISITES{$unwanted}}; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Python/DistOverrides.pm b/lib/Lintian/Check/Languages/Python/DistOverrides.pm new file mode 100644 index 0000000..2dadeb6 --- /dev/null +++ b/lib/Lintian/Check/Languages/Python/DistOverrides.pm @@ -0,0 +1,80 @@ +# languages/python/dist-overrides -- lintian check script -*- perl -*- +# +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Python::DistOverrides; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(uniq); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $SPACE => q{ }; + +sub source { + my ($self) = @_; + + my $override_file + = $self->processable->patched->resolve_path('debian/py3dist-overrides'); + return + unless defined $override_file; + + my $contents = $override_file->decoded_utf8; + return + unless length $contents; + + # strip comments + $contents =~ s/^\s*\#.*$//mg; + + # strip empty lines + $contents =~ s/^\s*$//mg; + + # trim leading spaces + $contents =~ s/^\s*//mg; + + my @lines = split(/\n/, $contents); + + # get first component from each line + my @identifiers + = grep { defined } map { (split($SPACE, $_, 2))[0] } @lines; + + my %count; + $count{$_}++ for @identifiers; + + my @duplicates = grep { $count{$_} > 1 } uniq @identifiers; + + $self->hint('duplicate-p3dist-override', $_) for @duplicates; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Python/Distutils.pm b/lib/Lintian/Check/Languages/Python/Distutils.pm new file mode 100644 index 0000000..cbc30ce --- /dev/null +++ b/lib/Lintian/Check/Languages/Python/Distutils.pm @@ -0,0 +1,77 @@ +# languages/python/distutils -- lintian check script -*- perl -*- +# +# Copyright (C) 2022 Louis-Philippe Véronneau <pollo@debian.org> +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Python::Distutils; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +my $PYTHON3_DEPEND + = 'python3:any | python3-dev:any | python3-all:any | python3-all-dev:any'; + +sub visit_patched_files { + my ($self, $item) = @_; + + my $build_all = $self->processable->relation('Build-Depends-All'); + + # Skip if the package doesn't depend on python + return + unless $build_all->satisfies($PYTHON3_DEPEND); + + # Skip if it's not a python file + return + unless $item->name =~ /\.py$/; + + # Skip if we can't open the file + return + unless $item->is_open_ok; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $position = 1; + while (my $line = <$fd>) { + + my $pointer = $item->pointer($position); + + $self->pointed_hint('uses-python-distutils', $pointer) + if $line =~ m{^from distutils} || $line =~ m{^import distutils}; + } continue { + ++$position; + } + + close $fd; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Python/Feedparser.pm b/lib/Lintian/Check/Languages/Python/Feedparser.pm new file mode 100644 index 0000000..da716e7 --- /dev/null +++ b/lib/Lintian/Check/Languages/Python/Feedparser.pm @@ -0,0 +1,54 @@ +# languages/python/feedparser -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Python::Feedparser; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + # embedded Feedparser library + $self->pointed_hint('embedded-feedparser-library', $item->pointer) + if $item->name =~ m{ / feedparser[.]py $}x + && $item->bytes =~ /Universal feed parser/ + && $self->processable->source_name ne 'feedparser'; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Python/Homepage.pm b/lib/Lintian/Check/Languages/Python/Homepage.pm new file mode 100644 index 0000000..18a0470 --- /dev/null +++ b/lib/Lintian/Check/Languages/Python/Homepage.pm @@ -0,0 +1,59 @@ +# languages/python/homepage -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2021 Felix Lechner +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Python::Homepage; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $fields = $self->processable->fields; + if ($fields->declares('Homepage')) { + + my $homepage = $fields->value('Homepage'); + + # see Bug#981932 + $self->hint('pypi-homepage', $homepage) + if $homepage + =~ m{^http s? :// (?:www [.])? pypi (:?[.] python)? [.] org/}isx; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Python/Obsolete.pm b/lib/Lintian/Check/Languages/Python/Obsolete.pm new file mode 100644 index 0000000..e810faa --- /dev/null +++ b/lib/Lintian/Check/Languages/Python/Obsolete.pm @@ -0,0 +1,63 @@ +# languages/python/obsolete -- lintian check script -*- perl -*- +# +# Copyright (C) 1999 Joey Hess +# Copyright (C) 2000 Sean 'Shaleh' Perry +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2007 Russ Allbery +# Copyright (C) 2013-2018 Bastien ROUCARIES +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Python::Obsolete; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $pycompat= $self->processable->patched->resolve_path('debian/pycompat'); + + $self->pointed_hint('debian-pycompat-is-obsolete', $pycompat->pointer) + if defined $pycompat + && $pycompat->is_file; + + my $pyversions + = $self->processable->patched->resolve_path('debian/pyversions'); + + $self->pointed_hint('debian-pyversions-is-obsolete', $pyversions->pointer) + if defined $pyversions + && $pyversions->is_file; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Python/Scripts.pm b/lib/Lintian/Check/Languages/Python/Scripts.pm new file mode 100644 index 0000000..988b915 --- /dev/null +++ b/lib/Lintian/Check/Languages/Python/Scripts.pm @@ -0,0 +1,54 @@ +# languages/python/scripts -- lintian check script -*- perl -*- +# +# Copyright (C) 2016 Chris Lamb +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Python::Scripts; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->name =~ m{(?:usr/)?bin/[^/]+}; + + return + unless $item->is_script; + + $self->pointed_hint('script-uses-unversioned-python-in-shebang', + $item->pointer) + if $item->interpreter =~ m{^(?:/usr/bin/)?python$}; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/R.pm b/lib/Lintian/Check/Languages/R.pm new file mode 100644 index 0000000..daa8462 --- /dev/null +++ b/lib/Lintian/Check/Languages/R.pm @@ -0,0 +1,74 @@ +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 1999 Joey Hess +# Copyright (C) 2000 Sean 'Shaleh' Perry +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2007 Russ Allbery +# Copyright (C) 2013-2018 Bastien ROUCARIES +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::R; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +const my $RDATA_MAGIC_LENGTH => 4; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + # Ensure we have a README.source for R data files + if ( $item->basename =~ /\.(?:rda|Rda|rdata|Rdata|RData)$/ + && $item->is_open_ok + && $item->file_type =~ /gzip compressed data/ + && !$self->processable->patched->resolve_path('debian/README.source')){ + + open(my $fd, '<:gzip', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + read($fd, my $magic, $RDATA_MAGIC_LENGTH) + or die encode_utf8('Cannot read from ' . $item->unpacked_path); + + close($fd); + + $self->pointed_hint('r-data-without-readme-source', $item->pointer) + if $magic eq 'RDX2'; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/R/Architecture.pm b/lib/Lintian/Check/Languages/R/Architecture.pm new file mode 100644 index 0000000..3ee0bd2 --- /dev/null +++ b/lib/Lintian/Check/Languages/R/Architecture.pm @@ -0,0 +1,69 @@ +# languages/r/architecture -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2021 Felix Lechner +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::R::Architecture; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has have_r_files => (is => 'rw', default => 0); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + if $item->is_dir; + + $self->have_r_files(1) + if $item->name =~ m{^usr/lib/R/.*/DESCRIPTION$} + && $item->decoded_utf8 =~ /^NeedsCompilation: no/m; + + return; +} + +sub installable { + my ($self) = @_; + + $self->hint('r-package-not-arch-all') + if $self->processable->name =~ /^r-(?:cran|bioc|other)-/ + && $self->have_r_files + && $self->processable->fields->value('Architecture') ne 'all'; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/R/SiteLibrary.pm b/lib/Lintian/Check/Languages/R/SiteLibrary.pm new file mode 100644 index 0000000..1ac6ac9 --- /dev/null +++ b/lib/Lintian/Check/Languages/R/SiteLibrary.pm @@ -0,0 +1,71 @@ +# languages/r/site-library -- lintian check script -*- perl -*- + +# Copyright (C) 2020 Dylan Aissi +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::R::SiteLibrary; + +use v5.20; +use warnings; +use utf8; + +use Lintian::Relation; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has r_site_libraries => (is => 'rw', default => sub { [] }); + +sub visit_installed_files { + my ($self, $item) = @_; + + # R site libraries + if ($item->name =~ m{^usr/lib/R/site-library/(.*)/DESCRIPTION$}) { + push(@{$self->r_site_libraries}, $1); + } + + return; +} + +sub installable { + my ($self) = @_; + + $self->hint('ships-r-site-library', $_) for @{$self->r_site_libraries}; + + return + unless @{$self->r_site_libraries}; + + my $depends = $self->processable->relation('strong'); + + # no version allowed for virtual package; no alternatives + $self->hint('requires-r-api') + unless $depends->matches(qr/^r-api-[\w\d+-.]+$/, + Lintian::Relation::VISIT_OR_CLAUSE_FULL); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Ruby.pm b/lib/Lintian/Check/Languages/Ruby.pm new file mode 100644 index 0000000..563f740 --- /dev/null +++ b/lib/Lintian/Check/Languages/Ruby.pm @@ -0,0 +1,72 @@ +# languages/ruby -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2021 Felix Lechner +# +# Parts of the code were taken from the old check script, which +# was Copyright (C) 1998 Richard Braakman (also licensed under the +# GPL 2 or higher) +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Ruby; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $fields = $self->processable->fields; + if ($fields->declares('Homepage')) { + + my $homepage = $fields->value('Homepage'); + + # rubygems itself is okay; see Bug#981935 + $self->hint('rubygem-homepage', $homepage) + if $homepage + =~ m{^http s? :// (?:www [.])? rubygems [.] org/gems/}isx; + } + + return; +} + +sub binary { + my ($self) = @_; + + my @prerequisites + = $self->processable->fields->trimmed_list('Depends', qr/,/); + + my @ruby_interpreter = grep { / \b ruby-interpreter \b /x } @prerequisites; + + $self->hint('ruby-interpreter-is-deprecated', $_)for @ruby_interpreter; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Languages/Rust.pm b/lib/Lintian/Check/Languages/Rust.pm new file mode 100644 index 0000000..140134f --- /dev/null +++ b/lib/Lintian/Check/Languages/Rust.pm @@ -0,0 +1,69 @@ +# languages/rust -- lintian check script -*- perl -*- + +# Copyright (C) 2020 Sylvestre Ledru +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Languages::Rust; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $debian_control = $self->processable->debian_control; + for my $installable ($debian_control->installables) { + + my $fields = $debian_control->installable_fields($installable); + my $extended = $fields->text('Description'); + + # drop synopsis + $extended =~ s/^ [^\n]* \n //sx; + + $self->hint('rust-boilerplate', $installable) + if $extended + =~ /^ \QThis package contains the following binaries built from the Rust crate\E /isx; + } + + return; +} + +sub installable { + my ($self) = @_; + + $self->hint('empty-rust-library-declares-provides') + if $self->processable->name =~ /^librust-/ + && $self->processable->not_just_docs + && length $self->processable->fields->value('Provides'); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Libraries/DebugSymbols.pm b/lib/Lintian/Check/Libraries/DebugSymbols.pm new file mode 100644 index 0000000..4f04e6f --- /dev/null +++ b/lib/Lintian/Check/Libraries/DebugSymbols.pm @@ -0,0 +1,59 @@ +# libraries/debug-symbols -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2012 Kees Cook +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Libraries::DebugSymbols; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + return + unless $item->file_type =~ /^ [^,]* \b ELF \b /x; + + # stripped but a debug or profiling library? + $self->pointed_hint('stripped-library', $item->pointer) + if $item->file_type !~ m{\bnot stripped\b} + && $item->name =~ m{^ (?:usr/)? lib/ (?: debug | profile ) / }x + && $item->size; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Libraries/Embedded.pm b/lib/Lintian/Check/Libraries/Embedded.pm new file mode 100644 index 0000000..502af47 --- /dev/null +++ b/lib/Lintian/Check/Libraries/Embedded.pm @@ -0,0 +1,124 @@ +# libraries/embedded -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2012 Kees Cook +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Libraries::Embedded; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::Compare; +use Unicode::UTF8 qw(encode_utf8); + +const my $SPACE => q{ }; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has EMBEDDED_LIBRARIES => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my %embedded_libraries; + + my $data + = $self->data->load('binaries/embedded-libs',qr{ \s*+ [|][|] }x); + + for my $label ($data->all) { + + my $details = $data->value($label); + + my ($pairs, $pattern) = split(m{ [|][|] }x, $details, 2); + + my %result; + for my $kvpair (split($SPACE, $pairs)) { + + my ($key, $value) = split(/=/, $kvpair, 2); + $result{$key} = $value; + } + + my $lc= List::Compare->new([keys %result], + [qw{libname source source-regex}]); + my @unknown = $lc->get_Lonly; + + die encode_utf8( +"Unknown options @unknown for $label (in binaries/embedded-libs)" + )if @unknown; + + die encode_utf8( +"Both source and source-regex used for $label (in binaries/embedded-libs)" + )if length $result{source} && length $result{'source-regex'}; + + $result{match} = qr/$pattern/; + + $result{libname} //= $label; + $result{source} //= $label; + + $embedded_libraries{$label} = \%result; + } + + return \%embedded_libraries; + } +); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + return + unless $item->file_type =~ /^ [^,]* \b ELF \b /x; + + for my $embedded_name (keys %{$self->EMBEDDED_LIBRARIES}) { + + my $library_data = $self->EMBEDDED_LIBRARIES->{$embedded_name}; + + next + if length $library_data->{'source-regex'} + && $self->processable->source_name=~ $library_data->{'source-regex'}; + + next + if length $library_data->{source} + && $self->processable->source_name eq $library_data->{source}; + + $self->pointed_hint('embedded-library', $item->pointer, + $library_data->{libname}) + if $item->strings =~ $library_data->{match}; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Libraries/Shared/Exit.pm b/lib/Lintian/Check/Libraries/Shared/Exit.pm new file mode 100644 index 0000000..5788808 --- /dev/null +++ b/lib/Lintian/Check/Libraries/Shared/Exit.pm @@ -0,0 +1,72 @@ +# libraries/shared/exit -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz +# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Libraries::Shared::Exit; + +use v5.20; +use warnings; +use utf8; + +use List::SomeUtils qw(any none); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +# not presently used +#my $UNKNOWN_SHARED_LIBRARY_EXCEPTIONS +# = $self->data->load('shared-libs/unknown-shared-library-exceptions'); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + # shared library + return + unless @{$item->elf->{SONAME} // [] }; + + my @symbols = grep { $_->section eq '.text' || $_->section eq 'UND' } + @{$item->elf->{SYMBOLS} // []}; + + my @symbol_names = map { $_->name } @symbols; + + # If it has an INTERP section it might be an application with + # a SONAME (hi openjdk-6, see #614305). Also see the comment + # for "shared-library-is-executable" below. + $self->pointed_hint('exit-in-shared-library', $item->pointer) + if (any { m/^_?exit$/ } @symbol_names) + && (none { $_ eq 'fork' } @symbol_names) + && !length $item->elf->{INTERP}; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Libraries/Shared/FilePermissions.pm b/lib/Lintian/Check/Libraries/Shared/FilePermissions.pm new file mode 100644 index 0000000..663205e --- /dev/null +++ b/lib/Lintian/Check/Libraries/Shared/FilePermissions.pm @@ -0,0 +1,72 @@ +# libraries/shared/file-permissions -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz +# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Libraries::Shared::FilePermissions; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $WIDELY_READABLE => oct(644); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + # shared library + return + unless @{$item->elf->{SONAME} // [] }; + + # Yes. But if the library has an INTERP section, it's + # designed to do something useful when executed, so don't + # report an error. Also give ld.so a pass, since it's + # special. + $self->pointed_hint('shared-library-is-executable', + $item->pointer, $item->octal_permissions) + if $item->is_executable + && !$item->elf->{INTERP} + && $item->name !~ m{^lib.*/ld-[\d.]+\.so$}; + + $self->pointed_hint('odd-permissions-on-shared-library', + $item->pointer, $item->octal_permissions) + if !$item->is_executable + && $item->operm != $WIDELY_READABLE; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Libraries/Shared/Links.pm b/lib/Lintian/Check/Libraries/Shared/Links.pm new file mode 100644 index 0000000..e25d3fd --- /dev/null +++ b/lib/Lintian/Check/Libraries/Shared/Links.pm @@ -0,0 +1,167 @@ +# libraries/shared/links -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz +# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Libraries::Shared::Links; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(none); + +const my $ARROW => q{->}; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has development_packages => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my @development_packages; + + for my $installable ($self->group->get_installables) { + + push(@development_packages, $installable) + if $installable->name =~ /-dev$/ + && $installable->relation('strong') + ->satisfies($self->processable->name); + } + + return \@development_packages; + } +); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + # shared library + return + unless @{$item->elf->{SONAME} // [] }; + + my $soname = $item->elf->{SONAME}[0]; + + my @ldconfig_folders = @{$self->data->architectures->ldconfig_folders}; + return + if none { $item->dirname eq $_ } @ldconfig_folders; + + my $installed = $self->processable->installed; + + my $versioned_name = $item->dirname . $soname; + my $versioned_item = $installed->lookup($versioned_name); + + my $unversioned_name = $versioned_name; + # libtool "-release" variant + $unversioned_name =~ s/-[\d\.]+\.so$/.so/; + # determine shlib link name (w/o version) + $unversioned_name =~ s/\.so.+$/.so/; + + $self->pointed_hint('lacks-versioned-link-to-shared-library', + $item->pointer, $versioned_name) + unless defined $versioned_item; + + $self->pointed_hint( + 'ldconfig-symlink-referencing-wrong-file', + $versioned_item->pointer,'should point to', + $versioned_item->link,'instead of',$item->basename + ) + if $versioned_name ne $item->name + && defined $versioned_item + && $versioned_item->is_symlink + && $versioned_item->link ne $item->basename; + + $self->pointed_hint( + 'ldconfig-symlink-is-not-a-symlink', + $versioned_item->pointer,'should point to', + $item->name + ) + if $versioned_name ne $item->name + && defined $versioned_item + && !$versioned_item->is_symlink; + + # shlib symlink may not exist. + # if shlib doesn't _have_ a version, then $unversioned_name and + # $item->name will be equal, and it's not a development link, + # so don't complain. + $self->pointed_hint( + 'link-to-shared-library-in-wrong-package', + $installed->lookup($unversioned_name)->pointer, + $item->name + ) + if $unversioned_name ne $item->name + && defined $installed->lookup($unversioned_name); + + # If the shared library is in /lib, we have to look for + # the dev symlink in /usr/lib + $unversioned_name = "usr/$unversioned_name" + unless $item->name =~ m{^usr/}; + + my @dev_links; + for my $dev_installable (@{$self->development_packages}) { + for my $dev_item (@{$dev_installable->installed->sorted_list}) { + + next + unless $dev_item->is_symlink; + + next + unless $dev_item->name =~ m{^ usr/lib/ }x; + + # try absolute first + my $resolved = $installed->resolve_path($dev_item->link); + + # otherwise relative + $resolved + = $installed->resolve_path($dev_item->dirname . $dev_item->link) + unless defined $resolved; + + next + unless defined $resolved; + + push(@dev_links, $dev_item) + if $resolved->name eq $item->name; + } + } + + # found -dev package; library needs a symlink + $self->pointed_hint('lacks-unversioned-link-to-shared-library', + $item->pointer, "example: $unversioned_name") + if @{$self->development_packages} + && (none { $_->name =~ m{ [.]so $}x } @dev_links); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Libraries/Shared/MultiArch.pm b/lib/Lintian/Check/Libraries/Shared/MultiArch.pm new file mode 100644 index 0000000..52c1bc5 --- /dev/null +++ b/lib/Lintian/Check/Libraries/Shared/MultiArch.pm @@ -0,0 +1,79 @@ +# libraries/shared/multi-arch -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz +# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Libraries::Shared::MultiArch; + +use v5.20; +use warnings; +use utf8; + +use List::SomeUtils qw(none uniq); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has shared_libraries => (is => 'rw', default => sub { [] }); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + return + unless $item->file_type =~ m{^ [^,]* \b ELF \b }x; + + return + unless $item->file_type + =~ m{(?: shared [ ] object | pie [ ] executable )}x; + + my @ldconfig_folders = @{$self->data->architectures->ldconfig_folders}; + return + if none { $item->dirname eq $_ } @ldconfig_folders; + + push(@{$self->shared_libraries}, $item->name); + + return; +} + +sub installable { + my ($self) = @_; + + $self->hint( + 'shared-library-is-multi-arch-foreign', + (sort +uniq @{$self->shared_libraries}) + ) + if @{$self->shared_libraries} + && $self->processable->fields->value('Multi-Arch') eq 'foreign'; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Libraries/Shared/Obsolete.pm b/lib/Lintian/Check/Libraries/Shared/Obsolete.pm new file mode 100644 index 0000000..699b70c --- /dev/null +++ b/lib/Lintian/Check/Libraries/Shared/Obsolete.pm @@ -0,0 +1,56 @@ +# libraries/shared/obsolete -- lintian check script -*- perl -*- + +# Copyright (C) 2020 Mo Zhou +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Libraries::Shared::Obsolete; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + return + unless $item->file_type =~ /^[^,]*\bELF\b/; + + my @needed = @{$item->elf->{NEEDED} // []}; + my @obsolete = grep { /^libcblas\.so\.\d/ } @needed; + + $self->pointed_hint('linked-with-obsolete-library', $item->pointer, $_) + for @obsolete; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Libraries/Shared/Relocation.pm b/lib/Lintian/Check/Libraries/Shared/Relocation.pm new file mode 100644 index 0000000..8c3dac9 --- /dev/null +++ b/lib/Lintian/Check/Libraries/Shared/Relocation.pm @@ -0,0 +1,58 @@ +# libraries/shared/relocation -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz +# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Libraries::Shared::Relocation; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + # shared library + return + unless @{$item->elf->{SONAME} // [] }; + + # Now that we're sure this is really a shared library, report on + # non-PIC problems. + $self->pointed_hint('specific-address-in-shared-library', $item->pointer) + if $item->elf->{TEXTREL}; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Libraries/Shared/Soname.pm b/lib/Lintian/Check/Libraries/Shared/Soname.pm new file mode 100644 index 0000000..9887e3b --- /dev/null +++ b/lib/Lintian/Check/Libraries/Shared/Soname.pm @@ -0,0 +1,123 @@ +# libraries/shared/soname -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2012 Kees Cook +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Libraries::Shared::Soname; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(any none uniq); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $SPACE => q{ }; +const my $SLASH => q{/}; + +has DEB_HOST_MULTIARCH => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return $self->data->architectures->deb_host_multiarch; + } +); + +sub installable { + my ($self) = @_; + + return + if $self->processable->type eq 'udeb'; + + my $architecture = $self->processable->fields->value('Architecture'); + my $multiarch_component = $self->DEB_HOST_MULTIARCH->{$architecture}; + + my @common_folders = qw{lib usr/lib}; + push(@common_folders, map { "$_/$multiarch_component" } @common_folders) + if length $multiarch_component; + + my @duplicated; + for my $item (@{$self->processable->installed->sorted_list}) { + + # For the package naming check, filter out SONAMEs where all the + # files are at paths other than /lib, /usr/lib and /usr/lib/<MA-DIR>. + # 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. + next + if none { $item->dirname eq $_ . $SLASH } @common_folders; + + # Also filter out nsswitch modules + next + if $item->basename =~ m{^ libnss_[^.]+\.so(?:\.\d+) $}x; + + push(@duplicated, @{$item->elf->{SONAME} // []}); + } + + my @sonames = uniq @duplicated; + + # try to strip transition strings + my $shortened_name = $self->processable->name; + $shortened_name =~ s/c102\b//; + $shortened_name =~ s/c2a?\b//; + $shortened_name =~ s/\dg$//; + $shortened_name =~ s/gf$//; + $shortened_name =~ s/v[5-6]$//; # GCC-5 / libstdc++6 C11 ABI breakage + $shortened_name =~ s/-udeb$//; + $shortened_name =~ s/^lib64/lib/; + + my $match_found = 0; + for my $soname (@sonames) { + + $soname =~ s/ ([0-9]) [.]so[.] /$1-/x; + $soname =~ s/ [.]so (?:[.]|\z) //x; + $soname =~ s/_/-/g; + + my $lowercase = lc $soname; + + $match_found = any { $lowercase eq $_ } + ($self->processable->name, $shortened_name); + + last + if $match_found; + } + + $self->hint('package-name-doesnt-match-sonames', + join($SPACE, sort @sonames)) + if @sonames && !$match_found; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Libraries/Shared/Soname/Missing.pm b/lib/Lintian/Check/Libraries/Shared/Soname/Missing.pm new file mode 100644 index 0000000..a01a878 --- /dev/null +++ b/lib/Lintian/Check/Libraries/Shared/Soname/Missing.pm @@ -0,0 +1,73 @@ +# libraries/shared/soname/missing -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz +# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Libraries::Shared::Soname::Missing; + +use v5.20; +use warnings; +use utf8; + +use List::SomeUtils qw(none); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + return + unless $item->file_type =~ m{^ [^,]* \b ELF \b }x; + + return + unless $item->file_type + =~ m{(?: shared [ ] object | pie [ ] executable )}x; + + # does not have SONAME + return + if @{$item->elf->{SONAME} // [] }; + + my @ldconfig_folders = @{$self->data->architectures->ldconfig_folders}; + return + if none { $item->dirname eq $_ } @ldconfig_folders; + + # disregard executables + $self->pointed_hint('sharedobject-in-library-directory-missing-soname', + $item->pointer) + if !$item->is_executable + || !defined $item->elf->{DEBUG} + || $item->name =~ / [.]so (?: [.] | $ ) /msx; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Libraries/Shared/Stack.pm b/lib/Lintian/Check/Libraries/Shared/Stack.pm new file mode 100644 index 0000000..f3e1d03 --- /dev/null +++ b/lib/Lintian/Check/Libraries/Shared/Stack.pm @@ -0,0 +1,69 @@ +# libraries/shared/stack -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz +# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Libraries::Shared::Stack; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + # shared library + return + unless @{$item->elf->{SONAME} // [] }; + + $self->pointed_hint('shared-library-lacks-stack-section',$item->pointer) + if $self->processable->fields->declares('Architecture') + && !exists $item->elf->{PH}{STACK}; + + $self->pointed_hint('executable-stack-in-shared-library', $item->pointer) + if exists $item->elf->{PH}{STACK} + && $item->elf->{PH}{STACK}{flags} ne 'rw-' + # Once the following line is removed again, please also remove + # the Test-Architectures line in + # t/recipes/checks/libraries/shared/stack/shared-libs-exec-stack/eval/desc + # and the MIPS-related notes in + # tags/e/executable-stack-in-shared-library.tag. See + # https://bugs.debian.org/1025436 and + # https://bugs.debian.org/1022787 for details + && $self->processable->fields->value('Architecture') !~ /mips/; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Libraries/Shared/Trigger/Ldconfig.pm b/lib/Lintian/Check/Libraries/Shared/Trigger/Ldconfig.pm new file mode 100644 index 0000000..66f5961 --- /dev/null +++ b/lib/Lintian/Check/Libraries/Shared/Trigger/Ldconfig.pm @@ -0,0 +1,131 @@ +# libraries/shared/trigger/ldconfig -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz +# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Libraries::Shared::Trigger::Ldconfig; + +use v5.20; +use warnings; +use utf8; + +use List::SomeUtils qw(any uniq); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has soname_by_filename => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my %soname_by_filename; + for my $item (@{$self->processable->installed->sorted_list}) { + + $soname_by_filename{$item->name}= $item->elf->{SONAME}[0] + if exists $item->elf->{SONAME}; + } + + return \%soname_by_filename; + } +); + +has must_call_ldconfig => (is => 'rw', default => sub { [] }); + +sub visit_installed_files { + my ($self, $item) = @_; + + my $resolved_name = $item->name; + $resolved_name = $item->link_normalized + if length $item->link; + + # Installed in a directory controlled by the dynamic + # linker? We have to strip off directories named for + # hardware capabilities. + # yes! so postinst must call ldconfig + push(@{$self->must_call_ldconfig}, $resolved_name) + if exists $self->soname_by_filename->{$resolved_name} + && $self->needs_ldconfig($item); + + return; +} + +sub installable { + my ($self) = @_; + + # determine if the package had an ldconfig trigger + my $triggers = $self->processable->control->resolve_path('triggers'); + + my $we_trigger_ldconfig = 0; + $we_trigger_ldconfig = 1 + if defined $triggers + && $triggers->decoded_utf8 + =~ /^ \s* activate-noawait \s+ ldconfig \s* $/mx; + + $self->hint('package-has-unnecessary-activation-of-ldconfig-trigger') + if !@{$self->must_call_ldconfig} + && $we_trigger_ldconfig + && $self->processable->type ne 'udeb'; + + $self->hint('lacks-ldconfig-trigger', + (sort +uniq @{$self->must_call_ldconfig})) + if @{$self->must_call_ldconfig} + && !$we_trigger_ldconfig + && $self->processable->type ne 'udeb'; + + return; +} + +sub needs_ldconfig { + my ($self, $item) = @_; + + # Libraries that should only be used in the presence of certain capabilities + # may be located in subdirectories of the standard ldconfig search path with + # one of the following names. + my $HWCAP_DIRS = $self->data->load('shared-libs/hwcap-dirs'); + my @ldconfig_folders = @{$self->data->architectures->ldconfig_folders}; + + my $dirname = $item->dirname; + my $encapsulator; + do { + $dirname =~ s{ ([^/]+) / $}{}x; + $encapsulator = $1; + + } while ($encapsulator && $HWCAP_DIRS->recognizes($encapsulator)); + + $dirname .= "$encapsulator/" if $encapsulator; + + # yes! so postinst must call ldconfig + return 1 + if any { $dirname eq $_ } @ldconfig_folders; + + return 0; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Libraries/Static.pm b/lib/Lintian/Check/Libraries/Static.pm new file mode 100644 index 0000000..72c8b97 --- /dev/null +++ b/lib/Lintian/Check/Libraries/Static.pm @@ -0,0 +1,121 @@ +# libraries/static -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2012 Kees Cook +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Libraries::Static; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::Compare; +use List::SomeUtils qw(any none uniq); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $SPACE => q{ }; +const my $LEFT_PARENTHESIS => q{(}; +const my $RIGHT_PARENTHESIS => q{)}; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + return + unless $item->file_type =~ m{ \b current [ ] ar [ ] archive \b }x; + + my @unstripped_members; + my %stripped_sections_by_member; + + for my $member_name (keys %{$item->elf_by_member}) { + + my $member_elf = $item->elf_by_member->{$member_name}; + + my @elf_sections = values %{$member_elf->{'SECTION-HEADERS'}}; + my @have_section_names = map { $_->name } @elf_sections; + + # These are the ones file(1) looks for. The ".zdebug_info" being the + # compressed version of .debug_info. + # - Technically, file(1) also looks for .symtab, but that is apparently + # not strippable for static libs. Accordingly, it is omitted below. + my @KNOWN_DEBUG_SECTION_NAMES = qw{.debug_info .zdebug_info}; + my $lc_debug = List::Compare->new(\@have_section_names, + \@KNOWN_DEBUG_SECTION_NAMES); + + my @have_debug_sections = $lc_debug->get_intersection; + + if (@have_debug_sections) { + + push(@unstripped_members, $member_name); + next; + } + + my @KNOWN_STRIPPED_SECTION_NAMES = qw{.note .comment}; + my $lc_stripped = List::Compare->new(\@have_section_names, + \@KNOWN_STRIPPED_SECTION_NAMES); + + my @have_stripped_sections = $lc_stripped->get_intersection; + + $stripped_sections_by_member{$member_name} //= []; + push( + @{$stripped_sections_by_member{$member_name}}, + @have_stripped_sections + ); + } + + $self->pointed_hint('unstripped-static-library', $item->pointer, + $LEFT_PARENTHESIS + . join($SPACE, sort +uniq @unstripped_members) + . $RIGHT_PARENTHESIS) + if @unstripped_members + && $item->name !~ m{ _g [.]a $}x; + + # "libfoo_g.a" is usually a "debug" library, so ignore + # unneeded sections in those. + for my $member (keys %stripped_sections_by_member) { + + $self->pointed_hint( + 'static-library-has-unneeded-sections', + $item->pointer, + "($member)", + join($SPACE, sort +uniq @{$stripped_sections_by_member{$member}}) + ) + if @{$stripped_sections_by_member{$member}} + && $item->name !~ m{ _g [.]a $}x; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Libraries/Static/LinkTimeOptimization.pm b/lib/Lintian/Check/Libraries/Static/LinkTimeOptimization.pm new file mode 100644 index 0000000..04e65e8 --- /dev/null +++ b/lib/Lintian/Check/Libraries/Static/LinkTimeOptimization.pm @@ -0,0 +1,70 @@ +# libraries/static/link-time-optimization -- lintian check script -*- perl -*- + +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Libraries::Static::LinkTimeOptimization; + +use v5.20; +use warnings; +use utf8; + +use List::SomeUtils qw(uniq); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + # not sure if that captures everything GHC, or too much + return + if $item->name =~ m{^ usr/lib/ghc/ }x; + + return + unless $item->file_type =~ m{ \b current [ ] ar [ ] archive \b }x; + + for my $member_name (keys %{$item->elf_by_member}) { + + my $member_elf = $item->elf_by_member->{$member_name}; + + my @elf_sections = values %{$member_elf->{'SECTION-HEADERS'}}; + my @section_names = map { $_->name } @elf_sections; + + my @lto_section_names = grep { m{^ [.]gnu[.]lto }x } @section_names; + + $self->pointed_hint('static-link-time-optimization', + $item->pointer, $member_name) + if @lto_section_names; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Libraries/Static/Name.pm b/lib/Lintian/Check/Libraries/Static/Name.pm new file mode 100644 index 0000000..a4c47d1 --- /dev/null +++ b/lib/Lintian/Check/Libraries/Static/Name.pm @@ -0,0 +1,61 @@ +# libraries/static/name -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2012 Kees Cook +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Libraries::Static::Name; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + return + unless $item->file_type =~ m{ \b current [ ] ar [ ] archive \b }x; + + my $shortened = $item->name; + + if ($shortened =~ s{ _s[.]a $}{.a}x) { + + $self->pointed_hint('odd-static-library-name', $item->pointer) + unless defined $self->processable->installed->lookup($shortened); + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Libraries/Static/NoCode.pm b/lib/Lintian/Check/Libraries/Static/NoCode.pm new file mode 100644 index 0000000..0d2415a --- /dev/null +++ b/lib/Lintian/Check/Libraries/Static/NoCode.pm @@ -0,0 +1,95 @@ +# libraries/static/no-code -- lintian check script -*- perl -*- + +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Libraries::Static::NoCode; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(any uniq); +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $SPACE => q{ }; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + # not sure if that captures everything GHC, or too much + return + if $item->name =~ m{^ usr/lib/ghc/ }x; + + return + unless $item->file_type =~ m{ \b current [ ] ar [ ] archive \b }x; + + my @codeful_members; + for my $member_name (keys %{$item->elf_by_member}) { + + my $member_elf = $item->elf_by_member->{$member_name}; + + my @elf_sections = values %{$member_elf->{'SECTION-HEADERS'}}; + my @sections_with_size = grep { $_->size > 0 } @elf_sections; + + my @names_with_size = map { $_->name } @sections_with_size; + + my @KNOWN_ARRAY_SECTIONS = qw{.preinit_array .init_array .fini_array}; + my $lc_array + = List::Compare->new(\@names_with_size, \@KNOWN_ARRAY_SECTIONS); + + my @have_array_sections = $lc_array->get_intersection; + +# adapted from https://github.com/rpm-software-management/rpmlint/blob/main/rpmlint/checks/BinariesCheck.py#L242-L249 + my $has_code = 0; + + $has_code = 1 + if any { m{^ [.]text }x } @names_with_size; + + $has_code = 1 + if any { m{^ [.]data }x } @names_with_size; + + $has_code = 1 + if @have_array_sections; + + push(@codeful_members, $member_name) + if $has_code; + } + + $self->pointed_hint('no-code-sections', $item->pointer) + unless @codeful_members; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Linda.pm b/lib/Lintian/Check/Linda.pm new file mode 100644 index 0000000..f7dcca8 --- /dev/null +++ b/lib/Lintian/Check/Linda.pm @@ -0,0 +1,47 @@ +# linda -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Linda; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + $self->pointed_hint('package-contains-linda-override', $item->pointer) + if $item->name =~ m{^usr/share/linda/overrides/\S+}; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Lintian.pm b/lib/Lintian/Check/Lintian.pm new file mode 100644 index 0000000..abfcccc --- /dev/null +++ b/lib/Lintian/Check/Lintian.pm @@ -0,0 +1,38 @@ +# Lintian -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Lintian; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Mailcap.pm b/lib/Lintian/Check/Mailcap.pm new file mode 100644 index 0000000..2588d43 --- /dev/null +++ b/lib/Lintian/Check/Mailcap.pm @@ -0,0 +1,108 @@ +# mailcap -- lintian check script -*- perl -*- + +# Copyright (C) 2019 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Mailcap; + +use v5.20; +use warnings; +use utf8; +use autodie qw(open); + +use Const::Fast; +use List::SomeUtils qw(uniq); +use Text::Balanced qw(extract_delimited extract_multiple); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->name =~ m{^usr/lib/mime/packages/}; + + return + unless $item->is_file && $item->is_open_ok; + + open(my $fd, '<', $item->unpacked_path); + + my @continuation; + + my $position = 1; + while (my $line = <$fd>) { + + unless (@continuation) { + # skip blank lines + next + if $line =~ /^\s*$/; + + # skip comments + next + if $line =~ /^\s*#/; + } + + # continuation line + if ($line =~ s/\\$//) { + push(@continuation, {string => $line, position => $position}); + next; + } + + push(@continuation, {string => $line, position => $position}); + + my $assembled = $EMPTY; + $assembled .= $_->{string} for @continuation; + + my $start_position = $continuation[0]->{position}; + + my @quoted + = extract_multiple($assembled, + [sub { extract_delimited($_[0], q{"'}, '[^\'"]*') }], + undef, 1); + + my @placeholders = uniq grep { /\%s/ } @quoted; + + $self->pointed_hint( + 'quoted-placeholder-in-mailcap-entry', + $item->pointer($start_position), + @placeholders + )if @placeholders; + + @continuation = (); + + } continue { + ++$position; + } + + close $fd; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/MaintainerScripts/Adduser.pm b/lib/Lintian/Check/MaintainerScripts/Adduser.pm new file mode 100644 index 0000000..f8bbea4 --- /dev/null +++ b/lib/Lintian/Check/MaintainerScripts/Adduser.pm @@ -0,0 +1,96 @@ +# maintainer_scripts::adduser -- lintian check script -*- perl -*- + +# Copyright (C) 2020 Topi Miettinen +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::MaintainerScripts::Adduser; + +use v5.20; +use warnings; +use utf8; + +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_control_files { + my ($self, $item) = @_; + + # get maintainer scripts + return + unless $item->is_maintainer_script; + + return + unless $item->is_open_ok; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $continuation = undef; + + my $position = 1; + while (my $line = <$fd>) { + + chomp $line; + + # merge lines ending with '\' + if (defined $continuation) { + $line = $continuation . $line; + $continuation = undef; + } + + if ($line =~ /\\$/) { + $continuation = $line; + $continuation =~ s/\\$/ /; + next; + } + + # trim right + $line =~ s/\s+$//; + + # skip empty lines + next + if $line =~ /^\s*$/; + + # skip comments + next + if $line =~ /^[#\n]/; + + $self->pointed_hint('adduser-with-home-var-run', + $item->pointer($position)) + if $line =~ /adduser .*--home +\/var\/run/; + + } continue { + ++$position; + } + + close $fd; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/MaintainerScripts/AncientVersion.pm b/lib/Lintian/Check/MaintainerScripts/AncientVersion.pm new file mode 100644 index 0000000..9fac1c5 --- /dev/null +++ b/lib/Lintian/Check/MaintainerScripts/AncientVersion.pm @@ -0,0 +1,180 @@ +# maintainer-scripts/ancient-version -- lintian check script -*- perl -*- +# +# Copyright (C) 1998 Richard Braakman +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::MaintainerScripts::AncientVersion; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use POSIX qw(strftime); +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; + +# date --date="Sat, 14 Aug 2021 17:41:41 -0400" +%s +# https://lists.debian.org/debian-announce/2021/msg00003.html +const my $OLDSTABLE_RELEASE_EPOCH => 1_628_977_301; + +# When detecting commands inside shell scripts, use this regex to match the +# beginning of the command rather than checking whether the command is at the +# beginning of a line. +const my $LEADING_PATTERN=> +'(?:(?:^|[`&;(|{])\s*|(?:if|then|do|while|!)\s+|env(?:\s+[[:alnum:]_]+=(?:\S+|\"[^"]*\"|\'[^\']*\'))*\s+)'; +const my $LEADING_REGEX => qr/$LEADING_PATTERN/; + +has old_versions => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my %old_versions; + for my $entry ( + $self->processable->changelog + ? @{$self->processable->changelog->entries} + : () + ) { + my $timestamp = $entry->Timestamp // $OLDSTABLE_RELEASE_EPOCH; + $old_versions{$entry->Version} = $timestamp + if $timestamp < $OLDSTABLE_RELEASE_EPOCH; + } + + return \%old_versions; + } +); + +sub visit_control_files { + my ($self, $item) = @_; + + return + unless $item->is_maintainer_script; + + return + unless length $item->interpreter; + + return + unless $item->is_open_ok; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $stashed = $EMPTY; + + my $position = 1; + while (my $possible_continuation = <$fd>) { + + chomp $possible_continuation; + + # skip empty lines + next + if $possible_continuation =~ /^\s*$/; + + # skip comment lines + next + if $possible_continuation =~ /^\s*\#/; + + my $no_comment = remove_comments($possible_continuation); + + # Concatenate lines containing continuation character (\) + # at the end + if ($no_comment =~ s{\\$}{}) { + + $stashed .= $no_comment; + + next; + } + + my $line = $stashed . $no_comment; + $stashed = $EMPTY; + + for my $old_version (keys %{$self->old_versions}) { + + next + if $old_version =~ /^\d+$/; + + if ($line + =~m{$LEADING_REGEX(?:/usr/bin/)?dpkg\s+--compare-versions\s+.*\b\Q$old_version\E(?!\.)\b} + ) { + my $date + = strftime('%Y-%m-%d', + gmtime $self->old_versions->{$old_version}); + my $epoch + = strftime('%Y-%m-%d', gmtime $OLDSTABLE_RELEASE_EPOCH); + + my $pointer = $item->pointer($position); + + $self->pointed_hint( + 'maintainer-script-supports-ancient-package-version', + $pointer, $old_version,"($date < $epoch)", + ); + } + } + + } continue { + ++$position; + } + + return; +} + +sub remove_comments { + my ($line) = @_; + + return $line + unless length $line; + + my $simplified = $line; + + # Remove quoted strings so we can more easily ignore comments + # inside them + $simplified =~ s/(^|[^\\](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g; + $simplified =~ s/(^|[^\\](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g; + + # If the remaining string contains what looks like a comment, + # eat it. In either case, swap the unmodified script line + # back in for processing (if required) and return it. + if ($simplified =~ m/(?:^|[^[\\])[\s\&;\(\)](\#.*$)/) { + + my $comment = $1; + + # eat comment + $line =~ s/\Q$comment\E//; + } + + return $line; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/MaintainerScripts/Diversion.pm b/lib/Lintian/Check/MaintainerScripts/Diversion.pm new file mode 100644 index 0000000..e786422 --- /dev/null +++ b/lib/Lintian/Check/MaintainerScripts/Diversion.pm @@ -0,0 +1,369 @@ +# maintainer-scripts/diversion -- lintian check script -*- perl -*- +# +# Copyright (C) 1998 Richard Braakman +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::MaintainerScripts::Diversion; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(any none); +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; + +# When detecting commands inside shell scripts, use this regex to match the +# beginning of the command rather than checking whether the command is at the +# beginning of a line. +const my $LEADING_PATTERN=> +'(?:(?:^|[`&;(|{])\s*|(?:if|then|do|while|!)\s+|env(?:\s+[[:alnum:]_]+=(?:\S+|\"[^"]*\"|\'[^\']*\'))*\s+)'; +const my $LEADING_REGEX => qr/$LEADING_PATTERN/; + +has added_diversions => (is => 'rw', default => sub { {} }); +has removed_diversions => (is => 'rw', default => sub { {} }); +has expand_diversions => (is => 'rw', default => 0); + +sub visit_control_files { + my ($self, $item) = @_; + + return + unless $item->is_maintainer_script; + + return + unless length $item->interpreter; + + return + unless $item->is_open_ok; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $stashed = $EMPTY; + + my $position = 1; + while (my $possible_continuation = <$fd>) { + + my $pointer = $item->pointer($position); + + chomp $possible_continuation; + + # skip empty lines + next + if $possible_continuation =~ /^\s*$/; + + # skip comment lines + next + if $possible_continuation =~ /^\s*\#/; + + my $no_comment = remove_comments($possible_continuation); + + # Concatenate lines containing continuation character (\) + # at the end + if ($no_comment =~ s{\\$}{}) { + + $stashed .= $no_comment; + + next; + } + + my $line = $stashed . $no_comment; + $stashed = $EMPTY; + + if ( $line =~ m{$LEADING_REGEX(?:/usr/sbin/)?dpkg-divert\s} + && $line !~ /--(?:help|list|truename|version)/) { + + $self->pointed_hint('package-uses-local-diversion',$pointer) + if $line =~ /--local/; + + my $mode = $line =~ /--remove/ ? 'remove' : 'add'; + + my ($divert) = ($line =~ /dpkg-divert\s*(.*)$/); + + $divert =~ s{\s*(?:\$[{]?[\w:=-]+[}]?)*\s* + # options without arguments + --(?:add|quiet|remove|rename|no-rename|test|local + # options with arguments + |(?:admindir|divert|package) \s+ \S+) + \s*}{}gxsm; + + # Remove unpaired opening or closing parenthesis + 1 while ($divert =~ m/\G.*?\(.+?\)/gc); + $divert =~ s/\G(.*?)[()]/$1/; + pos($divert) = undef; + + # Remove unpaired opening or closing braces + 1 while ($divert =~ m/\G.*?{.+?}/gc); + $divert =~ s/\G(.*?)[{}]/$1/; + pos($divert) = undef; + + # position after the last pair of quotation marks, if any + 1 while ($divert =~ m/\G.*?(["']).+?\1/gc); + + # Strip anything matching and after '&&', '||', ';', or '>' + # this is safe only after we are positioned after the last pair + # of quotation marks + $divert =~ s/\G.+?\K(?: && | \|\| | ; | \d*> ).*$//x; + pos($divert) = undef; + + # Remove quotation marks, they affect: + # * our var to regex trick + # * stripping the initial slash if the path was quoted + $divert =~ s/[\"\']//g; + + # remove the leading / because it's not in the index hash + $divert =~ s{^/}{}; + + # trim both ends + $divert =~ s/^\s+|\s+$//g; + + $divert = quotemeta($divert); + + # For now just replace variables, they will later be normalised + $self->expand_diversions(1) + if $divert =~ s/\\\$\w+/.+/g; + + $self->expand_diversions(1) + if $divert =~ s/\\\$\\[{]\w+.*?\\[}]/.+/g; + + # handle $() the same way: + $self->expand_diversions(1) + if $divert =~ s/\\\$\\\(.+?\\\)/.+/g; + + my %diversion; + $diversion{script} = $item; + $diversion{position} = $position; + + $self->added_diversions->{$divert} = \%diversion + if $mode eq 'add'; + + push(@{$self->removed_diversions->{$divert}}, \%diversion) + if $mode eq 'remove'; + + die encode_utf8("mode has unknown value: $mode") + if none { $mode eq $_ } qw{add remove}; + } + + } continue { + ++$position; + } + + return; +} + +sub installable { + my ($self) = @_; + + # If any of the maintainer scripts used a variable in the file or + # diversion name normalise them all + if ($self->expand_diversions) { + + for my $divert ( + keys %{$self->removed_diversions}, + keys %{$self->added_diversions} + ) { + + # if a wider regex was found, the entries might no longer be there + next + unless exists $self->removed_diversions->{$divert} + || exists $self->added_diversions->{$divert}; + + my $widerrx = $divert; + my $wider = $widerrx; + $wider =~ s/\\//g; + + # find the widest regex: + my @matches = grep { + my $lrx = $_; + my $l = $lrx; + $l =~ s/\\//g; + + if ($wider =~ m/^$lrx$/) { + $widerrx = $lrx; + $wider = $l; + 1; + } elsif ($l =~ m/^$widerrx$/) { + 1; + } else { + 0; + } + } ( + keys %{$self->removed_diversions}, + keys %{$self->added_diversions} + ); + + # replace all the occurrences with the widest regex: + for my $k (@matches) { + + next + if $k eq $widerrx; + + if (exists $self->removed_diversions->{$k}) { + + $self->removed_diversions->{$widerrx} + = $self->removed_diversions->{$k}; + + delete $self->removed_diversions->{$k}; + } + + if (exists $self->added_diversions->{$k}) { + + $self->added_diversions->{$widerrx} + = $self->added_diversions->{$k}; + + delete $self->added_diversions->{$k}; + } + } + } + } + + for my $divert (keys %{$self->removed_diversions}) { + + if (exists $self->added_diversions->{$divert}) { + # just mark the entry, because a --remove might + # happen in two branches in the script, i.e. we + # see it twice, which is not a bug + $self->added_diversions->{$divert}{removed} = 1; + + } else { + + for my $item (@{$self->removed_diversions->{$divert}}) { + + my $script = $item->{script}; + my $position = $item->{position}; + + next + unless $script->name eq 'postrm'; + + # Allow preinst and postinst to remove diversions the + # package doesn't add to clean up after previous + # versions of the package. + + my $unquoted = unquote($divert, $self->expand_diversions); + + my $pointer = $script->pointer($position); + + $self->pointed_hint('remove-of-unknown-diversion', $pointer, + $unquoted); + } + } + } + + for my $divert (keys %{$self->added_diversions}) { + + my $script = $self->added_diversions->{$divert}{script}; + my $position = $self->added_diversions->{$divert}{position}; + + my $pointer = $script->pointer($script); + $pointer->position($position); + + my $divertrx = $divert; + my $unquoted = unquote($divert, $self->expand_diversions); + + $self->pointed_hint('orphaned-diversion', $pointer, $unquoted) + unless exists $self->added_diversions->{$divertrx}{removed}; + + # Handle man page diversions somewhat specially. We may + # divert away a man page in one section without replacing that + # same file, since we're installing a man page in a different + # section. An example is diverting a man page in section 1 + # and replacing it with one in section 1p (such as + # libmodule-corelist-perl at the time of this writing). + # + # Deal with this by turning all man page diversions into + # wildcard expressions instead that match everything in the + # same numeric section so that they'll match the files shipped + # in the package. + if ($divertrx =~ m{^(usr\\/share\\/man\\/\S+\\/.*\\\.\d)\w*(\\\.gz\z)}) + { + $divertrx = "$1.*$2"; + $self->expand_diversions(1); + } + + if ($self->expand_diversions) { + + $self->pointed_hint('diversion-for-unknown-file', $pointer, + $unquoted) + unless (any { /$divertrx/ } + @{$self->processable->installed->sorted_list}); + + } else { + $self->pointed_hint('diversion-for-unknown-file', $pointer, + $unquoted) + unless $self->processable->installed->lookup($unquoted); + } + } + + return; +} + +sub remove_comments { + my ($line) = @_; + + return $line + unless length $line; + + my $simplified = $line; + + # Remove quoted strings so we can more easily ignore comments + # inside them + $simplified =~ s/(^|[^\\](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g; + $simplified =~ s/(^|[^\\](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g; + + # If the remaining string contains what looks like a comment, + # eat it. In either case, swap the unmodified script line + # back in for processing (if required) and return it. + if ($simplified =~ m/(?:^|[^[\\])[\s\&;\(\)](\#.*$)/) { + + my $comment = $1; + + # eat comment + $line =~ s/\Q$comment\E//; + } + + return $line; +} + +sub unquote { + my ($string, $replace_regex) = @_; + + $string =~ s{\\}{}g; + + $string =~ s{\.\+}{*}g + if $replace_regex; + + return $string; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/MaintainerScripts/DpkgStatoverride.pm b/lib/Lintian/Check/MaintainerScripts/DpkgStatoverride.pm new file mode 100644 index 0000000..6b8347c --- /dev/null +++ b/lib/Lintian/Check/MaintainerScripts/DpkgStatoverride.pm @@ -0,0 +1,148 @@ +# maintainer-scripts/dpkg-statoverride -- lintian check script -*- perl -*- +# +# Copyright (C) 1998 Richard Braakman +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::MaintainerScripts::DpkgStatoverride; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; + +# When detecting commands inside shell scripts, use this regex to match the +# beginning of the command rather than checking whether the command is at the +# beginning of a line. +const my $LEADING_PATTERN=> +'(?:(?:^|[`&;(|{])\s*|(?:if|then|do|while|!)\s+|env(?:\s+[[:alnum:]_]+=(?:\S+|\"[^"]*\"|\'[^\']*\'))*\s+)'; +const my $LEADING_REGEX => qr/$LEADING_PATTERN/; + +sub visit_control_files { + my ($self, $item) = @_; + + return + unless $item->is_maintainer_script; + + return + unless length $item->interpreter; + + return + unless $item->is_open_ok; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $stashed = $EMPTY; + + my $saw_statoverride_list = 0; + + my $position = 1; + while (my $possible_continuation = <$fd>) { + + my $pointer = $item->pointer($position); + + chomp $possible_continuation; + + # skip empty lines + next + if $possible_continuation =~ /^\s*$/; + + # skip comment lines + next + if $possible_continuation =~ /^\s*\#/; + + my $no_comment = remove_comments($possible_continuation); + + # Concatenate lines containing continuation character (\) + # at the end + if ($no_comment =~ s{\\$}{}) { + + $stashed .= $no_comment; + + next; + } + + my $line = $stashed . $no_comment; + $stashed = $EMPTY; + + if ($line =~ m{$LEADING_REGEX(?:/usr/bin/)?dpkg-statoverride\s}) { + + $saw_statoverride_list = 1 + if $line =~ /--list/; + + if ($line =~ /--add/) { + + $self->pointed_hint('unconditional-use-of-dpkg-statoverride', + $pointer) + unless $saw_statoverride_list; + } + } + + } continue { + ++$position; + } + + return; +} + +sub remove_comments { + my ($line) = @_; + + return $line + unless length $line; + + my $simplified = $line; + + # Remove quoted strings so we can more easily ignore comments + # inside them + $simplified =~ s/(^|[^\\](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g; + $simplified =~ s/(^|[^\\](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g; + + # If the remaining string contains what looks like a comment, + # eat it. In either case, swap the unmodified script line + # back in for processing (if required) and return it. + if ($simplified =~ m/(?:^|[^[\\])[\s\&;\(\)](\#.*$)/) { + + my $comment = $1; + + # eat comment + $line =~ s/\Q$comment\E//; + } + + return $line; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/MaintainerScripts/Empty.pm b/lib/Lintian/Check/MaintainerScripts/Empty.pm new file mode 100644 index 0000000..298eb0a --- /dev/null +++ b/lib/Lintian/Check/MaintainerScripts/Empty.pm @@ -0,0 +1,144 @@ +# maintainer-scripts/empty -- lintian check script -*- perl -*- +# +# Copyright (C) 1998 Richard Braakman +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::MaintainerScripts::Empty; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; + +sub visit_control_files { + my ($self, $item) = @_; + + return + unless $item->is_maintainer_script; + + return + unless length $item->interpreter; + + return + unless $item->is_open_ok; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $stashed = $EMPTY; + + my $has_code = 0; + + my $position = 1; + while (my $possible_continuation = <$fd>) { + + chomp $possible_continuation; + + # skip empty lines + next + if $possible_continuation =~ /^\s*$/; + + # skip comment lines + next + if $possible_continuation =~ /^\s*\#/; + + my $no_comment = remove_comments($possible_continuation); + + # Concatenate lines containing continuation character (\) + # at the end + if ($no_comment =~ s{\\$}{}) { + + $stashed .= $no_comment; + + next; + } + + my $line = $stashed . $no_comment; + $stashed = $EMPTY; + + # Don't consider the standard dh-make boilerplate to be code. This + # means ignoring the framework of a case statement, the labels, the + # echo complaining about unknown arguments, and an exit. + if ( $line !~ /^\s*set\s+-\w+\s*$/ + && $line !~ /^\s*case\s+\"?\$1\"?\s+in\s*$/ + && $line !~ /^\s*(?:[a-z|-]+|\*)\)\s*$/ + && $line !~ /^\s*[:;]+\s*$/ + && $line !~ /^\s*echo\s+\"[^\"]+\"(?:\s*>&2)?\s*$/ + && $line !~ /^\s*esac\s*$/ + && $line !~ /^\s*exit\s+\d+\s*$/) { + + $has_code = 1; + last; + } + + } continue { + ++$position; + } + + $self->pointed_hint('maintainer-script-empty', $item->pointer) + unless $has_code; + + return; +} + +sub remove_comments { + my ($line) = @_; + + return $line + unless length $line; + + my $simplified = $line; + + # Remove quoted strings so we can more easily ignore comments + # inside them + $simplified =~ s/(^|[^\\](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g; + $simplified =~ s/(^|[^\\](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g; + + # If the remaining string contains what looks like a comment, + # eat it. In either case, swap the unmodified script line + # back in for processing (if required) and return it. + if ($simplified =~ m/(?:^|[^[\\])[\s\&;\(\)](\#.*$)/) { + + my $comment = $1; + + # eat comment + $line =~ s/\Q$comment\E//; + } + + return $line; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/MaintainerScripts/Generated.pm b/lib/Lintian/Check/MaintainerScripts/Generated.pm new file mode 100644 index 0000000..bf00910 --- /dev/null +++ b/lib/Lintian/Check/MaintainerScripts/Generated.pm @@ -0,0 +1,85 @@ +# maintainer-scripts/generated -- lintian check script -*- perl -*- +# +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::MaintainerScripts::Generated; + +use v5.20; +use warnings; +use utf8; + +use List::SomeUtils qw(uniq); +use Path::Tiny; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub installable { + my ($self) = @_; + + my @tools_seen; + + # get maintainer scripts + my @control + = grep { $_->is_maintainer_script } + @{$self->processable->control->sorted_list}; + + for my $file (@control) { + + my $hashbang = $file->hashbang; + next + unless length $hashbang; + + next + unless $file->is_open_ok; + + my @lines = path($file->unpacked_path)->lines; + + # scan contents + for (@lines) { + + # skip empty lines + next + if /^\s*$/; + + if (/^# Automatically added by (\S+)\s*$/) { + my $tool = $1; +# remove trailing ":" from dh_python +# https://sources.debian.org/src/dh-python/4.20191017/dhpython/debhelper.py/#L200 + $tool =~ s/:\s*$//g; + push(@tools_seen, $tool); + } + } + } + + $self->hint('debhelper-autoscript-in-maintainer-scripts', $_) + for uniq @tools_seen; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/MaintainerScripts/Helper/Dpkg.pm b/lib/Lintian/Check/MaintainerScripts/Helper/Dpkg.pm new file mode 100644 index 0000000..ef87c40 --- /dev/null +++ b/lib/Lintian/Check/MaintainerScripts/Helper/Dpkg.pm @@ -0,0 +1,183 @@ +# maintainer-scripts/helper/dpkg -- lintian check script -*- perl -*- +# +# Copyright (C) 1998 Richard Braakman +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::MaintainerScripts::Helper::Dpkg; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::Compare; +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; + +# When detecting commands inside shell scripts, use this regex to match the +# beginning of the command rather than checking whether the command is at the +# beginning of a line. +const my $LEADING_PATTERN=> +'(?:(?:^|[`&;(|{])\s*|(?:if|then|do|while|!)\s+|env(?:\s+[[:alnum:]_]+=(?:\S+|\"[^"]*\"|\'[^\']*\'))*\s+)'; +const my $LEADING_REGEX => qr/$LEADING_PATTERN/; + +has seen_helper_commands => (is => 'rw', default => sub { {} }); + +sub visit_control_files { + my ($self, $item) = @_; + + return + unless $item->is_maintainer_script; + + return + unless length $item->interpreter; + + return + unless $item->is_open_ok; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $stashed = $EMPTY; + + my $position = 1; + while (my $possible_continuation = <$fd>) { + + chomp $possible_continuation; + + # skip empty lines + next + if $possible_continuation =~ /^\s*$/; + + # skip comment lines + next + if $possible_continuation =~ /^\s*\#/; + + my $no_comment = remove_comments($possible_continuation); + + # Concatenate lines containing continuation character (\) + # at the end + if ($no_comment =~ s{\\$}{}) { + + $stashed .= $no_comment; + + next; + } + + my $line = $stashed . $no_comment; + $stashed = $EMPTY; + + if ($line + =~ m{$LEADING_REGEX(?:/usr/bin/)?dpkg-maintscript-helper\s(\S+)}){ + + my $command = $1; + + $self->seen_helper_commands->{$command} //= []; + push(@{$self->seen_helper_commands->{$command}}, $item->name); + } + + } continue { + ++$position; + } + + close $fd; + + return; +} + +sub installable { + my ($self) = @_; + + for my $command (keys %{$self->seen_helper_commands}) { + + # entering the loop means there is at least one member + my @have = @{$self->seen_helper_commands->{$command} // [] }; + next + unless @have; + + # dpkg-maintscript-helper(1) recommends the snippets are in all + # maintainer scripts but they are not strictly required in prerm. + my @wanted = qw{preinst postinst postrm}; + + my $lc = List::Compare->new(\@wanted, \@have); + + my @missing = $lc->get_Lonly; + + for my $name (@missing) { + + my $item = $self->processable->control->lookup($name); + + if (defined $item) { + + $self->pointed_hint('missing-call-to-dpkg-maintscript-helper', + $item->pointer, $command); + + } else { + # file does not exist + $self->hint('missing-call-to-dpkg-maintscript-helper', + $command, "[$name]"); + } + } + } + + return; +} + +sub remove_comments { + my ($line) = @_; + + return $line + unless length $line; + + my $simplified = $line; + + # Remove quoted strings so we can more easily ignore comments + # inside them + $simplified =~ s/(^|[^\\](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g; + $simplified =~ s/(^|[^\\](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g; + + # If the remaining string contains what looks like a comment, + # eat it. In either case, swap the unmodified script line + # back in for processing (if required) and return it. + if ($simplified =~ m/(?:^|[^[\\])[\s\&;\(\)](\#.*$)/) { + + my $comment = $1; + + # eat comment + $line =~ s/\Q$comment\E//; + } + + return $line; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/MaintainerScripts/Killall.pm b/lib/Lintian/Check/MaintainerScripts/Killall.pm new file mode 100644 index 0000000..2c3dd09 --- /dev/null +++ b/lib/Lintian/Check/MaintainerScripts/Killall.pm @@ -0,0 +1,131 @@ +# maintainer-scripts/killall -- lintian check script -*- perl -*- +# +# Copyright (C) 1998 Richard Braakman +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::MaintainerScripts::Killall; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; + +sub visit_control_files { + my ($self, $item) = @_; + + return + unless $item->is_maintainer_script; + + return + unless length $item->interpreter; + + return + unless $item->is_open_ok; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $stashed = $EMPTY; + + my $position = 1; + while (my $possible_continuation = <$fd>) { + + my $pointer = $item->pointer($position); + + chomp $possible_continuation; + + # skip empty lines + next + if $possible_continuation =~ /^\s*$/; + + # skip comment lines + next + if $possible_continuation =~ /^\s*\#/; + + my $no_comment = remove_comments($possible_continuation); + + # Concatenate lines containing continuation character (\) + # at the end + if ($no_comment =~ s{\\$}{}) { + + $stashed .= $no_comment; + + next; + } + + my $line = $stashed . $no_comment; + $stashed = $EMPTY; + + $self->pointed_hint('killall-is-dangerous', $pointer) + if $line =~ /^\s*killall(?:\s|\z)/; + + } continue { + ++$position; + } + + close $fd; + + return; +} + +sub remove_comments { + my ($line) = @_; + + return $line + unless length $line; + + my $simplified = $line; + + # Remove quoted strings so we can more easily ignore comments + # inside them + $simplified =~ s/(^|[^\\](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g; + $simplified =~ s/(^|[^\\](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g; + + # If the remaining string contains what looks like a comment, + # eat it. In either case, swap the unmodified script line + # back in for processing (if required) and return it. + if ($simplified =~ m/(?:^|[^[\\])[\s\&;\(\)](\#.*$)/) { + + my $comment = $1; + + # eat comment + $line =~ s/\Q$comment\E//; + } + + return $line; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/MaintainerScripts/Ldconfig.pm b/lib/Lintian/Check/MaintainerScripts/Ldconfig.pm new file mode 100644 index 0000000..22e64d2 --- /dev/null +++ b/lib/Lintian/Check/MaintainerScripts/Ldconfig.pm @@ -0,0 +1,60 @@ +# maintainer-scripts/ldconfig -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz +# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::MaintainerScripts::Ldconfig; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_control_files { + my ($self, $item) = @_; + + return + unless $item->is_maintainer_script; + + return + unless $item->decoded_utf8 =~ /^ [^\#]* \b ldconfig \b /mx; + + $self->pointed_hint('udeb-postinst-calls-ldconfig', $item->pointer) + if $item->name eq 'postinst' + && $self->processable->type eq 'udeb'; + + $self->pointed_hint('maintscript-calls-ldconfig', $item->pointer) + if $item->name ne 'postinst' + || $self->processable->type ne 'udeb'; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/MaintainerScripts/Mknod.pm b/lib/Lintian/Check/MaintainerScripts/Mknod.pm new file mode 100644 index 0000000..e7269ea --- /dev/null +++ b/lib/Lintian/Check/MaintainerScripts/Mknod.pm @@ -0,0 +1,131 @@ +# maintainer-scripts/mknod -- lintian check script -*- perl -*- +# +# Copyright (C) 1998 Richard Braakman +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::MaintainerScripts::Mknod; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; + +sub visit_control_files { + my ($self, $item) = @_; + + return + unless $item->is_maintainer_script; + + return + unless length $item->interpreter; + + return + unless $item->is_open_ok; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $stashed = $EMPTY; + + my $position = 1; + while (my $possible_continuation = <$fd>) { + + my $pointer = $item->pointer($position); + + chomp $possible_continuation; + + # skip empty lines + next + if $possible_continuation =~ /^\s*$/; + + # skip comment lines + next + if $possible_continuation =~ /^\s*\#/; + + my $no_comment = remove_comments($possible_continuation); + + # Concatenate lines containing continuation character (\) + # at the end + if ($no_comment =~ s{\\$}{}) { + + $stashed .= $no_comment; + + next; + } + + my $line = $stashed . $no_comment; + $stashed = $EMPTY; + + $self->pointed_hint('mknod-in-maintainer-script', $pointer) + if $line =~ /^\s*mknod(?:\s|\z)/ && $line !~ /\sp\s/; + + } continue { + ++$position; + } + + close $fd; + + return; +} + +sub remove_comments { + my ($line) = @_; + + return $line + unless length $line; + + my $simplified = $line; + + # Remove quoted strings so we can more easily ignore comments + # inside them + $simplified =~ s/(^|[^\\](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g; + $simplified =~ s/(^|[^\\](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g; + + # If the remaining string contains what looks like a comment, + # eat it. In either case, swap the unmodified script line + # back in for processing (if required) and return it. + if ($simplified =~ m/(?:^|[^[\\])[\s\&;\(\)](\#.*$)/) { + + my $comment = $1; + + # eat comment + $line =~ s/\Q$comment\E//; + } + + return $line; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/MaintainerScripts/Systemctl.pm b/lib/Lintian/Check/MaintainerScripts/Systemctl.pm new file mode 100644 index 0000000..c5e1654 --- /dev/null +++ b/lib/Lintian/Check/MaintainerScripts/Systemctl.pm @@ -0,0 +1,76 @@ +# masitainer-scripts/systemctl -- lintian check script -*- perl -*- +# +# Copyright (C) 2013 Michael Stapelberg +# Copyright (C) 2016-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# based on the apache2 checks file by: +# Copyright (C) 2012 Arno Toell +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::MaintainerScripts::Systemctl; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_control_files { + my ($self, $item) = @_; + + return + unless $item->is_maintainer_script; + + # look only at shell scripts + return + unless $item->hashbang =~ /^\S*sh\b/; + + my @lines = split(/\n/, $item->decoded_utf8); + + my $position = 1; + for my $line (@lines) { + + next + if $line =~ /^#/; + + my $pointer = $item->pointer($position); + + # systemctl should not be called in maintainer scripts at all, + # except for systemctl daemon-reload calls. + $self->pointed_hint('maintainer-script-calls-systemctl', $pointer) + if $line =~ /^(?:.+;)?\s*systemctl\b/ + && $line !~ /daemon-reload/; + + } continue { + ++$position; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/MaintainerScripts/TemporaryFiles.pm b/lib/Lintian/Check/MaintainerScripts/TemporaryFiles.pm new file mode 100644 index 0000000..f6d1164 --- /dev/null +++ b/lib/Lintian/Check/MaintainerScripts/TemporaryFiles.pm @@ -0,0 +1,144 @@ +# maintainer-scripts/temporary-files -- lintian check script -*- perl -*- +# +# Copyright (C) 1998 Richard Braakman +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::MaintainerScripts::TemporaryFiles; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; + +sub visit_control_files { + my ($self, $item) = @_; + + return + unless $item->is_maintainer_script; + + return + unless length $item->interpreter; + + return + unless $item->is_open_ok; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $stashed = $EMPTY; + + my $position = 1; + while (my $possible_continuation = <$fd>) { + + my $pointer = $item->pointer($position); + + chomp $possible_continuation; + + # skip empty lines + next + if $possible_continuation =~ /^\s*$/; + + # skip comment lines + next + if $possible_continuation =~ /^\s*\#/; + + my $no_comment = remove_comments($possible_continuation); + + # Concatenate lines containing continuation character (\) + # at the end + if ($no_comment =~ s{\\$}{}) { + + $stashed .= $no_comment; + + next; + } + + my $line = $stashed . $no_comment; + $stashed = $EMPTY; + + if ($line =~ m{ \W ( (?:/var)?/tmp | \$TMPDIR /[^)\]\}\s]+ ) }x) { + + my $indicator = $1; + + $self->pointed_hint( + 'possibly-insecure-handling-of-tmp-files-in-maintainer-script', + $pointer, + $indicator + ) + if $line !~ /\bmks?temp\b/ + && $line !~ /\btempfile\b/ + && $line !~ /\bmkdir\b/ + && $line !~ /\bXXXXXX\b/ + && $line !~ /\$RANDOM/; + } + + } continue { + ++$position; + } + + close $fd; + + return; +} + +sub remove_comments { + my ($line) = @_; + + return $line + unless length $line; + + my $simplified = $line; + + # Remove quoted strings so we can more easily ignore comments + # inside them + $simplified =~ s/(^|[^\\](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g; + $simplified =~ s/(^|[^\\](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g; + + # If the remaining string contains what looks like a comment, + # eat it. In either case, swap the unmodified script line + # back in for processing (if required) and return it. + if ($simplified =~ m/(?:^|[^[\\])[\s\&;\(\)](\#.*$)/) { + + my $comment = $1; + + # eat comment + $line =~ s/\Q$comment\E//; + } + + return $line; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Md5sums.pm b/lib/Lintian/Check/Md5sums.pm new file mode 100644 index 0000000..c62d9cd --- /dev/null +++ b/lib/Lintian/Check/Md5sums.pm @@ -0,0 +1,133 @@ +# md5sums -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2020 Felix Lechner +# Copyright (C) 2018, 2020 Chris Lamb <lamby@debian.org> +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Md5sums; + +use v5.20; +use warnings; +use utf8; + +use List::Compare; +use Path::Tiny; + +use Lintian::Util qw(read_md5sums drop_relative_prefix); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has only_conffiles => (is => 'rw', default => 1); + +sub visit_installed_files { + my ($self, $item) = @_; + + # check if package contains non-conffiles + # debhelper doesn't create entries in md5sums + # for conffiles since this information would + # be redundant + + # Skip non-files, they will not appear in the md5sums file + return + unless $item->is_regular_file; + + $self->only_conffiles(0) + unless $self->processable->declared_conffiles->is_known($item->name); + + return; +} + +sub binary { + my ($self) = @_; + + my $control = $self->processable->control->lookup('md5sums'); + unless (defined $control) { + + # ignore if package contains no files + return + unless @{$self->processable->installed->sorted_list}; + + $self->hint('no-md5sums-control-file') + unless $self->only_conffiles; + + return; + } + + # The md5sums file should not be a symlink. If it is, the best + # we can do is to leave it alone. + return + if $control->is_symlink; + + return + unless $control->is_open_ok; + + # Is it empty? Then skip it. Tag will be issued by control-files + return + if $control->size == 0; + + my $text = $control->bytes; + + my ($md5sums, $errors) = read_md5sums($text); + + $self->pointed_hint('malformed-md5sums-control-file',$control->pointer, $_) + for @{$errors}; + + my %noprefix + = map { drop_relative_prefix($_) => $md5sums->{$_} } keys %{$md5sums}; + + my @listed = keys %noprefix; + my @found + = grep { $_->is_file} @{$self->processable->installed->sorted_list}; + + my $lc = List::Compare->new(\@listed, \@found); + + # find files that should exist but do not + $self->pointed_hint('md5sums-lists-nonexistent-file',$control->pointer, $_) + for $lc->get_Lonly; + + # find files that should be listed but are not + for my $name ($lc->get_Ronly) { + + $self->pointed_hint('file-missing-in-md5sums', $control->pointer,$name) + unless $self->processable->declared_conffiles->is_known($name) + || $name =~ m{^var/lib/[ai]spell/.}; + } + + # checksum should match for common files + for my $name ($lc->get_intersection) { + + my $item = $self->processable->installed->lookup($name); + + $self->pointed_hint('md5sum-mismatch', $control->pointer, $name) + unless $item->md5sum eq $noprefix{$name}; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/MenuFormat.pm b/lib/Lintian/Check/MenuFormat.pm new file mode 100644 index 0000000..c9d40a8 --- /dev/null +++ b/lib/Lintian/Check/MenuFormat.pm @@ -0,0 +1,907 @@ +# menu format -- lintian check script -*- perl -*- + +# Copyright (C) 1998 by Joey Hess +# Copyright (C) 2017-2018 Chris Lamb <lamby@debian.org> +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +# This script also checks desktop entries, since they share quite a bit of +# code. At some point, it would make sense to try to refactor this so that +# shared code is in libraries. +# +# Further things that the desktop file validation should be checking: +# +# - Encoding of the file should be UTF-8. +# - Additional Categories should be associated with Main Categories. +# - List entries (MimeType, Categories) should end with a semicolon. +# - Check for GNOME/GTK/X11/etc. dependencies and require the relevant +# Additional Category to be present. +# - Check all the escape characters supported by Exec. +# - Review desktop-file-validate to see what else we're missing. + +package Lintian::Check::MenuFormat; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use File::Basename; +use List::SomeUtils qw(any first_value); +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $SLASH => q{/}; + +const my $MAXIMUM_SIZE_STANDARD_ICON => 32; +const my $MAXIMUM_SIZE_32X32_ICON => 32; +const my $MAXIMUM_SIZE_16X16_ICON => 16; + +# This is a list of all tags that should be in every menu item. +my @req_tags = qw(needs section title command); + +# This is a list of all known tags. +my @known_tags = qw( + needs + section + title + sort + command + longtitle + icon + icon16x16 + icon32x32 + description + hotkey + hints +); + +# These 'needs' tags are always valid, no matter the context, and no other +# values are valid outside the Window Managers context (don't include wm here, +# in other words). It's case insensitive, use lower case here. +my @needs_tag_vals = qw(x11 text vc); + +has MENU_SECTIONS => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my %menu_sections; + + my $data = $self->data->load('menu-format/menu-sections'); + + for my $key ($data->all) { + + my ($root, $under) = split(m{/}, $key, 2); + + $under //= $EMPTY; + + # $under is empty if this is just a root section + $menu_sections{$root}{$under} = 1; + } + + return \%menu_sections; + } +); + +# Authoritative source of desktop keys: +# https://specifications.freedesktop.org/desktop-entry-spec/latest/ +# +# This is a list of all keys that should be in every desktop entry. +my @req_desktop_keys = qw(Type Name); + +# This is a list of all known keys. +has KNOWN_DESKTOP_KEYS => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return $self->data->load('menu-format/known-desktop-keys'); + } +); + +has DEPRECATED_DESKTOP_KEYS => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return $self->data->load('menu-format/deprecated-desktop-keys'); + } +); + +# KDE uses some additional keys that should start with X-KDE but don't for +# historical reasons. +has KDE_DESKTOP_KEYS => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return $self->data->load('menu-format/kde-desktop-keys'); + } +); + +# Known types of desktop entries. +# https://specifications.freedesktop.org/desktop-entry-spec/latest/ar01s06.html +my %known_desktop_types = map { $_ => 1 } qw( + Application + Link + Directory +); + +# Authoritative source of desktop categories: +# https://specifications.freedesktop.org/menu-spec/latest/apa.html + +# This is a list of all Main Categories for .desktop files. Application is +# added as an exception; it's not listed in the standard, but it's widely used +# and used as an example in the GNOME documentation. GNUstep is added as an +# exception since it's used by GNUstep packages. +my %main_categories = map { $_ => 1 } qw( + AudioVideo + Audio + Video + Development + Education + Game + Graphics + Network + Office + Science + Settings + System + Utility + Application + GNUstep +); + +# This is a list of all Additional Categories for .desktop files. Ideally we +# should be checking to be sure the associated Main Categories are present, +# but we don't have support for that yet. +has ADD_CATEGORIES => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return $self->data->load('menu-format/add-categories'); + } +); + +# This is a list of Reserved Categories for .desktop files. To use one of +# these, the desktop entry must also have an OnlyShowIn key limiting the +# environment to one that supports this category. +my %reserved_categories = map { $_ => 1 } qw( + Screensaver + TrayIcon + Applet + Shell +); + +# Path in which to search for binaries referenced in menu entries. These must +# not have leading slashes. +my @path = qw(usr/local/bin/ usr/bin/ bin/ usr/games/); + +my %known_tags_hash = map { $_ => 1 } @known_tags; +my %needs_tag_vals_hash = map { $_ => 1 } @needs_tag_vals; + +# ----------------------------------- + +sub installable { + my ($self) = @_; + + my $index = $self->processable->installed; + + my (@menufiles, %desktop_cmds); + for my $dirname (qw(usr/share/menu/ usr/lib/menu/)) { + if (my $dir = $index->resolve_path($dirname)) { + push(@menufiles, $dir->children); + } + } + + # Find the desktop files in the package for verification. + my @desktop_files; + for my $subdir (qw(applications xsessions)) { + if (my $dir = $index->lookup("usr/share/$subdir/")) { + for my $item ($dir->children) { + next + unless $item->is_file; + + next + if $item->is_dir; + + next + unless $item->basename =~ /\.desktop$/; + + $self->pointed_hint('executable-desktop-file', $item->pointer, + $item->octal_permissions) + if $item->is_executable; + + push(@desktop_files, $item) + unless $item->name =~ / template /msx; + } + } + } + + # Verify all the desktop files. + for my $desktop_file (@desktop_files) { + $self->verify_desktop_file($desktop_file, \%desktop_cmds); + } + + # Now all the menu files. + for my $menufile (@menufiles) { + # Do not try to parse executables + next if $menufile->is_executable or not $menufile->is_open_ok; + + # README is a special case + next if $menufile->basename eq 'README' && !$menufile->is_dir; + my $menufile_line =$EMPTY; + + open(my $fd, '<', $menufile->unpacked_path) + or die encode_utf8('Cannot open ' . $menufile->unpacked_path); + + # line below is commented out in favour of the while loop + # do { $_=<IN>; } while defined && (m/^\s* \#/ || m/^\s*$/); + while (my $line = <$fd>) { + if ($line =~ /^\s*\#/ || $line =~ /^\s*$/) { + next; + + } else { + $menufile_line = $line; + last; + } + } + + # Check first line of file to see if it matches the new menu + # file format. + if ($menufile_line =~ m/^!C\s*menu-2/) { + # we can't parse that yet + close($fd); + next; + } + + # Parse entire file as a new format menu file. + my $line=$EMPTY; + my $lc=0; + do { + $lc++; + + # Ignore lines that are comments. + if ($menufile_line =~ m/^\s*\#/) { + next; + } + $line .= $menufile_line; + # Note that I allow whitespace after the continuation character. + # This is caught by verify_line(). + if (!($menufile_line =~ m/\\\s*?$/)) { + $self->verify_line($menufile, $line,$lc,\%desktop_cmds); + $line=$EMPTY; + } + } while ($menufile_line = <$fd>); + $self->verify_line($menufile, $line,$lc,\%desktop_cmds); + + close($fd); + } + + return; +} + +# ----------------------------------- + +# Pass this a line of a menu file, it sanitizes it and +# verifies that it is correct. +sub verify_line { + my ($self, $menufile, $line, $position,$desktop_cmds) = @_; + + my $pointer = $menufile->pointer($position); + my %vals; + + chomp $line; + + # Replace all line continuation characters with whitespace. + # (do not remove them completely, because update-menus doesn't) + $line =~ s/\\\n/ /mg; + + # This is in here to fix a common mistake: whitespace after a '\' + # character. + if ($line =~ s/\\\s+\n/ /mg) { + $self->pointed_hint('whitespace-after-continuation-character', + $pointer); + } + + # Ignore lines that are all whitespace or empty. + return if $line =~ m/^\s*$/; + + # Ignore lines that are comments. + return if $line =~ m/^\s*\#/; + + # Start by testing the package check. + if (not $line =~ m/^\?package\((.*?)\):/) { + $self->pointed_hint('bad-test-in-menu-item', $pointer); + return; + } + my $pkg_test = $1; + my %tested_packages = map { $_ => 1 } split(/\s*,\s*/, $pkg_test); + my $tested_packages = scalar keys %tested_packages; + unless (exists $tested_packages{$self->processable->name}) { + $self->pointed_hint('pkg-not-in-package-test', $pointer, $pkg_test); + } + $line =~ s/^\?package\(.*?\)://; + + # Now collect all the tag=value pairs. I've heavily commented + # the killer regexp that's responsible. + # + # The basic idea here is we start at the beginning of the line. + # Each loop pulls off one tag=value pair and advances to the next + # when we have no more matches, there should be no text left on + # the line - if there is, it's a parse error. + while ( + $line =~ m{ + \s*? # allow whitespace between pairs + ( # capture what follows in $1, it's our tag + [^\"\s=] # a non-quote, non-whitespace, character + * # match as many as we can + ) + = + ( # capture what follows in $2, it's our value + (?: + \" # this is a quoted string + (?: + \\. # any quoted character + | # or + [^\"] # a non-quote character + ) + * # repeat as many times as possible + \" # end of the quoted value string + ) + | # the other possibility is a non-quoted string + (?: + [^\"\s] # a non-quote, non-whitespace character + * # match as many times as we can + ) + ) + }gcx + ) { + my $tag = $1; + my $value = $2; + + if (exists $vals{$tag}) { + $self->pointed_hint('duplicate-tag-in-menu', $pointer, $1); + } + + # If the value was quoted, remove those quotes. + if ($value =~ m/^\"(.*)\"$/) { + $value = $1; + } else { + $self->pointed_hint('unquoted-string-in-menu-item',$pointer, $1); + } + + # If the value has escaped characters, remove the + # escapes. + $value =~ s/\\(.)/$1/g; + + $vals{$tag} = $value; + } + + # This is not really a no-op. Note the use of the /c + # switch - this makes perl keep track of the current + # search position. Notice, we did it above in the loop, + # too. (I have a /g here just so the /c takes affect.) + # We use this below when we look at how far along in the + # string we matched. So the point of this line is to allow + # trailing whitespace on the end of a line. + $line =~ m/\s*/gc; + + # If that loop didn't match up to end of line, we have a + # problem.. + if (pos($line) < length($line)) { + $self->pointed_hint('unparsable-menu-item', $pointer); + # Give up now, before things just blow up in our face. + return; + } + + # Now validate the data in the menu file. + + # Test for important tags. + for my $tag (@req_tags) { + unless (exists($vals{$tag}) && defined($vals{$tag})) { + $self->pointed_hint('menu-item-missing-required-tag', + $pointer, $tag); + # Just give up right away, if such an essential tag is missing, + # chance is high the rest doesn't make sense either. And now all + # following checks can assume those tags to be there + return; + } + } + + # Make sure all tags are known. + for my $tag (keys %vals) { + if (!$known_tags_hash{$tag}) { + $self->pointed_hint('menu-item-contains-unknown-tag', + $pointer, $tag); + } + } + + # Sanitize the section tag + my $section = $vals{'section'}; + $section =~ tr:/:/:s; # eliminate duplicate slashes. # Hallo emacs ;; + $section =~ s{/$}{} # remove trailing slash + unless $section eq $SLASH; # - except if $section is '/' + + # Be sure the command is provided by the package. + my ($okay, $command) + = $self->verify_cmd($pointer, $vals{'command'}); + + $self->pointed_hint('menu-command-not-in-package', $pointer, $command) + if !$okay + && length $command + && $tested_packages < 2 + && $section !~ m{^(?:WindowManagers/Modules|FVWM Modules|Window Maker)}; + + if (length $command) { + $command =~ s{^(?:usr/)?s?bin/}{}; + $command =~ s{^usr/games/}{}; + + $self->pointed_hint('command-in-menu-file-and-desktop-file', + $pointer, $command) + if $desktop_cmds->{$command}; + } + + $self->verify_icon('icon', $vals{'icon'},$MAXIMUM_SIZE_STANDARD_ICON, + $pointer); + $self->verify_icon('icon32x32', $vals{'icon32x32'}, + $MAXIMUM_SIZE_32X32_ICON, $pointer); + $self->verify_icon('icon16x16', $vals{'icon16x16'}, + $MAXIMUM_SIZE_16X16_ICON, $pointer); + + # needs is case insensitive + my $needs = lc($vals{'needs'}); + + if ($section =~ m{^(WindowManagers/Modules|FVWM Modules|Window Maker)}) { + # WM/Modules: needs must not be the regular ones nor wm + $self->pointed_hint('non-wm-module-in-wm-modules-menu-section', + $pointer, $needs) + if $needs_tag_vals_hash{$needs} || $needs eq 'wm'; + + } elsif ($section =~ m{^Window ?Managers}) { + # Other WM sections: needs must be wm + $self->pointed_hint('non-wm-in-windowmanager-menu-section', + $pointer, $needs) + unless $needs eq 'wm'; + + } else { + # Any other section: just only the general ones + if ($needs eq 'dwww') { + $self->pointed_hint('menu-item-needs-dwww', $pointer); + + } elsif (!$needs_tag_vals_hash{$needs}) { + $self->pointed_hint('menu-item-needs-tag-has-unknown-value', + $pointer, $needs); + } + } + + # Check the section tag + # Check for historical changes in the section tree. + if ($section =~ m{^Apps/Games}) { + $self->pointed_hint('menu-item-uses-apps-games-section', $pointer); + $section =~ s{^Apps/}{}; + } + + if ($section =~ m{^Apps/}) { + $self->pointed_hint('menu-item-uses-apps-section', $pointer); + $section =~ s{^Apps/}{Applications/}; + } + + if ($section =~ m{^WindowManagers}) { + $self->pointed_hint('menu-item-uses-windowmanagers-section', $pointer); + $section =~ s{^WindowManagers}{Window Managers}; + } + + # Check for Evil new root sections. + my ($rootsec, $sect) = split(m{/}, $section, 2); + + my $root_data = $self->MENU_SECTIONS->{$rootsec}; + + if (!defined $root_data) { + + my $pkg = $self->processable->name; + $self->pointed_hint('menu-item-creates-new-root-section', + $pointer, $rootsec) + unless $rootsec =~ /$pkg/i; + + } else { + + $self->pointed_hint('menu-item-creates-new-section', + $pointer, $vals{section}) + if (length $sect && !exists $root_data->{$sect}) + || (!length $sect && !exists $root_data->{$EMPTY}); + } + + return; +} + +sub verify_icon { + my ($self, $tag, $name, $size, $pointer)= @_; + + return + unless length $name; + + if ($name eq 'none') { + + $self->pointed_hint('menu-item-uses-icon-none', $pointer, $tag); + return; + } + + $self->pointed_hint('menu-icon-uses-relative-path', $pointer, $tag, $name) + unless $name =~ s{^/+}{}; + + if ($name !~ /\.xpm$/i) { + + $self->pointed_hint('menu-icon-not-in-xpm-format', + $pointer, $tag, $name); + return; + } + + my @packages = ( + $self->processable, + @{ $self->group->direct_dependencies($self->processable) } + ); + + my @candidates; + for my $processable (@packages) { + + push(@candidates, $processable->installed->resolve_path($name)); + push(@candidates, + $processable->installed->resolve_path("usr/share/pixmaps/$name")); + } + + my $iconfile = first_value { defined } @candidates; + + if (!defined $iconfile || !$iconfile->is_open_ok) { + + $self->pointed_hint('menu-icon-missing', $pointer, $tag, $name); + return; + } + + open(my $fd, '<', $iconfile->unpacked_path) + or die encode_utf8('Cannot open ' . $iconfile->unpacked_path); + + my $parse = 'XPM header'; + + my $line; + do { defined($line = <$fd>) or goto PARSE_ERROR; } + until ($line =~ /\/\*\s*XPM\s*\*\//); + + $parse = 'size line'; + + do { defined($line = <$fd>) or goto PARSE_ERROR; } + until ($line =~ /"\s*([0-9]+)\s*([0-9]+)\s*(?:[0-9]+)\s*(?:[0-9]+)\s*"/); + my $width = $1 + 0; + my $height = $2 + 0; + + if ($width > $size || $height > $size) { + $self->pointed_hint('menu-icon-too-big', $pointer, $tag, + "$name: ${width}x${height} > ${size}x${size}"); + } + + close($fd); + + return; + + PARSE_ERROR: + close($fd); + $self->pointed_hint('menu-icon-cannot-be-parsed', $pointer, $tag, + "$name: looking for $parse"); + + return; +} + +# Syntax-checks a .desktop file. +sub verify_desktop_file { + my ($self, $item, $desktop_cmds) = @_; + + my ($saw_first, $warned_cr, %vals, @pending); + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $position = 1; + while (my $line = <$fd>) { + + chomp $line; + + my $pointer = $item->pointer($position); + + next + if $line =~ /^\s*\#/ || $line =~ /^\s*$/; + + if ($line =~ s/\r//) { + $self->pointed_hint('desktop-entry-file-has-crs', $pointer) + unless $warned_cr; + $warned_cr = 1; + } + + # Err on the side of caution for now. If the first non-comment line + # is not the required [Desktop Entry] group, ignore this file. Also + # ignore any keys in other groups. + last + if $saw_first && $line =~ /^\[(.*)\]\s*$/; + + unless ($saw_first) { + return + unless $line =~ /^\[(KDE )?Desktop Entry\]\s*$/; + $saw_first = 1; + $self->pointed_hint('desktop-contains-deprecated-key', $pointer) + if $line =~ /^\[KDE Desktop Entry\]\s*$/; + } + + # Tag = Value. For most errors, just add the error to pending rather + # than warning on it immediately since we want to not warn on tag + # errors if we didn't know the file type. + # + # TODO: We do not check for properly formatted localised values for + # keys but might be worth checking if they are properly formatted (not + # their value) + if ($line =~ /^(.*?)\s*=\s*(.*)$/) { + my ($tag, $value) = ($1, $2); + my $basetag = $tag; + $basetag =~ s/\[([^\]]+)\]$//; + if (exists $vals{$tag}) { + $self->pointed_hint('duplicate-key-in-desktop', $pointer,$tag); + } elsif ($self->DEPRECATED_DESKTOP_KEYS->recognizes($basetag)) { + if ($basetag eq 'Encoding') { + push(@pending, + ['desktop-entry-contains-encoding-key',$pointer, $tag] + ); + } else { + push( + @pending, + [ + 'desktop-entry-contains-deprecated-key', + $pointer, $tag + ] + ); + } + } elsif (not $self->KNOWN_DESKTOP_KEYS->recognizes($basetag) + and not $self->KDE_DESKTOP_KEYS->recognizes($basetag) + and not $basetag =~ /^X-/) { + push(@pending, + ['desktop-entry-contains-unknown-key', $pointer, $tag]); + } + $vals{$tag} = $value; + } + + } continue { + ++$position; + } + + close($fd); + + # Now validate the data in the desktop file, but only if it's a known type. + # Warn if it's not. + my $type = $vals{'Type'}; + return + unless defined $type; + + unless ($known_desktop_types{$type}) { + $self->pointed_hint('desktop-entry-unknown-type', $item->pointer, + $type); + return; + } + + $self->pointed_hint(@{$_}) for @pending; + + # Test for important keys. + for my $tag (@req_desktop_keys) { + unless (defined $vals{$tag}) { + $self->pointed_hint('desktop-entry-missing-required-key', + $item->pointer, $tag); + } + } + + # test if missing Keywords (only if NoDisplay is not set) + if (!defined $vals{NoDisplay}) { + + $self->pointed_hint('desktop-entry-lacks-icon-entry', $item->pointer) + unless defined $vals{Icon}; + + $self->pointed_hint('desktop-entry-lacks-keywords-entry', + $item->pointer) + if !defined $vals{Keywords} && $vals{'Type'} eq 'Application'; + } + + # Only test whether the binary is in the package if the desktop file is + # directly under /usr/share/applications. Too many applications use + # desktop files for other purposes with custom paths. + # + # TODO: Should check quoting and the check special field + # codes in Exec for desktop files. + if ( $item->name =~ m{^usr/share/applications/} + && $vals{'Exec'} + && $vals{'Exec'} =~ /\S/) { + + my ($okay, $command) + = $self->verify_cmd($item->pointer, $vals{'Exec'}); + + $self->pointed_hint('desktop-command-not-in-package', + $item->pointer, $command) + unless $okay + || $command eq 'kcmshell'; + + $command =~ s{^(?:usr/)?s?bin/}{}; + $desktop_cmds->{$command} = 1 + unless $command =~ m/^(?:su-to-root|sux?|(?:gk|kde)su)$/; + } + + # Check the Category tag. + my $in_reserved; + if (defined $vals{'Categories'}) { + + my $saw_main; + + my @categories = split(/;/, $vals{'Categories'}); + for my $category (@categories) { + + next + if $category =~ /^X-/; + + if ($reserved_categories{$category}) { + $self->pointed_hint('desktop-entry-uses-reserved-category', + $item->pointer,$category) + unless $vals{'OnlyShowIn'}; + + $saw_main = 1; + $in_reserved = 1; + + } elsif (!$self->ADD_CATEGORIES->recognizes($category) + && !$main_categories{$category}) { + $self->pointed_hint('desktop-entry-invalid-category', + $item->pointer, $category); + + } elsif ($main_categories{$category}) { + $saw_main = 1; + } + } + + $self->pointed_hint('desktop-entry-lacks-main-category',$item->pointer) + unless $saw_main; + } + + # Check the OnlyShowIn tag. If this is not an application in a reserved + # category, warn about any desktop entry that specifies OnlyShowIn for + # more than one environment. In that case, the application probably + # should be using NotShowIn instead. + if (defined $vals{OnlyShowIn} and not $in_reserved) { + my @envs = split(/;/, $vals{OnlyShowIn}); + if (@envs > 1) { + $self->pointed_hint('desktop-entry-limited-to-environments', + $item->pointer); + } + } + + # Check that the Exec tag specifies how to pass a filename if MimeType + # tags are present. + if ($item->name =~ m{^usr/share/applications/} + && defined $vals{'MimeType'}) { + + $self->pointed_hint('desktop-mime-but-no-exec-code', $item->pointer) + unless defined $vals{'Exec'} + && $vals{'Exec'} =~ /(?:^|[^%])%[fFuU]/; + } + + return; +} + +# Verify whether a command is shipped as part of the package. Takes the full +# path to the file being checked (for error reporting) and the binary. +# Returns a list whose first member is true if the command is present and +# false otherwise, and whose second member is the command (minus any leading +# su-to-root wrapper). Shared between the desktop and menu code. +sub verify_cmd { + my ($self, $pointer, $exec) = @_; + + my $index = $self->processable->installed; + + # This routine handles su wrappers. The option parsing here is ugly and + # dead-simple, but it's hopefully good enough for what will show up in + # desktop files. su-to-root and sux require -c options, kdesu optionally + # allows one, and gksu has the command at the end of its arguments. + my @components = split($SPACE, $exec); + my $cmd; + + $self->pointed_hint('su-to-root-with-usr-sbin', $pointer) + if $components[0] && $components[0] eq '/usr/sbin/su-to-root'; + + if ( $components[0] + && $components[0] =~ m{^(?:/usr/s?bin/)?(su-to-root|gksu|kdesu|sux)$}){ + + my $wrapper = $1; + shift @components; + + while (@components) { + unless ($components[0]) { + shift @components; + next; + } + + if ($components[0] eq '-c') { + $cmd = $components[1]; + last; + + } elsif ( + $components[0] =~ /^-[Dfmupi]|^--(user|description|message)/) { + shift @components; + shift @components; + + } elsif ($components[0] =~ /^-/) { + shift @components; + + } else { + last; + } + } + + if (!$cmd && $wrapper =~ /^(gk|kde)su$/) { + if (@components) { + $cmd = $components[0]; + } else { + $cmd = $wrapper; + undef $wrapper; + } + } + + $self->pointed_hint('su-wrapper-without--c', $pointer, $wrapper) + unless $cmd; + + $self->pointed_hint('su-wrapper-not-su-to-root', $pointer, $wrapper) + if $wrapper + && $wrapper !~ /su-to-root/ + && $wrapper ne $self->processable->name; + + } else { + $cmd = $components[0]; + } + + my $cmd_file = $cmd; + if ($cmd_file) { + $cmd_file =~ s{^/}{}; + } + + my $okay = $cmd + && ( $cmd =~ /^[\'\"]/ + || $index->lookup($cmd_file) + || $cmd =~ m{^(/bin/)?sh} + || $cmd =~ m{^(/usr/bin/)?sensible-(pager|editor|browser)} + || any { $index->lookup($_ . $cmd) } @path); + + return ($okay, $cmd_file); +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Menus.pm b/lib/Lintian/Check/Menus.pm new file mode 100644 index 0000000..2e8f3d1 --- /dev/null +++ b/lib/Lintian/Check/Menus.pm @@ -0,0 +1,818 @@ +# menus -- lintian check script -*- perl -*- + +# somewhat of a misnomer -- it doesn't only check menus + +# Copyright (C) 1998 Christian Schwarz +# Copyright (C) 2018 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Menus; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::Spelling qw(check_spelling check_spelling_picky); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $SLASH => q{/}; +const my $DOT => q{.}; +const my $QUESTION_MARK => q{?}; + +# Supported documentation formats for doc-base files. +my %known_doc_base_formats + = map { $_ => 1 }qw(html text pdf postscript info dvi debiandoc-sgml); + +# Known fields for doc-base files. The value is 1 for required fields and 0 +# for optional fields. +my %KNOWN_DOCBASE_MAIN_FIELDS = ( + 'Document' => 1, + 'Title' => 1, + 'Section' => 1, + 'Abstract' => 0, + 'Author' => 0 +); + +my %KNOWN_DOCBASE_FORMAT_FIELDS = ( + 'Format' => 1, + 'Files' => 1, + 'Index' => 0 +); + +has menu_item => (is => 'rw'); +has menumethod_item => (is => 'rw'); +has documentation => (is => 'rw', default => 0); + +sub spelling_tag_emitter { + my ($self, @orig_args) = @_; + + return sub { + return $self->pointed_hint(@orig_args, @_); + }; +} + +sub visit_installed_files { + my ($self, $item) = @_; + + if ($item->is_file) { # file checks + # menu file? + if ($item->name =~ m{^usr/(lib|share)/menu/\S}){ # correct permissions? + + $self->pointed_hint('executable-menu-file', $item->pointer, + $item->octal_permissions) + if $item->is_executable; + + return + if $item->name =~ m{^usr/(?:lib|share)/menu/README$}; + + if ($item->name =~ m{^usr/lib/}) { + $self->pointed_hint('menu-file-in-usr-lib', $item->pointer); + } + + $self->menu_item($item); + + $self->pointed_hint('bad-menu-file-name', $item->pointer) + if $item->name =~ m{^usr/(?:lib|share)/menu/menu$} + && $self->processable->name ne 'menu'; + } + #menu-methods file? + elsif ($item->name =~ m{^etc/menu-methods/\S}) { + #TODO: we should test if the menu-methods file + # is made executable in the postinst as recommended by + # the menu manual + + my $menumethod_includes_menu_h = 0; + $self->menumethod_item($item); + + if ($item->is_open_ok) { + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + while (my $line = <$fd>) { + chomp $line; + if ($line =~ /^!include menu.h/) { + $menumethod_includes_menu_h = 1; + last; + } + } + close($fd); + } + + $self->pointed_hint('menu-method-lacks-include', $item->pointer) + unless $menumethod_includes_menu_h + or $self->processable->name eq 'menu'; + } + # package doc dir? + elsif ( + $item->name =~ m{ \A usr/share/doc/(?:[^/]+/)? + (.+\.(?:html|pdf))(?:\.gz)? + \Z}xsm + ) { + my $name = $1; + unless ($name =~ m/^changelog\.html$/ + or $name =~ m/^README[.-]/ + or $name =~ m/examples/) { + $self->documentation(1); + } + } + } + + return; +} + +sub installable { + my ($self) = @_; + + my $pkg = $self->processable->name; + my $processable = $self->processable; + my $group = $self->group; + + my (%all_files, %all_links); + + my %preinst; + my %postinst; + my %prerm; + my %postrm; + + $self->check_script($processable->control->lookup('preinst'),\%preinst); + $self->check_script($processable->control->lookup('postinst'),\%postinst); + $self->check_script($processable->control->lookup('prerm'),\%prerm); + $self->check_script($processable->control->lookup('postrm'),\%postrm); + + # Populate all_{files,links} from current package and its dependencies + for my $installable ($group->get_installables) { + next + unless $processable->name eq $installable->name + || $processable->relation('strong')->satisfies($installable->name); + + for my $item (@{$installable->installed->sorted_list}) { + add_file_link_info($installable, $item->name, \%all_files, + \%all_links); + } + } + + # prerm scripts should not call update-menus + $self->pointed_hint('prerm-calls-updatemenus',$prerm{'calls-updatemenus'}) + if defined $prerm{'calls-updatemenus'}; + + # postrm scripts should not call install-docs + $self->pointed_hint('postrm-calls-installdocs', + $postrm{'calls-installdocs'}) + if defined $postrm{'calls-installdocs'}; + $self->pointed_hint('postrm-calls-installdocs', + $postrm{'calls-installdocs-r'}) + if defined $postrm{'calls-installdocs-r'}; + + # preinst scripts should not call either update-menus nor installdocs + $self->pointed_hint('preinst-calls-updatemenus', + $preinst{'calls-updatemenus'}) + if defined $preinst{'calls-updatemenus'}; + + $self->pointed_hint('preinst-calls-installdocs', + $preinst{'calls-installdocs'}) + if defined $preinst{'calls-installdocs'}; + + my $anymenu_item = $self->menu_item || $self->menumethod_item; + + # No one needs to call install-docs any more; triggers now handles that. + $self->pointed_hint('postinst-has-useless-call-to-install-docs', + $postinst{'calls-installdocs'}) + if defined $postinst{'calls-installdocs'}; + $self->pointed_hint('postinst-has-useless-call-to-install-docs', + $postinst{'calls-installdocs-r'}) + if defined $postinst{'calls-installdocs-r'}; + + $self->pointed_hint('prerm-has-useless-call-to-install-docs', + $prerm{'calls-installdocs'}) + if defined $prerm{'calls-installdocs'}; + $self->pointed_hint('prerm-has-useless-call-to-install-docs', + $prerm{'calls-installdocs-r'}) + if defined $prerm{'calls-installdocs-r'}; + + # check consistency + # docbase file? + if (my $db_dir + = $processable->installed->resolve_path('usr/share/doc-base/')){ + for my $item ($db_dir->children) { + next + if !$item->is_open_ok; + + if ($item->resolve_path->is_executable) { + + $self->pointed_hint('executable-in-usr-share-docbase', + $item->pointer, $item->octal_permissions); + next; + } + + $self->check_doc_base_file($item, \%all_files,\%all_links); + } + } elsif ($self->documentation) { + if ($pkg =~ /^libghc6?-.*-doc$/) { + # This is the library documentation for a haskell library. Haskell + # libraries register their documentation via the ghc compiler's + # documentation registration mechanism. See bug #586877. + } else { + $self->hint('possible-documentation-but-no-doc-base-registration'); + } + } + + if ($anymenu_item) { + # postinst and postrm should not need to call update-menus + # unless there is a menu-method file. However, update-menus + # currently won't enable packages that have outstanding + # triggers, leading to an update-menus call being required for + # at least some packages right now. Until this bug is fixed, + # we still require it. See #518919 for more information. + # + # That bug does not require calling update-menus from postrm, + # but debhelper apparently currently still adds that to the + # maintainer script, so don't warn if it's done. + $self->pointed_hint('postinst-does-not-call-updatemenus', + $anymenu_item->pointer) + if !defined $postinst{'calls-updatemenus'}; + + $self->pointed_hint( + 'postrm-does-not-call-updatemenus', + $self->menumethod_item->pointer + ) + if defined $self->menumethod_item + && !defined $postrm{'calls-updatemenus'} + && $pkg ne 'menu'; + + } else { + $self->pointed_hint('postinst-has-useless-call-to-update-menus', + $postinst{'calls-updatemenus'}) + if defined $postinst{'calls-updatemenus'}; + + $self->pointed_hint('postrm-has-useless-call-to-update-menus', + $postrm{'calls-updatemenus'}) + if defined $postrm{'calls-updatemenus'}; + } + + return; +} + +# ----------------------------------- + +sub check_doc_base_file { + my ($self, $item, $all_files, $all_links) = @_; + + my $pkg = $self->processable->name; + my $group = $self->group; + + # another check complains about invalid encoding + return + unless ($item->is_valid_utf8); + + my $contents = $item->decoded_utf8; + my @lines = split(/\n/, $contents); + + my $knownfields = \%KNOWN_DOCBASE_MAIN_FIELDS; + my ($field, @vals); + my %sawfields; # local for each section of control file + my %sawformats; # global for control file + my $line = 0; # global + + my $position = 1; + while (defined(my $string = shift @lines)) { + chomp $string; + + # New field. check previous field, if we have any. + if ($string =~ /^(\S+)\s*:\s*(.*)$/) { + my (@new) = ($1, $2); + if ($field) { + $self->check_doc_base_field( + $item, $line, $field, + \@vals,\%sawfields, \%sawformats, + $knownfields,$all_files, $all_links + ); + } + + $field = $new[0]; + + @vals = ($new[1]); + $line = $position; + + # Continuation of previously defined field. + } elsif ($field && $string =~ /^\s+\S/) { + push(@vals, $string); + + # All tags will be reported on the last continuation line of the + # doc-base field. + $line = $position; + + # Sections' separator. + } elsif ($string =~ /^(\s*)$/) { + $self->pointed_hint('doc-base-file-separator-extra-whitespace', + $item->pointer($position)) + if $1; + next unless $field; # skip successive empty lines + + # Check previously defined field and section. + $self->check_doc_base_field( + $item, $line, $field, + \@vals,\%sawfields, \%sawformats, + $knownfields,$all_files, $all_links + ); + $self->check_doc_base_file_section($item, $line + 1,\%sawfields, + \%sawformats, $knownfields); + + # Initialize variables for new section. + undef $field; + undef $line; + @vals = (); + %sawfields = (); + + # Each section except the first one is format section. + $knownfields = \%KNOWN_DOCBASE_FORMAT_FIELDS; + + # Everything else is a syntax error. + } else { + $self->pointed_hint('doc-base-file-syntax-error', + $item->pointer($position)); + } + + } continue { + ++$position; + } + + # Check the last field/section of the control file. + if ($field) { + $self->check_doc_base_field( + $item, $line, $field, + \@vals, \%sawfields,\%sawformats, + $knownfields,$all_files,$all_links + ); + $self->check_doc_base_file_section($item, $line, \%sawfields, + \%sawformats,$knownfields); + } + + # Make sure we saw at least one format. + $self->pointed_hint('doc-base-file-no-format-section', $item->pointer) + unless %sawformats; + + return; +} + +# Checks one field of a doc-base control file. $vals is array ref containing +# all lines of the field. Modifies $sawfields and $sawformats. +sub check_doc_base_field { + my ( + $self, $item, $position, $field,$vals, + $sawfields, $sawformats,$knownfields,$all_files, $all_links + ) = @_; + + my $pkg = $self->processable->name; + my $group = $self->group; + + my $SECTIONS = $self->data->load('doc-base/sections'); + + $self->pointed_hint('doc-base-file-unknown-field', + $item->pointer($position), $field) + unless defined $knownfields->{$field}; + $self->pointed_hint('duplicate-field-in-doc-base', + $item->pointer($position), $field) + if $sawfields->{$field}; + $sawfields->{$field} = 1; + + # Index/Files field. + # + # Check if files referenced by doc-base are included in the package. The + # Index field should refer to only one file without wildcards. The Files + # field is a whitespace-separated list of files and may contain wildcards. + # We skip without validating wildcard patterns containing character + # classes since otherwise we'd need to deal with wildcards inside + # character classes and aren't there yet. + if ($field eq 'Index' or $field eq 'Files') { + my @files = map { split($SPACE) } @{$vals}; + + if ($field eq 'Index' && @files > 1) { + $self->pointed_hint('doc-base-index-references-multiple-files', + $item->pointer($position)); + } + for my $file (@files) { + next if $file =~ m{^/usr/share/doc/}; + next if $file =~ m{^/usr/share/info/}; + + $self->pointed_hint('doc-base-file-references-wrong-path', + $item->pointer($position), $file); + } + for my $file (@files) { + my $realfile = delink($file, $all_links); + # openoffice.org-dev-doc has thousands of files listed so try to + # use the hash if possible. + my $found; + if ($realfile =~ /[*?]/) { + my $regex = quotemeta($realfile); + unless ($field eq 'Index') { + next if $regex =~ /\[/; + $regex =~ s{\\\*}{[^/]*}g; + $regex =~ s{\\\?}{[^/]}g; + $regex .= $SLASH . $QUESTION_MARK; + } + $found = grep { /^$regex\z/ } keys %{$all_files}; + } else { + $found = $all_files->{$realfile} || $all_files->{"$realfile/"}; + } + unless ($found) { + $self->pointed_hint('doc-base-file-references-missing-file', + $item->pointer($position),$file); + } + } + undef @files; + + # Format field. + } elsif ($field eq 'Format') { + my $format = join($SPACE, @{$vals}); + + # trim both ends + $format =~ s/^\s+|\s+$//g; + + $format = lc $format; + $self->pointed_hint('doc-base-file-unknown-format', + $item->pointer($position), $format) + unless $known_doc_base_formats{$format}; + $self->pointed_hint('duplicate-format-in-doc-base', + $item->pointer($position), $format) + if $sawformats->{$format}; + $sawformats->{$format} = 1; + + # Save the current format for the later section check. + $sawformats->{' *current* '} = $format; + + # Document field. + } elsif ($field eq 'Document') { + $_ = join($SPACE, @{$vals}); + + $self->pointed_hint('doc-base-invalid-document-field', + $item->pointer($position), $_) + unless /^[a-z0-9+.-]+$/; + $self->pointed_hint('doc-base-document-field-ends-in-whitespace', + $item->pointer($position)) + if /[ \t]$/; + $self->pointed_hint('doc-base-document-field-not-in-first-line', + $item->pointer($position)) + unless $position == 1; + + # Title field. + } elsif ($field eq 'Title') { + if (@{$vals}) { + my $stag_emitter + = $self->spelling_tag_emitter( + 'spelling-error-in-doc-base-title-field', + $item->pointer($position)); + check_spelling( + $self->data, + join($SPACE, @{$vals}), + $group->spelling_exceptions, + $stag_emitter + ); + check_spelling_picky($self->data, join($SPACE, @{$vals}), + $stag_emitter); + } + + # Section field. + } elsif ($field eq 'Section') { + $_ = join($SPACE, @{$vals}); + unless ($SECTIONS->recognizes($_)) { + if (m{^App(?:lication)?s/(.+)$} && $SECTIONS->recognizes($1)) { + $self->pointed_hint('doc-base-uses-applications-section', + $item->pointer($position), $_); + } elsif (m{^(.+)/(?:[^/]+)$} && $SECTIONS->recognizes($1)) { + # allows creating a new subsection to a known section + } else { + $self->pointed_hint('doc-base-unknown-section', + $item->pointer($position), $_); + } + } + + # Abstract field. + } elsif ($field eq 'Abstract') { + # The three following variables are used for checking if the field is + # correctly phrased. We detect if each line (except for the first + # line and lines containing single dot) of the field starts with the + # same number of spaces, not followed by the same non-space character, + # and the number of spaces is > 1. + # + # We try to match fields like this: + # ||Abstract: The Boost web site provides free peer-reviewed portable + # || C++ source libraries. The emphasis is on libraries which work + # || well with the C++ Standard Library. One goal is to establish + # + # but not like this: + # ||Abstract: This is "Ding" + # || * a dictionary lookup program for Unix, + # || * DIctionary Nice Grep, + my $leadsp; # string with leading spaces from second line + my $charafter; # first non-whitespace char of second line + my $leadsp_ok = 1; # are spaces OK? + + # Intentionally skipping the first line. + for my $idx (1 .. $#{$vals}) { + $_ = $vals->[$idx]; + + if (/manage\s+online\s+manuals\s.*Debian/) { + $self->pointed_hint('doc-base-abstract-field-is-template', + $item->pointer($position)) + unless $pkg eq 'doc-base'; + + } elsif (/^(\s+)\.(\s*)$/ and ($1 ne $SPACE or $2)) { + $self->pointed_hint( + 'doc-base-abstract-field-separator-extra-whitespace', + $item->pointer($position - $#{$vals} + $idx) + ); + + } elsif (!$leadsp && /^(\s+)(\S)/) { + # The regexp should always match. + ($leadsp, $charafter) = ($1, $2); + $leadsp_ok = $leadsp eq $SPACE; + + } elsif (!$leadsp_ok && /^(\s+)(\S)/) { + # The regexp should always match. + undef $charafter if $charafter && $charafter ne $2; + $leadsp_ok = 1 + if ($1 ne $leadsp) || ($1 eq $leadsp && $charafter); + } + } + + unless ($leadsp_ok) { + $self->pointed_hint( + 'doc-base-abstract-might-contain-extra-leading-whitespace', + $item->pointer($position)); + } + + # Check spelling. + if (@{$vals}) { + my $stag_emitter + = $self->spelling_tag_emitter( + 'spelling-error-in-doc-base-abstract-field', + $item->pointer($position)); + check_spelling( + $self->data, + join($SPACE, @{$vals}), + $group->spelling_exceptions, + $stag_emitter + ); + check_spelling_picky($self->data, join($SPACE, @{$vals}), + $stag_emitter); + } + } + + return; +} + +# Checks the section of the doc-base control file. Tries to find required +# fields missing in the section. +sub check_doc_base_file_section { + my ($self, $item, $position, $sawfields, $sawformats, $knownfields) = @_; + + $self->pointed_hint('doc-base-file-no-format', $item->pointer($position)) + if ((defined $sawfields->{'Files'} || defined $sawfields->{'Index'}) + && !(defined $sawfields->{'Format'})); + + # The current format is set by check_doc_base_field. + if ($sawfields->{'Format'}) { + my $format = $sawformats->{' *current* '}; + $self->pointed_hint('doc-base-file-no-index',$item->pointer($position)) + if ( $format + && ($format eq 'html' || $format eq 'info') + && !$sawfields->{'Index'}); + } + for my $field (sort keys %{$knownfields}) { + $self->pointed_hint('doc-base-file-lacks-required-field', + $item->pointer($position), $field) + if ($knownfields->{$field} == 1 && !$sawfields->{$field}); + } + + return; +} + +# Add file and link to $all_files and $all_links. Note that both files and +# links have to include a leading /. +sub add_file_link_info { + my ($processable, $file, $all_files, $all_links) = @_; + + my $link = $processable->installed->lookup($file)->link; + my $ishard = $processable->installed->lookup($file)->is_hardlink; + + # make name absolute + $file = $SLASH . $file + unless $file =~ m{^/}; + + $file =~ s{/+}{/}g; # remove duplicated `/' + $all_files->{$file} = 1; + + if (length $link) { + + $link = $DOT . $SLASH . $link + if $link !~ m{^/}; + + if ($ishard) { + $link =~ s{^\./}{/}; + } elsif ($link !~ m{^/}) { # not absolute link + $link + = $SLASH + . $link; # make sure link starts with '/' + $link =~ s{/+\./+}{/}g; # remove all /./ parts + my $dcount = 1; + while ($link =~ s{^/+\.\./+}{/}) { #\ count & remove + $dcount++; #/ any leading /../ parts + } + my $f = $file; + while ($dcount--) { #\ remove last $dcount + $f=~ s{/[^/]*$}{}; #/ path components from $file + } + $link + = $f. $link; # now we should have absolute link + } + $all_links->{$file} = $link unless ($link eq $file); + } + + return; +} + +# Dereference all symlinks in file. +sub delink { + my ($file, $all_links) = @_; + + $file =~ s{/+}{/}g; # remove duplicated '/' + return $file + unless %{$all_links}; # package doesn't symlinks + + my $p1 = $EMPTY; + my $p2 = $file; + my %used_links; + + # In the loop below we split $file into two parts on each '/' until + # there's no remaining slashes. We try substituting the first part with + # corresponding symlink and if it succeeds, we start the procedure from + # beginning. + # + # Example: + # Let $all_links{"/a/b"} == "/d", and $file == "/a/b/c" + # Then 0) $p1 == "", $p2 == "/a/b/c" + # 1) $p1 == "/a", $p2 == "/b/c" + # 2) $p1 == "/a/b", $p2 == "/c" ; substitute "/d" for "/a/b" + # 3) $p1 == "", $p2 == "/d/c" + # 4) $p1 == "/d", $p2 == "/c" + # 5) $p1 == "/d/c", $p2 == "" + # + # Note that the algorithm supposes, that + # i) $all_links{$X} != $X for each $X + # ii) both keys and values of %all_links start with '/' + + while (($p2 =~ s{^(/[^/]*)}{}g) > 0) { + $p1 .= $1; + if (defined $all_links->{$p1}) { + return '!!! SYMLINK LOOP !!!' if defined $used_links{$p1}; + $p2 = $all_links->{$p1} . $p2; + $p1 = $EMPTY; + $used_links{$p1} = 1; + } + } + + # After the loop $p2 should be empty and $p1 should contain the target + # file. In some rare cases when $file contains no slashes, $p1 will be + # empty and $p2 will contain the result (which will be equal to $file). + return $p1 ne $EMPTY ? $p1 : $p2; +} + +sub check_script { + my ($self, $item, $pres) = @_; + + my $pkg = $self->processable->name; + + my ($no_check_menu, $no_check_installdocs); + + # control files are regular files and not symlinks, pipes etc. + return + unless defined $item; + + return + if $item->is_symlink; + + return + unless $item->is_open_ok; + + # nothing to do for ELF + return + if $item->is_elf; + + my $interpreter = $item->interpreter || 'unknown'; + + if ($item->is_shell_script) { + $interpreter = 'sh'; + + } elsif ($interpreter =~ m{^/usr/bin/perl}) { + $interpreter = 'perl'; + } + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $position = 1; + while (my $line = <$fd>) { + # skip comments + $line =~ s/\#.*$//; + + ## + # update-menus will satisfy the checks that the menu file + # installed is properly used + ## + + # does the script check whether update-menus exists? + $pres->{'checks-for-updatemenus'} = $item->pointer($position) + if $line =~ /-x\s+\S*update-menus/ + || $line =~ /(?:which|type)\s+update-menus/ + || $line =~ /command\s+.*?update-menus/; + + # does the script call update-menus? + # TODO this regex-magic should be moved to some lib for checking + # whether a certain word is likely called as command... --Jeroen + if ( + $line =~m{ (?:^\s*|[;&|]\s*|(?:then|do|exec)\s+) + (?:\/usr\/bin\/)?update-menus + (?:\s|[;&|<>]|\Z)}xsm + ) { + # yes, it does. + $pres->{'calls-updatemenus'} = $item->pointer($position); + + # checked first? + if (not $pres->{'checks-for-updatemenus'} and $pkg ne 'menu') { + $self->pointed_hint( +'maintainer-script-does-not-check-for-existence-of-updatemenus', + $item->pointer($position) + ) unless $no_check_menu++; + } + } + + # does the script check whether install-docs exists? + $pres->{'checks-for-installdocs'} = $item->pointer($position) + if $line =~ s/-x\s+\S*install-docs// + || $line =~/(?:which|type)\s+install-docs/ + || $line =~ s/command\s+.*?install-docs//; + + # does the script call install-docs? + if ( + $line =~ m{ (?:^\s*|[;&|]\s*|(?:then|do)\s+) + (?:\/usr\/sbin\/)?install-docs + (?:\s|[;&|<>]|\Z) }xsm + ) { + # yes, it does. Does it remove or add a doc? + if ($line =~ /install-docs\s+(?:-r|--remove)\s/) { + $pres->{'calls-installdocs-r'} = $item->pointer($position); + } else { + $pres->{'calls-installdocs'} = $item->pointer($position); + } + + # checked first? + if (not $pres->{'checks-for-installdocs'}) { + $self->pointed_hint( +'maintainer-script-does-not-check-for-existence-of-installdocs', + $item->pointer($position) + ) unless $no_check_installdocs++; + } + } + + } continue { + ++$position; + } + + close($fd); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Mimeinfo.pm b/lib/Lintian/Check/Mimeinfo.pm new file mode 100644 index 0000000..f24b73d --- /dev/null +++ b/lib/Lintian/Check/Mimeinfo.pm @@ -0,0 +1,61 @@ +# mimeinfo -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Mimeinfo; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + if ($item->name =~ m{^usr/share/applications/mimeinfo.cache(?:\.gz)?$}){ + $self->pointed_hint('package-contains-mimeinfo.cache-file', + $item->pointer); + + }elsif ($item->name =~ m{^usr/share/mime/.+}) { + + if ($item->name =~ m{^usr/share/mime/[^/]+$}) { + $self->pointed_hint('package-contains-mime-cache-file', + $item->pointer); + + } elsif ($item->name !~ m{^usr/share/mime/packages/}) { + $self->pointed_hint( + 'package-contains-mime-file-outside-package-dir', + $item->pointer); + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Modprobe.pm b/lib/Lintian/Check/Modprobe.pm new file mode 100644 index 0000000..f9af6c7 --- /dev/null +++ b/lib/Lintian/Check/Modprobe.pm @@ -0,0 +1,61 @@ +# modprobe -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Modprobe; + +use v5.20; +use warnings; +use utf8; + +use List::SomeUtils qw(uniq); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + if ( $item->name =~ m{^etc/modprobe\.d/ }x + && $item->name !~ m{ [.]conf $}x + && !$item->is_dir) { + + $self->pointed_hint('non-conf-file-in-modprobe.d', $item->pointer); + + } elsif ($item->name =~ m{^ etc/modprobe[.]d/ }x + || $item->name =~ m{^ etc/modules-load\.d/ }x) { + + my @obsolete = ($item->bytes =~ m{^ \s* ( install | remove ) }gmx); + $self->pointed_hint('obsolete-command-in-modprobe.d-file', + $item->pointer, $_) + for uniq @obsolete; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Nmu.pm b/lib/Lintian/Check/Nmu.pm new file mode 100644 index 0000000..a758728 --- /dev/null +++ b/lib/Lintian/Check/Nmu.pm @@ -0,0 +1,193 @@ +# nmu -- lintian check script -*- perl -*- + +# Copyright (C) 2004 Jeroen van Wolffelaar +# Copyright (C) 2017-2019 Chris Lamb <lamby@debian.org> +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Nmu; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(any); +use List::Util qw(first); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; + +sub source { + my ($self) = @_; + + my $processable = $self->processable; + + my $changelog_mentions_nmu = 0; + my $changelog_mentions_local = 0; + my $changelog_mentions_qa = 0; + my $changelog_mentions_team_upload = 0; + + my $debian_dir = $processable->patched->resolve_path('debian/'); + + my $chf; + $chf = $debian_dir->child('changelog') if $debian_dir; + + # This isn't really an NMU check, but right now no other check + # looks at debian/changelog in source packages. Catch a + # debian/changelog file that's a symlink. + $self->pointed_hint('changelog-is-symlink', $chf->pointer) + if $chf && $chf->is_symlink; + + return + unless $processable->changelog; + + # Get some data from the changelog file. + my ($entry) = @{$processable->changelog->entries}; + + my $pointer = $chf->pointer($entry->position); + + my $uploader = canonicalize($entry->Maintainer // $EMPTY); + + # trim both ends + $self->pointed_hint('extra-whitespace-around-name-in-changelog-trailer', + $pointer) + if $uploader =~ s/^\s+|\s+$//g; + + my $changes = $entry->Changes; + $changes =~ s/^(\s*\n)+//; + my $firstline = first { /^\s*\*/ } split(/\n/, $changes); + + # Check the first line for QA, NMU or team upload mentions. + if ($firstline) { + local $_ = $firstline; + if (/\bnmu\b/i or /non-maintainer upload/i or m/LowThresholdNMU/i) { + unless ( + m{ + (?:ackno|\back\b|confir|incorporat).* + (?:\bnmu\b|non-maintainer)}xi + ) { + $changelog_mentions_nmu = 1; + } + } + $changelog_mentions_local = 1 if /\blocal\s+package\b/i; + $changelog_mentions_qa = 1 if /orphan/i or /qa (?:group )?upload/i; + $changelog_mentions_team_upload = 1 if /team upload/i; + } + + # If the version field is missing, assume it to be a native, + # maintainer upload as it is probably the most likely case. + my $version = $processable->fields->value('Version') || '0-1'; + my $maintainer= canonicalize($processable->fields->value('Maintainer')); + my $uploaders = $processable->fields->value('Uploaders'); + + my $version_nmuness = 0; + my $version_local = 0; + my $upload_is_backport = $version =~ m/~bpo(\d+)\+(\d+)$/; + my $upload_is_stable_update = $version =~ m/~deb(\d+)u(\d+)$/; + + if ($version =~ /-[^.-]+(\.[^.-]+)?(\.[^.-]+)?$/) { + $version_nmuness = 1 if defined $1; + $version_nmuness = 2 if defined $2; + } + if ($version =~ /\+nmu\d+$/) { + $version_nmuness = 1; + } + if ($version =~ /\+b\d+$/) { + $version_nmuness = 2; + } + if ($version =~ /local/i) { + $version_local = 1; + } + + my $upload_is_nmu = $uploader ne $maintainer; + + my @uploaders = map { canonicalize($_) } split />\K\s*,\s*/,$uploaders; + $upload_is_nmu = 0 if any { $_ eq $uploader } @uploaders; + + # If the changelog entry is missing a maintainer (eg. "-- <blank>") + # assume it's an upload still work in progress. + $upload_is_nmu = 0 if not $uploader; + + if ($maintainer =~ /packages\@qa.debian.org/) { + + $self->pointed_hint('uploaders-in-orphan', $pointer) + if $processable->fields->declares('Uploaders'); + + $self->pointed_hint('qa-upload-has-incorrect-version-number', + $pointer, $version) + if $version_nmuness == 1; + + $self->pointed_hint('no-qa-in-changelog', $pointer) + unless $changelog_mentions_qa; + + } elsif ($changelog_mentions_team_upload) { + + $self->pointed_hint('team-upload-has-incorrect-version-number', + $pointer, $version) + if $version_nmuness == 1; + + $self->pointed_hint('unnecessary-team-upload', $pointer) + unless $upload_is_nmu; + + } else { + # Local packages may be either NMUs or not. + unless ($changelog_mentions_local || $version_local) { + + $self->pointed_hint('no-nmu-in-changelog', $pointer) + if !$changelog_mentions_nmu && $upload_is_nmu; + + $self->pointed_hint('source-nmu-has-incorrect-version-number', + $pointer, $version) + if $upload_is_nmu + && $version_nmuness != 1 + && !$upload_is_stable_update + && !$upload_is_backport; + } + + $self->pointed_hint('nmu-in-changelog', $pointer) + if $changelog_mentions_nmu && !$upload_is_nmu; + + $self->pointed_hint('maintainer-upload-has-incorrect-version-number', + $pointer, $version) + if !$upload_is_nmu && $version_nmuness; + } + + return; +} + +# Canonicalize a maintainer address with respect to case. E-mail addresses +# are case-insensitive in the right-hand side. +sub canonicalize { + my ($maintainer) = @_; + + $maintainer =~ s/<([^>\@]+\@)([\w.-]+)>/<$1\L$2>/; + + return $maintainer; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/ObsoleteSites.pm b/lib/Lintian/Check/ObsoleteSites.pm new file mode 100644 index 0000000..976cdb2 --- /dev/null +++ b/lib/Lintian/Check/ObsoleteSites.pm @@ -0,0 +1,96 @@ +# obsolete-sites -- lintian check script -*- perl -*- + +# Copyright (C) 2015 Axel Beckert <abe@debian.org> +# Copyright (C) 2017-2018 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::ObsoleteSites; + +use v5.20; +use warnings; +use utf8; + +use List::SomeUtils qw(any); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +my @interesting_files = qw( + control + copyright + watch + upstream + upstream/metadata + upstream-metadata.yaml +); + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->is_regular_file; + + $self->search_for_obsolete_sites($item) + if any { $item->name =~ m{^ debian/$_ $}x } @interesting_files; + + return; +} + +sub search_for_obsolete_sites { + my ($self, $item) = @_; + + return + unless $item->is_open_ok; + + my $OBSOLETE_SITES= $self->data->load('obsolete-sites/obsolete-sites'); + + my $bytes = $item->bytes; + + # strip comments + $bytes =~ s/^ \s* [#] .* $//gmx; + + for my $site ($OBSOLETE_SITES->all) { + + if ($bytes + =~ m{ (\w+:// (?: [\w.]* [.] )? \Q$site\E [/:] [^\s"<>\$]* ) }ix) { + + my $url = $1; + $self->pointed_hint('obsolete-url-in-packaging', $item->pointer, + $url); + } + } + + if ($bytes =~ m{ (ftp:// (?:ftp|security) [.]debian[.]org) }ix) { + + my $url = $1; + $self->pointed_hint('obsolete-url-in-packaging', $item->pointer, $url); + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Origtar.pm b/lib/Lintian/Check/Origtar.pm new file mode 100644 index 0000000..47de793 --- /dev/null +++ b/lib/Lintian/Check/Origtar.pm @@ -0,0 +1,55 @@ +# origtar -- lintian check script -*- perl -*- +# +# Copyright (C) 2008 Bernhard R. Link +# Copyright (C) 2019 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Origtar; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $processable = $self->processable; + + return + if $processable->native; + + my @origfiles = @{$processable->orig->sorted_list}; + + $self->hint('empty-upstream-sources') + unless @origfiles; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Pe.pm b/lib/Lintian/Check/Pe.pm new file mode 100644 index 0000000..d5514d5 --- /dev/null +++ b/lib/Lintian/Check/Pe.pm @@ -0,0 +1,113 @@ +# pe -- lintian check script -*- perl -*- + +# Copyright (C) 2017-2019 Chris Lamb <lamby@debian.org> +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Pe; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Syntax::Keyword::Try; +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $SPACE => q{ }; + +const my $MAIN_HEADER => 0x3c; +const my $MAIN_HEADER_LENGTH_WORD_SIZE => 4; +const my $OPTIONAL_HEADER => 0x18; +const my $DLL_CHARACTERISTICS => 0x46; +const my $ASLR_FLAG => 0x40; +const my $DEP_NX_FLAG => 0x100; +const my $UNSAFE_SEH_FLAG => 0x400; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + return + unless $item->file_type =~ /^PE32\+? executable/; + + return + unless $item->is_open_ok; + + my $buf; + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + try { + # offset to main header + seek($fd, $MAIN_HEADER, 0) + or die encode_utf8("seek: $!"); + + read($fd, $buf, $MAIN_HEADER_LENGTH_WORD_SIZE) + or die encode_utf8("read: $!"); + + my $pe_offset = unpack('V', $buf); + + # 0x18 is index to "Optional Header"; 0x46 to DLL Characteristics + seek($fd, $pe_offset + $OPTIONAL_HEADER + $DLL_CHARACTERISTICS, 0) + or die encode_utf8("seek: $!"); + + # get DLLCharacteristics value + read($fd, $buf, 2) + or die encode_utf8("read: $!"); + + } catch { + die $@; + } + + my $characteristics = unpack('v', $buf); + my %features = ( + 'ASLR' => $characteristics & $ASLR_FLAG, + 'DEP/NX' => $characteristics & $DEP_NX_FLAG, + 'SafeSEH' => ~$characteristics & $UNSAFE_SEH_FLAG, # note negation + ); + + # Don't check for the x86-specific "SafeSEH" feature for code + # that is JIT-compiled by the Mono runtime. (#926334) + delete $features{'SafeSEH'} + if $item->file_type =~ / Mono\/.Net assembly, /; + + my @missing = grep { !$features{$_} } sort keys %features; + + $self->pointed_hint('portable-executable-missing-security-features', + $item->pointer,join($SPACE, @missing)) + if scalar @missing; + + close $fd; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Script/Deprecated/Chown.pm b/lib/Lintian/Check/Script/Deprecated/Chown.pm new file mode 100644 index 0000000..e640e17 --- /dev/null +++ b/lib/Lintian/Check/Script/Deprecated/Chown.pm @@ -0,0 +1,96 @@ +# script/deprecated/chown -- lintian check script -*- perl -*- + +# Copyright (C) 2022 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Script::Deprecated::Chown; + +use v5.20; +use warnings; +use utf8; + +use Unicode::UTF8 qw(valid_utf8 encode_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub check_item { + my ($self, $item) = @_; + + return + unless $item->is_file; + + return + unless $item->is_script; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $position = 1; + while (my $line = <$fd>) { + + chomp $line; + + next + if $line =~ /^#/; + + next + unless length $line; + + if ($line =~ m{ \b chown \s+ (?: -\S+ \s+ )* ( \S+ [.] \S+ ) \b }x) { + + my $ownership = $1; + + $self->pointed_hint('chown-with-dot', $item->pointer($position), + $ownership); + } + + } continue { + ++$position; + } + + close $fd; + + return; +} + +sub visit_control_files { + my ($self, $item) = @_; + + $self->check_item($item); + + return; +} + +sub visit_installed_files { + my ($self, $item) = @_; + + $self->check_item($item); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Script/Syntax.pm b/lib/Lintian/Check/Script/Syntax.pm new file mode 100644 index 0000000..20188f1 --- /dev/null +++ b/lib/Lintian/Check/Script/Syntax.pm @@ -0,0 +1,224 @@ +# script/syntax -- lintian check script -*- perl -*- +# +# Copyright (C) 1998 Richard Braakman +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Script::Syntax; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use File::Basename; + +use Lintian::IPC::Run3 qw(safe_qx); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $MAXIMUM_LINES_ANALYZED => 54; + +# exclude some shells. zsh -n is broken, see #485885 +const my %SYNTAX_CHECKERS => ( + sh => [qw{/bin/dash -n}], + bash => [qw{/bin/bash -n}] +); + +sub visit_installed_files { + my ($self, $item) = @_; + + # Consider /usr/src/ scripts as "documentation" + # - packages containing /usr/src/ tend to be "-source" .debs + # and usually come with overrides + # no checks necessary at all for scripts in /usr/share/doc/ + # unless they are examples + return + if ($item->name =~ m{^usr/share/doc/} || $item->name =~ m{^usr/src/}) + && $item->name !~ m{^usr/share/doc/[^/]+/examples/}; + + # Syntax-check most shell scripts, but don't syntax-check + # scripts that end in .dpatch. bash -n doesn't stop checking + # at exit 0 and goes on to blow up on the patch itself. + $self->pointed_hint('shell-script-fails-syntax-check',$item->pointer) + if $self->fails_syntax_check($item) + && $item->name !~ m{^usr/share/doc/[^/]+/examples/} + && $item->name !~ /\.dpatch$/ + && $item->name !~ /\.erb$/; + + $self->pointed_hint('example-shell-script-fails-syntax-check', + $item->pointer) + if $self->fails_syntax_check($item) + && $item->name =~ m{^usr/share/doc/[^/]+/examples/} + && $item->name !~ /\.dpatch$/ + && $item->name !~ /\.erb$/; + + return; +} + +sub visit_control_files { + my ($self, $item) = @_; + + $self->pointed_hint('maintainer-shell-script-fails-syntax-check', + $item->pointer) + if $self->fails_syntax_check($item); + + return; +} + +sub fails_syntax_check { + my ($self, $item) = @_; + + return 0 + unless length $item->interpreter; + + my $basename = basename($item->interpreter); + + my @command; + + # "Perl doesn't distinguish between restricted hashes and readonly hashes." + # https://metacpan.org/pod/Const::Fast#CAVEATS + @command = @{$SYNTAX_CHECKERS{$basename}} + if exists $SYNTAX_CHECKERS{$basename}; + + return 0 + unless @command; + + my $program = $command[0]; + return 0 + unless length $program + && -x $program; + + return 0 + unless $item->is_open_ok; + + return 0 + if script_looks_dangerous($item); + + # Given an interpreter and a file, run the interpreter on that file with the + # -n option to check syntax, discarding output and returning the exit status. + safe_qx(@command, $item->unpacked_path); + my $failed = $?; + + return $failed; +} + +# Returns non-zero if the given file is not actually a shell script, +# just looks like one. +sub script_looks_dangerous { + my ($item) = @_; + + my $result = 0; + my $shell_variable_name = '0'; + my $backgrounded = 0; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $position = 1; + while (my $line = <$fd>) { + + chomp $line; + + next + if $line =~ /^#/; + + next + unless length $line; + + last + if $position >= $MAXIMUM_LINES_ANALYZED; + + if ( + $line =~ m< + # the exec should either be "eval"ed or a new statement + (?:^\s*|\beval\s*[\'\"]|(?:;|&&|\b(?:then|else))\s*) + + # eat anything between the exec and $0 + exec\s*.+\s* + + # optionally quoted executable name (via $0) + .?\$$shell_variable_name.?\s* + + # optional "end of options" indicator + (?:--\s*)? + + # Match expressions of the form '${1+$@}', '${1:+"$@"', + # '"${1+$@', "$@", etc where the quotes (before the dollar + # sign(s)) are optional and the second (or only if the $1 + # clause is omitted) parameter may be $@ or $*. + # + # Finally the whole subexpression may be omitted for scripts + # which do not pass on their parameters (i.e. after re-execing + # they take their parameters (and potentially data) from stdin + .?(?:\$[{]1:?\+.?)?(?:\$[\@\*])?>x + ) { + $result = 1; + + last; + + } elsif ($line =~ /^\s*(\w+)=\$0;/) { + $shell_variable_name = $1; + + } elsif ( + $line =~ m< + # Match scripts which use "foo $0 $@ &\nexec true\n" + # Program name + \S+\s+ + + # As above + .?\$$shell_variable_name.?\s* + (?:--\s*)? + .?(?:\$[{]1:?\+.?)?(?:\$[\@\*])?.?\s*\&>x + ) { + + $backgrounded = 1; + + } elsif ( + $backgrounded + && $line =~ m{ + # the exec should either be "eval"ed or a new statement + (?:^\s*|\beval\s*[\'\"]|(?:;|&&|\b(?:then|else))\s*) + exec\s+true(?:\s|\Z)}x + ) { + + $result = 1; + last; + } + + } continue { + ++$position; + } + + close $fd; + + return $result; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Scripts.pm b/lib/Lintian/Check/Scripts.pm new file mode 100644 index 0000000..5539208 --- /dev/null +++ b/lib/Lintian/Check/Scripts.pm @@ -0,0 +1,1070 @@ +# scripts -- lintian check script -*- perl -*- +# +# Copyright (C) 1998 Richard Braakman +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Scripts; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use File::Basename; +use List::SomeUtils qw(any none); +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::IPC::Run3 qw(safe_qx); +use Lintian::Relation; + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $SLASH => q{/}; +const my $AT_SIGN => q{@}; +const my $ASTERISK => q{*}; +const my $DOT => q{.}; +const my $DOUBLE_QUOTE => q{"}; +const my $NOT_EQUAL => q{!=}; + +const my $BAD_MAINTAINER_COMMAND_FIELDS => 5; +const my $UNVERSIONED_INTERPRETER_FIELDS => 2; +const my $VERSIONED_INTERPRETER_FIELDS => 5; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +# This is a map of all known interpreters. The key is the interpreter +# name (the binary invoked on the #! line). The value is an anonymous +# array of two elements. The first argument is the path on a Debian +# system where that interpreter would be installed. The second +# argument is the dependency that provides that interpreter. +# +# $INTERPRETERS maps names of (unversioned) interpreters to the path +# they are installed and what package to depend on to use them. +# +has INTERPRETERS => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my %unversioned; + + my $data + = $self->data->load('scripts/interpreters',qr/ \s* => \s* /msx); + + for my $interpreter ($data->all) { + + my $remainder = $data->value($interpreter); + + my ($folder, $prerequisites)= split(/ \s* , \s* /msx, + $remainder, $UNVERSIONED_INTERPRETER_FIELDS); + + $prerequisites //= $EMPTY; + + $unversioned{$interpreter} = { + folder => $folder, + prerequisites => $prerequisites + }; + } + + return \%unversioned; + } +); + +# The more complex case of interpreters that may have a version number. +# +# This is a hash from the base interpreter name to a list. The base +# interpreter name may appear by itself or followed by some combination of +# dashes, digits, and periods. +# +# The list contains the following values: +# [<path>, <dependency-relation>, <regex>, <dependency-template>, <version-list>] +# +# Their meaning is documented in Lintian's scripts/versioned-interpreters +# file, though they are ordered differently and there are a few differences +# as described below: +# +# * <regex> has been passed through qr/^<value>$/ +# * If <dependency-relation> was left out, it has been substituted by the +# interpreter. +# * The magic values of <dependency-relation> are represented as: +# @SKIP_UNVERSIONED@ -> undef (i.e the undefined value) +# * <version-list> has been split into a list of versions. +# (e.g. "1.6 1.8" will be ["1.6", "1.8"]) +# +# A full example is: +# +# data: +# lua => /usr/bin, lua([\d.]+), 'lua$1', 40 50 5.1 +# +# $VERSIONED_INTERPRETERS->value ('lua') is +# [ '/usr/bin', 'lua', qr/^lua([\d.]+)$/, 'lua$1', ["40", "50", "5.1"] ] +# +has VERSIONED_INTERPRETERS => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my %versioned; + + my $data = $self->data->load('scripts/versioned-interpreters', + qr/ \s* => \s* /msx); + + for my $interpreter ($data->all) { + + my $remainder = $data->value($interpreter); + + my ($folder, $pattern, $template, $version_list, $prerequisites) + = split(/ \s* , \s* /msx, + $remainder, $VERSIONED_INTERPRETER_FIELDS); + + my @versions = split(/ \s+ /msx, $version_list); + $prerequisites //= $EMPTY; + + if ($prerequisites eq $AT_SIGN . 'SKIP_UNVERSIONED' . $AT_SIGN) { + $prerequisites = undef; + + } elsif ($prerequisites =~ / @ /msx) { + die encode_utf8( +"Unknown magic value $prerequisites for versioned interpreter $interpreter" + ); + } + + $versioned{$interpreter} = { + folder => $folder, + prerequisites => $prerequisites, + regex => qr/^$pattern$/, + template => $template, + versions => \@versions + }; + } + + return \%versioned; + } +); + +# When detecting commands inside shell scripts, use this regex to match the +# beginning of the command rather than checking whether the command is at the +# beginning of a line. +const my $LEADING_PATTERN=> +'(?:(?:^|[`&;(|{])\s*|(?:if|then|do|while|!)\s+|env(?:\s+[[:alnum:]_]+=(?:\S+|\"[^"]*\"|\'[^\']*\'))*\s+)'; +const my $LEADING_REGEX => qr/$LEADING_PATTERN/; + +#forbidden command in maintainer scripts +has BAD_MAINTAINER_COMMANDS => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my %forbidden; + + my $data = $self->data->load('scripts/maintainer-script-bad-command', + qr/\s*\~\~/); + + for my $key ($data->all) { + + my $value = $data->value($key); + + my ($in_cat,$in_auto,$package_include_pattern, + $script_include_pattern,$command_pattern) + = split(/ \s* ~~ /msx, $value,$BAD_MAINTAINER_COMMAND_FIELDS); + + die encode_utf8( + "Syntax error in scripts/maintainer-script-bad-command: $.") + if any { !defined }( + $in_cat,$in_auto,$package_include_pattern, + $script_include_pattern,$command_pattern + ); + + # trim both ends + $in_cat =~ s/^\s+|\s+$//g; + $in_auto =~ s/^\s+|\s+$//g; + $package_include_pattern =~ s/^\s+|\s+$//g; + $script_include_pattern =~ s/^\s+|\s+$//g; + + $package_include_pattern ||= '\a\Z'; + + $script_include_pattern ||= $DOT . $ASTERISK; + + $command_pattern=~ s/\$[{]LEADING_PATTERN[}]/$LEADING_PATTERN/; + + $forbidden{$key} = { + ignore_automatic_sections => !!$in_auto, + in_cat_string => !!$in_cat, + package_exclude_regex => qr/$package_include_pattern/x, + script_include_regex => qr/$script_include_pattern/x, + command_pattern => $command_pattern, + }; + } + + return \%forbidden; + } +); + +# Appearance of one of these regexes in a maintainer script means that there +# must be a dependency (or pre-dependency) on the given package. The tag +# reported is maintainer-script-needs-depends-on-%s, so be sure to update +# scripts.desc when adding a new rule. +my %prerequisite_by_command_pattern = ( + '\badduser\s' => 'adduser', + '\bgconf-schemas\s' => 'gconf2', + '\bupdate-inetd\s' => +'update-inetd | inet-superserver | openbsd-inetd | inetutils-inetd | rlinetd | xinetd', + '\bucf\s' => 'ucf', + '\bupdate-xmlcatalog\s' => 'xml-core', + '\bupdate-fonts-(?:alias|dir|scale)\s' => 'xfonts-utils', +); + +# no dependency for install-menu, because the menu package specifically +# says not to depend on it. +has all_prerequisites => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $all_prerequisites + = $self->processable->relation('all') + ->logical_and($self->processable->relation('Provides'), + $self->processable->name); + + return $all_prerequisites; + } +); + +has strong_prerequisites => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $strong_prerequisites = $self->processable->relation('strong'); + + return $strong_prerequisites; + } +); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_script; + + # Consider /usr/src/ scripts as "documentation" + # - packages containing /usr/src/ tend to be "-source" .debs + # and usually comes with overrides for most of the checks + # below. + # Supposedly, they could be checked as examples, but there is + # a risk that the scripts need substitution to be complete + # (so, syntax checking is not as reliable). + + # no checks necessary at all for scripts in /usr/share/doc/ + # unless they are examples + return + if ($item->name =~ m{^usr/share/doc/} || $item->name =~ m{^usr/src/}) + && $item->name !~ m{^usr/share/doc/[^/]+/examples/}; + + my $basename = basename($item->interpreter); + + # Ignore Python scripts that are shipped under dist-packages; these + # files aren't supposed to be called as scripts. + return + if $basename eq 'python' + && $item->name =~ m{^usr/lib/python3/dist-packages/}; + + # allow exception for .in files that have stuff like #!@PERL@ + return + if $item->name =~ /\.in$/ + && $item->interpreter =~ /^(\@|<\<)[A-Z_]+(\@|>\>)$/; + + my $is_absolute = ($item->interpreter =~ m{^/} || $item->calls_env); + + # As a special-exception, Policy 10.4 states that Perl scripts must use + # /usr/bin/perl directly and not via /usr/bin/env, etc. + $self->pointed_hint( + 'incorrect-path-for-interpreter', + $item->pointer,'/usr/bin/env perl', + $NOT_EQUAL, '/usr/bin/perl' + ) + if $item->calls_env + && $item->interpreter eq 'perl' + && $item->name !~ m{^usr/share/doc/[^/]+/examples/}; + + $self->pointed_hint( + 'example-incorrect-path-for-interpreter', + $item->pointer,'/usr/bin/env perl', + $NOT_EQUAL, '/usr/bin/perl' + ) + if $item->calls_env + && $item->interpreter eq 'perl' + && $item->name =~ m{^usr/share/doc/[^/]+/examples/}; + + # Skip files that have the #! line, but are not executable and + # do not have an absolute path and are not in a bin/ directory + # (/usr/bin, /bin etc). They are probably not scripts after + # all. + return + if ( $item->name !~ m{(?:bin/|etc/init\.d/)} + && (!$item->is_file || !$item->is_executable) + && !$is_absolute + && $item->name !~ m{^usr/share/doc/[^/]+/examples/}); + + # Example directories sometimes contain Perl libraries, and + # some people use initial lines like #!perl or #!python to + # provide editor hints, so skip those too if they're not + # executable. Be conservative here, since it's not uncommon + # for people to both not set examples executable and not fix + # the path and we want to warn about that. + return + if ( $item->name =~ /\.pm\z/ + && (!$item->is_file || !$item->is_executable) + && !$is_absolute + && $item->name =~ m{^usr/share/doc/[^/]+/examples/}); + + # Skip upstream source code shipped in /usr/share/cargo/registry/ + return + if $item->name =~ m{^usr/share/cargo/registry/}; + + if ($item->interpreter eq $EMPTY) { + + $self->pointed_hint('script-without-interpreter', $item->pointer) + if $item->name !~ m{^usr/share/doc/[^/]+/examples/}; + + $self->pointed_hint('example-script-without-interpreter', + $item->pointer) + if $item->name =~ m{^usr/share/doc/[^/]+/examples/}; + + return; + } + + # Either they use an absolute path or they use '/usr/bin/env interp'. + $self->pointed_hint('interpreter-not-absolute', $item->pointer, + $item->interpreter) + if !$is_absolute + && $item->name !~ m{^usr/share/doc/[^/]+/examples/}; + + $self->pointed_hint('example-interpreter-not-absolute', + $item->pointer,$item->interpreter) + if !$is_absolute + && $item->name =~ m{^usr/share/doc/[^/]+/examples/}; + + my $bash_completion_regex= qr{^usr/share/bash-completion/completions/.*}; + + $self->pointed_hint('script-not-executable', $item->pointer) + if (!$item->is_file || !$item->is_executable) + && $item->name !~ m{^usr/(?:lib|share)/.*\.pm} + && $item->name !~ m{^usr/(?:lib|share)/.*\.py} + && $item->name !~ m{^usr/(?:lib|share)/ruby/.*\.rb} + && $item->name !~ m{^usr/share/debconf/confmodule(?:\.sh)?$} + && $item->name !~ /\.in$/ + && $item->name !~ /\.erb$/ + && $item->name !~ /\.ex$/ + && $item->name ne 'etc/init.d/skeleton' + && $item->name !~ m{^etc/menu-methods} + && $item->name !~ $bash_completion_regex + && $item->name !~ m{^etc/X11/Xsession\.d} + && $item->name !~ m{^usr/share/doc/} + && $item->name !~ m{^usr/src/}; + + return + unless $item->is_open_ok; + + # Try to find the expected path of the script to check. First + # check $INTERPRETERS and %versioned_interpreters. If not + # found there, see if it ends in a version number and the base + # is found in $VERSIONED_INTERPRETERS + my $interpreter_data = $self->INTERPRETERS->{$basename}; + + my $versioned = 0; + unless (defined $interpreter_data) { + + $interpreter_data = $self->VERSIONED_INTERPRETERS->{$basename}; + + if (!defined $interpreter_data && $basename =~ /^(.*[^\d.-])-?[\d.]+$/) + { + $interpreter_data = $self->VERSIONED_INTERPRETERS->{$1}; + undef $interpreter_data + unless $interpreter_data + && $basename =~ /$interpreter_data->{regex}/; + } + + $versioned = 1 + if defined $interpreter_data; + } + + if (defined $interpreter_data) { + my $expected = $interpreter_data->{folder} . $SLASH . $basename; + + my @context = ($item->interpreter, $NOT_EQUAL, $expected); + + $self->pointed_hint('wrong-path-for-interpreter', $item->pointer, + @context) + if $item->interpreter ne $expected + && !$item->calls_env + && $expected ne '/usr/bin/env perl' + && $item->name !~ m{^usr/share/doc/[^/]+/examples/}; + + $self->pointed_hint('example-wrong-path-for-interpreter', + $item->pointer, @context) + if $item->interpreter ne $expected + && !$item->calls_env + && $expected ne '/usr/bin/env perl' + && $item->name =~ m{^usr/share/doc/[^/]+/examples/}; + + $self->pointed_hint('incorrect-path-for-interpreter', + $item->pointer, @context) + if $item->interpreter ne $expected + && !$item->calls_env + && $expected eq '/usr/bin/env perl' + && $item->name !~ m{^usr/share/doc/[^/]+/examples/}; + + $self->pointed_hint('example-incorrect-path-for-interpreter', + $item->pointer, @context) + if $item->interpreter ne $expected + && !$item->calls_env + && $expected eq '/usr/bin/env perl' + && $item->name =~ m{^usr/share/doc/[^/]+/examples/}; + + } elsif ($item->interpreter =~ m{^/usr/local/}) { + + $self->pointed_hint('interpreter-in-usr-local', $item->pointer, + $item->interpreter) + if $item->name !~ m{^usr/share/doc/[^/]+/examples/}; + + $self->pointed_hint('example-interpreter-in-usr-local', + $item->pointer,$item->interpreter) + if $item->name =~ m{^usr/share/doc/[^/]+/examples/}; + + } elsif ($item->interpreter eq '/bin/env') { + + $self->pointed_hint('script-uses-bin-env', $item->pointer, + $item->interpreter) + if $item->name !~ m{^usr/share/doc/[^/]+/examples/}; + + $self->pointed_hint('example-script-uses-bin-env', $item->pointer, + $item->interpreter) + if $item->name =~ m{^usr/share/doc/[^/]+/examples/}; + + } elsif ($item->interpreter eq 'nodejs') { + + $self->pointed_hint('script-uses-deprecated-nodejs-location', + $item->pointer,$item->interpreter) + if $item->name !~ m{^usr/share/doc/[^/]+/examples/}; + + $self->pointed_hint('example-script-uses-deprecated-nodejs-location', + $item->pointer,$item->interpreter) + if $item->name =~ m{^usr/share/doc/[^/]+/examples/}; + + # Check whether we have correct dependendies on nodejs regardless. + $interpreter_data = $self->INTERPRETERS->{'node'}; + + } elsif ($basename =~ /^php/) { + + $self->pointed_hint('php-script-with-unusual-interpreter', + $item->pointer,$item->interpreter) + if $item->name !~ m{^usr/share/doc/[^/]+/examples/}; + + $self->pointed_hint('example-php-script-with-unusual-interpreter', + $item->pointer, $item->interpreter) + if $item->name =~ m{^usr/share/doc/[^/]+/examples/}; + + # This allows us to still perform the dependencies checks + # below even when an unusual interpreter has been found. + $interpreter_data = $self->INTERPRETERS->{'php'}; + + } else { + my @private_interpreters; + + # Check if the package ships the interpreter (and it is + # executable). + my $name = $item->interpreter; + if ($name =~ s{^/}{}) { + my $file = $self->processable->installed->lookup($name); + push(@private_interpreters, $file) + if defined $file; + + } elsif ($item->calls_env) { + my @files= map { + $self->processable->installed->lookup( + $_ . $SLASH . $item->interpreter) + }qw{bin usr/bin}; + push(@private_interpreters, grep { defined } @files); + } + + $self->pointed_hint('unusual-interpreter', $item->pointer, + $item->interpreter) + if (none { $_->is_file && $_->is_executable } @private_interpreters) + && $item->name !~ m{^usr/share/doc/[^/]+/examples/}; + + $self->pointed_hint('example-unusual-interpreter', $item->pointer, + $item->interpreter) + if (none { $_->is_file && $_->is_executable } @private_interpreters) + && $item->name =~ m{^usr/share/doc/[^/]+/examples/}; + } + + # If we found the interpreter and the script is executable, + # check dependencies. This should be the last thing we do in + # the loop so that we can use next for an early exit and + # reduce the nesting. + return + unless $interpreter_data; + + return + unless $item->is_file && $item->is_executable; + + return + if $item->name =~ m{^usr/share/doc/} || $item->name =~ m{^usr/src/}; + + if (!$versioned) { + my $depends = $interpreter_data->{prerequisites}; + + if ($depends && !$self->all_prerequisites->satisfies($depends)) { + + if ($basename =~ /^php/) { + + $self->pointed_hint('php-script-but-no-php-cli-dep', + $item->pointer, $item->interpreter, + "(does not satisfy $depends)"); + + } elsif ($basename =~ /^(python\d|ruby|[mg]awk)$/) { + + $self->pointed_hint( + ( + "$basename-script-but-no-$basename-dep", + $item->pointer, + $item->interpreter, + "(does not satisfy $depends)" + ) + ); + + } elsif ($basename eq 'csh' + && $item->name =~ m{^etc/csh/login\.d/}){ + # Initialization files for csh. + + } elsif ($basename eq 'fish' && $item->name =~ m{^etc/fish\.d/}) { + # Initialization files for fish. + + } elsif ( + $basename eq 'ocamlrun' + && $self->all_prerequisites->matches( + qr/^ocaml(?:-base)?(?:-nox)?-\d\.[\d.]+/) + ) { + # ABI-versioned virtual packages for ocaml + + } elsif ($basename eq 'escript' + && $self->all_prerequisites->matches(qr/^erlang-abi-[\d+\.]+$/) + ) { + # ABI-versioned virtual packages for erlang + + } else { + + $self->pointed_hint('missing-dep-for-interpreter', + $item->pointer, $item->interpreter, + "(does not satisfy $depends)"); + } + } + + } elsif (exists $self->VERSIONED_INTERPRETERS->{$basename}) { + my @versions = @{ $interpreter_data->{versions} }; + + my @depends; + for my $version (@versions) { + my $d = $interpreter_data->{template}; + $d =~ s/\$1/$version/g; + push(@depends, $d); + } + + unshift(@depends, $interpreter_data->{prerequisites}) + if length $interpreter_data->{prerequisites}; + + my $depends = join(' | ', @depends); + unless ($self->all_prerequisites->satisfies($depends)) { + if ($basename =~ /^(wish|tclsh)/) { + + my $shell_name = $1; + + $self->pointed_hint( + "$shell_name-script-but-no-$shell_name-dep", + $item->pointer, $item->interpreter, + "(does not satisfy $depends)"); + + } else { + + $self->pointed_hint('missing-dep-for-interpreter', + $item->pointer, $item->interpreter, + "(does not satisfy $depends)"); + } + } + + } else { + + my ($version) = ($basename =~ /$interpreter_data->{regex}/); + my $depends = $interpreter_data->{template}; + $depends =~ s/\$1/$version/g; + + unless ($self->all_prerequisites->satisfies($depends)) { + if ($basename =~ /^(python|ruby)/) { + + $self->pointed_hint("$1-script-but-no-$1-dep", + $item->pointer, $item->interpreter, + "(does not satisfy $depends)"); + + } else { + + $self->pointed_hint('missing-dep-for-interpreter', + $item->pointer, $item->interpreter, + "(does not satisfy $depends)"); + } + } + } + + return; +} + +sub visit_control_files { + my ($self, $item) = @_; + + return + unless $item->is_maintainer_script; + + if ($item->is_elf) { + + $self->pointed_hint('elf-maintainer-script', $item->pointer); + return; + } + + # keep 'env', if present + my $interpreter = $item->hashbang; + + # keep base command without options + $interpreter =~ s/^(\S+).*/$1/; + + if ($interpreter eq $EMPTY) { + + $self->pointed_hint('script-without-interpreter', $item->pointer); + return; + } + + # tag for statistics + $self->pointed_hint('maintainer-script-interpreter', + $item->pointer, $interpreter); + + $self->pointed_hint('interpreter-not-absolute', $item->pointer, + $interpreter) + unless $interpreter =~ m{^/}; + + my $basename = basename($interpreter); + + if ($interpreter =~ m{^/usr/local/}) { + $self->pointed_hint('control-interpreter-in-usr-local', + $item->pointer, $interpreter); + + } elsif ($basename eq 'sh' || $basename eq 'bash' || $basename eq 'perl') { + my $expected + = $self->INTERPRETERS->{$basename}->{folder}. $SLASH. $basename; + + my $tag_name + = ($expected eq '/usr/bin/env perl') + ? + 'incorrect-path-for-interpreter' + : 'wrong-path-for-interpreter'; + + $self->pointed_hint( + $tag_name, $item->pointer, $interpreter, + $NOT_EQUAL, $expected + )unless $interpreter eq $expected; + + } elsif ($item->name eq 'config') { + $self->pointed_hint('forbidden-config-interpreter', + $item->pointer, $interpreter); + + } elsif ($item->name eq 'postrm') { + $self->pointed_hint('forbidden-postrm-interpreter', + $item->pointer, $interpreter); + + } elsif (exists $self->INTERPRETERS->{$basename}) { + + my $interpreter_data = $self->INTERPRETERS->{$basename}; + my $expected = $interpreter_data->{folder} . $SLASH . $basename; + + my $tag_name + = ($expected eq '/usr/bin/env perl') + ? + 'incorrect-path-for-interpreter' + : 'wrong-path-for-interpreter'; + + $self->pointed_hint( + $tag_name, $item->pointer, $interpreter, + $NOT_EQUAL, $expected + )unless $interpreter eq $expected; + + $self->pointed_hint('unusual-control-interpreter', $item->pointer, + $interpreter); + + # Interpreters used by preinst scripts must be in + # Pre-Depends. Interpreters used by postinst or prerm + # scripts must be in Depends. + if ($interpreter_data->{prerequisites}) { + + my $depends = Lintian::Relation->new->load( + $interpreter_data->{prerequisites}); + + if ($item->name eq 'preinst') { + + $self->pointed_hint( + 'control-interpreter-without-predepends', + $item->pointer, + $interpreter, + '(does not satisfy ' . $depends->to_string . ')' + ) + unless $self->processable->relation('Pre-Depends') + ->satisfies($depends); + + } else { + + $self->pointed_hint( + 'control-interpreter-without-depends', + $item->pointer, + $interpreter, + '(does not satisfy ' . $depends->to_string . ')' + ) + unless $self->processable->relation('strong') + ->satisfies($depends); + } + } + + } else { + $self->pointed_hint('unknown-control-interpreter', $item->pointer, + $interpreter); + + # no use doing further checks if it's not a known interpreter + return; + } + + return + unless $item->is_open_ok; + + # now scan the file contents themselves + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $saw_debconf; + my $saw_bange; + my $saw_sete; + my $saw_udevadm_guard; + + my $cat_string = $EMPTY; + + my $previous_line = $EMPTY; + my $in_automatic_section = 0; + + my $position = 1; + while (my $line = <$fd>) { + + my $pointer = $item->pointer($position); + + $saw_bange = 1 + if $position == 1 + && $item->is_shell_script + && $line =~ m{/$basename\s*.*\s-\w*e\w*\b}; + + $in_automatic_section = 1 + if $line =~ /^# Automatically added by \S+\s*$/; + + $in_automatic_section = 0 + if $line eq '# End automatically added section'; + + # skip empty lines + next + if $line =~ /^\s*$/; + + # skip comment lines + next + if $line =~ /^\s*\#/; + + $line = remove_comments($line); + + # Concatenate lines containing continuation character (\) + # at the end + if ($item->is_shell_script && $line =~ /\\$/) { + + $line =~ s/\\//; + chomp $line; + $previous_line .= $line; + + next; + } + + chomp $line; + + $line = $previous_line . $line; + $previous_line = $EMPTY; + + $saw_sete = 1 + if $item->is_shell_script + && $line =~ /${LEADING_REGEX}set\s*(?:\s+-(?:-.*|[^e]+))*\s-\w*e/; + + $saw_udevadm_guard = 1 + if $line =~ /\b(if|which|command)\s+.*udevadm/g; + + if ($line =~ m{$LEADING_REGEX(?:/bin/)?udevadm\s} && $saw_sete) { + + $self->pointed_hint('udevadm-called-without-guard',$pointer) + unless $saw_udevadm_guard + || $line =~ m{\|\|} + || $self->strong_prerequisites->satisfies('udev:any'); + } + + if ($item->is_shell_script) { + + $cat_string = $EMPTY + if $cat_string ne $EMPTY + && $line =~ /^\Q$cat_string\E$/; + + my $within_another_shell = 0; + + $within_another_shell = 1 + if $item->interpreter !~ m{(?:^|/)sh$} + && $item->interpreter_with_options =~ /\S+\s+-c/; + + if (!$cat_string) { + + $self->generic_check_bad_command($item, $line, + $position, 0,$in_automatic_section); + + $saw_debconf = 1 + if $line =~ m{/usr/share/debconf/confmodule}; + + $self->pointed_hint('read-in-maintainer-script',$pointer) + if $line =~ /^\s*read(?:\s|\z)/ && !$saw_debconf; + + $self->pointed_hint('multi-arch-same-package-calls-pycompile', + $pointer) + if $line =~ /^\s*py3?compile(?:\s|\z)/ + &&$self->processable->fields->value('Multi-Arch') eq 'same'; + + $self->pointed_hint('maintainer-script-modifies-inetd-conf', + $pointer) + if $line =~ m{>\s*/etc/inetd\.conf(?:\s|\Z)} + && !$self->processable->relation('Provides') + ->satisfies('inet-superserver:any'); + + $self->pointed_hint('maintainer-script-modifies-inetd-conf', + $pointer) + if $line=~ m{^\s*(?:cp|mv)\s+(?:.*\s)?/etc/inetd\.conf\s*$} + && !$self->processable->relation('Provides') + ->satisfies('inet-superserver:any'); + + # Check for running commands with a leading path. + # + # Unfortunately, our $LEADING_REGEX string doesn't work + # well for this in the presence of commands that + # contain backquoted expressions because it can't + # tell the difference between the initial backtick + # and the closing backtick. We therefore first + # extract all backquoted expressions and check + # them separately, and then remove them from a + # copy of a string and then check it for bashisms. + while ($line =~ /\`([^\`]+)\`/g) { + + my $mangled = $1; + + if ( + $mangled =~ m{ $LEADING_REGEX + (/(?:usr/)?s?bin/[\w.+-]+) + (?:\s|;|\Z)}xsm + ) { + my $command = $1; + + $self->pointed_hint( + 'command-with-path-in-maintainer-script', + $pointer, $command,'(in backticks)') + unless $in_automatic_section; + } + } + + # check for test syntax + if( + $line =~ m{\[\s+ + (?:!\s+)? -x \s+ + (/(?:usr/)?s?bin/[\w.+-]+) + \s+ \]}xsm + ){ + my $command = $1; + + $self->pointed_hint( + 'command-with-path-in-maintainer-script', + $pointer, $command,'(in test syntax)') + unless $in_automatic_section; + } + + my $mangled = $line; + $mangled =~ s/\`[^\`]+\`//g; + + if ($mangled + =~ m{$LEADING_REGEX(/(?:usr/)?s?bin/[\w.+-]+)(?:\s|;|$)}){ + my $command = $1; + + $self->pointed_hint( + 'command-with-path-in-maintainer-script', + $pointer, $command, '(plain script)') + unless $in_automatic_section; + } + } + } + + for my $pattern (keys %prerequisite_by_command_pattern) { + + next + unless $line =~ /($pattern)/; + + my $command = $1; + + next + if $line =~ /-x\s+\S*$pattern/ + || $line =~ /(?:which|type)\s+$pattern/ + || $line =~ /command\s+.*?$pattern/ + || $line =~ m{ [|][|] \s* true \b }x; + + my $requirement = $prerequisite_by_command_pattern{$pattern}; + + my $first_alternative = $requirement; + $first_alternative =~ s/[ \(].*//; + + $self->pointed_hint( + "maintainer-script-needs-depends-on-$first_alternative", + $pointer, $command,"(does not satisfy $requirement)") + unless $self->processable->relation('strong') + ->satisfies($requirement) + || $self->processable->name eq $first_alternative + || $item->name eq 'postrm'; + } + + $self->generic_check_bad_command($item, $line, $position, 1, + $in_automatic_section); + + if ($line =~ m{$LEADING_REGEX(?:/usr/sbin/)?update-inetd\s}) { + + $self->pointed_hint( + 'maintainer-script-has-invalid-update-inetd-options', + $pointer, '(--pattern with --add)') + if $line =~ /--pattern/ + && $line =~ /--add/; + + $self->pointed_hint( + 'maintainer-script-has-invalid-update-inetd-options', + $pointer, '(--group without --add)') + if $line =~ /--group/ + && $line !~ /--add/; + } + + } continue { + ++$position; + } + + close $fd; + + $self->pointed_hint('maintainer-script-without-set-e', $item->pointer) + if $item->is_shell_script && !$saw_sete && $saw_bange; + + $self->pointed_hint('maintainer-script-ignores-errors', $item->pointer) + if $item->is_shell_script && !$saw_sete && !$saw_bange; + + return; +} + +sub generic_check_bad_command { + my ($self, $script, $line, $position, $find_in_cat_string, + $in_automatic_section) + = @_; + + for my $tag_name (keys %{$self->BAD_MAINTAINER_COMMANDS}) { + + my $command_data= $self->BAD_MAINTAINER_COMMANDS->{$tag_name}; + + next + if $in_automatic_section + && $command_data->{ignore_automatic_sections}; + + next + unless $script->name =~ $command_data->{script_include_regex}; + + next + unless $find_in_cat_string == $command_data->{in_cat_string}; + + if ($line =~ m{ ( $command_data->{command_pattern} ) }x) { + + my $bad_command = $1 // $EMPTY; + + # trim both ends + $bad_command =~ s/^\s+|\s+$//g; + + my $pointer = $script->pointer($position); + + $self->pointed_hint($tag_name, $pointer, + $DOUBLE_QUOTE . $bad_command . $DOUBLE_QUOTE) + unless $self->processable->name + =~ $command_data->{package_exclude_regex}; + } + } + + return; +} + +sub remove_comments { + my ($line) = @_; + + return $line + unless length $line; + + my $simplified = $line; + + # Remove quoted strings so we can more easily ignore comments + # inside them + $simplified =~ s/(^|[^\\](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g; + $simplified =~ s/(^|[^\\](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g; + + # If the remaining string contains what looks like a comment, + # eat it. In either case, swap the unmodified script line + # back in for processing (if required) and return it. + if ($simplified =~ m/(?:^|[^[\\])[\s\&;\(\)](\#.*$)/) { + + my $comment = $1; + + # eat comment + $line =~ s/\Q$comment\E//; + } + + return $line; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Shell/Bash/Completion.pm b/lib/Lintian/Check/Shell/Bash/Completion.pm new file mode 100644 index 0000000..4b0584e --- /dev/null +++ b/lib/Lintian/Check/Shell/Bash/Completion.pm @@ -0,0 +1,54 @@ +# shell/bash/completion -- lintian check script -*- perl -*- +# +# Copyright (C) 1998 Richard Braakman +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Shell::Bash::Completion; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->name =~ m{^ usr/share/bash-completion/completions/ }x; + + $self->pointed_hint('bash-completion-with-hashbang', + $item->pointer(1), $item->hashbang) + if length $item->hashbang; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Shell/Csh.pm b/lib/Lintian/Check/Shell/Csh.pm new file mode 100644 index 0000000..f84d374 --- /dev/null +++ b/lib/Lintian/Check/Shell/Csh.pm @@ -0,0 +1,89 @@ +# shell/csh -- lintian check script -*- perl -*- +# +# Copyright (C) 1998 Richard Braakman +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Shell::Csh; + +use v5.20; +use warnings; +use utf8; + +use File::Basename; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + # Consider /usr/src/ scripts as "documentation" + # - packages containing /usr/src/ tend to be "-source" .debs + # and usually come with overrides + # no checks necessary at all for scripts in /usr/share/doc/ + # unless they are examples + return + if ($item->name =~ m{^usr/share/doc/} || $item->name =~ m{^usr/src/}) + && $item->name !~ m{^usr/share/doc/[^/]+/examples/}; + + $self->pointed_hint('csh-considered-harmful', $item->pointer(1), + $item->interpreter) + if $self->is_csh_script($item) + && $item->name !~ m{^ etc/csh/login[.]d/ }x; + + return; +} + +sub visit_control_files { + my ($self, $item) = @_; + + # perhaps we should warn about *csh even if they're somehow screwed, + # but that's not really important... + $self->pointed_hint('csh-considered-harmful', $item->pointer(1), + $item->interpreter) + if $self->is_csh_script($item); + + return; +} + +sub is_csh_script { + my ($self, $item) = @_; + + return 0 + unless length $item->interpreter; + + my $basename = basename($item->interpreter); + + return 1 + if $basename eq 'csh' || $basename eq 'tcsh'; + + return 0; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Shell/NonPosix/BashCentric.pm b/lib/Lintian/Check/Shell/NonPosix/BashCentric.pm new file mode 100644 index 0000000..024ea6a --- /dev/null +++ b/lib/Lintian/Check/Shell/NonPosix/BashCentric.pm @@ -0,0 +1,348 @@ +# shell/non-posix/bash-centric -- lintian check script -*- perl -*- +# +# Copyright (C) 1998 Richard Braakman +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# Copyright (C) 2021 Rafael Laboissiere +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +# bashism sounded too much like fascism +package Lintian::Check::Shell::NonPosix::BashCentric; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use File::Basename; +use List::SomeUtils qw(uniq); +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; +const my $SLASH => q{/}; + +# When detecting commands inside shell scripts, use this regex to match the +# beginning of the command rather than checking whether the command is at the +# beginning of a line. +const my $LEADING_PATTERN=> +'(?:(?:^|[`&;(|{])\s*|(?:if|then|do|while|!)\s+|env(?:\s+[[:alnum:]_]+=(?:\S+|\"[^"]*\"|\'[^\']*\'))*\s+)'; +const my $LEADING_REGEX => qr/$LEADING_PATTERN/; + +my @bashism_single_quote_regexes = ( + $LEADING_REGEX + . qr{echo\s+(?:-[^e\s]+\s+)?\'[^\']*(\\[abcEfnrtv0])+.*?[\']}, + # unsafe echo with backslashes + $LEADING_REGEX . qr{source\s+[\"\']?(?:\.\/|[\/\$\w~.-])\S*}, + # should be '.', not 'source' +); + +my @bashism_string_regexes = ( + qr/\$\[\w+\]/, # arith not allowed + qr/\$\{\w+\:\d+(?::\d+)?\}/, # ${foo:3[:1]} + qr/\$\{\w+(\/.+?){1,2}\}/, # ${parm/?/pat[/str]} + qr/\$\{\#?\w+\[[0-9\*\@]+\]\}/,# bash arrays, ${name[0|*|@]} + qr/\$\{!\w+[\@*]\}/, # ${!prefix[*|@]} + qr/\$\{!\w+\}/, # ${!name} + qr/(\$\(|\`)\s*\<\s*\S+\s*([\)\`])/, # $(\< foo) should be $(cat foo) + qr/\$\{?RANDOM\}?\b/, # $RANDOM + qr/\$\{?(OS|MACH)TYPE\}?\b/, # $(OS|MACH)TYPE + qr/\$\{?HOST(TYPE|NAME)\}?\b/, # $HOST(TYPE|NAME) + qr/\$\{?DIRSTACK\}?\b/, # $DIRSTACK + qr/\$\{?EUID\}?\b/, # $EUID should be "id -u" + qr/\$\{?UID\}?\b/, # $UID should be "id -ru" + qr/\$\{?SECONDS\}?\b/, # $SECONDS + qr/\$\{?BASH_[A-Z]+\}?\b/, # $BASH_SOMETHING + qr/\$\{?SHELLOPTS\}?\b/, # $SHELLOPTS + qr/\$\{?PIPESTATUS\}?\b/, # $PIPESTATUS + qr/\$\{?SHLVL\}?\b/, # $SHLVL + qr/<<</, # <<< here string + $LEADING_REGEX + . qr/echo\s+(?:-[^e\s]+\s+)?\"[^\"]*(\\[abcEfnrtv0])+.*?[\"]/, + # unsafe echo with backslashes +); + +my @bashism_regexes = ( + qr/(?:^|\s+)function \w+(\s|\(|\Z)/, # function is useless + qr/(test|-o|-a)\s*[^\s]+\s+==\s/, # should be 'b = a' + qr/\[\s+[^\]]+\s+==\s/, # should be 'b = a' + qr/\s(\|\&)/, # pipelining is not POSIX + qr/[^\\\$]\{(?:[^\s\\\}]*?,)+[^\\\}\s]*\}/, # brace expansion + qr/(?:^|\s+)\w+\[\d+\]=/, # bash arrays, H[0] + $LEADING_REGEX . qr/read\s+(?:-[a-qs-zA-Z\d-]+)/, + # read with option other than -r + $LEADING_REGEX . qr/read\s*(?:-\w+\s*)*(?:\".*?\"|[\'].*?[\'])?\s*(?:;|$)/, + # read without variable + qr/\&>/, # cshism + qr/(<\&|>\&)\s*((-|\d+)[^\s;|)`&\\\\]|[^-\d\s]+)/, # should be >word 2>&1 + qr/\[\[(?!:)/, # alternative test command + $LEADING_REGEX . qr/select\s+\w+/, # 'select' is not POSIX + $LEADING_REGEX . qr/echo\s+(-n\s+)?-n?en?/, # echo -e + $LEADING_REGEX . qr/exec\s+-[acl]/, # exec -c/-l/-a name + qr/(?:^|\s+)let\s/, # let ... + qr/(?<![\$\(])\(\(.*\)\)/, # '((' should be '$((' + qr/\$\[[^][]+\]/, # '$[' should be '$((' + qr/(\[|test)\s+-a/, # test with unary -a (should be -e) + qr{/dev/(tcp|udp)}, # /dev/(tcp|udp) + $LEADING_REGEX . qr/\w+\+=/, # should be "VAR="${VAR}foo" + $LEADING_REGEX . qr/suspend\s/, + $LEADING_REGEX . qr/caller\s/, + $LEADING_REGEX . qr/complete\s/, + $LEADING_REGEX . qr/compgen\s/, + $LEADING_REGEX . qr/declare\s/, + $LEADING_REGEX . qr/typeset\s/, + $LEADING_REGEX . qr/disown\s/, + $LEADING_REGEX . qr/builtin\s/, + $LEADING_REGEX . qr/set\s+-[BHT]+/, # set -[BHT] + $LEADING_REGEX . qr/alias\s+-p/, # alias -p + $LEADING_REGEX . qr/unalias\s+-a/, # unalias -a + $LEADING_REGEX . qr/local\s+-[a-zA-Z]+/, # local -opt + qr/(?:^|\s+)\s*\(?\w*[^\(\w\s]+\S*?\s*\(\)\s*([\{|\(]|\Z)/, + # function names should only contain [a-z0-9_] + $LEADING_REGEX . qr/(push|pop)d(\s|\Z)/, # (push|pod)d + $LEADING_REGEX . qr/export\s+-[^p]/, # export only takes -p as an option + $LEADING_REGEX . qr/ulimit(\s|\Z)/, + $LEADING_REGEX . qr/shopt(\s|\Z)/, + $LEADING_REGEX . qr/time\s/, + $LEADING_REGEX . qr/dirs(\s|\Z)/, + qr/(?:^|\s+)[<>]\(.*?\)/, # <() process substitution + qr/(?:^|\s+)readonly\s+-[af]/, # readonly -[af] + $LEADING_REGEX . qr/(sh|\$\{?SHELL\}?) -[rD]/, # sh -[rD] + $LEADING_REGEX . qr/(sh|\$\{?SHELL\}?) --\w+/, # sh --long-option + $LEADING_REGEX . qr/(sh|\$\{?SHELL\}?) [-+]O/, # sh [-+]O +); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless length $item->interpreter; + + my $basename = basename($item->interpreter); + + return + unless $basename eq 'sh'; + + $self->check_bash_centric($item, 'bash-term-in-posix-shell'); + + return; +} + +sub visit_control_files { + my ($self, $item) = @_; + + return + unless length $item->interpreter; + + my $basename = basename($item->interpreter); + + return + unless $basename eq 'sh'; + + $self->check_bash_centric($item, 'possible-bashism-in-maintainer-script'); + + return; +} + +sub check_bash_centric { + my ($self, $item, $tag_name) = @_; + + return + unless $item->is_open_ok; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $stashed = $EMPTY; + + my $position = 1; + while (my $possible_continuation = <$fd>) { + + chomp $possible_continuation; + + # skip empty lines + next + if $possible_continuation =~ /^\s*$/; + + # skip comment lines + next + if $possible_continuation =~ /^\s*\#/; + + my $no_comment = remove_comments($possible_continuation); + + # Concatenate lines containing continuation character (\) + # at the end + if ($no_comment =~ s{\\$}{}) { + + $stashed .= $no_comment; + + next; + } + + my $line = $stashed . $no_comment; + $stashed = $EMPTY; + + # see Bug#999756 and tclsh(1) + last + if $line =~ m{^ exec \s }x; + + my $pointer = $item->pointer($position); + + my @matches = uniq +$self->check_line($line); + + for my $match (@matches) { + + my $printable = "'$match'"; + $printable = '{hex:' . sprintf('%vX', $match) . '}' + if $match =~ /\P{XPosixPrint}/; + + $self->pointed_hint($tag_name, $pointer, $printable); + } + + } continue { + ++$position; + } + + close $fd; + + return; +} + +sub check_line { + my ($self, $line) = @_; + + my @matches; + + # since this test is ugly, I have to do it by itself + # detect source (.) trying to pass args to the command it runs + # The first expression weeds out '. "foo bar"' + if ( + $line !~ m{\A \s*\.\s+ + (?:\"[^\"]+\"|\'[^\']+\')\s* + (?:[\&\|<;]|\d?>|\Z)}xsm + && $line =~ /^\s*(\.\s+[^\s;\`:]+\s+([^\s;]+))/ + ) { + + my ($dot_command, $extra) = ($1, $2); + + push(@matches, $dot_command) + if length $dot_command + && $extra !~ m{^ & | [|] | < | \d? > }x; + } + + my $modified = $line; + + for my $regex (@bashism_single_quote_regexes) { + if ($modified =~ $regex) { + + # on unmodified line + my ($match) = ($line =~ /($regex)/); + + push(@matches, $match) + if length $match; + } + } + + # Ignore anything inside single quotes; it could be an + # argument to grep or the like. + + # Remove "quoted quotes". They're likely to be + # inside another pair of quotes; we're not + # interested in them for their own sake and + # removing them makes finding the limits of + # the outer pair far easier. + $modified =~ s/(^|[^\\\'\"])\"\'\"/$1/g; + $modified =~ s/(^|[^\\\'\"])\'\"\'/$1/g; + + $modified =~ s/(^|[^\\\"](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g; + + for my $regex (@bashism_string_regexes) { + if ($modified =~ $regex) { + + # on unmodified line + my ($match) = ($line =~ /($regex)/); + + $match //= $EMPTY; + + push(@matches, $match) + if length $match; + } + } + + $modified =~ s/(^|[^\\\'](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g; + + for my $regex (@bashism_regexes) { + if ($modified =~ $regex) { + + # on unmodified line + my ($match) = ($line =~ /($regex)/); + + $match //= $EMPTY; + + push(@matches, $match) + if length $match; + } + } + + # trim both ends of each element + s/^\s+|\s+$//g for @matches; + + my @meaningful = grep { length } @matches; + + return @meaningful; +} + +sub remove_comments { + my ($line) = @_; + + return $line + unless length $line; + + my $simplified = $line; + + # Remove quoted strings so we can more easily ignore comments + # inside them + $simplified =~ s/(^|[^\\](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g; + $simplified =~ s/(^|[^\\](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g; + + # If the remaining string contains what looks like a comment, + # eat it. In either case, swap the unmodified script line + # back in for processing (if required) and return it. + if ($simplified =~ m/(?:^|[^[\\])[\s\&;\(\)](\#.*$)/) { + + my $comment = $1; + + # eat comment + $line =~ s/\Q$comment\E//; + } + + return $line; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Substvars/Libc.pm b/lib/Lintian/Check/Substvars/Libc.pm new file mode 100644 index 0000000..db97ee5 --- /dev/null +++ b/lib/Lintian/Check/Substvars/Libc.pm @@ -0,0 +1,86 @@ +# substvars/libc -- lintian check script -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Substvars::Libc; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +use Lintian::Relation; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +# The list of libc packages, used for checking for a hard-coded dependency +# rather than using ${shlibs:Depends}. +const my @LIBCS => qw(libc6:any libc6.1:any libc0.1:any libc0.3:any); + +my $LIBC_RELATION = Lintian::Relation->new->load(join(' | ', @LIBCS)); + +sub source { + my ($self) = @_; + + my $control = $self->processable->debian_control; + + my @prerequisite_fields = qw(Pre-Depends Depends Recommends Suggests); + + for my $installable ($control->installables) { + my $installable_fields = $control->installable_fields($installable); + + for my $field (@prerequisite_fields) { + + next + unless $control->installable_fields($installable) + ->declares($field); + + my $relation + = $self->processable->binary_relation($installable,$field); + + my $control_item= $self->processable->debian_control->item; + my $position = $installable_fields->position($field); + my $pointer = $control_item->pointer($position); + + $self->pointed_hint( + 'package-depends-on-hardcoded-libc', + $pointer,"(in section for $installable)", + $field, $relation->to_string + ) + if $relation->satisfies($LIBC_RELATION) + && $self->processable->name !~ /^e?glibc$/; + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Substvars/Misc/PreDepends.pm b/lib/Lintian/Check/Substvars/Misc/PreDepends.pm new file mode 100644 index 0000000..6172aca --- /dev/null +++ b/lib/Lintian/Check/Substvars/Misc/PreDepends.pm @@ -0,0 +1,64 @@ +# substvars/misc/pre-depends -- lintian check script -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Substvars::Misc::PreDepends; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $control = $self->processable->debian_control; + + for my $installable ($control->installables) { + my $installable_fields = $control->installable_fields($installable); + + my $field = 'Depends'; + + my $depends= $control->installable_fields($installable)->value($field); + + my $control_item= $self->processable->debian_control->item; + my $position = $installable_fields->position($field); + my $pointer = $control_item->pointer($position); + + $self->pointed_hint('depends-on-misc-pre-depends', $pointer,$depends, + "(in section for $installable)") + if $depends =~ m/\$\{misc:Pre-Depends\}/; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Systemd.pm b/lib/Lintian/Check/Systemd.pm new file mode 100644 index 0000000..39487e0 --- /dev/null +++ b/lib/Lintian/Check/Systemd.pm @@ -0,0 +1,530 @@ +# systemd -- lintian check script -*- perl -*- +# +# Copyright (C) 2013 Michael Stapelberg +# Copyright (C) 2016-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# based on the apache2 checks file by: +# Copyright (C) 2012 Arno Toell +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Systemd; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Data::Validate::URI qw(is_uri); +use List::Compare; +use List::SomeUtils qw(any none); +use Text::ParseWords qw(shellwords); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; + +# "Usual" targets for WantedBy +const my @WANTEDBY_WHITELIST => qw{ + default.target + graphical.target + multi-user.target + network-online.target + sleep.target + sysinit.target +}; + +# Known hardening flags in [Service] section +const my @HARDENING_FLAGS => qw{ + CapabilityBoundingSet + DeviceAllow + DynamicUser + IPAddressDeny + InaccessiblePaths + KeyringMode + LimitNOFILE + LockPersonality + MemoryDenyWriteExecute + MountFlags + NoNewPrivileges + PrivateDevices + PrivateMounts + PrivateNetwork + PrivateTmp + PrivateUsers + ProtectControlGroups + ProtectHome + ProtectHostname + ProtectKernelLogs + ProtectKernelModules + ProtectKernelTunables + ProtectSystem + ReadOnlyPaths + RemoveIPC + RestrictAddressFamilies + RestrictNamespaces + RestrictRealtime + RestrictSUIDSGID + SystemCallArchitectures + SystemCallFilter + UMask +}; + +# init scripts that do not need a service file +has PROVIDED_BY_SYSTEMD => ( + is => 'rw', + lazy => 1, + default =>sub { + my ($self) = @_; + + return $self->data->load('systemd/init-whitelist'); + } +); + +# array of names provided by the service files. +# This includes Alias= directives, so after parsing +# NetworkManager.service, it will contain NetworkManager and +# network-manager. +has service_names => (is => 'rw', default => sub { [] }); + +has timer_files => (is => 'rw', default => sub { [] }); + +has init_files_by_service_name => (is => 'rw', default => sub { {} }); +has cron_scripts => (is => 'rw', default => sub { [] }); + +has is_rcs_script_by_name => (is => 'rw', default => sub { {} }); + +sub visit_installed_files { + my ($self, $item) = @_; + + if ($item->name =~ m{/systemd/system/.*\.service$}) { + + $self->check_systemd_service_file($item); + + my $service_name = $item->basename; + $service_name =~ s/@?\.service$//; + + push(@{$self->service_names}, $service_name); + + my @aliases + = $self->extract_service_file_values($item, 'Install', 'Alias'); + + for my $alias (@aliases) { + + $self->pointed_hint('systemd-service-alias-without-extension', + $item->pointer) + if $alias !~ m/\.service$/; + + # maybe issue a tag for duplicates? + + $alias =~ s{ [.]service $}{}x; + push(@{$self->service_names}, $alias); + } + } + + push(@{$self->timer_files}, $item) + if $item->name =~ m{^(?:usr/)?lib/systemd/system/[^\/]+\.timer$}; + + push(@{$self->cron_scripts}, $item) + if $item->dirname =~ m{^ etc/cron[.][^\/]+ / $}x; + + if ( + $item->dirname eq 'etc/init.d/' + && !$item->is_dir + && (none { $item->basename eq $_} qw{README skeleton rc rcS}) + && $self->processable->name ne 'initscripts' + && $item->link ne 'lib/init/upstart-job' + ) { + + unless ($item->is_file) { + + $self->pointed_hint('init-script-is-not-a-file', $item->pointer); + return; + } + + # sysv generator drops the .sh suffix + my $service_name = $item->basename; + $service_name =~ s{ [.]sh $}{}x; + + $self->init_files_by_service_name->{$service_name} //= []; + push(@{$self->init_files_by_service_name->{$service_name}}, $item); + + $self->is_rcs_script_by_name->{$item->name} + = $self->check_init_script($item); + } + + if ($item->name =~ m{ /systemd/system/ .*[.]socket $}x) { + + my @values + = $self->extract_service_file_values($item,'Socket','ListenStream'); + + $self->pointed_hint('systemd-service-file-refers-to-var-run', + $item->pointer, 'ListenStream', $_) + for grep { m{^/var/run/} } @values; + } + + return; +} + +sub installable { + my ($self) = @_; + + my $lc = List::Compare->new([keys %{$self->init_files_by_service_name}], + $self->service_names); + + my @missing_service_names = $lc->get_Lonly; + + for my $service_name (@missing_service_names) { + + next + if $self->PROVIDED_BY_SYSTEMD->recognizes($service_name); + + my @init_files + = @{$self->init_files_by_service_name->{$service_name} // []}; + + for my $init_file (@init_files) { + + # rcS scripts are particularly bad; always tag + $self->pointed_hint( + 'missing-systemd-service-for-init.d-rcS-script', + $init_file->pointer, $service_name) + if $self->is_rcs_script_by_name->{$init_file->name}; + + $self->pointed_hint('omitted-systemd-service-for-init.d-script', + $init_file->pointer, $service_name) + if @{$self->service_names} + && !$self->is_rcs_script_by_name->{$init_file->name}; + + $self->pointed_hint('missing-systemd-service-for-init.d-script', + $init_file->pointer, $service_name) + if !@{$self->service_names} + && !$self->is_rcs_script_by_name->{$init_file->name}; + } + } + + if (!@{$self->timer_files}) { + + $self->pointed_hint('missing-systemd-timer-for-cron-script', + $_->pointer) + for @{$self->cron_scripts}; + } + + return; +} + +# Verify that each init script includes /lib/lsb/init-functions, +# because that is where the systemd diversion happens. +sub check_init_script { + my ($self, $item) = @_; + + my $lsb_source_seen; + my $is_rcs_script = 0; + + my @lines = split(/\n/, $item->decoded_utf8); + + my $position = 1; + for my $line (@lines) { + + # trim left + $line =~ s/^\s+//; + + $lsb_source_seen = 1 + if $position == 1 + && $line + =~ m{\A [#]! \s* (?:/usr/bin/env)? \s* /lib/init/init-d-script}xsm; + + $is_rcs_script = 1 + if $line =~ m{#.*Default-Start:.*S}; + + next + if $line =~ /^#/; + + $lsb_source_seen = 1 + if $line + =~ m{(?:\.|source)\s+/lib/(?:lsb/init-functions|init/init-d-script)}; + + } continue { + ++$position; + } + + $self->pointed_hint('init.d-script-does-not-source-init-functions', + $item->pointer) + unless $lsb_source_seen; + + return $is_rcs_script; +} + +sub check_systemd_service_file { + my ($self, $item) = @_; + + # ambivalent about /lib or /usr/lib + $self->pointed_hint('systemd-service-in-odd-location', $item->pointer) + if $item =~ m{^etc/systemd/system/}; + + unless ($item->is_open_ok + || ($item->is_symlink && $item->link eq '/dev/null')) { + + $self->pointed_hint('service-file-is-not-a-file', $item->pointer); + return 0; + } + + my @values = $self->extract_service_file_values($item, 'Unit', 'After'); + my @obsolete = grep { /^(?:syslog|dbus)\.target$/ } @values; + + $self->pointed_hint('systemd-service-file-refers-to-obsolete-target', + $item->pointer, $_) + for @obsolete; + + $self->pointed_hint('systemd-service-file-refers-to-obsolete-bindto', + $item->pointer) + if $self->extract_service_file_values($item, 'Unit', 'BindTo'); + + for my $key ( + qw(ExecStart ExecStartPre ExecStartPost ExecReload ExecStop ExecStopPost) + ) { + $self->pointed_hint('systemd-service-file-wraps-init-script', + $item->pointer, $key) + if any { m{^/etc/init\.d/} } + $self->extract_service_file_values($item, 'Service', $key); + } + + unless ($item->link eq '/dev/null') { + + my @wanted_by + = $self->extract_service_file_values($item, 'Install', 'WantedBy'); + my $is_oneshot = any { $_ eq 'oneshot' } + $self->extract_service_file_values($item, 'Service', 'Type'); + + # We are a "standalone" service file if we have no .path or .timer + # equivalent. + my $is_standalone = 1; + if ($item =~ m{^(usr/)?lib/systemd/system/([^/]*?)@?\.service$}) { + + my ($usr, $service) = ($1 // $EMPTY, $2); + + $is_standalone = 0 + if $self->processable->installed->resolve_path( + "${usr}lib/systemd/system/${service}.path") + || $self->processable->installed->resolve_path( + "${usr}lib/systemd/system/${service}.timer"); + } + + for my $target (@wanted_by) { + + $self->pointed_hint( + 'systemd-service-file-refers-to-unusual-wantedby-target', + $item->pointer, $target) + unless (any { $target eq $_ } @WANTEDBY_WHITELIST) + || $self->processable->name eq 'systemd'; + } + + my @documentation + = $self->extract_service_file_values($item, 'Unit','Documentation'); + + $self->pointed_hint('systemd-service-file-missing-documentation-key', + $item->pointer) + unless @documentation; + + for my $documentation (@documentation) { + + my @uris = split(m{\s+}, $documentation); + + my @invalid = grep { !is_uri($_) } @uris; + + $self->pointed_hint('invalid-systemd-documentation', + $item->pointer, $_) + for @invalid; + } + + my @kill_modes + = $self->extract_service_file_values($item, 'Service','KillMode'); + + for my $kill_mode (@kill_modes) { + + # trim both ends + $kill_mode =~ s/^\s+|\s+$//g; + + $self->pointed_hint('kill-mode-none',$item->pointer, $_) + if $kill_mode eq 'none'; + } + + if ( !@wanted_by + && !$is_oneshot + && $is_standalone + && $item =~ m{^(?:usr/)?lib/systemd/[^\/]+/[^\/]+\.service$} + && $item !~ m{@\.service$}) { + + $self->pointed_hint('systemd-service-file-missing-install-key', + $item->pointer) + unless $self->extract_service_file_values($item, 'Install', + 'RequiredBy') + || $self->extract_service_file_values($item, 'Install', 'Also'); + } + + my @pidfile + = $self->extract_service_file_values($item,'Service','PIDFile'); + for my $x (@pidfile) { + $self->pointed_hint('systemd-service-file-refers-to-var-run', + $item->pointer, 'PIDFile', $x) + if $x =~ m{^/var/run/}; + } + + my $seen_hardening + = any { $self->extract_service_file_values($item, 'Service', $_) } + @HARDENING_FLAGS; + + $self->pointed_hint('systemd-service-file-missing-hardening-features', + $item->pointer) + unless $seen_hardening + || $is_oneshot + || any { 'sleep.target' eq $_ } @wanted_by; + + if ( + $self->extract_service_file_values( + $item, 'Unit', 'DefaultDependencies', 1 + ) + ) { + my @before + = $self->extract_service_file_values($item, 'Unit','Before'); + my @conflicts + = $self->extract_service_file_values($item, 'Unit','Conflicts'); + + $self->pointed_hint('systemd-service-file-shutdown-problems', + $item->pointer) + if (none { $_ eq 'shutdown.target' } @before) + && (any { $_ eq 'shutdown.target' } @conflicts); + } + + my %bad_users = ( + 'User' => 'nobody', + 'Group' => 'nogroup', + ); + + for my $key (keys %bad_users) { + + my $value = $bad_users{$key}; + + $self->pointed_hint('systemd-service-file-uses-nobody-or-nogroup', + $item->pointer, "$key=$value") + if any { $_ eq $value } + $self->extract_service_file_values($item, 'Service',$key); + } + + for my $key (qw(StandardError StandardOutput)) { + for my $value (qw(syslog syslog-console)) { + + $self->pointed_hint( + 'systemd-service-file-uses-deprecated-syslog-facility', + $item->pointer, "$key=$value") + if any { $_ eq $value } + $self->extract_service_file_values($item, 'Service',$key); + } + } + } + + return 1; +} + +sub service_file_lines { + my ($item) = @_; + + my @output; + + return @output + if $item->is_symlink and $item->link eq '/dev/null'; + + my @lines = split(/\n/, $item->decoded_utf8); + my $continuation = $EMPTY; + + my $position = 1; + for my $line (@lines) { + + $line = $continuation . $line; + $continuation = $EMPTY; + + if ($line =~ s/\\$/ /) { + $continuation = $line; + next; + } + + # trim right + $line =~ s/\s+$//; + + next + unless length $line; + + next + if $line =~ /^[#;\n]/; + + push(@output, $line); + } + + return @output; +} + +# Extracts the values of a specific Key from a .service file +sub extract_service_file_values { + my ($self, $item, $extract_section, $extract_key) = @_; + + return () + unless length $extract_section && length $extract_key; + + my @values; + my $section; + + my @lines = service_file_lines($item); + for my $line (@lines) { + # section header + if ($line =~ /^\[([^\]]+)\]$/) { + $section = $1; + next; + } + + if (!defined($section)) { + # Assignment outside of section. Ignoring. + next; + } + + my ($key, $value) = ($line =~ m{^(.*)\s*=\s*(.*)$}); + if ( defined($key) + && $section eq $extract_section + && $key eq $extract_key) { + + if (length $value) { + push(@values, shellwords($value)); + + } else { + # Empty assignment resets the list + @values = (); + } + } + } + + return @values; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Systemd/Native/Prerequisites.pm b/lib/Lintian/Check/Systemd/Native/Prerequisites.pm new file mode 100644 index 0000000..5a2480f --- /dev/null +++ b/lib/Lintian/Check/Systemd/Native/Prerequisites.pm @@ -0,0 +1,146 @@ +# systemd/native/prerequisites -- lintian check script -*- perl -*- +# +# Copyright (C) 1998 Richard Braakman +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Systemd::Native::Prerequisites; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(any none); +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; + +const my $SYSTEMD_NATIVE_PREREQUISITES => 'init-system-helpers:any'; + +has satisfies_systemd_native_prerequisites => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $pre_depends = $self->processable->relation('Pre-Depends'); + + return $pre_depends->satisfies($SYSTEMD_NATIVE_PREREQUISITES); + } +); + +sub visit_control_files { + my ($self, $item) = @_; + + return + unless $item->is_maintainer_script; + + return + unless length $item->interpreter; + + return + unless $item->is_open_ok; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $stashed = $EMPTY; + + my $position = 1; + while (my $possible_continuation = <$fd>) { + + chomp $possible_continuation; + + # skip empty lines + next + if $possible_continuation =~ /^\s*$/; + + # skip comment lines + next + if $possible_continuation =~ /^\s*\#/; + + my $no_comment = remove_comments($possible_continuation); + + # Concatenate lines containing continuation character (\) + # at the end + if ($no_comment =~ s{\\$}{}) { + + $stashed .= $no_comment; + + next; + } + + my $line = $stashed . $no_comment; + $stashed = $EMPTY; + + my $pointer = $item->pointer($position); + + $self->pointed_hint('skip-systemd-native-flag-missing-pre-depends', + $pointer,"(does not satisfy $SYSTEMD_NATIVE_PREREQUISITES)") + if $line =~ /invoke-rc.d\b.*--skip-systemd-native\b/ + && !$self->satisfies_systemd_native_prerequisites; + + } continue { + ++$position; + } + + return; +} + +sub remove_comments { + my ($line) = @_; + + return $line + unless length $line; + + my $simplified = $line; + + # Remove quoted strings so we can more easily ignore comments + # inside them + $simplified =~ s/(^|[^\\](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g; + $simplified =~ s/(^|[^\\](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g; + + # If the remaining string contains what looks like a comment, + # eat it. In either case, swap the unmodified script line + # back in for processing (if required) and return it. + if ($simplified =~ m/(?:^|[^[\\])[\s\&;\(\)](\#.*$)/) { + + my $comment = $1; + + # eat comment + $line =~ s/\Q$comment\E//; + } + + return $line; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Systemd/Tmpfiles.pm b/lib/Lintian/Check/Systemd/Tmpfiles.pm new file mode 100644 index 0000000..dc86628 --- /dev/null +++ b/lib/Lintian/Check/Systemd/Tmpfiles.pm @@ -0,0 +1,57 @@ +# systemd -- lintian check script -*- perl -*- +# +# Copyright (C) 2013 Michael Stapelberg +# Copyright (C) 2016-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# based on the apache2 checks file by: +# Copyright (C) 2012 Arno Toell +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Systemd::Tmpfiles; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + $self->pointed_hint('systemd-tmpfile-in-var-run', $item->pointer) + if $item->name =~ m{^ usr/lib/tmpfiles[.]d/ .* [.]conf $}sx + && $item->decoded_utf8 =~ m{^ d \s+ /var/run/ }msx; + + $self->pointed_hint('misplaced-systemd-tmpfiles', $item->pointer) + if $item->name =~ m{^ etc/tmpfiles[.]d/ .* [.]conf $}sx + && $item->is_file; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Team/PkgJs/Deprecated.pm b/lib/Lintian/Check/Team/PkgJs/Deprecated.pm new file mode 100644 index 0000000..e04099d --- /dev/null +++ b/lib/Lintian/Check/Team/PkgJs/Deprecated.pm @@ -0,0 +1,76 @@ +# team/pkg-js/deprecated -- lintian check script for deprecated javascript -*- perl -*- +# +# Copyright (C) 2019 Xavier Guimard <yadd@debian.org> +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Team::PkgJs::Deprecated; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has javascript_team_maintained => ( + is => 'rw', + lazy => 1, + coerce => sub { my ($boolean) = @_; return ($boolean // 0); }, + default => sub { + my ($self) = @_; + + my $maintainer = $self->processable->fields->value('Maintainer'); + + # only for pkg-perl packages + return 1 + if $maintainer + =~ /pkg-javascript-maintainers\@lists\.alioth\.debian\.org/; + + return 0; + } +); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $self->javascript_team_maintained; + + return + unless $item->name =~ /\.js$/; + + my $bytes = $item->bytes; + return + unless length $bytes; + + $self->pointed_hint('nodejs-bad-buffer-usage', $item->pointer) + if $bytes =~ /\bnew\s+Buffer\(/; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Team/PkgJs/Testsuite.pm b/lib/Lintian/Check/Team/PkgJs/Testsuite.pm new file mode 100644 index 0000000..2920fe0 --- /dev/null +++ b/lib/Lintian/Check/Team/PkgJs/Testsuite.pm @@ -0,0 +1,73 @@ +# team/pkg-js/testsuite -- lintian check script for detecting a missing Testsuite header -*- perl -*- +# +# Copyright (C) 2013 Niels Thykier <niels@thykier.net> +# Copyright (C) 2013 gregor herrmann <gregoa@debian.org> +# Copyright (C) 2014 Niko Tyni <ntyni@debian.org> +# Copyright (C) 2018 Florian Schlichting <fsfs@debian.org> +# Copyright (C) 2019 Xavier Guimard <yadd@debian.org> +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Team::PkgJs::Testsuite; + +use v5.20; +use warnings; +use utf8; + +use List::SomeUtils qw(none); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $maintainer = $self->processable->fields->value('Maintainer'); + + # only for pkg-perl packages + return + unless $maintainer + =~ /pkg-javascript-maintainers\@lists\.alioth\.debian\.org/; + + unless ($self->processable->fields->declares('Testsuite')) { + + $self->hint('no-testsuite-header'); + return; + } + + my @testsuites + = $self->processable->fields->trimmed_list('Testsuite', qr/,/); + + if (none { $_ eq 'autopkgtest-pkg-perl' } @testsuites) { + + $self->hint('no-team-tests'); + return; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Team/PkgJs/Vcs.pm b/lib/Lintian/Check/Team/PkgJs/Vcs.pm new file mode 100644 index 0000000..e4d4bec --- /dev/null +++ b/lib/Lintian/Check/Team/PkgJs/Vcs.pm @@ -0,0 +1,78 @@ +# team/pkg-js/debhelper -- lintian check script for checking Vcs-* headers -*- perl -*- +# +# Copyright (C) 2013 Niels Thykier <niels@thykier.net> +# Copyright (C) 2013 gregor herrmann <gregoa@debian.org> +# Copyright (C) 2013 Axel Beckert <abe@debian.org> +# Copyright (C) 2019 Xavier Guimard <yadd@debian.org> +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Team::PkgJs::Vcs; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +my @NON_GIT_VCS_FIELDS + = qw(Vcs-Arch Vcs-Bzr Vcs-Cvs Vcs-Darcs Vcs-Hg Vcs-Mtn Vcs-Svn); +my @VCS_FIELDS = (@NON_GIT_VCS_FIELDS, qw(Vcs-Git Vcs-Browser)); + +sub source { + my ($self) = @_; + + my $fields = $self->processable->fields; + + # only for pkg-perl packages + my $maintainer = $fields->value('Maintainer'); + return + unless $maintainer + =~ /pkg-javascript-maintainers\@lists\.alioth\.debian\.org/; + + my @non_git = grep { $fields->declares($_) } @NON_GIT_VCS_FIELDS; + $self->hint('no-git', $_) for @non_git; + + # check for team locations + for my $name (@VCS_FIELDS) { + + next + unless $fields->declares($name); + + my $value = $fields->value($name); + + # get actual capitalization + my $original_name = $fields->literal_name($name); + + $self->hint('no-team-url', $original_name, $value) + unless $value=~ m{^https://salsa.debian.org/js-team}i; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Team/PkgPerl/Testsuite.pm b/lib/Lintian/Check/Team/PkgPerl/Testsuite.pm new file mode 100644 index 0000000..2bf6776 --- /dev/null +++ b/lib/Lintian/Check/Team/PkgPerl/Testsuite.pm @@ -0,0 +1,78 @@ +# team/pkg-perl/no-testsuite -- lintian check script for detecting a missing Testsuite header -*- perl -*- +# +# Copyright (C) 2013 Niels Thykier <niels@thykier.net> +# Copyright (C) 2013 gregor herrmann <gregoa@debian.org> +# Copyright (C) 2014 Niko Tyni <ntyni@debian.org> +# Copyright (C) 2018 Florian Schlichting <fsfs@debian.org> +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Team::PkgPerl::Testsuite; + +use v5.20; +use warnings; +use utf8; + +use List::SomeUtils qw(none); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + # only for pkg-perl packages + my $maintainer = $self->processable->fields->value('Maintainer'); + return + unless $maintainer=~ /pkg-perl-maintainers\@lists\.alioth\.debian\.org/; + + unless ($self->processable->fields->declares('Testsuite')) { + + $self->hint('no-testsuite-header'); + return; + } + + my @testsuites + = $self->processable->fields->trimmed_list('Testsuite', qr/,/); + + if (none { $_ eq 'autopkgtest-pkg-perl' } @testsuites) { + + $self->hint('no-team-tests'); + return; + } + + my $metajson = $self->processable->patched->lookup('META.json'); + my $metayml = $self->processable->patched->lookup('META.yml'); + + $self->hint('autopkgtest-needs-use-name') + unless (defined $metajson && $metajson->size) + || (defined $metayml && $metayml->size) + || $self->processable->patched->lookup('debian/tests/pkg-perl/use-name'); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Team/PkgPerl/Vcs.pm b/lib/Lintian/Check/Team/PkgPerl/Vcs.pm new file mode 100644 index 0000000..2818b78 --- /dev/null +++ b/lib/Lintian/Check/Team/PkgPerl/Vcs.pm @@ -0,0 +1,77 @@ +# team/pkg-perl/debhelper -- lintian check script for checking Vcs-* headers -*- perl -*- +# +# Copyright (C) 2013 Niels Thykier <niels@thykier.net> +# Copyright (C) 2013 gregor herrmann <gregoa@debian.org> +# Copyright (C) 2013 Axel Beckert <abe@debian.org> +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Team::PkgPerl::Vcs; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +my @NON_GIT_VCS_FIELDS + = qw(Vcs-Arch Vcs-Bzr Vcs-Cvs Vcs-Darcs Vcs-Hg Vcs-Mtn Vcs-Svn); +my @VCS_FIELDS = (@NON_GIT_VCS_FIELDS, qw(Vcs-Git Vcs-Browser)); + +sub source { + my ($self) = @_; + + my $fields = $self->processable->fields; + + # only for pkg-perl packages + my $maintainer = $fields->value('Maintainer'); + return + unless $maintainer=~ /pkg-perl-maintainers\@lists\.alioth\.debian\.org/; + + my @non_git = grep { $fields->declares($_) } @NON_GIT_VCS_FIELDS; + $self->hint('no-git', $_) for @non_git; + + # check for team locations + for my $name (@VCS_FIELDS) { + + next + unless $fields->declares($name); + + my $value = $fields->value($name); + + # get actual capitalization + my $original_name = $fields->literal_name($name); + + $self->hint('no-team-url', $original_name, $value) + unless $value + =~ m{^https://salsa\.debian\.org/perl-team/modules/packages}i; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Team/PkgPerl/XsAbi.pm b/lib/Lintian/Check/Team/PkgPerl/XsAbi.pm new file mode 100644 index 0000000..bb6ea56 --- /dev/null +++ b/lib/Lintian/Check/Team/PkgPerl/XsAbi.pm @@ -0,0 +1,95 @@ +# team/pkg-perl/xs-abi -- lintian check script for XS target directory -*- perl -*- +# +# Copyright (C) 2014 Damyan Ivanov <dmn@debian.org> +# Copyright (C) 2014 Axel Beckert <abe@debian.org> +# Copyright (C) 2020 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Team::PkgPerl::XsAbi; + +use v5.20; +use warnings; +use utf8; + +use Dpkg::Version; + +use Lintian::Relation; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +has relies_on_modern_api => ( + is => 'rw', + lazy => 1, + coerce => sub { my ($boolean) = @_; return ($boolean // 0); }, + default => sub { + my ($self) = @_; + + return 0 + if $self->processable->fields->value('Architecture') eq 'all'; + + my $depends = $self->processable->relation('strong'); + + my $api_version = $depends->visit( + sub { + my ($prerequisite) = @_; + + if ($prerequisite =~ /^perlapi-(\d[\d.]*)$/) { + return $1; + } + + return; + }, + Lintian::Relation::VISIT_OR_CLAUSE_FULL + | Lintian::Relation::VISIT_STOP_FIRST_MATCH + ); + + return 0 + unless defined $api_version; + + return 1 + if version_compare_relation($api_version, REL_GE, '5.19.11'); + + return 0; + } +); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + return + unless $item->name =~ m{^usr/lib/perl5/}; + + $self->pointed_hint('legacy-vendorarch-directory', $item->pointer) + if $self->relies_on_modern_api; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Template/DhMake/Control/Vcs.pm b/lib/Lintian/Check/Template/DhMake/Control/Vcs.pm new file mode 100644 index 0000000..11bf366 --- /dev/null +++ b/lib/Lintian/Check/Template/DhMake/Control/Vcs.pm @@ -0,0 +1,77 @@ +# template/dh-make/control/vcs -- lintian check script -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Template::DhMake::Control::Vcs; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $item = $self->processable->debian_control->item; + return + unless defined $item; + + my @lines = split(/\n/, $item->decoded_utf8); + + my $line; + my $position = 1; + while (defined($line = shift @lines)) { + + $line =~ s{\s*$}{}; + + if ( + $line =~ m{\A \# \s* Vcs-(?:Git|Browser): \s* + (?:git|http)://git\.debian\.org/ + (?:\?p=)?collab-maint/<pkg>\.git}smx + ) { + + my $pointer = $item->pointer($position); + + $self->pointed_hint('control-file-contains-dh-make-vcs-comment', + $pointer, $line); + + # once per source + last; + } + + } continue { + ++$position; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Testsuite.pm b/lib/Lintian/Check/Testsuite.pm new file mode 100644 index 0000000..46556e5 --- /dev/null +++ b/lib/Lintian/Check/Testsuite.pm @@ -0,0 +1,352 @@ +# testsuite -- lintian check script -*- perl -*- + +# Copyright (C) 2013 Nicolas Boulenguez <nicolas@debian.org> +# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner + +# This file is part of lintian. + +# Lintian 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 3 of the License, or +# (at your option) any later version. + +# Lintian 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 Lintian. If not, see <http://www.gnu.org/licenses/>. + +package Lintian::Check::Testsuite; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::Compare; +use List::SomeUtils qw(any none uniq); +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::Deb822; +use Lintian::Deb822::Constants qw(DCTRL_COMMENTS_AT_EOL); +use Lintian::Relation; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $DOT => q{.}; +const my $DOUBLE_QUOTE => q{"}; + +const my @KNOWN_FIELDS => qw( + Tests + Restrictions + Features + Depends + Tests-Directory + Test-Command + Architecture + Classes +); + +my %KNOWN_FEATURES = map { $_ => 1 } qw(); + +our $PYTHON3_ALL_DEPEND + = 'python3-all:any | python3-all-dev:any | python3-all-dbg:any'; + +my %KNOWN_SPECIAL_DEPENDS = map { $_ => 1 } qw( + @ + @builddeps@ + @recommends@ +); + +sub source { + my ($self) = @_; + + my $KNOWN_TESTSUITES= $self->data->load('testsuite/known-testsuites'); + + my $debian_control = $self->processable->debian_control; + + my $testsuite = $debian_control->source_fields->value('Testsuite'); + my @testsuites = split(/\s*,\s*/, $testsuite); + + my $lc = List::Compare->new(\@testsuites, [$KNOWN_TESTSUITES->all]); + my @unknown = $lc->get_Lonly; + + my $control_position + = $debian_control->source_fields->position('Testsuite'); + my $control_pointer = $debian_control->item->pointer($control_position); + + $self->pointed_hint('unknown-testsuite', $control_pointer, $_)for @unknown; + + my $tests_control + = $self->processable->patched->resolve_path('debian/tests/control'); + + # field added automatically since dpkg 1.17 when d/tests/control is present + $self->pointed_hint('unnecessary-testsuite-autopkgtest-field', + $control_pointer) + if (any { $_ eq 'autopkgtest' } @testsuites) && defined $tests_control; + + # need d/tests/control for plain autopkgtest + $self->pointed_hint('missing-tests-control', $control_pointer) + if (any { $_ eq 'autopkgtest' } @testsuites) && !defined $tests_control; + + die encode_utf8('debian tests control is not a regular file') + if defined $tests_control && !$tests_control->is_regular_file; + + if (defined $tests_control && $tests_control->is_valid_utf8) { + + # another check complains about invalid encoding + my $contents = $tests_control->decoded_utf8; + + my $control_file = Lintian::Deb822->new; + $control_file->parse_string($contents, DCTRL_COMMENTS_AT_EOL); + + my @sections = @{$control_file->sections}; + + $self->pointed_hint('empty-debian-tests-control', + $tests_control->pointer) + unless @sections; + + $self->check_control_paragraph($tests_control, $_) for @sections; + + my @thorough + = grep { $_->value('Restrictions') !~ m{\bsuperficial\b} } @sections; + $self->pointed_hint('superficial-tests', $tests_control->pointer) + if @sections && !@thorough; + + if (scalar @sections == 1) { + + my $section = $sections[0]; + + my $command = $section->unfolded_value('Test-Command'); + my $position = $section->position('Test-Command'); + my $pointer = $tests_control->pointer($position); + + $self->pointed_hint('no-op-testsuite', $pointer) + if $command =~ m{^ \s* (?:/bin/)? true \s* $}sx; + } + } + + my $control_autodep8 + = $self->processable->patched->resolve_path( + 'debian/tests/control.autodep8'); + $self->pointed_hint('debian-tests-control-autodep8-is-obsolete', + $control_autodep8->pointer) + if defined $control_autodep8; + + return; +} + +sub check_control_paragraph { + my ($self, $tests_control, $section) = @_; + + my $section_pointer = $tests_control->pointer($section->position); + + $self->pointed_hint('no-tests', $section_pointer) + unless $section->declares('Tests') || $section->declares('Test-Command'); + + $self->pointed_hint('conflicting-test-fields', $section_pointer, 'Tests', + 'Test-Command') + if $section->declares('Tests') && $section->declares('Test-Command'); + + my @lowercase_names = map { lc } $section->names; + my @lowercase_known = map { lc } @KNOWN_FIELDS; + + my $lc = List::Compare->new(\@lowercase_names, \@lowercase_known); + my @lowercase_unknown = $lc->get_Lonly; + + my @unknown = map { $section->literal_name($_) } @lowercase_unknown; + $self->pointed_hint('unknown-runtime-tests-field', + $tests_control->pointer($section->position($_)), $_) + for @unknown; + + my @features = $section->trimmed_list('Features', qr/ \s* , \s* | \s+ /x); + for my $feature (@features) { + + my $position = $section->position('Features'); + my $pointer = $tests_control->pointer($position); + + $self->pointed_hint('unknown-runtime-tests-feature',$pointer, $feature) + unless exists $KNOWN_FEATURES{$feature} + || $feature =~ m/^test-name=\S+/; + } + + my $KNOWN_RESTRICTIONS= $self->data->load('testsuite/known-restrictions'); + my $KNOWN_OBSOLETE_RESTRICTIONS + = $self->data->load('testsuite/known-obsolete-restrictions'); + + my @restrictions + = $section->trimmed_list('Restrictions', qr/ \s* , \s* | \s+ /x); + for my $restriction (@restrictions) { + + my $position = $section->position('Restrictions'); + my $pointer = $tests_control->pointer($position); + + $self->pointed_hint('unknown-runtime-tests-restriction', + $pointer, $restriction) + unless $KNOWN_RESTRICTIONS->recognizes($restriction); + + $self->pointed_hint('obsolete-runtime-tests-restriction', + $pointer, $restriction) + if $KNOWN_OBSOLETE_RESTRICTIONS->recognizes($restriction); + } + + my $test_command = $section->unfolded_value('Test-Command'); + + # trim both sides + $test_command =~ s/^\s+|\s+$//g; + + $self->pointed_hint('backgrounded-test-command', + $tests_control->pointer($section->position('Test-Command')), + $test_command) + if $test_command =~ / & $/x; + + my $directory = $section->unfolded_value('Tests-Directory') + || 'debian/tests'; + + my $tests_position = $section->position('Tests'); + my $tests_pointer = $tests_control->pointer($tests_position); + + my @tests = uniq +$section->trimmed_list('Tests', qr/ \s* , \s* | \s+ /x); + + my @illegal_names = grep { !m{^ [ [:alnum:] \+ \- \. / ]+ $}x } @tests; + $self->pointed_hint('illegal-runtime-test-name', $tests_pointer, $_) + for @illegal_names; + + my @paths; + if ($directory eq $DOT) { + + # Special case with "Tests-Directory: ." (see #849880) + @paths = @tests; + + } else { + @paths = map { "$directory/$_" } @tests; + } + + my $debian_control = $self->processable->debian_control; + + my $depends_norestriction = Lintian::Relation->new; + $depends_norestriction->load($section->unfolded_value('Depends')); + + my $all_tests_use_supported = 1; + + for my $path (@paths) { + + my $item = $self->processable->patched->resolve_path($path); + if (!defined $item) { + + $self->pointed_hint('missing-runtime-test-file', $tests_pointer, + $path); + next; + } + + if (!$item->is_open_ok) { + + $self->pointed_hint('runtime-test-file-is-not-a-regular-file', + $tests_pointer, $path); + next; + } + + my $queries_all_python_versions = 0; + + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $position = 1; + while (my $line = <$fd>) { + + my $pointer = $item->pointer($position); + + $self->pointed_hint('uses-deprecated-adttmp', $pointer) + if $line =~ /ADTTMP/; + + if ($line =~ /(py3versions)((?:\s+--?\w+)*)/) { + + my $command = $1 . $2; + my $options = $2; + + $self->pointed_hint( + 'runtime-test-file-uses-installed-python-versions', + $pointer, $command) + if $options =~ /\s(?:-\w*i|--installed)/; + + $self->pointed_hint( +'runtime-test-file-uses-supported-python-versions-without-test-depends', + $pointer, + $command + ) + if $options =~ /\s(?:-\w*s|--supported)/ + && !$depends_norestriction->satisfies($PYTHON3_ALL_DEPEND); + + $self->pointed_hint('declare-python-versions-for-test', + $pointer, $command) + if $options =~ m{ \s (?: -\w*r | --requested ) }x + && !$debian_control->source_fields->declares( + 'X-Python3-Version'); + + $queries_all_python_versions = 1 + if $options =~ m{ \s (?: -\w*s | --supported ) }x; + } + + } continue { + ++$position; + } + + close $fd; + + $all_tests_use_supported = 0 + if !$queries_all_python_versions; + + $self->pointed_hint('test-leaves-python-version-untested', + $item->pointer) + if $depends_norestriction->satisfies($PYTHON3_ALL_DEPEND) + && !$queries_all_python_versions; + } + + if ( $debian_control->source_fields->declares('X-Python3-Version') + && $all_tests_use_supported) { + + my $position + = $debian_control->source_fields->position('X-Python3-Version'); + my $pointer = $debian_control->item->pointer($position); + + $self->pointed_hint('drop-python-version-declaration',$pointer); + } + + if ($section->declares('Depends')) { + + my $depends = $section->unfolded_value('Depends'); + + # trim both sides + $depends =~ s/^\s+|\s+$//g; + + my $relation = Lintian::Relation->new->load($depends); + + # autopkgtest allows @ as predicate as an exception + my @unparsable = grep { !exists $KNOWN_SPECIAL_DEPENDS{$_} } + $relation->unparsable_predicates; + + my $position = $section->position('Depends'); + my $pointer = $tests_control->pointer($position); + + $self->pointed_hint('testsuite-dependency-has-unparsable-elements', + $pointer, $DOUBLE_QUOTE . $_ . $DOUBLE_QUOTE) + for @unparsable; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Triggers.pm b/lib/Lintian/Check/Triggers.pm new file mode 100644 index 0000000..738f3c6 --- /dev/null +++ b/lib/Lintian/Check/Triggers.pm @@ -0,0 +1,145 @@ +# triggers -- lintian check script -*- perl -*- + +# Copyright (C) 2017 Niels Thykier +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Triggers; + +use v5.20; +use warnings; +use utf8; +use autodie qw(open); + +use Const::Fast; +use List::SomeUtils qw(all); +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $SPACE => q{ }; +const my $LEFT_PARENTHESIS => q{(}; +const my $RIGHT_PARENTHESIS => q{)}; + +has TRIGGER_TYPES => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my %trigger_types; + + my $data + = $self->data->load('triggers/trigger-types',qr{ \s* => \s* }x); + for my $type ($data->all) { + + my $attributes = $data->value($type); + + my %one_type; + + for my $pair (split(m{ \s* , \s* }x, $attributes)) { + + my ($flag, $setting) = split(m{ \s* = \s* }x, $pair, 2); + $one_type{$flag} = $setting; + } + + die encode_utf8( +"Invalid trigger-types: $type is defined as implicit-await but not await" + ) + if $one_type{'implicit-await'} + && !$one_type{await}; + + $trigger_types{$type} = \%one_type; + } + + return \%trigger_types; + } +); + +sub visit_control_files { + my ($self, $item) = @_; + + return + unless $item->name eq 'triggers'; + + my @lines = split(m{\n}, $item->decoded_utf8); + + my %positions_by_trigger_name; + + my $position = 1; + while (defined(my $line = shift @lines)) { + + # trim both ends + $line =~ s/^\s+|\s+$//g; + + next + if $line =~ m/^(?:\s*)(?:#.*)?$/; + + my ($trigger_type, $trigger_name) = split($SPACE, $line, 2); + next + unless all { length } ($trigger_type, $trigger_name); + + $positions_by_trigger_name{$trigger_name} //= []; + push(@{$positions_by_trigger_name{$trigger_name}}, $position); + + my $trigger_info = $self->TRIGGER_TYPES->{$trigger_type}; + if (!$trigger_info) { + + $self->pointed_hint('unknown-trigger', $item->pointer($position), + $trigger_type); + next; + } + + $self->pointed_hint('uses-implicit-await-trigger', + $item->pointer($position), + $trigger_type) + if $trigger_info->{'implicit-await'}; + + } continue { + ++$position; + } + + my @duplicates= grep { @{$positions_by_trigger_name{$_}} > 1 } + keys %positions_by_trigger_name; + + for my $trigger_name (@duplicates) { + + my $indicator + = $LEFT_PARENTHESIS . 'lines' + . $SPACE + . join($SPACE, + sort { $a <=> $b }@{$positions_by_trigger_name{$trigger_name}}) + . $RIGHT_PARENTHESIS; + + $self->pointed_hint('repeated-trigger-name', $item->pointer, + $trigger_name, $indicator); + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Udev.pm b/lib/Lintian/Check/Udev.pm new file mode 100644 index 0000000..4d1779a --- /dev/null +++ b/lib/Lintian/Check/Udev.pm @@ -0,0 +1,172 @@ +# udev -- lintian check script -*- perl -*- + +# Copyright (C) 2016 Petter Reinholdtsen +# Copyright (C) 2018 Chris Lamb <lamby@debian.org> +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Udev; + +use v5.20; +use warnings; +use utf8; +use autodie qw(open); + +use Const::Fast; + +const my $EMPTY => q{}; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +# Check /lib/udev/rules.d/, detect use of MODE="0666" and use of +# GROUP="plugdev" without TAG+="uaccess". + +sub installable { + my ($self) = @_; + + foreach my $lib_dir (qw(usr/lib lib)) { + my $rules_dir + = $self->processable->installed->resolve_path( + "$lib_dir/udev/rules.d/"); + next + unless $rules_dir; + + for my $item ($rules_dir->children) { + + if (!$item->is_open_ok) { + + $self->pointed_hint('udev-rule-unreadable', $item->pointer); + next; + } + + $self->check_udev_rules($item); + } + } + + return; +} + +sub check_rule { + my ($self, $item, $position, $in_goto, $rule) = @_; + + # for USB, if everyone or the plugdev group members are + # allowed access, the uaccess tag should be used too. + $self->pointed_hint( + 'udev-rule-missing-uaccess', + $item->pointer($position), + 'user accessible device missing TAG+="uaccess"' + ) + if $rule =~ m/SUBSYSTEM=="usb"/ + && ( $rule =~ m/GROUP="plugdev"/ + || $rule =~ m/MODE="0666"/) + && $rule !~ m/ENV\{COLOR_MEASUREMENT_DEVICE\}/ + && $rule !~ m/ENV\{DDC_DEVICE\}/ + && $rule !~ m/ENV\{ID_CDROM\}/ + && $rule !~ m/ENV\{ID_FFADO\}/ + && $rule !~ m/ENV\{ID_GPHOTO2\}/ + && $rule !~ m/ENV\{ID_HPLIP\}/ + && $rule !~ m/ENV\{ID_INPUT_JOYSTICK\}/ + && $rule !~ m/ENV\{ID_MAKER_TOOL\}/ + && $rule !~ m/ENV\{ID_MEDIA_PLAYER\}/ + && $rule !~ m/ENV\{ID_PDA\}/ + && $rule !~ m/ENV\{ID_REMOTE_CONTROL\}/ + && $rule !~ m/ENV\{ID_SECURITY_TOKEN\}/ + && $rule !~ m/ENV\{ID_SMARTCARD_READER\}/ + && $rule !~ m/ENV\{ID_SOFTWARE_RADIO\}/ + && $rule !~ m/TAG\+="uaccess"/; + + # Matching rules mentioning vendor/product should also specify + # subsystem, as vendor/product is subsystem specific. + $self->pointed_hint( + 'udev-rule-missing-subsystem', + $item->pointer($position), + 'vendor/product matching missing SUBSYSTEM specifier' + ) + if $rule =~ m/ATTR\{idVendor\}=="[0-9a-fA-F]+"/ + && $rule =~ m/ATTR\{idProduct\}=="[0-9a-fA-F]*"/ + && !$in_goto + && $rule !~ m/SUBSYSTEM=="[^"]+"/; + + return 0; +} + +sub check_udev_rules { + my ($self, $item) = @_; + + my $contents = $item->decoded_utf8; + my @lines = split(/\n/, $contents); + + my $continued = $EMPTY; + my $in_goto = $EMPTY; + my $result = 0; + + my $position = 1; + while (defined(my $line = shift @lines)) { + + if (length $continued) { + $line = $continued . $line; + $continued = $EMPTY; + } + + if ($line =~ /^(.*)\\$/) { + $continued = $1; + next; + } + + # Skip comments + next + if $line =~ /^#.*/; + + $in_goto = $EMPTY + if $line =~ /LABEL="[^"]+"/; + + $in_goto = $line + if $line =~ /SUBSYSTEM!="[^"]+"/ + && $line =~ /GOTO="[^"]+"/; + + $result |= $self->check_rule($item, $position, $in_goto, $line); + + } continue { + $position++; + } + + return $result; +} + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->name =~ m{^etc/udev/}; + + # /etc/udev/rules.d + $self->pointed_hint('udev-rule-in-etc', $item->pointer) + if $item->name =~ m{^etc/udev/rules\.d/\S}; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Unpack.pm b/lib/Lintian/Check/Unpack.pm new file mode 100644 index 0000000..9395942 --- /dev/null +++ b/lib/Lintian/Check/Unpack.pm @@ -0,0 +1,67 @@ +# unpack -- lintian check script -*- perl -*- + +# Copyright (C) 2021 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Unpack; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $processable = $self->processable; + + $self->hint('unpack-message-for-source', $_) + for @{$processable->patched->unpack_messages}; + + # empty for native + $self->hint('unpack-message-for-orig', $_) + for @{$processable->orig->unpack_messages}; + + return; +} + +sub installable { + my ($self) = @_; + + my $processable = $self->processable; + + $self->hint('unpack-message-for-deb-data', $_) + for @{$processable->installed->unpack_messages}; + + $self->hint('unpack-message-for-deb-control', $_) + for @{$processable->control->unpack_messages}; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/UpstreamSignature.pm b/lib/Lintian/Check/UpstreamSignature.pm new file mode 100644 index 0000000..3278e87 --- /dev/null +++ b/lib/Lintian/Check/UpstreamSignature.pm @@ -0,0 +1,126 @@ +# upstream-signature -- lintian check script -*- perl -*- +# +# Copyright (C) 2019 Felix Lechner +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::UpstreamSignature; + +use v5.20; +use warnings; +use utf8; + +use Path::Tiny; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub source { + my ($self) = @_; + + my $SIGNING_KEY_FILENAMES + = $self->data->load('common/signing-key-filenames'); + + my @keynames = $SIGNING_KEY_FILENAMES->all; + my @keypaths + = map { $self->processable->patched->resolve_path("debian/$_") } + @keynames; + my @keys = grep { $_ && $_->is_file } @keypaths; + + # in uscan's gittag mode,signature will never match + my $watch = $self->processable->patched->resolve_path('debian/watch'); + my $gittag = $watch && $watch->bytes =~ /pgpmode=gittag/; + + my @filenames = sort keys %{$self->processable->files}; + my @origtar= grep { /^.*\.orig(?:-[A-Za-z\d-]+)?\.tar\./ } + grep { !/\.asc$/ }@filenames; + + my %signatures; + for my $filename (@origtar) { + + my ($uncompressed) = ($filename =~ /(^.*\.tar)/); + + my @componentsigs; + for my $tarball ($filename, $uncompressed) { + my $signaturename = "$tarball.asc"; + push(@componentsigs, $signaturename) + if exists $self->processable->files->{$signaturename}; + } + + $signatures{$filename} = \@componentsigs; + } + + # orig tarballs should be signed if upstream's public key is present + if (@keys && !$self->processable->repacked && !$gittag) { + + for my $filename (@origtar) { + + $self->hint('orig-tarball-missing-upstream-signature', $filename) + unless scalar @{$signatures{$filename}}; + } + } + + my $parentdir = path($self->processable->path)->parent->stringify; + + # check signatures + my @allsigs = map { @{$signatures{$_}} } @origtar; + for my $signature (@allsigs) { + my $sig_file = path($parentdir)->child($signature); + # Only try to slurp file if it exists. Otherwise Path::Tiny ≥ + # 0.142 will bail out. (Returned empty string instead before + # that version.) + next unless $sig_file->is_file; + + # take from location near input file + my $contents = $sig_file->slurp; + + if ($contents =~ /^-----BEGIN PGP ARMORED FILE-----/m) { + + if ($contents =~ /^LS0tLS1CRUd/m) { + # doubly armored + $self->hint('doubly-armored-upstream-signature', $signature); + + } else { + # non standard armored header + $self->hint('explicitly-armored-upstream-signature', + $signature); + } + + my @spurious = ($contents =~ /\n([^:\n]+):/g); + $self->hint('spurious-fields-in-upstream-signature', + $signature, @spurious) + if @spurious; + } + + # multiple signatures in one file + $self->hint('concatenated-upstream-signatures', $signature) + if $contents + =~ m/(?:-----BEGIN PGP SIGNATURE-----[^-]*-----END PGP SIGNATURE-----\s*){2,}/; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Usrmerge.pm b/lib/Lintian/Check/Usrmerge.pm new file mode 100644 index 0000000..a435470 --- /dev/null +++ b/lib/Lintian/Check/Usrmerge.pm @@ -0,0 +1,66 @@ +# usrmerge -- lintian check script -*- perl -*- + +# Copyright (C) 2016 Marco d'Itri +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Usrmerge; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->name =~ m{^(?:s?bin|lib(?:|[ox]?32|64))/}; + + my $usrfile = $self->processable->installed->lookup("usr/$item"); + + return + unless defined $usrfile; + + return + if $item->is_dir and $usrfile->is_dir; + + if ($item =~ m{^lib.+\.(?:so[\.0-9]*|a)$}) { + $self->pointed_hint('library-in-root-and-usr', $item->pointer, + 'already in:', $usrfile->name); + + } else { + $self->pointed_hint( + 'file-in-root-and-usr', $item->pointer, + 'already in:', $usrfile->name + ); + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Vim.pm b/lib/Lintian/Check/Vim.pm new file mode 100644 index 0000000..ef889f5 --- /dev/null +++ b/lib/Lintian/Check/Vim.pm @@ -0,0 +1,53 @@ +# vim -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Vim; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + if ($item->name =~ m{^usr/share/vim/vim(?:current|\d\d)/([^/]+)}){ + my $is_vimhelp + = $1 eq 'doc' && $self->processable->name =~ /^vimhelp-\w+$/; + my $is_vim = $self->processable->source_name =~ /vim/; + + $self->pointed_hint('vim-addon-within-vim-runtime-path',$item->pointer) + unless $is_vim || $is_vimhelp; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Vim/Addons.pm b/lib/Lintian/Check/Vim/Addons.pm new file mode 100644 index 0000000..9823f0c --- /dev/null +++ b/lib/Lintian/Check/Vim/Addons.pm @@ -0,0 +1,48 @@ +# vim -- lintian check script -*- perl -*- + +# Copyright (C) Louis-Philippe Veronneau +# +# 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 https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Vim::Addons; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub installable { + my ($self) = @_; + + $self->hint('obsolete-vim-addon-manager') + if $self->processable->relation('strong') + ->satisfies('vim-addon-manager'); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et |