diff options
Diffstat (limited to 'lib')
477 files changed, 79487 insertions, 0 deletions
diff --git a/lib/Lintian/Archive.pm b/lib/Lintian/Archive.pm new file mode 100644 index 0000000..b9652af --- /dev/null +++ b/lib/Lintian/Archive.pm @@ -0,0 +1,179 @@ +# 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::Archive; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use IPC::Run3; +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +const my $SLASH => q{/}; + +const my $WAIT_STATUS_SHIFT => 8; + +=head1 NAME + +Lintian::Archive -- Facilities for archive data + +=head1 SYNOPSIS + +use Lintian::Archive; + +=head1 DESCRIPTION + +A class for downloading and accessing archive information + +=head1 INSTANCE METHODS + +=over 4 + +=item mirror_base + +=item work_folder + +=item packages + +=cut + +has mirror_base => (is => 'rw', default => 'https://deb.debian.org/debian'); + +has work_folder => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $work_folder + = Path::Tiny->tempdir(TEMPLATE => 'lintian-archive-XXXXXXXXXX'); + + return $work_folder; + } +); + +has packages => (is => 'rw', default => sub { {} }); + +=item contents_gz + +=cut + +sub contents_gz { + my ($self, $release, $archive_liberty, $installable_architecture) = @_; + + my $relative + = "$release/$archive_liberty/Contents-$installable_architecture.gz"; + my $local_path = $self->work_folder . $SLASH . $relative; + + return $local_path + if -e $local_path; + + path($local_path)->parent->mkpath; + + my $url = $self->mirror_base . "/dists/$relative"; + + my $stderr; + run3([qw{wget --quiet}, "--output-document=$local_path", $url], + undef, \$stderr); + my $status = ($? >> $WAIT_STATUS_SHIFT); + + # stderr already in UTF-8 + die $stderr + if $status; + + return $local_path; +} + +=item deb822_packages_by_installable_name + +=cut + +sub deb822_packages_by_installable_name { + my ($self, $release, $archive_liberty, $port) = @_; + + return $self->packages->{$release}{$archive_liberty}{$port} + if exists $self->packages->{$release}{$archive_liberty}{$port}; + + my $relative_unzipped = "$release/$archive_liberty/binary-$port/Packages"; + my $local_path = $self->work_folder . $SLASH . $relative_unzipped; + + path($local_path)->parent->mkpath; + + my $url = $self->mirror_base . "/dists/$relative_unzipped.gz"; + + my $stderr; + + run3([qw{wget --quiet}, "--output-document=$local_path.gz", $url], + undef, \$stderr); + my $status = ($? >> $WAIT_STATUS_SHIFT); + + # stderr already in UTF-8 + die $stderr + if $status; + + run3(['gunzip', "$local_path.gz"], undef, \$stderr); + $status = ($? >> $WAIT_STATUS_SHIFT); + + # stderr already in UTF-8 + die $stderr + if $status; + + my $deb822 = Lintian::Deb822->new; + my @sections = $deb822->read_file($local_path); + + unlink($local_path) + or die encode_utf8("Cannot delete $local_path"); + + my %section_by_installable_name; + for my $section (@sections) { + + my $installable_name = $section->value('Package'); + $section_by_installable_name{$installable_name} = $section; + } + + $self->packages->{$release}{$archive_liberty}{$port} + = \%section_by_installable_name; + + return \%section_by_installable_name; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Changelog.pm b/lib/Lintian/Changelog.pm new file mode 100644 index 0000000..84854c3 --- /dev/null +++ b/lib/Lintian/Changelog.pm @@ -0,0 +1,380 @@ +# Copyright (C) 2019 Felix Lechner <felix.lechner@lease-up.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::Changelog; + +use v5.20; +use warnings; +use utf8; + +use Carp; +use Const::Fast; +use Date::Parse; + +use Lintian::Changelog::Entry; + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $ASTERISK => q{*}; +const my $UNKNOWN => q{unknown}; + +use Moo; +use namespace::clean; + +=head1 NAME + +Lintian::Changelog -- Parse a literal version string into its constituents + +=head1 SYNOPSIS + + use Lintian::Changelog; + + my $version = Lintian::Changelog->new; + $version->set('1.2.3-4', undef); + +=head1 DESCRIPTION + +A class for parsing literal version strings + +=head1 CLASS METHODS + +=over 4 + +=item new () + +Creates a new Lintian::Changelog object. + +=cut + +=item find_closes + +Takes one string as argument and finds "Closes: #123456, #654321" statements +as supported by the Debian Archive software in it. Returns all closed bug +numbers in an array reference. + +=cut + +sub find_closes { + my $changes = shift; + my @closes = (); + + while ( + $changes + && ($changes + =~ /(closes:\s*(?:bug)?\#?\s?\d+(?:,\s*(?:bug)?\#?\s?\d+)*)/ig) + ) { + push(@closes, $1 =~ /\#?\s?(\d+)/g); + } + + @closes = sort { $a <=> $b } @closes; + return \@closes; +} + +=back + +=head1 INSTANCE METHODS + +=over 4 + +=item parse (STRING) + +Parses STRING as the content of a debian/changelog file. + +=cut + +sub parse { + my ($self, $contents) = @_; + + $self->errors([]); + $self->entries([]); + + # careful with negative matching /m + unless ( + $contents =~ m{^ \S+ \s* [(] [^\)]+ [)] \s* (?:[^ \t;]+ \s*)+ ; }mx) { + + push(@{$self->errors}, [1, 'not a Debian changelog']); + return; + } + + my @lines = split(/\n/, $contents); + + # based on /usr/lib/dpkg/parsechangelog/debian + my $expect='first heading'; + my $entry = Lintian::Changelog::Entry->new; + my $blanklines = 0; + + # to make unknown version unique, for id + my $unknown_version_counter = 1; + + my $position = 1; + for my $line (@lines) { + + # trim end + $line =~ s/\s+\r?$//; + + # print encode_utf*(sprintf(STDERR "%-39.39s %-39.39s\n",$expect,$line)); + if ($line + =~ m/^(?<Source>\w[-+0-9a-z.]*) \((?<Version>[^\(\) \t]+)\)(?<Distribution>(?:\s+[-+0-9a-z.]+)+)\;\s*(?<kvpairs>.*)$/i + ){ + my $source = $+{Source}; + my $version = $+{Version}; + my $distribution = $+{Distribution}; + my $kvpairs = $+{kvpairs}; + + unless ($expect eq 'first heading' + || $expect eq 'next heading or eof') { + $entry->ERROR( + [ + $position, + "found start of entry where expected $expect",$line + ] + ); + push @{$self->errors}, $entry->ERROR; + } + + unless ($entry->is_empty) { + $entry->Closes(find_closes($entry->Changes)); + + push @{$self->entries}, $entry; + $entry = Lintian::Changelog::Entry->new; + } + + $entry->position($position); + + $entry->Header($line); + + $entry->Source($source); + $entry->Version($version); + + $distribution =~ s/^\s+//; + $entry->Distribution($distribution); + + my %kvdone; + for my $kv (split(/\s*,\s*/,$kvpairs)) { + $kv =~ m/^([-0-9a-z]+)\=\s*(.*\S)$/i + ||push @{$self->errors}, + [$position,"bad key-value after ';': '$kv'"]; + my $k = ucfirst $1; + my $v = $2; + $kvdone{$k}++ + && push @{$self->errors}, + [$position,"repeated key-value $k"]; + if ($k eq 'Urgency') { + $v =~ m/^([-0-9a-z]+)((\s+.*)?)$/i + ||push @{$self->errors}, + [$position,"badly formatted urgency value $v"]; + $entry->Urgency($1); + $entry->Urgency_LC(lc($1)); + $entry->Urgency_Comment($2); + } elsif ($k =~ m/^X[BCS]+-/i) { + # Extensions - XB for putting in Binary, + # XC for putting in Control, XS for putting in Source + $entry->{$k}= $v; + } else { + push @{$self->errors}, + [$position, + "unknown key-value key $k - copying to XS-$k"]; + $entry->{ExtraFields}{"XS-$k"} = $v; + } + } + $expect= 'start of change data'; + $blanklines = 0; + + } elsif ($line =~ /^(?:;;\s*)?Local variables:/i) { + last; # skip Emacs variables at end of file + + } elsif ($line =~ /^vim:/i) { + last; # skip vim variables at end of file + + } elsif ($line =~ /^\$\w+:.*\$/) { + next; # skip stuff that look like a CVS keyword + + } elsif ($line =~ /^\# /) { + next; # skip comments, even that's not supported + + } elsif ($line =~ m{^/\*.*\*/}) { + next; # more comments + + } elsif ($line + =~ m/^(?:\w+\s+\w+\s+\d{1,2} \d{1,2}:\d{1,2}:\d{1,2}\s+[\w\s]*\d{4})\s+(?:.*)\s+[<\(](?:.*)[\)>]/ + || $line + =~ m/^(?:\w+\s+\w+\s+\d{1,2},?\s*\d{4})\s+(?:.*)\s+[<\(](?:.*)[\)>]/ + || $line =~ m/^(?:\w[-+0-9a-z.]*) \((?:[^\(\) \t]+)\)\;?/i + || $line =~ m/^(?:[\w.+-]+)[- ]\S+ Debian \S+/i + || $line =~ m/^Changes from version (?:.*) to (?:.*):/i + || $line =~ m/^Changes for [\w.+-]+-[\w.+-]+:?$/i + || fc($line) eq fc('Old Changelog:') + || $line =~ m/^(?:\d+:)?\w[\w.+~-]*:?$/) { + # save entries on old changelog format verbatim + # we assume the rest of the file will be in old format once we + # hit it for the first time + last; + + } elsif ($line =~ m/^\S/) { + push @{$self->errors}, + [$position,'badly formatted heading line', $line]; + + } elsif ($line + =~ m/^ \-\- (?<name>.*) <(?<email>.*)>(?<sep> ?)(?<date>(?:\w+\,\s*)?\d{1,2}\s+\w+\s+\d{4}\s+\d{1,2}:\d\d:\d\d\s+[-+]\d{4}(?:\s+\([^\\\(\)]\))?)$/ + ) { + + my $name = $+{name}; + my $email = $+{email}; + my $separator = $+{sep}; + my $date = $+{date}; + + $expect eq 'more change data or trailer' + || push @{$self->errors}, + [$position,"found trailer where expected $expect", $line]; + if ($separator ne $SPACE . $SPACE) { + push @{$self->errors}, + [$position,'badly formatted trailer line', $line]; + } + $entry->Trailer($line); + $entry->Maintainer("$name <$email>") + unless length $entry->Maintainer; + + unless(length $entry->Date && defined $entry->Timestamp) { + $entry->Date($date); + $entry->Timestamp(str2time($date)); + unless (defined $entry->Timestamp) { + push @{$self->errors}, + [$position,"could not parse date $date"]; + } + } + $expect = 'next heading or eof'; + + } elsif ($line =~ m/^ \-\-/) { + $entry->{ERROR} + = [$position, 'badly formatted trailer line', $line]; + push @{$self->errors}, $entry->ERROR; + # $expect = 'next heading or eof' + # if $expect eq 'more change data or trailer'; + + } elsif ($line =~ m/^\s{2,}(\S)/) { + $expect eq 'start of change data' + || $expect eq 'more change data or trailer' + || do { + push @{$self->errors}, + [$position,"found change data where expected $expect",$line]; + if (($expect eq 'next heading or eof') + && !$entry->is_empty) { + # lets assume we have missed the actual header line + $entry->Closes(find_closes($entry->Changes)); + + push @{$self->entries}, $entry; + + $entry = Lintian::Changelog::Entry->new; + $entry->Source($UNKNOWN); + $entry->Distribution($UNKNOWN); + $entry->Urgency($UNKNOWN); + $entry->Urgency_LC($UNKNOWN); + $entry->Version($UNKNOWN . (++$unknown_version_counter)); + $entry->Urgency_Comment($EMPTY); + $entry->ERROR( + [ + $position, + "found change data where expected $expect",$line + ] + ); + } + }; + $entry->{'Changes'} .= (" \n" x $blanklines)." $line\n"; + if (!$entry->{Items} || $1 eq $ASTERISK) { + $entry->{Items} ||= []; + push @{$entry->{Items}}, "$line\n"; + } else { + $entry->{'Items'}[-1] .= (" \n" x $blanklines)." $line\n"; + } + $blanklines = 0; + $expect = 'more change data or trailer'; + + } elsif ($line !~ m/\S/) { + next + if $expect eq 'start of change data' + || $expect eq 'next heading or eof'; + $expect eq 'more change data or trailer' + || push @{$self->errors}, + [$position,"found blank line where expected $expect"]; + $blanklines++; + + } else { + push @{$self->errors}, [$position, 'unrecognised line', $line]; + ( $expect eq 'start of change data' + || $expect eq 'more change data or trailer') + && do { + # lets assume change data if we expected it + $entry->{'Changes'} .= (" \n" x $blanklines)." $line\n"; + if (!$entry->{Items}) { + $entry->{Items} ||= []; + push @{$entry->{Items}}, "$line\n"; + } else { + $entry->{'Items'}[-1] .= (" \n" x $blanklines)." $line\n"; + } + $blanklines = 0; + $expect = 'more change data or trailer'; + $entry->ERROR([$position, 'unrecognised line', $line]); + }; + } + + } continue { + ++$position; + } + + $expect eq 'next heading or eof' + || do { + $entry->ERROR([$position, "found eof where expected $expect"]); + push @{$self->errors}, $entry->ERROR; + }; + + unless ($entry->is_empty) { + $entry->Closes(find_closes($entry->Changes)); + push @{$self->entries}, $entry; + } + + return; +} + +=item errors + +=item entries + +=cut + +has errors => (is => 'rw', default => sub { [] }); +has entries => (is => 'rw', default => sub { [] }); + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Changelog/Entry.pm b/lib/Lintian/Changelog/Entry.pm new file mode 100644 index 0000000..f36cb92 --- /dev/null +++ b/lib/Lintian/Changelog/Entry.pm @@ -0,0 +1,184 @@ +# +# Lintian::Changelog::Entry +# +# Copyright (C) 2005 Frank Lichtenheld <frank@lichtenheld.de> +# Copyright (C) 2019 Felix Lechner <felix.lechner@lease-up.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, write to the Free Software +# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +# + +package Lintian::Changelog::Entry; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +use Moo; +use namespace::clean; + +const my $EMPTY => q{}; +const my $UNKNOWN => q{unknown}; + +has Changes => (is => 'rw', default => $EMPTY); +has Closes => (is => 'rw'); +has Date => (is => 'rw'); +has Distribution => (is => 'rw'); +has Header => (is => 'rw'); +#has Items => (is => 'rw', default => sub { [] }); +has Maintainer => (is => 'rw'); +has Source => (is => 'rw'); +has Timestamp => (is => 'rw'); +has Trailer => (is => 'rw'); +has Urgency => (is => 'rw', default => $UNKNOWN); +has Urgency_LC => (is => 'rw', default => $UNKNOWN); +has Urgency_Comment => (is => 'rw', default => $EMPTY); +has Version => (is => 'rw'); +has ERROR => (is => 'rw'); +has position => (is => 'rw'); + +=head1 NAME + +Lintian::Changelog::Entry - represents one entry in a Debian changelog + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +=head2 Methods + +=head3 init + +Creates a new object, no options. + +=head3 new + +Alias for init. + +=head3 is_empty + +Checks if the object is actually initialized with data. Due to limitations +in Parse::DebianChangelog this currently simply checks if one of the +fields Source, Version, Maintainer, Date, or Changes is initialized. + +=head2 Accessors + +The following fields are available via accessor functions (all +fields are string values unless otherwise noted): + +=over 4 + +=item Source + +=item Version + +=item Distribution + +=item Urgency + +=item Urgency_Comment + +=item C<Urgency_LC> + +=item C<ExtraFields> + +Extra_Fields (all fields except for urgency as hash; POD spelling forces the underscore) + +=item Header + +Header (the whole header in verbatim form) + +=item Changes + +Changes (the actual content of the bug report, in verbatim form) + +=item Trailer + +Trailer (the whole trailer in verbatim form) + +=item Closes + +Closes (Array of bug numbers) + +=item Maintainer + +=item C<MaintainerEmail> + +=item Date + +=item Timestamp + +Timestamp (Date expressed in seconds since the epoch) + +=item ERROR + +Last parse error related to this entry in the format described +at Parse::DebianChangelog::get_parse_errors. + +=item position + +=back + +=begin Pod::Coverage + +Changes +Closes +Date +Distribution +Header +Maintainer +C<MaintainerEmail> +Source +Timestamp +Trailer + +=end Pod::Coverage + +=cut + +sub is_empty { + my ($self) = @_; + + return !(length $self->Changes + || length $self->Source + || length $self->Version + || length $self->Maintainer + || length $self->Date); +} + +1; +__END__ + +=head1 SEE ALSO + +Originally based on Parse::DebianChangelog by Frank Lichtenheld, E<lt>frank@lichtenheld.deE<gt> + +=head1 AUTHOR + +Written by Felix Lechner <felix.lechner@lease-up.com> for Lintian in response to #933134. + +=head1 COPYRIGHT AND LICENSE + +Please see in the code; FSF's standard short text triggered a POD spelling error +here. + +=cut + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Changelog/Version.pm b/lib/Lintian/Changelog/Version.pm new file mode 100644 index 0000000..d0e29f4 --- /dev/null +++ b/lib/Lintian/Changelog/Version.pm @@ -0,0 +1,250 @@ +# Copyright (C) 2019 Felix Lechner <felix.lechner@lease-up.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::Changelog::Version; + +use v5.20; +use warnings; +use utf8; + +use Carp; +use Const::Fast; +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +const my $EMPTY => q{}; + +=head1 NAME + +Lintian::Changelog::Version -- Parse a literal version string into its constituents + +=head1 SYNOPSIS + + use Lintian::Changelog::Version; + + my $version = Lintian::Changelog::Version->new; + $version->assign('1.2.3-4', undef); + +=head1 DESCRIPTION + +A class for parsing literal version strings + +=head1 CLASS METHODS + +=over 4 + +=item new () + +Creates a new Lintian::Changelog::Version object. + +=cut + +=back + +=head1 INSTANCE METHODS + +=over 4 + +=item assign (LITERAL, NATIVE) + +Assign the various members in the Lintian::Changelog::Version object +using the LITERAL version string and the NATIVE boolean selector. + +=cut + +sub assign { + + my ($self, $literal, $native) = @_; + + croak encode_utf8('Literal version string required for version parsing') + unless defined $literal; + + croak encode_utf8('Native flag required for version parsing') + unless defined $native; + + my $epoch_pattern = qr/([0-9]+)/; + my $upstream_pattern = qr/([A-Za-z0-9.+\-~]+?)/; + my $maintainer_revision_pattern = qr/([A-Za-z0-9.+~]+?)/; + my $source_nmu_pattern = qr/([A-Za-z0-9.+~]+)/; + my $bin_nmu_pattern = qr/([0-9]+)/; + + my $source_pattern; + + # these capture three matches each + $source_pattern + = qr/$upstream_pattern/ + . qr/(?:-$maintainer_revision_pattern(?:\.$source_nmu_pattern)?)?/ + if !$native; + $source_pattern + = qr/()/ + . qr/$maintainer_revision_pattern/ + . qr/(?:\+nmu$source_nmu_pattern)?/ + if $native; + + my $pattern + = qr/^/ + . qr/(?:$epoch_pattern:)?/ + . qr/$source_pattern/ + . qr/(?:\+b$bin_nmu_pattern)?/. qr/$/; + + my ($epoch, $upstream, $maintainer_revision, $source_nmu, $binary_nmu) + = ($literal =~ $pattern); + + $epoch //= $EMPTY; + $upstream //= $EMPTY; + $maintainer_revision //= $EMPTY; + $source_nmu //= $EMPTY; + $binary_nmu //= $EMPTY; + + my $source_nmu_string = $EMPTY; + + $source_nmu_string = ($native ? "+nmu$source_nmu" : ".$source_nmu") + if length $source_nmu; + + my $debian_source = $maintainer_revision . $source_nmu_string; + + my $debian_no_epoch + = $debian_source . (length $binary_nmu ? "+b$binary_nmu" : $EMPTY); + + my $upstream_string = (length $upstream ? "$upstream-" : $EMPTY); + + my $no_epoch= $upstream_string . $debian_no_epoch; + + my $epoch_string = (length $epoch ? "$epoch:" : $EMPTY); + + my $reconstructed= $epoch_string . $no_epoch; + + croak encode_utf8( + "Failed to parse package version: $reconstructed ne $literal") + unless $reconstructed eq $literal; + + $self->literal($literal); + $self->epoch($epoch); + $self->no_epoch($no_epoch); + $self->upstream($upstream); + $self->maintainer_revision($maintainer_revision); + $self->debian_source($debian_source); + $self->debian_no_epoch($debian_no_epoch); + $self->source_nmu($source_nmu); + $self->binary_nmu($binary_nmu); + + my $without_source_nmu + = $epoch_string . $upstream_string . $maintainer_revision; + + $self->without_source_nmu($without_source_nmu); + + my $backport_pattern = qr/^(.*)[+~]deb(\d+)u(\d+)$/; + + my ($debian_without_backport, $backport_release, $backport_revision) + = ($self->maintainer_revision =~ $backport_pattern); + + $debian_without_backport //= $maintainer_revision; + $backport_release //= $EMPTY; + $backport_revision //= $EMPTY; + + $self->debian_without_backport($debian_without_backport); + $self->backport_release($backport_release); + $self->backport_revision($backport_revision); + + my $without_backport + = $epoch_string . $upstream_string . $debian_without_backport; + + $self->without_backport($without_backport); + + return; +} + +=item literal + +=item epoch + +=item no_epoch + +=item upstream + +=item maintainer_revision + +=item debian_source + +=item debian_no_epoch + +=item source_nmu + +=item binary_nmu + +=item without_source_nmu + +=item debian_without_backport + +=item backport_release + +=item backport_revision + +=item without_backport + +=cut + +has literal => (is => 'rw', default => $EMPTY); + +has epoch => (is => 'rw', default => $EMPTY); + +has no_epoch => (is => 'rw', default => $EMPTY); + +has upstream => (is => 'rw', default => $EMPTY); + +has maintainer_revision => (is => 'rw', default => $EMPTY); + +has debian_source => (is => 'rw', default => $EMPTY); + +has debian_no_epoch => (is => 'rw', default => $EMPTY); + +has source_nmu => (is => 'rw', default => $EMPTY); + +has binary_nmu => (is => 'rw', default => $EMPTY); + +has without_source_nmu => (is => 'rw', default => $EMPTY); + +has debian_without_backport => (is => 'rw', default => $EMPTY); + +has backport_release => (is => 'rw', default => $EMPTY); + +has backport_revision => (is => 'rw', default => $EMPTY); + +has without_backport => (is => 'rw', default => $EMPTY); + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check.pm b/lib/Lintian/Check.pm new file mode 100644 index 0000000..02e459f --- /dev/null +++ b/lib/Lintian/Check.pm @@ -0,0 +1,232 @@ +# Copyright (C) 2012 Niels Thykier <niels@thykier.net> +# Copyright (C) 2017-2018 Chris Lamb <lamby@debian.org> +# Copyright (C) 2019-2021 Felix Lechner <felix.lechner@lease-up.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; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::Hint::Annotated; +use Lintian::Hint::Pointed; + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $UNDERSCORE => q{_}; + +use Moo::Role; +use namespace::clean; + +=head1 NAME + +Lintian::Check -- Common facilities for Lintian checks + +=head1 SYNOPSIS + + use Moo; + use namespace::clean; + + with('Lintian::Check'); + +=head1 DESCRIPTION + +A class for operating Lintian checks + +=head1 INSTANCE METHODS + +=over 4 + +=item name + +=item processable + +=item group + +=item profile + +=item hints + +=cut + +has name => (is => 'rw', default => $EMPTY); +has processable => (is => 'rw', default => sub { {} }); +has group => (is => 'rw', default => sub { {} }); +has profile => (is => 'rw'); + +has hints => (is => 'rw', default => sub { [] }); + +=item data + +=cut + +sub data { + my ($self) = @_; + + return $self->profile->data; +} + +=item visit_files + +=cut + +sub visit_files { + my ($self, $index) = @_; + + my $visit_hook = 'visit' . $UNDERSCORE . $index . $UNDERSCORE . 'files'; + + return + unless $self->can($visit_hook); + + my @items = @{$self->processable->$index->sorted_list}; + + # do not look inside quilt directory + @items = grep { $_->name !~ m{^\.pc/} } @items + if $index eq 'patched'; + + # exclude Lintian's test suite from source scans + @items = grep { $_->name !~ m{^t/} } @items + if $self->processable->name eq 'lintian' && $index eq 'patched'; + + $self->$visit_hook($_) for @items; + + return; +} + +=item run + +=cut + +sub run { + my ($self) = @_; + + # do not carry over any hints + $self->hints([]); + + my $type = $self->processable->type; + + if ($type eq 'source') { + + $self->visit_files('orig'); + $self->visit_files('patched'); + } + + if ($type eq 'binary' || $type eq 'udeb') { + + $self->visit_files('control'); + $self->visit_files('installed'); + + $self->installable + if $self->can('installable'); + } + + $self->$type + if $self->can($type); + + $self->always + if $self->can('always'); + + return @{$self->hints}; +} + +=item pointed_hint + +=cut + +sub pointed_hint { + my ($self, $tag_name, $pointer, @notes) = @_; + + my $hint = Lintian::Hint::Pointed->new; + + $hint->tag_name($tag_name); + $hint->issued_by($self->name); + + my $note = stringify(@notes); + $hint->note($note); + $hint->pointer($pointer); + + push(@{$self->hints}, $hint); + + return; +} + +=item hint + +=cut + +sub hint { + my ($self, $tag_name, @notes) = @_; + + my $hint = Lintian::Hint::Annotated->new; + + $hint->tag_name($tag_name); + $hint->issued_by($self->name); + + my $note = stringify(@notes); + $hint->note($note); + + push(@{$self->hints}, $hint); + + return; +} + +=item stringify + +=cut + +sub stringify { + my (@arguments) = @_; + + # skip empty arguments + my @meaningful = grep { length } @arguments; + + # trim both ends of each item + s{^ \s+ | \s+ $}{}gx for @meaningful; + + # concatenate with spaces + my $text = join($SPACE, @meaningful) // $EMPTY; + + # escape newlines; maybe add others + $text =~ s{\n}{\\n}g; + + return $text; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et 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 diff --git a/lib/Lintian/Conffiles.pm b/lib/Lintian/Conffiles.pm new file mode 100644 index 0000000..1daa2c4 --- /dev/null +++ b/lib/Lintian/Conffiles.pm @@ -0,0 +1,162 @@ +# -*- perl -*- Lintian::Processable::Installable::Conffiles +# +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Conffiles; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +use Lintian::Conffiles::Entry; + +const my $SPACE => q{ }; +const my $NEWLINE => qq{\n}; + +const my $TRUE => 1; +const my $FALSE => 0; + +use Moo; +use namespace::clean; + +=head1 NAME + +Lintian::Conffiles - access to collected control data for conffiles + +=head1 SYNOPSIS + + use Lintian::Processable; + +=head1 DESCRIPTION + +Lintian::Conffiles provides an interface to control data for conffiles. + +=head1 INSTANCE METHODS + +=over 4 + +=item by_file + +=cut + +has by_file => (is => 'rw', default => sub { {} }); + +=item parse + +=cut + +sub parse { + my ($self, $item) = @_; + + return + unless $item && $item->is_valid_utf8; + + my @lines = split($NEWLINE, $item->decoded_utf8); + + # dpkg strips whitespace (using isspace) from the right hand + # side of the file name. + + # trim right + s/\s+$// for @lines; + + my $position = 1; + for my $line (@lines) { + + next + unless length $line; + + my @words = split($SPACE, $line); + my $relative = pop @words; + + my $conffile = Lintian::Conffiles::Entry->new; + + # path must be absolute + if ($relative =~ s{^ / }{}x) { + $conffile->is_relative($FALSE); + } else { + $conffile->is_relative($TRUE); + } + + $conffile->instructions(\@words); + $conffile->position($position); + + # but use relative path as key + $self->by_file->{$relative} //= []; + push(@{$self->by_file->{$relative}}, $conffile); + + } continue { + ++$position; + } + + return; +} + +=item all + +Returns a list of absolute filenames found for conffiles. + +=cut + +sub all { + my ($self) = @_; + + return keys %{$self->by_file}; +} + +=item is_known (FILE) + +Returns a truth value if FILE is listed in the conffiles control file. +If the control file is not present or FILE is not listed in it, it +returns C<undef>. + +Note that FILE should be the filename relative to the package root +(even though the control file uses absolute paths). If the control +file does relative paths, they are assumed to be relative to the +package root as well (and used without warning). + +=cut + +sub is_known { + my ($self, $relative) = @_; + + return 1 + if exists $self->by_file->{$relative}; + + return 0; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for +Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Conffiles/Entry.pm b/lib/Lintian/Conffiles/Entry.pm new file mode 100644 index 0000000..488cd99 --- /dev/null +++ b/lib/Lintian/Conffiles/Entry.pm @@ -0,0 +1,72 @@ +# -*- perl -*- Lintian::Conffiles::Entry +# +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Conffiles::Entry; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +=head1 NAME + +Lintian::Conffiles::Entry - access to collected control data for conffiles + +=head1 SYNOPSIS + + use Lintian::Processable; + +=head1 DESCRIPTION + +Lintian::Conffiles::Entry provides an interface to control data for conffiles. + +=head1 INSTANCE METHODS + +=over 4 + +=item instructions +=item is_relative +=item position + +=cut + +has instructions => (is => 'rw', default => sub { [] }); +has is_relative => (is => 'rw'); +has position => (is => 'rw'); + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for +Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Data.pm b/lib/Lintian/Data.pm new file mode 100644 index 0000000..6a0b227 --- /dev/null +++ b/lib/Lintian/Data.pm @@ -0,0 +1,354 @@ +# Copyright (C) 2011 Niels Thykier <niels@thykier.net> +# Copyright (C) 2018 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# Copyright (C) 2022 Axel Beckert +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, you can find it on the World Wide +# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Data; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(croak); +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::Data::Architectures; +use Lintian::Data::Archive::AutoRejection; +use Lintian::Data::Archive::Sections; +use Lintian::Data::Buildflags::Hardening; +use Lintian::Data::Debhelper::Addons; +use Lintian::Data::Debhelper::Commands; +use Lintian::Data::Debhelper::Levels; +use Lintian::Data::Fonts; +use Lintian::Data::InitD::VirtualFacilities; +use Lintian::Data::Policy::Releases; +use Lintian::Data::Provides::MailTransportAgent; +use Lintian::Data::Stylesheet; +use Lintian::Data::Traditional; + +use Moo; +use namespace::clean; + +with 'Lintian::Data::Authorities'; + +=head1 NAME + +Lintian::Data - Data parser for Lintian + +=head1 SYNOPSIS + + my $profile = Lintian::Data->new (vendor => 'debian'); + +=head1 DESCRIPTION + +Lintian::Data handles finding, parsing and implementation of Lintian Data + +=head1 INSTANCE METHODS + +=over 4 + +=item vendor + +=item data_paths + +=item data_cache + +=cut + +has vendor => (is => 'rw'); + +has data_paths => ( + is => 'rw', + coerce => sub { my ($arrayref) = @_; return ($arrayref // []); }, + default => sub { [] } +); + +has data_cache => ( + is => 'rw', + coerce => sub { my ($hashref) = @_; return ($hashref // {}); }, + default => sub { {} } +); + +=item load + +=cut + +sub load { + my ($self, $location, $separator) = @_; + + croak encode_utf8('no data type specified') + unless $location; + + unless (exists $self->data_cache->{$location}) { + + my $cache = Lintian::Data::Traditional->new; + $cache->location($location); + $cache->separator($separator); + + $cache->load($self->data_paths, $self->vendor); + + $self->data_cache->{$location} = $cache; + } + + return $self->data_cache->{$location}; +} + +=item all_sources + +=cut + +sub all_sources { + my ($self) = @_; + + my @sources = ( + $self->architectures,$self->auto_rejection, + $self->debhelper_addons,$self->debhelper_commands, + $self->debhelper_levels,$self->fonts, + $self->hardening_buildflags,$self->mail_transport_agents, + $self->policy_releases,$self->sections, + #$self->style_sheet, + $self->virtual_initd_facilities + ); + + return @sources; +} + +=item architectures + +=cut + +has architectures => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $architectures = Lintian::Data::Architectures->new; + $architectures->load($self->data_paths, $self->vendor); + + return $architectures; + } +); + +=item auto_rejection + +=cut + +has auto_rejection => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $auto_rejection = Lintian::Data::Archive::AutoRejection->new; + $auto_rejection->load($self->data_paths, $self->vendor); + + return $auto_rejection; + } +); + +=item debhelper_addons + +=cut + +has debhelper_addons => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $addons = Lintian::Data::Debhelper::Addons->new; + $addons->load($self->data_paths, $self->vendor); + + return $addons; + } +); + +=item debhelper_commands + +=cut + +has debhelper_commands => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $commands = Lintian::Data::Debhelper::Commands->new; + $commands->load($self->data_paths, $self->vendor); + + return $commands; + } +); + +=item debhelper_levels + +=cut + +has debhelper_levels => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $levels = Lintian::Data::Debhelper::Levels->new; + $levels->load($self->data_paths, $self->vendor); + + return $levels; + } +); + +=item fonts + +=cut + +has fonts => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $fonts = Lintian::Data::Fonts->new; + $fonts->load($self->data_paths, $self->vendor); + + return $fonts; + } +); + +=item hardening_buildflags + +=cut + +has hardening_buildflags => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $buildflags = Lintian::Data::Buildflags::Hardening->new; + $buildflags->load($self->data_paths, $self->vendor); + + return $buildflags; + } +); + +=item mail_transport_agents + +=cut + +has mail_transport_agents => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $manual = Lintian::Data::Provides::MailTransportAgent->new; + $manual->load($self->data_paths, $self->vendor); + + return $manual; + } +); + +=item policy_releases + +=cut + +has policy_releases => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $releases = Lintian::Data::Policy::Releases->new; + $releases->load($self->data_paths, $self->vendor); + + return $releases; + } +); + +=item sections + +=cut + +has sections => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $sections = Lintian::Data::Archive::Sections->new; + $sections->load($self->data_paths, $self->vendor); + + return $sections; + } +); + +=item style_sheet + +=cut + +has style_sheet => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $stylesheets = Lintian::Data::Stylesheet->new; + $stylesheets->load($self->data_paths, $self->vendor); + + return $stylesheets; + } +); + +=item virtual_initd_facilities + +=cut + +has virtual_initd_facilities => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $facilities = Lintian::Data::InitD::VirtualFacilities->new; + $facilities->load($self->data_paths, $self->vendor); + + return $facilities; + } +); + +=back + +=head1 AUTHOR + +Originally written by Niels Thykier <niels@thykier.net> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Data/Architectures.pm b/lib/Lintian/Data/Architectures.pm new file mode 100644 index 0000000..c45ced4 --- /dev/null +++ b/lib/Lintian/Data/Architectures.pm @@ -0,0 +1,441 @@ +# -*- perl -*- + +# Copyright (C) 2011-2012 Niels Thykier <niels@thykier.net> +# - Based on a shell script by Raphael Geissert <atomo64@gmail.com> +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Data::Architectures; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(first_value); +use Unicode::UTF8 qw(decode_utf8); + +use Lintian::IPC::Run3 qw(safe_qx); + +const my $EMPTY => q{}; +const my $SLASH => q{/}; + +const my $HOST_VARIABLES => q{host_variables}; + +use Moo; +use namespace::clean; + +with 'Lintian::Data::PreambledJSON'; + +=encoding utf-8 + +=head1 NAME + +Lintian::Data::Architectures -- Lintian API for handling architectures and wildcards + +=head1 SYNOPSIS + + use Lintian::Data::Architectures; + +=head1 DESCRIPTION + +Lintian API for checking and expanding architectures and architecture +wildcards. The functions are backed by a L<data|Lintian::Data> file, +so it may be out of date (use private/refresh-archs to update it). + +Generally all architecture names are in the format "$os-$architecture" and +wildcards are "$os-any" or "any-$cpu", though there are exceptions: + +Note that the architecture and cpu name are not always identical +(example architecture "armhf" has cpu name "arm"). + +=head1 INSTANCE METHODS + +=over 4 + +=item title + +=item location + +=item host_variables + +=item C<wildcards> + +=item C<names> + +=cut + +has title => ( + is => 'rw', + default => 'DEB_HOST_* Variables from Dpkg' +); + +has location => ( + is => 'rw', + default => 'architectures/host.json' +); + +has host_variables => ( + is => 'rw', + default => sub { {} }, + coerce => sub { my ($hashref) = @_; return ($hashref // {}); } +); + +has deb_host_multiarch => ( + is => 'rw', + lazy => 1, + coerce => sub { my ($hashref) = @_; return ($hashref // {}); }, + default => sub { + my ($self) = @_; + + my %deb_host_multiarch; + + $deb_host_multiarch{$_} + = $self->host_variables->{$_}{DEB_HOST_MULTIARCH} + for keys %{$self->host_variables}; + + return \%deb_host_multiarch; + } +); + +# The list of directories searched by default by the dynamic linker. +# Packages installing shared libraries into these directories must call +# ldconfig, must have shlibs files, and must ensure those libraries have +# proper SONAMEs. +# +# Directories listed here must not have leading slashes. +# +# On the topic of multi-arch dirs. Hopefully including the ones not +# native to the local platform won't hurt. +# +# See Bug#469301 and Bug#464796 for more details. +# +has ldconfig_folders => ( + is => 'rw', + lazy => 1, + coerce => sub { my ($arrayref) = @_; return ($arrayref // {}); }, + default => sub { + my ($self) = @_; + + my @multiarch = values %{$self->deb_host_multiarch}; + my @ldconfig_folders = map { ("lib/$_", "usr/lib/$_") } @multiarch; + + my @always = qw{ + lib + lib32 + lib64 + libx32 + usr/lib + usr/lib32 + usr/lib64 + usr/libx32 + usr/local/lib + }; + push(@ldconfig_folders, @always); + + my @with_slash = map { $_ . $SLASH } @ldconfig_folders; + + return \@with_slash; + } +); + +# Valid architecture wildcards. +has wildcards => ( + is => 'rw', + lazy => 1, + coerce => sub { my ($hashref) = @_; return ($hashref // {}); }, + default => sub { + my ($self) = @_; + + my %wildcards; + + for my $hyphenated (keys %{$self->host_variables}) { + + my $variables = $self->host_variables->{$hyphenated}; + + # NB: "$os-$cpu" is not always equal to $hyphenated + my $abi = $variables->{DEB_HOST_ARCH_ABI}; + my $libc = $variables->{DEB_HOST_ARCH_LIBC}; + my $os = $variables->{DEB_HOST_ARCH_OS}; + my $cpu = $variables->{DEB_HOST_ARCH_CPU}; + + # map $os-any (e.g. "linux-any") and any-$architecture (e.g. "any-amd64") to + # the relevant architectures. + $wildcards{'any'}{$hyphenated} = 1; + + $wildcards{'any-any'}{$hyphenated} = 1; + $wildcards{"any-$cpu"}{$hyphenated} = 1; + $wildcards{"$os-any"}{$hyphenated} = 1; + + $wildcards{'any-any-any'}{$hyphenated} = 1; + $wildcards{"any-any-$cpu"}{$hyphenated} = 1; + $wildcards{"any-$os-any"}{$hyphenated} = 1; + $wildcards{"any-$os-$cpu"}{$hyphenated} = 1; + $wildcards{"$libc-any-any"}{$hyphenated} = 1; + $wildcards{"$libc-any-$cpu"}{$hyphenated} = 1; + $wildcards{"$libc-$os-any"}{$hyphenated} = 1; + + $wildcards{'any-any-any-any'}{$hyphenated} = 1; + $wildcards{"any-any-any-$cpu"}{$hyphenated} = 1; + $wildcards{"any-any-$os-any"}{$hyphenated} = 1; + $wildcards{"any-any-$os-$cpu"}{$hyphenated} = 1; + $wildcards{"any-$libc-any-any"}{$hyphenated} = 1; + $wildcards{"any-$libc-any-$cpu"}{$hyphenated} = 1; + $wildcards{"any-$libc-$os-any"}{$hyphenated} = 1; + $wildcards{"any-$libc-$os-$cpu"}{$hyphenated} = 1; + $wildcards{"$abi-any-any-any"}{$hyphenated} = 1; + $wildcards{"$abi-any-any-$cpu"}{$hyphenated} = 1; + $wildcards{"$abi-any-$os-any"}{$hyphenated} = 1; + $wildcards{"$abi-any-$os-$cpu"}{$hyphenated} = 1; + $wildcards{"$abi-$libc-any-any"}{$hyphenated} = 1; + $wildcards{"$abi-$libc-any-$cpu"}{$hyphenated} = 1; + $wildcards{"$abi-$libc-$os-any"}{$hyphenated} = 1; + } + + return \%wildcards; + } +); + +# Maps aliases to the "original" arch name. +# (e.g. "linux-amd64" => "amd64") +has names => ( + is => 'rw', + lazy => 1, + coerce => sub { my ($hashref) = @_; return ($hashref // {}); }, + default => sub { + my ($self) = @_; + + my %names; + + for my $hyphenated (keys %{$self->host_variables}) { + + my $variables = $self->host_variables->{$hyphenated}; + + $names{$hyphenated} = $hyphenated; + + # NB: "$os-$cpu" ne $hyphenated in some cases + my $os = $variables->{DEB_HOST_ARCH_OS}; + my $cpu = $variables->{DEB_HOST_ARCH_CPU}; + + if ($os eq 'linux') { + + # Per Policy section 11.1 (3.9.3): + # + #"""[architecture] strings are in the format "os-arch", though + # the OS part is sometimes elided, as when the OS is Linux.""" + # + # i.e. "linux-amd64" and "amd64" are aliases, so handle them + # as such. Currently, dpkg-architecture -L gives us "amd64" + # but in case it changes to "linux-amd64", we are prepared. + + if ($hyphenated =~ /^linux-/) { + # It may be temping to use $cpu here, but it does not work + # for (e.g.) arm based architectures. Instead extract the + # "short" architecture name from $hyphenated + my (undef, $short) = split(/-/, $hyphenated, 2); + $names{$short} = $hyphenated; + + } else { + # short string in $hyphenated + my $long = "$os-$hyphenated"; + $names{$long} = $hyphenated; + } + } + } + + return \%names; + } +); + +=item is_wildcard ($wildcard) + +Returns a truth value if $wildcard is a known architecture wildcard. + +Note: 'any' is considered a wildcard and not an architecture. + +=cut + +sub is_wildcard { + my ($self, $wildcard) = @_; + + return exists $self->wildcards->{$wildcard}; +} + +=item is_release_architecture ($architecture) + +Returns a truth value if $architecture is (an alias of) a Debian machine +architecture. It returns a false value for +architecture wildcards (including "any") and unknown architectures. + +=cut + +sub is_release_architecture { + my ($self, $architecture) = @_; + + return exists $self->names->{$architecture}; +} + +=item expand_wildcard ($wildcard) + +Returns a list of architectures that this wildcard expands to. No +order is guaranteed (even between calls). Returned values must not be +modified. + +Note: This list is based on the architectures in Lintian's data file. +However, many of these are not supported or used in Debian or any of +its derivatives. + +The returned values matches the list generated by dpkg-architecture -L, +so the returned list may use (e.g.) "amd64" for "linux-amd64". + +=cut + +sub expand_wildcard { + my ($self, $wildcard) = @_; + + return keys %{ $self->wildcards->{$wildcard} // {} }; +} + +=item wildcard_includes ($wildcard, $architecture) + +Returns a truth value if $architecture is included in the list of +architectures that $wildcard expands to. + +This is generally faster than + + grep { $_ eq $architecture } expand_arch_wildcard ($wildcard) + +It also properly handles cases like "linux-amd64" and "amd64" being +aliases. + +=cut + +sub wildcard_includes { + my ($self, $wildcard, $architecture) = @_; + + $architecture = $self->names->{$architecture} + if exists $self->names->{$architecture}; + + return exists $self->wildcards->{$wildcard}{$architecture}; +} + +=item valid_restriction + +=cut + +sub valid_restriction { + my ($self, $restriction) = @_; + + # strip any negative prefix + $restriction =~ s/^!//; + + return + $self->is_release_architecture($restriction) + || $self->is_wildcard($restriction) + || $restriction eq 'all'; +} + +=item restriction_matches + +=cut + +sub restriction_matches { + my ($self, $restriction, $architecture) = @_; + + # look for negative prefix and strip + my $match_wanted = !($restriction =~ s/^!//); + + return $match_wanted + if $restriction eq $architecture; + + return $match_wanted + if $self->is_wildcard($restriction) + && $self->wildcard_includes($restriction, $architecture); + + return !$match_wanted; +} + +=item load + +=cut + +sub load { + my ($self, $search_space, $our_vendor) = @_; + + my @candidates = map { $_ . $SLASH . $self->location } @{$search_space}; + my $path = first_value { -e } @candidates; + + my $host_variables; + + return 0 + unless $self->read_file($path, \$host_variables); + + $self->host_variables($host_variables); + + return 1; +} + +=item refresh + +=cut + +sub refresh { + my ($self, $archive, $basedir) = @_; + + local $ENV{LC_ALL} = 'C'; + delete local $ENV{DEB_HOST_ARCH}; + + my @architectures + = split(/\n/, decode_utf8(safe_qx(qw{dpkg-architecture --list-known}))); + chomp for @architectures; + + my %host_variables; + for my $architecture (@architectures) { + + my @lines= split( + /\n/, + decode_utf8( + safe_qx(qw{dpkg-architecture --host-arch}, $architecture) + ) + ); + + for my $line (@lines) { + my ($key, $value) = split(/=/, $line, 2); + + $host_variables{$architecture}{$key} = $value + if $key =~ /^DEB_HOST_/; + } + } + + $self->cargo('host_variables'); + + my $data_path = "$basedir/" . $self->location; + my $status + = $self->write_file($HOST_VARIABLES, \%host_variables, $data_path); + + return $status; +} + +=back + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Data/Archive/AutoRejection.pm b/lib/Lintian/Data/Archive/AutoRejection.pm new file mode 100644 index 0000000..d05ae51 --- /dev/null +++ b/lib/Lintian/Data/Archive/AutoRejection.pm @@ -0,0 +1,154 @@ +# -*- 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Data::Archive::AutoRejection; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(carp); +use Const::Fast; +use HTTP::Tiny; +use List::SomeUtils qw(first_value uniq); +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8); +use YAML::XS qw(LoadFile); + +const my $EMPTY => q{}; +const my $SLASH => q{/}; + +use Moo; +use namespace::clean; + +=head1 NAME + +Lintian::Data::Archive::AutoRejection - Lintian interface to the archive's auto-rejection tags + +=head1 SYNOPSIS + + use Lintian::Data::Archive::AutoRejection; + +=head1 DESCRIPTION + +This module provides a way to load data files for the archive's auto-rejection tags + +=head1 INSTANCE METHODS + +=over 4 + +=item title + +=item location + +=item certain + +=item preventable + +=cut + +has title => ( + is => 'rw', + default => 'Archive Auto-Rejection Tags' +); + +has location => ( + is => 'rw', + default => 'archive/auto-rejection.yaml' +); + +has certain => (is => 'rw', default => sub { [] }); +has preventable => (is => 'rw', default => sub { [] }); + +=item load + +=cut + +sub load { + my ($self, $search_space, $our_vendor) = @_; + + my @candidates = map { $_ . $SLASH . $self->location } @{$search_space}; + my $path = first_value { -e } @candidates; + + unless (length $path) { + carp encode_utf8('Unknown data file: ' . $self->location); + return; + } + + my $yaml = LoadFile($path); + die encode_utf8('Could not parse YAML file ' . $self->location) + unless defined $yaml; + + my $base = $yaml->{lintian}; + die encode_utf8('Could not parse document base for ' . $self->location) + unless defined $base; + + my @certain = uniq @{ $base->{fatal} // [] }; + my @preventable = uniq @{ $base->{nonfatal} // [] }; + + $self->certain(\@certain); + $self->preventable(\@preventable); + + return; +} + +=item refresh + +=cut + +sub refresh { + my ($self, $archive, $basedir) = @_; + + my $auto_rejection_url + = 'https://ftp-master.debian.org/static/lintian.tags'; + + my $response = HTTP::Tiny->new->get($auto_rejection_url); + die encode_utf8("Failed to get $auto_rejection_url!\n") + unless $response->{success}; + + my $auto_rejection_yaml = $response->{content}; + + my $data_path = "$basedir/" . $self->location; + my $parent_dir = path($data_path)->parent->stringify; + path($parent_dir)->mkpath + unless -e $parent_dir; + + # already in UTF-8 + path($data_path)->spew($auto_rejection_yaml); + + return 1; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Data/Archive/Sections.pm b/lib/Lintian/Data/Archive/Sections.pm new file mode 100644 index 0000000..24a99c7 --- /dev/null +++ b/lib/Lintian/Data/Archive/Sections.pm @@ -0,0 +1,133 @@ +# -*- perl -*- +# +# Copyright (C) 2021 Felix Lechner +# Copyright (C) 2022 Axel Beckert +# +# This program is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by the Free +# Software Foundation; either version 2 of the License, or (at your option) +# any later version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +# FITNESS FOR A PARTICULAR PURPOSE. See the GNU 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::Data::Archive::Sections; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(carp); +use Const::Fast; +use HTTP::Tiny; +use List::SomeUtils qw(first_value uniq); +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8); +use Lintian::Deb822; + +const my $EMPTY => q{}; +const my $SLASH => q{/}; + +use Moo; +use namespace::clean; + +with 'Lintian::Data::JoinedLines'; + +=head1 NAME + +Lintian::Data::Archive::Sections - Lintian interface to the archive's sections + +=head1 SYNOPSIS + + use Lintian::Data::Archive::Sections; + +=head1 DESCRIPTION + +This module provides a way to load the data file for the archive's section. + +=head1 INSTANCE METHODS + +=over 4 + +=item title + +=cut + +has title => ( + is => 'rw', + default => 'Archive Sections' +); + +=item location + +=cut + +has location => ( + is => 'rw', + default => 'fields/archive-sections' +); + +=item separator + +=cut + +has separator => (is => 'rw'); + +=item refresh + +=cut + +sub refresh { + my ($self, $archive, $basedir) = @_; + + my $sections_url = 'https://metadata.ftp-master.debian.org/sections.822'; + + my $response = HTTP::Tiny->new->get($sections_url); + die encode_utf8("Failed to get $sections_url!\n") + unless $response->{success}; + + my $sections_822 = $response->{content}; + + # TODO: We should probably save this in the original format and + # parse it with Lintian::Deb822 at some time. + my $sections = join("\n", + map { s/^Section: //r } + grep { m{^Section: [^/]*$} } + split(/\n/, $sections_822)) + ."\n"; + + my $data_path = "$basedir/" . $self->location; + my $parent_dir = path($data_path)->parent->stringify; + path($parent_dir)->mkpath + unless -e $parent_dir; + + # already in UTF-8 + path($data_path)->spew($sections); + + return 1; +} + +=back + +=head1 AUTHOR + +Originally written by Axel Beckert <abe@debian.org> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Data/Authorities.pm b/lib/Lintian/Data/Authorities.pm new file mode 100644 index 0000000..fdb77cd --- /dev/null +++ b/lib/Lintian/Data/Authorities.pm @@ -0,0 +1,330 @@ +# Copyright (C) 2011 Niels Thykier <niels@thykier.net> +# 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::Data::Authorities; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +use Lintian::Data::Authority::DebconfSpecification; +use Lintian::Data::Authority::DebianPolicy; +use Lintian::Data::Authority::DeveloperReference; +use Lintian::Data::Authority::DocBaseManual; +use Lintian::Data::Authority::FilesystemHierarchy; +use Lintian::Data::Authority::JavaPolicy; +use Lintian::Data::Authority::LintianManual; +use Lintian::Data::Authority::MenuPolicy; +use Lintian::Data::Authority::MenuManual; +use Lintian::Data::Authority::NewMaintainer; +use Lintian::Data::Authority::PerlPolicy; +use Lintian::Data::Authority::PythonPolicy; +use Lintian::Data::Authority::VimPolicy; + +const my $EMPTY => q{}; + +use Moo::Role; +use namespace::clean; + +=head1 NAME + +Lintian::Data::Authorities - Lintian's Reference Authorities + +=head1 SYNOPSIS + + my $data = Lintian::Data->new; + +=head1 DESCRIPTION + +Lintian::Data::Authorities handles finding, parsing and implementation of Lintian reference authorities + +=head1 INSTANCE METHODS + +=over 4 + +=item markdown_authority_reference + +=cut + +sub markdown_authority_reference { + my ($self, $volume, $section) = @_; + + my @MARKDOWN_CAPABLE = ( + $self->new_maintainer,$self->menu_policy, + $self->perl_policy,$self->python_policy, + $self->java_policy,$self->vim_policy, + $self->lintian_manual,$self->developer_reference, + $self->policy_manual,$self->debconf_specification, + $self->menu_manual,$self->doc_base_manual, + $self->filesystem_hierarchy_standard, + ); + + my %by_shorthand = map { $_->shorthand => $_ } @MARKDOWN_CAPABLE; + + return $EMPTY + unless exists $by_shorthand{$volume}; + + my $manual = $by_shorthand{$volume}; + + return $manual->markdown_citation($section); +} + +=item debconf_specification + +=cut + +has debconf_specification => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $manual = Lintian::Data::Authority::DebconfSpecification->new; + $manual->load($self->data_paths, $self->vendor); + + return $manual; + } +); + +=item developer_reference + +=cut + +has developer_reference => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $manual = Lintian::Data::Authority::DeveloperReference->new; + $manual->load($self->data_paths, $self->vendor); + + return $manual; + } +); + +=item doc_base_manual + +=cut + +has doc_base_manual => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $manual = Lintian::Data::Authority::DocBaseManual->new; + $manual->load($self->data_paths, $self->vendor); + + return $manual; + } +); + +=item filesystem_hierarchy_standard + +=cut + +has filesystem_hierarchy_standard => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $manual= Lintian::Data::Authority::FilesystemHierarchy->new; + $manual->load($self->data_paths, $self->vendor); + + return $manual; + } +); + +=item java_policy + +=cut + +has java_policy => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $manual = Lintian::Data::Authority::JavaPolicy->new; + $manual->load($self->data_paths, $self->vendor); + + return $manual; + } +); + +=item lintian_manual + +=cut + +has lintian_manual => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $manual = Lintian::Data::Authority::LintianManual->new; + $manual->load($self->data_paths, $self->vendor); + + return $manual; + } +); + +=item menu_manual + +=cut + +has menu_manual => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $manual = Lintian::Data::Authority::MenuManual->new; + $manual->load($self->data_paths, $self->vendor); + + return $manual; + } +); + +=item menu_policy + +=cut + +has menu_policy => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $manual = Lintian::Data::Authority::MenuPolicy->new; + $manual->load($self->data_paths, $self->vendor); + + return $manual; + } +); + +=item menu_policy + +=cut + +has new_maintainer => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $manual = Lintian::Data::Authority::NewMaintainer->new; + $manual->load($self->data_paths, $self->vendor); + + return $manual; + } +); + +=item perl_policy + +=cut + +has perl_policy => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $manual = Lintian::Data::Authority::PerlPolicy->new; + $manual->load($self->data_paths, $self->vendor); + + return $manual; + } +); + +=item policy_manual + +=cut + +has policy_manual => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $manual = Lintian::Data::Authority::DebianPolicy->new; + $manual->load($self->data_paths, $self->vendor); + + return $manual; + } +); + +=item python_policy + +=cut + +has python_policy => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $manual = Lintian::Data::Authority::PythonPolicy->new; + $manual->load($self->data_paths, $self->vendor); + + return $manual; + } +); + +=item vim_policy + +=cut + +has vim_policy => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $manual = Lintian::Data::Authority::VimPolicy->new; + $manual->load($self->data_paths, $self->vendor); + + return $manual; + } +); + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Data/Authority/DebconfSpecification.pm b/lib/Lintian/Data/Authority/DebconfSpecification.pm new file mode 100644 index 0000000..661d11e --- /dev/null +++ b/lib/Lintian/Data/Authority/DebconfSpecification.pm @@ -0,0 +1,328 @@ +# -*- perl -*- +# +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2001 Colin Watson +# Copyright (C) 2008 Jorda Polo +# Copyright (C) 2009 Russ Allbery +# Copyright (C) 2017-2019 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Data::Authority::DebconfSpecification; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(croak); +use Const::Fast; +use File::Basename qw(dirname); +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8); +use WWW::Mechanize (); + +use Lintian::Output::Markdown qw(markdown_authority); + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $SLASH => q{/}; +const my $COLON => q{:}; +const my $UNDERSCORE => q{_}; +const my $LEFT_PARENTHESIS => q{(}; +const my $RIGHT_PARENTHESIS => q{)}; + +const my $TWO_PARTS => 2; + +const my $VOLUME_KEY => $UNDERSCORE; +const my $SEPARATOR => $COLON x 2; + +use Moo; +use namespace::clean; + +with 'Lintian::Data::JoinedLines'; + +=head1 NAME + +Lintian::Data::Authority::DebconfSpecification - Lintian interface for manual references + +=head1 SYNOPSIS + + use Lintian::Data::Authority::DebconfSpecification; + +=head1 DESCRIPTION + +Lintian::Data::Authority::DebconfSpecification provides a way to load data files for +manual references. + +=head1 CLASS METHODS + +=over 4 + +=item title + +=item shorthand + +=item location + +=item separator + +=cut + +has title => ( + is => 'rw', + default => 'Debconf Specification' +); + +has shorthand => ( + is => 'rw', + default => 'debconf-specification' +); + +has location => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return 'authority/' . $self->shorthand; + } +); + +has separator => ( + is => 'rw', + default => sub { qr/::/ } +); + +=item consumer + +=cut + +sub consumer { + my ($self, $key, $remainder, $previous) = @_; + + return undef + if defined $previous; + + my ($title, $url)= split($self->separator, $remainder, $TWO_PARTS); + + my %entry; + $entry{title} = $title; + $entry{url} = $url; + + return \%entry; +} + +=item markdown_citation + +=cut + +sub markdown_citation { + my ($self, $section_key) = @_; + + croak "Invalid section $section_key" + if $section_key eq $VOLUME_KEY; + + my $volume_entry = $self->value($VOLUME_KEY); + + # start with the citation to the overall manual. + my $volume_title = $volume_entry->{title}; + my $volume_url = $volume_entry->{url}; + + my $section_title; + my $section_url; + + if ($self->recognizes($section_key)) { + + my $section_entry = $self->value($section_key); + + $section_title = $section_entry->{title}; + $section_url = $section_entry->{url}; + } + + return markdown_authority( + $volume_title, $volume_url,$section_key, + $section_title, $section_url + ); +} + +=item write_line + +=cut + +sub write_line { + my ($data_fd, $section_key, $section_title, $destination) = @_; + + # drop final dots + $section_key =~ s{ [.]+ $}{}x; + + # reduce consecutive whitespace + $section_title =~ s{ \s+ }{ }gx; + + my $line= join($SEPARATOR,$section_key, $section_title, $destination); + + say {$data_fd} encode_utf8($line); + + return; +} + +=item write_data_file + +=cut + +sub write_data_file { + my ($self, $basedir, $generated) = @_; + + my $header =<<"HEADER"; +# Data about titles, sections, and URLs of manuals, used to expand references +# in tag descriptions and add links for HTML output. Each line of this file +# has three fields separated by double colons: +# +# <section> :: <title> :: <url> +# +# If <section> is an underscore, that line specifies the title and URL for the +# whole manual. + +HEADER + + my $data_path = "$basedir/" . $self->location; + my $parent_dir = path($data_path)->parent->stringify; + path($parent_dir)->mkpath + unless -e $parent_dir; + + my $output = encode_utf8($header) . $generated; + path($data_path)->spew($output); + + return; +} + +=item extract_sections_from_links + +=cut + +sub extract_sections_from_links { + my ($self, $data_fd, $base_url, $page_name)= @_; + + my $page_url = $base_url . $page_name; + + my $mechanize = WWW::Mechanize->new(); + $mechanize->get($page_url); + + my $page_title = $mechanize->title; + + # strip explanatory remark + $page_title =~ s{ \s* \N{EM DASH} .* $}{}x; + + # underscore is a token for the whole page + write_line($data_fd, $VOLUME_KEY, $page_title, $page_url); + + my %by_section_key; + my $in_appendix = 0; + + # https://stackoverflow.com/a/254687 + for my $link ($mechanize->links) { + + next + unless length $link->text; + + next + if $link->text !~ qr{^ \s* ([.\d]+) \s+ (.+) $}x; + + my $section_key = $1; + my $section_title = $2; + + # drop final dots + $section_key =~ s{ [.]+ $}{}x; + + # reduce consecutive whitespace + $section_title =~ s{ \s+ }{ }gx; + + my $relative_destination = $link->url; + + my $destination_base = $page_url; + $destination_base = dirname($page_url) . $SLASH + unless $destination_base =~ m{ / $}x + || $relative_destination =~ m{^ [#] }x; + + my $full_destination = $destination_base . $relative_destination; + + next + if exists $by_section_key{$section_key} + && ( $by_section_key{$section_key}{title} eq $section_title + || $by_section_key{$section_key}{destination} eq$full_destination); + + # Some manuals reuse section numbers for different references, + # e.g. the Debian Policy's normal and appendix sections are + # numbers that clash with each other. Track if we've already + # seen a section pointing to some other URL than the current one, + # and prepend it with an indicator + $in_appendix = 1 + if exists $by_section_key{$section_key} + && $by_section_key{$section_key}{destination} ne$full_destination; + + $section_key = "appendix-$section_key" + if $in_appendix; + + $by_section_key{$section_key}{title} = $section_title; + $by_section_key{$section_key}{destination} = $full_destination; + + write_line($data_fd, $section_key, $section_title, $full_destination); + } + + return; +} + +=item refresh + +=cut + +sub refresh { + my ($self, $archive, $basedir) = @_; + + # single page + my $base_url = 'https://www.debian.org/doc/packaging-manuals/'; + my $index_name = 'debconf_specification.html'; + + my $generated; + open(my $memory_fd, '>', \$generated) + or die encode_utf8('Cannot open scalar'); + + $self->extract_sections_from_links($memory_fd, $base_url, $index_name); + + close $memory_fd; + + $self->write_data_file($basedir, $generated); + + return; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Data/Authority/DebianPolicy.pm b/lib/Lintian/Data/Authority/DebianPolicy.pm new file mode 100644 index 0000000..177b07d --- /dev/null +++ b/lib/Lintian/Data/Authority/DebianPolicy.pm @@ -0,0 +1,321 @@ +# -*- perl -*- +# +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2001 Colin Watson +# Copyright (C) 2008 Jorda Polo +# Copyright (C) 2009 Russ Allbery +# Copyright (C) 2017-2019 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Data::Authority::DebianPolicy; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(croak); +use Const::Fast; +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8); +use WWW::Mechanize (); + +use Lintian::Output::Markdown qw(markdown_authority); + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $SLASH => q{/}; +const my $COLON => q{:}; +const my $UNDERSCORE => q{_}; +const my $LEFT_PARENTHESIS => q{(}; +const my $RIGHT_PARENTHESIS => q{)}; + +const my $TWO_PARTS => 2; + +const my $VOLUME_KEY => $UNDERSCORE; +const my $SEPARATOR => $COLON x 2; + +use Moo; +use namespace::clean; + +with 'Lintian::Data::JoinedLines'; + +=head1 NAME + +Lintian::Data::Authority::DebianPolicy - Lintian interface for manual references + +=head1 SYNOPSIS + + use Lintian::Data::Authority::DebianPolicy; + +=head1 DESCRIPTION + +Lintian::Data::Authority::DebianPolicy provides a way to load data files for +manual references. + +=head1 CLASS METHODS + +=over 4 + +=item title + +=item shorthand + +=item location + +=item separator + +=cut + +has title => ( + is => 'rw', + default => 'Debian Policy' +); + +has shorthand => ( + is => 'rw', + default => 'debian-policy' +); + +has location => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return 'authority/' . $self->shorthand; + } +); + +has separator => ( + is => 'rw', + default => sub { qr/::/ } +); + +=item consumer + +=cut + +sub consumer { + my ($self, $key, $remainder, $previous) = @_; + + return undef + if defined $previous; + + my ($title, $url)= split($self->separator, $remainder, $TWO_PARTS); + + my %entry; + $entry{title} = $title; + $entry{url} = $url; + + return \%entry; +} + +=item markdown_citation + +=cut + +sub markdown_citation { + my ($self, $section_key) = @_; + + croak "Invalid section $section_key" + if $section_key eq $VOLUME_KEY; + + my $volume_entry = $self->value($VOLUME_KEY); + + # start with the citation to the overall manual. + my $volume_title = $volume_entry->{title}; + my $volume_url = $volume_entry->{url}; + + my $section_title; + my $section_url; + + if ($self->recognizes($section_key)) { + + my $section_entry = $self->value($section_key); + + $section_title = $section_entry->{title}; + $section_url = $section_entry->{url}; + } + + return markdown_authority( + $volume_title, $volume_url,$section_key, + $section_title, $section_url + ); +} + +=item write_line + +=cut + +sub write_line { + my ($data_fd, $section_key, $section_title, $destination) = @_; + + # drop final dots + $section_key =~ s{ [.]+ $}{}x; + + # reduce consecutive whitespace + $section_title =~ s{ \s+ }{ }gx; + + my $line= join($SEPARATOR,$section_key, $section_title, $destination); + + say {$data_fd} encode_utf8($line); + + return; +} + +=item write_data_file + +=cut + +sub write_data_file { + my ($self, $basedir, $generated) = @_; + + my $header =<<"HEADER"; +# Data about titles, sections, and URLs of manuals, used to expand references +# in tag descriptions and add links for HTML output. Each line of this file +# has three fields separated by double colons: +# +# <section> :: <title> :: <url> +# +# If <section> is an underscore, that line specifies the title and URL for the +# whole manual. + +HEADER + + my $data_path = "$basedir/" . $self->location; + my $parent_dir = path($data_path)->parent->stringify; + path($parent_dir)->mkpath + unless -e $parent_dir; + + my $output = encode_utf8($header) . $generated; + path($data_path)->spew($output); + + return; +} + +=item extract_sections_from_links + +=cut + +sub extract_sections_from_links { + my ($self, $data_fd, $base_url)= @_; + + my $mechanize = WWW::Mechanize->new(); + $mechanize->get($base_url); + + my $page_title = $mechanize->title; + + # strip explanatory remark + $page_title =~ s{ \s* \N{EM DASH} .* $}{}x; + + # underscore is a token for the whole page + write_line($data_fd, $VOLUME_KEY, $page_title, $base_url); + + my %by_section_key; + my $in_appendix = 0; + + # https://stackoverflow.com/a/254687 + for my $link ($mechanize->links) { + + next + unless length $link->text; + + next + if $link->text !~ qr{^ \s* ([.\d]+) \s+ (.+) $}x; + + my $section_key = $1; + my $section_title = $2; + + # drop final dots + $section_key =~ s{ [.]+ $}{}x; + + # reduce consecutive whitespace + $section_title =~ s{ \s+ }{ }gx; + + my $destination = $base_url . $link->url; + + next + if exists $by_section_key{$section_key} + && ( $by_section_key{$section_key}{title} eq $section_title + || $by_section_key{$section_key}{destination} eq $destination); + + # Some manuals reuse section numbers for different references, + # e.g. the Debian Policy's normal and appendix sections are + # numbers that clash with each other. Track if we've already + # seen a section pointing to some other URL than the current one, + # and prepend it with an indicator + $in_appendix = 1 + if exists $by_section_key{$section_key} + && $by_section_key{$section_key}{destination} ne $destination; + + $section_key = "appendix-$section_key" + if $in_appendix; + + # do not collect the upgrading checklists in appendix 10 of policy + # the numbering changes all the time + next + if $section_key =~ m{^ appendix-10 [.] }x; + + $by_section_key{$section_key}{title} = $section_title; + $by_section_key{$section_key}{destination} = $destination; + + write_line($data_fd, $section_key, $section_title, $destination); + } + + return; +} + +=item refresh + +=cut + +sub refresh { + my ($self, $archive, $basedir) = @_; + + my $base_url = 'https://www.debian.org/doc/debian-policy/'; + + my $generated; + open(my $memory_fd, '>', \$generated) + or die encode_utf8('Cannot open scalar'); + + $self->extract_sections_from_links($memory_fd, $base_url); + + close $memory_fd; + + $self->write_data_file($basedir, $generated); + + return; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Data/Authority/DeveloperReference.pm b/lib/Lintian/Data/Authority/DeveloperReference.pm new file mode 100644 index 0000000..676cbf4 --- /dev/null +++ b/lib/Lintian/Data/Authority/DeveloperReference.pm @@ -0,0 +1,319 @@ +# -*- perl -*- +# +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2001 Colin Watson +# Copyright (C) 2008 Jorda Polo +# Copyright (C) 2009 Russ Allbery +# Copyright (C) 2017-2019 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Data::Authority::DeveloperReference; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(croak); +use Const::Fast; +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8); +use WWW::Mechanize (); + +use Lintian::Output::Markdown qw(markdown_authority); + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $SLASH => q{/}; +const my $COLON => q{:}; +const my $UNDERSCORE => q{_}; +const my $LEFT_PARENTHESIS => q{(}; +const my $RIGHT_PARENTHESIS => q{)}; + +const my $TWO_PARTS => 2; + +const my $VOLUME_KEY => $UNDERSCORE; +const my $SEPARATOR => $COLON x 2; + +use Moo; +use namespace::clean; + +with 'Lintian::Data::JoinedLines'; + +=head1 NAME + +Lintian::Data::Authority::DeveloperReference - Lintian interface for manual references + +=head1 SYNOPSIS + + use Lintian::Data::Authority::DeveloperReference; + +=head1 DESCRIPTION + +Lintian::Data::Authority::DeveloperReference provides a way to load data files for +manual references. + +=head1 CLASS METHODS + +=over 4 + +=item title + +=item shorthand + +=item location + +=item separator + +=cut + +has title => ( + is => 'rw', + default => q{Developer's Reference} +); + +has shorthand => ( + is => 'rw', + default => 'developer-reference' +); + +has location => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return 'authority/' . $self->shorthand; + } +); + +has separator => ( + is => 'rw', + default => sub { qr/::/ } +); + +=item consumer + +=cut + +sub consumer { + my ($self, $key, $remainder, $previous) = @_; + + return undef + if defined $previous; + + my ($title, $url)= split($self->separator, $remainder, $TWO_PARTS); + + my %entry; + $entry{title} = $title; + $entry{url} = $url; + + return \%entry; +} + +=item markdown_citation + +=cut + +sub markdown_citation { + my ($self, $section_key) = @_; + + croak "Invalid section $section_key" + if $section_key eq $VOLUME_KEY; + + my $volume_entry = $self->value($VOLUME_KEY); + + # start with the citation to the overall manual. + my $volume_title = $volume_entry->{title}; + my $volume_url = $volume_entry->{url}; + + my $section_title; + my $section_url; + + if ($self->recognizes($section_key)) { + + my $section_entry = $self->value($section_key); + + $section_title = $section_entry->{title}; + $section_url = $section_entry->{url}; + } + + return markdown_authority( + $volume_title, $volume_url,$section_key, + $section_title, $section_url + ); +} + +=item write_line + +=cut + +sub write_line { + my ($data_fd, $section_key, $section_title, $destination) = @_; + + # drop final dots + $section_key =~ s{ [.]+ $}{}x; + + # reduce consecutive whitespace + $section_title =~ s{ \s+ }{ }gx; + + my $line= join($SEPARATOR,$section_key, $section_title, $destination); + + say {$data_fd} encode_utf8($line); + + return; +} + +=item write_data_file + +=cut + +sub write_data_file { + my ($self, $basedir, $generated) = @_; + + my $header =<<"HEADER"; +# Data about titles, sections, and URLs of manuals, used to expand references +# in tag descriptions and add links for HTML output. Each line of this file +# has three fields separated by double colons: +# +# <section> :: <title> :: <url> +# +# If <section> is an underscore, that line specifies the title and URL for the +# whole manual. + +HEADER + + my $data_path = "$basedir/" . $self->location; + my $parent_dir = path($data_path)->parent->stringify; + path($parent_dir)->mkpath + unless -e $parent_dir; + + my $output = encode_utf8($header) . $generated; + path($data_path)->spew($output); + + return; +} + +=item extract_sections_from_links + +=cut + +sub extract_sections_from_links { + my ($self, $data_fd, $base_url)= @_; + + my $mechanize = WWW::Mechanize->new(); + $mechanize->get($base_url); + + my $page_title = $mechanize->title; + + # strip explanatory remark + $page_title =~ s{ \s* \N{EM DASH} .* $}{}x; + + # underscore is a token for the whole page + write_line($data_fd, $VOLUME_KEY, $page_title, $base_url); + + my %by_section_key; + my $in_appendix = 0; + + # https://stackoverflow.com/a/254687 + for my $link ($mechanize->links) { + + next + unless length $link->text; + + next + if $link->text !~ qr{^ \s* ([.\d]+) \s+ (.+) $}x; + + my $section_key = $1; + my $section_title = $2; + + # drop final dots + $section_key =~ s{ [.]+ $}{}x; + + # reduce consecutive whitespace + $section_title =~ s{ \s+ }{ }gx; + + my $destination = $base_url . $link->url; + + # developers reference likes to return locale specific pages + $destination =~ s{ [.]\w{2}[.]html }{.html}x; + + next + if exists $by_section_key{$section_key} + && ( $by_section_key{$section_key}{title} eq $section_title + || $by_section_key{$section_key}{destination} eq $destination); + + # Some manuals reuse section numbers for different references, + # e.g. the Debian Policy's normal and appendix sections are + # numbers that clash with each other. Track if we've already + # seen a section pointing to some other URL than the current one, + # and prepend it with an indicator + $in_appendix = 1 + if exists $by_section_key{$section_key} + && $by_section_key{$section_key}{destination} ne $destination; + + $section_key = "appendix-$section_key" + if $in_appendix; + + $by_section_key{$section_key}{title} = $section_title; + $by_section_key{$section_key}{destination} = $destination; + + write_line($data_fd, $section_key, $section_title, $destination); + } + + return; +} + +=item refresh + +=cut + +sub refresh { + my ($self, $archive, $basedir) = @_; + + my $base_url = 'https://www.debian.org/doc/developers-reference/'; + + my $generated; + open(my $memory_fd, '>', \$generated) + or die encode_utf8('Cannot open scalar'); + + $self->extract_sections_from_links($memory_fd, $base_url); + + close $memory_fd; + + $self->write_data_file($basedir, $generated); + + return; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Data/Authority/DocBaseManual.pm b/lib/Lintian/Data/Authority/DocBaseManual.pm new file mode 100644 index 0000000..53cfbcb --- /dev/null +++ b/lib/Lintian/Data/Authority/DocBaseManual.pm @@ -0,0 +1,431 @@ +# -*- perl -*- +# +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2001 Colin Watson +# Copyright (C) 2008 Jorda Polo +# Copyright (C) 2009 Russ Allbery +# Copyright (C) 2017-2019 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Data::Authority::DocBaseManual; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(croak); +use Const::Fast; +use File::Basename qw(dirname basename); +use IPC::Run3; +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8); +use WWW::Mechanize (); + +use Lintian::Output::Markdown qw(markdown_authority); + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $SLASH => q{/}; +const my $COLON => q{:}; +const my $INDENT => $SPACE x 4; +const my $UNDERSCORE => q{_}; +const my $LEFT_PARENTHESIS => q{(}; +const my $RIGHT_PARENTHESIS => q{)}; + +const my $TWO_PARTS => 2; + +const my $VOLUME_KEY => $UNDERSCORE; +const my $SEPARATOR => $COLON x 2; + +const my $WAIT_STATUS_SHIFT => 8; + +use Moo; +use namespace::clean; + +with 'Lintian::Data::JoinedLines'; + +=head1 NAME + +Lintian::Data::Authority::DocBaseManual - Lintian interface for manual references + +=head1 SYNOPSIS + + use Lintian::Data::Authority::DocBaseManual; + +=head1 DESCRIPTION + +Lintian::Data::Authority::DocBaseManual provides a way to load data files for +manual references. + +=head1 CLASS METHODS + +=over 4 + +=item title + +=item shorthand + +=item location + +=item separator + +=cut + +has title => ( + is => 'rw', + default => 'Doc-Base Manual' +); + +has shorthand => ( + is => 'rw', + default => 'doc-base-manual' +); + +has location => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return 'authority/' . $self->shorthand; + } +); + +has separator => ( + is => 'rw', + default => sub { qr/::/ } +); + +=item consumer + +=cut + +sub consumer { + my ($self, $key, $remainder, $previous) = @_; + + return undef + if defined $previous; + + my ($title, $url)= split($self->separator, $remainder, $TWO_PARTS); + + my %entry; + $entry{title} = $title; + $entry{url} = $url; + + return \%entry; +} + +=item markdown_citation + +=cut + +sub markdown_citation { + my ($self, $section_key) = @_; + + croak "Invalid section $section_key" + if $section_key eq $VOLUME_KEY; + + my $volume_entry = $self->value($VOLUME_KEY); + + # start with the citation to the overall manual. + my $volume_title = $volume_entry->{title}; + my $volume_url = $volume_entry->{url}; + + my $section_title; + my $section_url; + + if ($self->recognizes($section_key)) { + + my $section_entry = $self->value($section_key); + + $section_title = $section_entry->{title}; + $section_url = $section_entry->{url}; + } + + return markdown_authority( + $volume_title, $volume_url,$section_key, + $section_title, $section_url + ); +} + +=item write_line + +=cut + +sub write_line { + my ($data_fd, $section_key, $section_title, $destination) = @_; + + # drop final dots + $section_key =~ s{ [.]+ $}{}x; + + # reduce consecutive whitespace + $section_title =~ s{ \s+ }{ }gx; + + my $line= join($SEPARATOR,$section_key, $section_title, $destination); + + say {$data_fd} encode_utf8($line); + + return; +} + +=item write_data_file + +=cut + +sub write_data_file { + my ($self, $basedir, $generated) = @_; + + my $header =<<"HEADER"; +# Data about titles, sections, and URLs of manuals, used to expand references +# in tag descriptions and add links for HTML output. Each line of this file +# has three fields separated by double colons: +# +# <section> :: <title> :: <url> +# +# If <section> is an underscore, that line specifies the title and URL for the +# whole manual. + +HEADER + + my $data_path = "$basedir/" . $self->location; + my $parent_dir = path($data_path)->parent->stringify; + path($parent_dir)->mkpath + unless -e $parent_dir; + + my $output = encode_utf8($header) . $generated; + path($data_path)->spew($output); + + return; +} + +=item find_installable_name + +=cut + +sub find_installable_name { + my ($self, $archive, $port, $requested_path) = @_; + + my @installed_by; + + # find installable package + for my $installable_architecture ('all', $port) { + + my $local_path + = $archive->contents_gz('sid', 'main', $installable_architecture); + + open(my $fd, '<:gzip', $local_path) + or die encode_utf8("Cannot open $local_path."); + + while (my $line = <$fd>) { + + chomp $line; + + my ($path, $finder) = split($SPACE, $line, 2); + next + unless length $path + && length $finder; + + if ($path eq $requested_path) { + + my $name = $1; + + my @locations = split(m{,}, $finder); + for my $location (@locations) { + + my ($section, $installable)= split(m{/}, $location, 2); + + push(@installed_by, $installable); + } + + next; + } + } + + close $fd; + } + + die encode_utf8( + "The path $requested_path is not installed by any package.") + if @installed_by < 1; + + if (@installed_by > 1) { + warn encode_utf8( + "The path $requested_path is installed by multiple packages:\n"); + warn encode_utf8($INDENT . "- $_\n")for @installed_by; + } + + my $installable_name = shift @installed_by; + + return $installable_name; +} + +=item refresh + +=cut + +sub refresh { + my ($self, $archive, $basedir) = @_; + + # shipped as part of the doc-base installable + my $shipped_base = 'usr/share/doc/doc-base/doc-base.html/'; + my $index_name = 'index.html'; + + my $shipped_path = $shipped_base . $index_name; + my $stored_uri = "file:///$shipped_path"; + + # neutral sort order + local $ENV{LC_ALL} = 'C'; + + my $port = 'amd64'; + my $installable_name + = $self->find_installable_name($archive, $port, $shipped_path); + + my $deb822_by_installable_name + = $archive->deb822_packages_by_installable_name('sid', 'main', $port); + + my $work_folder + = Path::Tiny->tempdir(TEMPLATE => 'refresh-doc-base-manual-XXXXXXXXXX'); + + die encode_utf8("Installable $installable_name not shipped in port $port") + unless exists $deb822_by_installable_name->{$installable_name}; + + my $deb822 = $deb822_by_installable_name->{$installable_name}; + + my $pool_path = $deb822->value('Filename'); + + my $deb_filename = basename($pool_path); + my $deb_local_path = "$work_folder/$deb_filename"; + my $deb_url = $archive->mirror_base . $SLASH . $pool_path; + + my $stderr; + run3([qw{wget --quiet}, "--output-document=$deb_local_path", $deb_url], + undef, \$stderr); + my $status = ($? >> $WAIT_STATUS_SHIFT); + + # stderr already in UTF-8 + die $stderr + if $status; + + my $extract_folder = "$work_folder/unpacked/$pool_path"; + path($extract_folder)->mkpath; + + run3([qw{dpkg-deb --extract}, $deb_local_path, $extract_folder], + undef, \$stderr); + $status = ($? >> $WAIT_STATUS_SHIFT); + + # stderr already in UTF-8 + die $stderr + if $status; + + unlink($deb_local_path) + or die encode_utf8("Cannot delete $deb_local_path"); + + my $generated; + open(my $memory_fd, '>', \$generated) + or die encode_utf8('Cannot open scalar'); + + my $mechanize = WWW::Mechanize->new(); + + my $fresh_uri = URI::file->new_abs("/$extract_folder/$shipped_path"); + $mechanize->get($fresh_uri); + + my $page_title = $mechanize->title; + + # strip explanatory remark + $page_title =~ s{ \s* \N{EM DASH} .* $}{}x; + + # underscore is a token for the whole page + write_line($memory_fd, $VOLUME_KEY, $page_title, $stored_uri); + + my %by_section_key; + my $in_appendix = 0; + + # https://stackoverflow.com/a/254687 + for my $link ($mechanize->links) { + + next + unless length $link->text; + + next + if $link->text !~ qr{^ \s* ([.\d]+) \s+ (.+) $}x; + + my $section_key = $1; + my $section_title = $2; + + # drop final dots + $section_key =~ s{ [.]+ $}{}x; + + # reduce consecutive whitespace + $section_title =~ s{ \s+ }{ }gx; + + my $relative_destination = $link->url; + + my $destination_base = $stored_uri; + $destination_base = dirname($stored_uri) . $SLASH + unless $destination_base =~ m{ / $}x + || $relative_destination =~ m{^ [#] }x; + + my $full_destination = $destination_base . $relative_destination; + + next + if exists $by_section_key{$section_key} + && ( $by_section_key{$section_key}{title} eq $section_title + || $by_section_key{$section_key}{destination} eq$full_destination); + + # Some manuals reuse section numbers for different references, + # e.g. the Debian Policy's normal and appendix sections are + # numbers that clash with each other. Track if we've already + # seen a section pointing to some other URL than the current one, + # and prepend it with an indicator + $in_appendix = 1 + if exists $by_section_key{$section_key} + && $by_section_key{$section_key}{destination} ne$full_destination; + + $section_key = "appendix-$section_key" + if $in_appendix; + + $by_section_key{$section_key}{title} = $section_title; + $by_section_key{$section_key}{destination} = $full_destination; + + write_line($memory_fd, $section_key, $section_title,$full_destination); + } + + close $memory_fd; + + $self->write_data_file($basedir, $generated); + + return; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Data/Authority/FilesystemHierarchy.pm b/lib/Lintian/Data/Authority/FilesystemHierarchy.pm new file mode 100644 index 0000000..89fb677 --- /dev/null +++ b/lib/Lintian/Data/Authority/FilesystemHierarchy.pm @@ -0,0 +1,333 @@ +# -*- perl -*- +# +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2001 Colin Watson +# Copyright (C) 2008 Jorda Polo +# Copyright (C) 2009 Russ Allbery +# Copyright (C) 2017-2019 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Data::Authority::FilesystemHierarchy; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(croak); +use Const::Fast; +use File::Basename qw(dirname); +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8); +use WWW::Mechanize (); + +use Lintian::Output::Markdown qw(markdown_authority); + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $SLASH => q{/}; +const my $COLON => q{:}; +const my $UNDERSCORE => q{_}; +const my $LEFT_PARENTHESIS => q{(}; +const my $RIGHT_PARENTHESIS => q{)}; + +const my $THREE_PARTS => 3; + +const my $VOLUME_KEY => $UNDERSCORE; +const my $SEPARATOR => $COLON x 2; + +use Moo; +use namespace::clean; + +with 'Lintian::Data::JoinedLines'; + +=head1 NAME + +Lintian::Data::Authority::FilesystemHierarchy - Lintian interface for manual references + +=head1 SYNOPSIS + + use Lintian::Data::Authority::FilesystemHierarchy; + +=head1 DESCRIPTION + +Lintian::Data::Authority::FilesystemHierarchy provides a way to load data files for +manual references. + +=head1 CLASS METHODS + +=over 4 + +=item title + +=item shorthand + +=item location + +=item separator + +=cut + +has title => ( + is => 'rw', + default => 'Filesystem Hierarchy Standard' +); + +has shorthand => ( + is => 'rw', + default => 'filesystem-hierarchy' +); + +has location => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return 'authority/' . $self->shorthand; + } +); + +has separator => ( + is => 'rw', + default => sub { qr/::/ } +); + +=item consumer + +=cut + +sub consumer { + my ($self, $key, $remainder, $previous) = @_; + + return undef + if defined $previous; + + my ($number, $title, $url) + = split($self->separator, $remainder, $THREE_PARTS); + + my %entry; + $entry{title} = $title; + $entry{number} = $number; + $entry{url} = $url; + + return \%entry; +} + +=item markdown_citation + +=cut + +sub markdown_citation { + my ($self, $section_key) = @_; + + croak "Invalid section $section_key" + if $section_key eq $VOLUME_KEY; + + my $volume_entry = $self->value($VOLUME_KEY); + + # start with the citation to the overall manual. + my $volume_title = $volume_entry->{title}; + my $volume_url = $volume_entry->{url}; + + my $section_title; + my $section_number; + my $section_url; + + if ($self->recognizes($section_key)) { + + my $section_entry = $self->value($section_key); + + $section_title = $section_entry->{title}; + $section_number = $section_entry->{number}; + $section_url = $section_entry->{url}; + } + + return markdown_authority( + $volume_title, $volume_url,$section_number, + $section_title, $section_url + ); +} + +=item write_line + +=cut + +sub write_line { + my ($data_fd, $section_key, $section_number, $section_title, $destination) + = @_; + + # drop final dots + $section_key =~ s{ [.]+ $}{}x; + + # reduce consecutive whitespace + $section_title =~ s{ \s+ }{ }gx; + + my $line= join($SEPARATOR, + $section_key, $section_number, $section_title, $destination); + + say {$data_fd} encode_utf8($line); + + return; +} + +=item write_data_file + +=cut + +sub write_data_file { + my ($self, $basedir, $generated) = @_; + + my $header =<<"HEADER"; +# Data about titles, sections, and URLs of manuals, used to expand references +# in tag descriptions and add links for HTML output. Each line of this file +# has three fields separated by double colons: +# +# <section> :: <title> :: <url> +# +# If <section> is an underscore, that line specifies the title and URL for the +# whole manual. + +HEADER + + my $data_path = "$basedir/" . $self->location; + my $parent_dir = path($data_path)->parent->stringify; + path($parent_dir)->mkpath + unless -e $parent_dir; + + my $output = encode_utf8($header) . $generated; + path($data_path)->spew($output); + + return; +} + +=item extract_sections_from_links + +=cut + +sub extract_sections_from_links { + my ($self, $data_fd, $base_url, $page_name)= @_; + + my $page_url = $base_url . $page_name; + + my $mechanize = WWW::Mechanize->new(); + $mechanize->get($page_url); + + my $page_title = $mechanize->title; + + # strip explanatory remark + $page_title =~ s{ \s* \N{EM DASH} .* $}{}x; + + # underscore is a token for the whole page + write_line($data_fd, $VOLUME_KEY, $EMPTY, $page_title, $page_url); + + my %by_section_key; + my $in_appendix = 0; + + # https://stackoverflow.com/a/254687 + for my $link ($mechanize->links) { + + next + unless length $link->url; + + # make lowercase + my $section_key = lc($link->url); + + # strip hash; it's a fragment; + $section_key =~ s{^ [#] }{}x; + + next + unless length $link->text; + + next + if $link->text !~ qr{^ \s* ([.\d]+) \s+ (.+) $}x; + + my $section_number = $1; + my $section_title = $2; + + # drop final dot + $section_number =~ s{ [.]+ $}{}x; + + # reduce consecutive whitespace + $section_title =~ s{ \s+ }{ }gx; + + # includes hash + my $relative_destination = $link->url; + + my $destination_base = $page_url; + $destination_base = dirname($page_url) . $SLASH + unless $destination_base =~ m{ / $}x + || $relative_destination =~ m{^ [#] }x; + + my $full_destination = $destination_base . $relative_destination; + + next + if exists $by_section_key{$section_key}; + + $by_section_key{$section_key}{title} = $section_title; + $by_section_key{$section_key}{number} = $section_number; + $by_section_key{$section_key}{destination} = $full_destination; + + write_line($data_fd, $section_key, $section_number, + $section_title, $full_destination); + } + + return; +} + +=item refresh + +=cut + +sub refresh { + my ($self, $archive, $basedir) = @_; + + # single page version + # plain directory shows a file list + my $base_url = 'https://refspecs.linuxfoundation.org/FHS_3.0/'; + my $index_name = 'fhs-3.0.html'; + + my $generated; + open(my $memory_fd, '>', \$generated) + or die encode_utf8('Cannot open scalar'); + + $self->extract_sections_from_links($memory_fd, $base_url, $index_name); + + close $memory_fd; + + $self->write_data_file($basedir, $generated); + + return; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Data/Authority/JavaPolicy.pm b/lib/Lintian/Data/Authority/JavaPolicy.pm new file mode 100644 index 0000000..eaa6704 --- /dev/null +++ b/lib/Lintian/Data/Authority/JavaPolicy.pm @@ -0,0 +1,290 @@ +# -*- perl -*- +# +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2001 Colin Watson +# Copyright (C) 2008 Jorda Polo +# Copyright (C) 2009 Russ Allbery +# Copyright (C) 2017-2019 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Data::Authority::JavaPolicy; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(croak); +use Const::Fast; +use List::SomeUtils qw(any first_value); +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8); +use WWW::Mechanize (); + +use Lintian::Output::Markdown qw(markdown_authority); + +const my $SLASH => q{/}; +const my $UNDERSCORE => q{_}; + +const my $VOLUME_KEY => $UNDERSCORE; +const my $SECTIONS => 'sections'; + +use Moo; +use namespace::clean; + +with 'Lintian::Data::PreambledJSON'; + +=head1 NAME + +Lintian::Data::Authority::JavaPolicy - Lintian interface for manual references + +=head1 SYNOPSIS + + use Lintian::Data::Authority::JavaPolicy; + +=head1 DESCRIPTION + +Lintian::Data::Authority::JavaPolicy provides a way to load data files for +manual references. + +=head1 CLASS METHODS + +=over 4 + +=item title + +=item shorthand + +=item location + +=item by_section_key + +=cut + +has title => ( + is => 'rw', + default => 'Java Policy' +); + +has shorthand => ( + is => 'rw', + default => 'java-policy' +); + +has location => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return 'authority/' . $self->shorthand . '.json'; + } +); + +has by_section_key => (is => 'rw', default => sub { {} }); + +=item markdown_citation + +=cut + +sub markdown_citation { + my ($self, $section_key) = @_; + + croak "Invalid section $section_key" + if $section_key eq $VOLUME_KEY; + + my $volume_entry = $self->value($VOLUME_KEY); + + # start with the citation to the overall manual. + my $volume_title = $volume_entry->{title}; + my $volume_url = $volume_entry->{destination}; + + my $section_title; + my $section_url; + + if ($self->recognizes($section_key)) { + + my $section_entry = $self->value($section_key); + + $section_title = $section_entry->{title}; + $section_url = $section_entry->{destination}; + } + + return markdown_authority( + $volume_title, $volume_url,$section_key, + $section_title, $section_url + ); +} + +=item recognizes (KEY) + +Returns true if KEY is known, and false otherwise. + +=cut + +sub recognizes { + my ($self, $key) = @_; + + return 0 + unless length $key; + + return 1 + if exists $self->by_section_key->{$key}; + + return 0; +} + +=item value (KEY) + +Returns the value attached to KEY if it was listed in the data +file represented by this Lintian::Data instance and the undefined value +otherwise. + +=cut + +sub value { + my ($self, $key) = @_; + + return undef + unless length $key; + + return $self->by_section_key->{$key}; +} + +=item load + +=cut + +sub load { + my ($self, $search_space, $our_vendor) = @_; + + my @candidates = map { $_ . $SLASH . $self->location } @{$search_space}; + my $path = first_value { -e } @candidates; + + my $reference; + + return 0 + unless $self->read_file($path, \$reference); + + my @sections = @{$reference // []}; + + for my $section (@sections) { + + my $key = $section->{key}; + + # only store first value for duplicates + # silently ignore later values + $self->by_section_key->{$key} //= $section; + } + + return 1; +} + +=item refresh + +=cut + +sub refresh { + my ($self, $archive, $basedir) = @_; + + my $base_url = 'https://www.debian.org/doc/packaging-manuals/java-policy/'; + + my $mechanize = WWW::Mechanize->new(); + $mechanize->get($base_url); + + my $page_title = $mechanize->title; + + my @sections; + + # underscore is a token for the whole page + my %volume; + $volume{key} = $VOLUME_KEY; + $volume{title} = $page_title; + $volume{destination} = $base_url; + + # store array to resemble web layout + # may contain duplicates + push(@sections, \%volume); + + my $in_appendix = 0; + + # https://stackoverflow.com/a/254687 + for my $link ($mechanize->links) { + + next + unless length $link->text; + + next + if $link->text !~ qr{^ \s* ([.\d]+) \s+ (.+) $}x; + + my $section_key = $1; + my $section_title = $2; + + # drop final dots + $section_key =~ s{ [.]+ $}{}x; + + # reduce consecutive whitespace + $section_title =~ s{ \s+ }{ }gx; + + my $destination = $base_url . $link->url; + + my @similar = grep { $_->{key} eq $section_key } @sections; + next + if (any { $_->{title} eq $section_title } @similar) + || (any { $_->{destination} eq $destination } @similar); + + # Some manuals reuse section numbers for different references, + # e.g. the Debian Policy's normal and appendix sections are + # numbers that clash with each other. Track if we've already + # seen a section pointing to some other URL than the current one, + # and prepend it with an indicator + $in_appendix = 1 + if any { $_->{destination} ne $destination } @similar; + + $section_key = "appendix-$section_key" + if $in_appendix; + + my %section; + $section{key} = $section_key; + $section{title} = $section_title; + $section{destination} = $destination; + push(@sections, \%section); + } + + my $data_path = "$basedir/" . $self->location; + my $status = $self->write_file($SECTIONS, \@sections, $data_path); + + return $status; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Data/Authority/LintianManual.pm b/lib/Lintian/Data/Authority/LintianManual.pm new file mode 100644 index 0000000..3fc7bd0 --- /dev/null +++ b/lib/Lintian/Data/Authority/LintianManual.pm @@ -0,0 +1,324 @@ +# -*- perl -*- +# +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2001 Colin Watson +# Copyright (C) 2008 Jorda Polo +# Copyright (C) 2009 Russ Allbery +# Copyright (C) 2017-2019 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Data::Authority::LintianManual; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(croak); +use Const::Fast; +use IPC::Run3; +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8); +use URI::file; +use WWW::Mechanize (); + +use Lintian::Output::Markdown qw(markdown_authority); + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $SLASH => q{/}; +const my $COLON => q{:}; +const my $UNDERSCORE => q{_}; +const my $LEFT_PARENTHESIS => q{(}; +const my $RIGHT_PARENTHESIS => q{)}; + +const my $TWO_PARTS => 2; + +const my $VOLUME_KEY => $UNDERSCORE; +const my $SEPARATOR => $COLON x 2; + +const my $WAIT_STATUS_SHIFT => 8; + +use Moo; +use namespace::clean; + +with 'Lintian::Data::JoinedLines'; + +=head1 NAME + +Lintian::Data::Authority::LintianManual - Lintian interface for manual references + +=head1 SYNOPSIS + + use Lintian::Data::Authority::LintianManual; + +=head1 DESCRIPTION + +Lintian::Data::Authority::LintianManual provides a way to load data files for +manual references. + +=head1 CLASS METHODS + +=over 4 + +=item title + +=item shorthand + +=item location + +=item separator + +=cut + +has title => ( + is => 'rw', + default => 'Lintian Manual' +); + +has shorthand => ( + is => 'rw', + default => 'lintian-manual' +); + +has location => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return 'authority/' . $self->shorthand; + } +); + +has separator => ( + is => 'rw', + default => sub { qr/::/ } +); + +=item consumer + +=cut + +sub consumer { + my ($self, $key, $remainder, $previous) = @_; + + return undef + if defined $previous; + + my ($title, $url)= split($self->separator, $remainder, $TWO_PARTS); + + my %entry; + $entry{title} = $title; + $entry{url} = $url; + + return \%entry; +} + +=item markdown_citation + +=cut + +sub markdown_citation { + my ($self, $section_key) = @_; + + croak "Invalid section $section_key" + if $section_key eq $VOLUME_KEY; + + my $volume_entry = $self->value($VOLUME_KEY); + + # start with the citation to the overall manual. + my $volume_title = $volume_entry->{title}; + my $volume_url = $volume_entry->{url}; + + my $section_title; + my $section_url; + + if ($self->recognizes($section_key)) { + + my $section_entry = $self->value($section_key); + + $section_title = $section_entry->{title}; + $section_url = $section_entry->{url}; + } + + return markdown_authority( + $volume_title, $volume_url,$section_key, + $section_title, $section_url + ); +} + +=item write_line + +=cut + +sub write_line { + my ($data_fd, $section_key, $section_title, $destination) = @_; + + # drop final dots + $section_key =~ s{ [.]+ $}{}x; + + # reduce consecutive whitespace + $section_title =~ s{ \s+ }{ }gx; + + my $line= join($SEPARATOR,$section_key, $section_title, $destination); + + say {$data_fd} encode_utf8($line); + + return; +} + +=item write_data_file + +=cut + +sub write_data_file { + my ($self, $basedir, $generated) = @_; + + my $header =<<"HEADER"; +# Data about titles, sections, and URLs of manuals, used to expand references +# in tag descriptions and add links for HTML output. Each line of this file +# has three fields separated by double colons: +# +# <section> :: <title> :: <url> +# +# If <section> is an underscore, that line specifies the title and URL for the +# whole manual. + +HEADER + + my $data_path = "$basedir/" . $self->location; + my $parent_dir = path($data_path)->parent->stringify; + path($parent_dir)->mkpath + unless -e $parent_dir; + + my $output = encode_utf8($header) . $generated; + path($data_path)->spew($output); + + return; +} + +=item refresh + +=cut + +sub refresh { + my ($self, $archive, $basedir) = @_; + + # WWW::Mechanize will not parse page title without the suffix + my $temp_tiny = Path::Tiny->tempfile( + TEMPLATE => 'lintian-manual-XXXXXXXX', + SUFFIX => '.html' + ); + my $local_uri = URI::file->new_abs($temp_tiny->stringify); + + # for rst2html + local $ENV{LC_ALL} = 'en_US.UTF-8'; + + my $stderr; + run3(['rst2html', "$ENV{LINTIAN_BASE}/doc/lintian.rst"], + undef, $local_uri->file, \$stderr); + my $status = ($? >> $WAIT_STATUS_SHIFT); + + # stderr already in UTF-8 + die $stderr + if $status; + + my $generated; + open(my $memory_fd, '>', \$generated) + or die encode_utf8("Cannot open scalar: $!"); + + my $page_url = 'https://lintian.debian.org/manual/index.html'; + + my $mechanize = WWW::Mechanize->new(); + $mechanize->get($local_uri); + + my $page_title = $mechanize->title; + + # underscore is a token for the whole page + write_line($memory_fd, $VOLUME_KEY, $page_title, $page_url); + + my %by_section_key; + my $in_appendix = 0; + + # https://stackoverflow.com/a/254687 + for my $link ($mechanize->links) { + + next + unless length $link->text; + + next + if $link->text !~ qr{^ \s* ([.\d]+) \s+ (.+) $}x; + + my $section_key = $1; + my $section_title = $2; + + # drop final dots + $section_key =~ s{ [.]+ $}{}x; + + # reduce consecutive whitespace + $section_title =~ s{ \s+ }{ }gx; + + my $destination = $page_url . $link->url; + + next + if exists $by_section_key{$section_key} + && ( $by_section_key{$section_key}{title} eq $section_title + || $by_section_key{$section_key}{destination} eq $destination); + + # Some manuals reuse section numbers for different references, + # e.g. the Debian Policy's normal and appendix sections are + # numbers that clash with each other. Track if we've already + # seen a section pointing to some other URL than the current one, + # and prepend it with an indicator + $in_appendix = 1 + if exists $by_section_key{$section_key} + && $by_section_key{$section_key}{destination} ne $destination; + + $section_key = "appendix-$section_key" + if $in_appendix; + + $by_section_key{$section_key}{title} = $section_title; + $by_section_key{$section_key}{destination} = $destination; + + write_line($memory_fd, $section_key, $section_title, $destination); + } + + close $memory_fd; + + $self->write_data_file($basedir, $generated); + + return; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Data/Authority/MenuManual.pm b/lib/Lintian/Data/Authority/MenuManual.pm new file mode 100644 index 0000000..c8a2878 --- /dev/null +++ b/lib/Lintian/Data/Authority/MenuManual.pm @@ -0,0 +1,316 @@ +# -*- perl -*- +# +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2001 Colin Watson +# Copyright (C) 2008 Jorda Polo +# Copyright (C) 2009 Russ Allbery +# Copyright (C) 2017-2019 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Data::Authority::MenuManual; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(croak); +use Const::Fast; +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8); +use WWW::Mechanize (); + +use Lintian::Output::Markdown qw(markdown_authority); + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $SLASH => q{/}; +const my $COLON => q{:}; +const my $UNDERSCORE => q{_}; +const my $LEFT_PARENTHESIS => q{(}; +const my $RIGHT_PARENTHESIS => q{)}; + +const my $TWO_PARTS => 2; + +const my $VOLUME_KEY => $UNDERSCORE; +const my $SEPARATOR => $COLON x 2; + +use Moo; +use namespace::clean; + +with 'Lintian::Data::JoinedLines'; + +=head1 NAME + +Lintian::Data::Authority::MenuManual - Lintian interface for manual references + +=head1 SYNOPSIS + + use Lintian::Data::Authority::MenuManual; + +=head1 DESCRIPTION + +Lintian::Data::Authority::MenuManual provides a way to load data files for +manual references. + +=head1 CLASS METHODS + +=over 4 + +=item title + +=item shorthand + +=item location + +=item separator + +=cut + +has title => ( + is => 'rw', + default => 'Menu Manual' +); + +has shorthand => ( + is => 'rw', + default => 'menu-manual' +); + +has location => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return 'authority/' . $self->shorthand; + } +); + +has separator => ( + is => 'rw', + default => sub { qr/::/ } +); + +=item consumer + +=cut + +sub consumer { + my ($self, $key, $remainder, $previous) = @_; + + return undef + if defined $previous; + + my ($title, $url)= split($self->separator, $remainder, $TWO_PARTS); + + my %entry; + $entry{title} = $title; + $entry{url} = $url; + + return \%entry; +} + +=item markdown_citation + +=cut + +sub markdown_citation { + my ($self, $section_key) = @_; + + croak "Invalid section $section_key" + if $section_key eq $VOLUME_KEY; + + my $volume_entry = $self->value($VOLUME_KEY); + + # start with the citation to the overall manual. + my $volume_title = $volume_entry->{title}; + my $volume_url = $volume_entry->{url}; + + my $section_title; + my $section_url; + + if ($self->recognizes($section_key)) { + + my $section_entry = $self->value($section_key); + + $section_title = $section_entry->{title}; + $section_url = $section_entry->{url}; + } + + return markdown_authority( + $volume_title, $volume_url,$section_key, + $section_title, $section_url + ); +} + +=item write_line + +=cut + +sub write_line { + my ($data_fd, $section_key, $section_title, $destination) = @_; + + # drop final dots + $section_key =~ s{ [.]+ $}{}x; + + # reduce consecutive whitespace + $section_title =~ s{ \s+ }{ }gx; + + my $line= join($SEPARATOR,$section_key, $section_title, $destination); + + say {$data_fd} encode_utf8($line); + + return; +} + +=item write_data_file + +=cut + +sub write_data_file { + my ($self, $basedir, $generated) = @_; + + my $header =<<"HEADER"; +# Data about titles, sections, and URLs of manuals, used to expand references +# in tag descriptions and add links for HTML output. Each line of this file +# has three fields separated by double colons: +# +# <section> :: <title> :: <url> +# +# If <section> is an underscore, that line specifies the title and URL for the +# whole manual. + +HEADER + + my $data_path = "$basedir/" . $self->location; + my $parent_dir = path($data_path)->parent->stringify; + path($parent_dir)->mkpath + unless -e $parent_dir; + + my $output = encode_utf8($header) . $generated; + path($data_path)->spew($output); + + return; +} + +=item extract_sections_from_links + +=cut + +sub extract_sections_from_links { + my ($self, $data_fd, $base_url)= @_; + + my $mechanize = WWW::Mechanize->new(); + $mechanize->get($base_url); + + my $page_title = $mechanize->title; + + # strip explanatory remark + $page_title =~ s{ \s* \N{EM DASH} .* $}{}x; + + # underscore is a token for the whole page + write_line($data_fd, $VOLUME_KEY, $page_title, $base_url); + + my %by_section_key; + my $in_appendix = 0; + + # https://stackoverflow.com/a/254687 + for my $link ($mechanize->links) { + + next + unless length $link->text; + + next + if $link->text !~ qr{^ \s* ([.\d]+) \s+ (.+) $}x; + + my $section_key = $1; + my $section_title = $2; + + # drop final dots + $section_key =~ s{ [.]+ $}{}x; + + # reduce consecutive whitespace + $section_title =~ s{ \s+ }{ }gx; + + my $destination = $base_url . $link->url; + + next + if exists $by_section_key{$section_key} + && ( $by_section_key{$section_key}{title} eq $section_title + || $by_section_key{$section_key}{destination} eq $destination); + + # Some manuals reuse section numbers for different references, + # e.g. the Debian Policy's normal and appendix sections are + # numbers that clash with each other. Track if we've already + # seen a section pointing to some other URL than the current one, + # and prepend it with an indicator + $in_appendix = 1 + if exists $by_section_key{$section_key} + && $by_section_key{$section_key}{destination} ne $destination; + + $section_key = "appendix-$section_key" + if $in_appendix; + + $by_section_key{$section_key}{title} = $section_title; + $by_section_key{$section_key}{destination} = $destination; + + write_line($data_fd, $section_key, $section_title, $destination); + } + + return; +} + +=item refresh + +=cut + +sub refresh { + my ($self, $archive, $basedir) = @_; + + my $base_url = 'https://www.debian.org/doc/packaging-manuals/menu.html/'; + + my $generated; + open(my $memory_fd, '>', \$generated) + or die encode_utf8('Cannot open scalar'); + + $self->extract_sections_from_links($memory_fd, $base_url); + + close $memory_fd; + + $self->write_data_file($basedir, $generated); + + return; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Data/Authority/MenuPolicy.pm b/lib/Lintian/Data/Authority/MenuPolicy.pm new file mode 100644 index 0000000..e0f710a --- /dev/null +++ b/lib/Lintian/Data/Authority/MenuPolicy.pm @@ -0,0 +1,316 @@ +# -*- perl -*- +# +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2001 Colin Watson +# Copyright (C) 2008 Jorda Polo +# Copyright (C) 2009 Russ Allbery +# Copyright (C) 2017-2019 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Data::Authority::MenuPolicy; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(croak); +use Const::Fast; +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8); +use WWW::Mechanize (); + +use Lintian::Output::Markdown qw(markdown_authority); + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $SLASH => q{/}; +const my $COLON => q{:}; +const my $UNDERSCORE => q{_}; +const my $LEFT_PARENTHESIS => q{(}; +const my $RIGHT_PARENTHESIS => q{)}; + +const my $TWO_PARTS => 2; + +const my $VOLUME_KEY => $UNDERSCORE; +const my $SEPARATOR => $COLON x 2; + +use Moo; +use namespace::clean; + +with 'Lintian::Data::JoinedLines'; + +=head1 NAME + +Lintian::Data::Authority::MenuPolicy - Lintian interface for manual references + +=head1 SYNOPSIS + + use Lintian::Data::Authority::MenuPolicy; + +=head1 DESCRIPTION + +Lintian::Data::Authority::MenuPolicy provides a way to load data files for +manual references. + +=head1 CLASS METHODS + +=over 4 + +=item title + +=item shorthand + +=item location + +=item separator + +=cut + +has title => ( + is => 'rw', + default => 'Menu Policy' +); + +has shorthand => ( + is => 'rw', + default => 'menu-policy' +); + +has location => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return 'authority/' . $self->shorthand; + } +); + +has separator => ( + is => 'rw', + default => sub { qr/::/ } +); + +=item consumer + +=cut + +sub consumer { + my ($self, $key, $remainder, $previous) = @_; + + return undef + if defined $previous; + + my ($title, $url)= split($self->separator, $remainder, $TWO_PARTS); + + my %entry; + $entry{title} = $title; + $entry{url} = $url; + + return \%entry; +} + +=item markdown_citation + +=cut + +sub markdown_citation { + my ($self, $section_key) = @_; + + croak "Invalid section $section_key" + if $section_key eq $VOLUME_KEY; + + my $volume_entry = $self->value($VOLUME_KEY); + + # start with the citation to the overall manual. + my $volume_title = $volume_entry->{title}; + my $volume_url = $volume_entry->{url}; + + my $section_title; + my $section_url; + + if ($self->recognizes($section_key)) { + + my $section_entry = $self->value($section_key); + + $section_title = $section_entry->{title}; + $section_url = $section_entry->{url}; + } + + return markdown_authority( + $volume_title, $volume_url,$section_key, + $section_title, $section_url + ); +} + +=item write_line + +=cut + +sub write_line { + my ($data_fd, $section_key, $section_title, $destination) = @_; + + # drop final dots + $section_key =~ s{ [.]+ $}{}x; + + # reduce consecutive whitespace + $section_title =~ s{ \s+ }{ }gx; + + my $line= join($SEPARATOR,$section_key, $section_title, $destination); + + say {$data_fd} encode_utf8($line); + + return; +} + +=item write_data_file + +=cut + +sub write_data_file { + my ($self, $basedir, $generated) = @_; + + my $header =<<"HEADER"; +# Data about titles, sections, and URLs of manuals, used to expand references +# in tag descriptions and add links for HTML output. Each line of this file +# has three fields separated by double colons: +# +# <section> :: <title> :: <url> +# +# If <section> is an underscore, that line specifies the title and URL for the +# whole manual. + +HEADER + + my $data_path = "$basedir/" . $self->location; + my $parent_dir = path($data_path)->parent->stringify; + path($parent_dir)->mkpath + unless -e $parent_dir; + + my $output = encode_utf8($header) . $generated; + path($data_path)->spew($output); + + return; +} + +=item extract_sections_from_links + +=cut + +sub extract_sections_from_links { + my ($self, $data_fd, $base_url)= @_; + + my $mechanize = WWW::Mechanize->new(); + $mechanize->get($base_url); + + my $page_title = $mechanize->title; + + # strip explanatory remark + $page_title =~ s{ \s* \N{EM DASH} .* $}{}x; + + # underscore is a token for the whole page + write_line($data_fd, $VOLUME_KEY, $page_title, $base_url); + + my %by_section_key; + my $in_appendix = 0; + + # https://stackoverflow.com/a/254687 + for my $link ($mechanize->links) { + + next + unless length $link->text; + + next + if $link->text !~ qr{^ \s* ([.\d]+) \s+ (.+) $}x; + + my $section_key = $1; + my $section_title = $2; + + # drop final dots + $section_key =~ s{ [.]+ $}{}x; + + # reduce consecutive whitespace + $section_title =~ s{ \s+ }{ }gx; + + my $destination = $base_url . $link->url; + + next + if exists $by_section_key{$section_key} + && ( $by_section_key{$section_key}{title} eq $section_title + || $by_section_key{$section_key}{destination} eq $destination); + + # Some manuals reuse section numbers for different references, + # e.g. the Debian Policy's normal and appendix sections are + # numbers that clash with each other. Track if we've already + # seen a section pointing to some other URL than the current one, + # and prepend it with an indicator + $in_appendix = 1 + if exists $by_section_key{$section_key} + && $by_section_key{$section_key}{destination} ne $destination; + + $section_key = "appendix-$section_key" + if $in_appendix; + + $by_section_key{$section_key}{title} = $section_title; + $by_section_key{$section_key}{destination} = $destination; + + write_line($data_fd, $section_key, $section_title, $destination); + } + + return; +} + +=item refresh + +=cut + +sub refresh { + my ($self, $archive, $basedir) = @_; + + my $base_url = 'https://www.debian.org/doc/packaging-manuals/menu-policy/'; + + my $generated; + open(my $memory_fd, '>', \$generated) + or die encode_utf8('Cannot open scalar'); + + $self->extract_sections_from_links($memory_fd, $base_url); + + close $memory_fd; + + $self->write_data_file($basedir, $generated); + + return; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Data/Authority/NewMaintainer.pm b/lib/Lintian/Data/Authority/NewMaintainer.pm new file mode 100644 index 0000000..bd8c933 --- /dev/null +++ b/lib/Lintian/Data/Authority/NewMaintainer.pm @@ -0,0 +1,290 @@ +# -*- perl -*- +# +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2001 Colin Watson +# Copyright (C) 2008 Jorda Polo +# Copyright (C) 2009 Russ Allbery +# Copyright (C) 2017-2019 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Data::Authority::NewMaintainer; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(croak); +use Const::Fast; +use List::SomeUtils qw(any first_value); +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8); +use WWW::Mechanize (); + +use Lintian::Output::Markdown qw(markdown_authority); + +const my $SLASH => q{/}; +const my $UNDERSCORE => q{_}; + +const my $VOLUME_KEY => $UNDERSCORE; +const my $SECTIONS => 'sections'; + +use Moo; +use namespace::clean; + +with 'Lintian::Data::PreambledJSON'; + +=head1 NAME + +Lintian::Data::Authority::NewMaintainer - Lintian interface for manual references + +=head1 SYNOPSIS + + use Lintian::Data::Authority::NewMaintainer; + +=head1 DESCRIPTION + +Lintian::Data::Authority::NewMaintainer provides a way to load data files for +manual references. + +=head1 CLASS METHODS + +=over 4 + +=item title + +=item shorthand + +=item location + +=item by_section_key + +=cut + +has title => ( + is => 'rw', + default => 'New Maintainer\'s Guide' +); + +has shorthand => ( + is => 'rw', + default => 'new-maintainer' +); + +has location => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return 'authority/' . $self->shorthand . '.json'; + } +); + +has by_section_key => (is => 'rw', default => sub { {} }); + +=item markdown_citation + +=cut + +sub markdown_citation { + my ($self, $section_key) = @_; + + croak "Invalid section $section_key" + if $section_key eq $VOLUME_KEY; + + my $volume_entry = $self->value($VOLUME_KEY); + + # start with the citation to the overall manual. + my $volume_title = $volume_entry->{title}; + my $volume_url = $volume_entry->{destination}; + + my $section_title; + my $section_url; + + if ($self->recognizes($section_key)) { + + my $section_entry = $self->value($section_key); + + $section_title = $section_entry->{title}; + $section_url = $section_entry->{destination}; + } + + return markdown_authority( + $volume_title, $volume_url,$section_key, + $section_title, $section_url + ); +} + +=item recognizes (KEY) + +Returns true if KEY is known, and false otherwise. + +=cut + +sub recognizes { + my ($self, $key) = @_; + + return 0 + unless length $key; + + return 1 + if exists $self->by_section_key->{$key}; + + return 0; +} + +=item value (KEY) + +Returns the value attached to KEY if it was listed in the data +file represented by this Lintian::Data instance and the undefined value +otherwise. + +=cut + +sub value { + my ($self, $key) = @_; + + return undef + unless length $key; + + return $self->by_section_key->{$key}; +} + +=item load + +=cut + +sub load { + my ($self, $search_space, $our_vendor) = @_; + + my @candidates = map { $_ . $SLASH . $self->location } @{$search_space}; + my $path = first_value { -e } @candidates; + + my $reference; + + return 0 + unless $self->read_file($path, \$reference); + + my @sections = @{$reference // []}; + + for my $section (@sections) { + + my $key = $section->{key}; + + # only store first value for duplicates + # silently ignore later values + $self->by_section_key->{$key} //= $section; + } + + return 1; +} + +=item refresh + +=cut + +sub refresh { + my ($self, $archive, $basedir) = @_; + + my $base_url = 'https://www.debian.org/doc/manuals/maint-guide/index.html'; + + my $mechanize = WWW::Mechanize->new(); + $mechanize->get($base_url); + + my $page_title = $mechanize->title; + + my @sections; + + # underscore is a token for the whole page + my %volume; + $volume{key} = $VOLUME_KEY; + $volume{title} = $page_title; + $volume{destination} = $base_url; + + # store array to resemble web layout + # may contain duplicates + push(@sections, \%volume); + + my $in_appendix = 0; + + # https://stackoverflow.com/a/254687 + for my $link ($mechanize->links) { + + next + unless length $link->text; + + next + if $link->text !~ qr{^ \s* ([.\d[:upper:]]+) \s+ (.+) $}x; + + my $section_key = $1; + my $section_title = $2; + + # drop final dots + $section_key =~ s{ [.]+ $}{}x; + + # reduce consecutive whitespace + $section_title =~ s{ \s+ }{ }gx; + + my $destination = $base_url . $link->url; + + my @similar = grep { $_->{key} eq $section_key } @sections; + next + if (any { $_->{title} eq $section_title } @similar) + || (any { $_->{destination} eq $destination } @similar); + + # Some manuals reuse section numbers for different references, + # e.g. the Debian Policy's normal and appendix sections are + # numbers that clash with each other. Track if we've already + # seen a section pointing to some other URL than the current one, + # and prepend it with an indicator + $in_appendix = 1 + if any { $_->{destination} ne $destination } @similar; + + $section_key = "appendix-$section_key" + if $in_appendix; + + my %section; + $section{key} = $section_key; + $section{title} = $section_title; + $section{destination} = $destination; + push(@sections, \%section); + } + + my $data_path = "$basedir/" . $self->location; + my $status = $self->write_file($SECTIONS, \@sections, $data_path); + + return $status; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Data/Authority/PerlPolicy.pm b/lib/Lintian/Data/Authority/PerlPolicy.pm new file mode 100644 index 0000000..92dc31a --- /dev/null +++ b/lib/Lintian/Data/Authority/PerlPolicy.pm @@ -0,0 +1,316 @@ +# -*- perl -*- +# +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2001 Colin Watson +# Copyright (C) 2008 Jorda Polo +# Copyright (C) 2009 Russ Allbery +# Copyright (C) 2017-2019 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Data::Authority::PerlPolicy; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(croak); +use Const::Fast; +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8); +use WWW::Mechanize (); + +use Lintian::Output::Markdown qw(markdown_authority); + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $SLASH => q{/}; +const my $COLON => q{:}; +const my $UNDERSCORE => q{_}; +const my $LEFT_PARENTHESIS => q{(}; +const my $RIGHT_PARENTHESIS => q{)}; + +const my $TWO_PARTS => 2; + +const my $VOLUME_KEY => $UNDERSCORE; +const my $SEPARATOR => $COLON x 2; + +use Moo; +use namespace::clean; + +with 'Lintian::Data::JoinedLines'; + +=head1 NAME + +Lintian::Data::Authority::PerlPolicy - Lintian interface for manual references + +=head1 SYNOPSIS + + use Lintian::Data::Authority::PerlPolicy; + +=head1 DESCRIPTION + +Lintian::Data::Authority::PerlPolicy provides a way to load data files for +manual references. + +=head1 CLASS METHODS + +=over 4 + +=item title + +=item shorthand + +=item location + +=item separator + +=cut + +has title => ( + is => 'rw', + default => 'Perl Policy' +); + +has shorthand => ( + is => 'rw', + default => 'perl-policy' +); + +has location => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return 'authority/' . $self->shorthand; + } +); + +has separator => ( + is => 'rw', + default => sub { qr/::/ } +); + +=item consumer + +=cut + +sub consumer { + my ($self, $key, $remainder, $previous) = @_; + + return undef + if defined $previous; + + my ($title, $url)= split($self->separator, $remainder, $TWO_PARTS); + + my %entry; + $entry{title} = $title; + $entry{url} = $url; + + return \%entry; +} + +=item markdown_citation + +=cut + +sub markdown_citation { + my ($self, $section_key) = @_; + + croak "Invalid section $section_key" + if $section_key eq $VOLUME_KEY; + + my $volume_entry = $self->value($VOLUME_KEY); + + # start with the citation to the overall manual. + my $volume_title = $volume_entry->{title}; + my $volume_url = $volume_entry->{url}; + + my $section_title; + my $section_url; + + if ($self->recognizes($section_key)) { + + my $section_entry = $self->value($section_key); + + $section_title = $section_entry->{title}; + $section_url = $section_entry->{url}; + } + + return markdown_authority( + $volume_title, $volume_url,$section_key, + $section_title, $section_url + ); +} + +=item write_line + +=cut + +sub write_line { + my ($data_fd, $section_key, $section_title, $destination) = @_; + + # drop final dots + $section_key =~ s{ [.]+ $}{}x; + + # reduce consecutive whitespace + $section_title =~ s{ \s+ }{ }gx; + + my $line= join($SEPARATOR,$section_key, $section_title, $destination); + + say {$data_fd} encode_utf8($line); + + return; +} + +=item write_data_file + +=cut + +sub write_data_file { + my ($self, $basedir, $generated) = @_; + + my $header =<<"HEADER"; +# Data about titles, sections, and URLs of manuals, used to expand references +# in tag descriptions and add links for HTML output. Each line of this file +# has three fields separated by double colons: +# +# <section> :: <title> :: <url> +# +# If <section> is an underscore, that line specifies the title and URL for the +# whole manual. + +HEADER + + my $data_path = "$basedir/" . $self->location; + my $parent_dir = path($data_path)->parent->stringify; + path($parent_dir)->mkpath + unless -e $parent_dir; + + my $output = encode_utf8($header) . $generated; + path($data_path)->spew($output); + + return; +} + +=item extract_sections_from_links + +=cut + +sub extract_sections_from_links { + my ($self, $data_fd, $base_url)= @_; + + my $mechanize = WWW::Mechanize->new(); + $mechanize->get($base_url); + + my $page_title = $mechanize->title; + + # strip explanatory remark + $page_title =~ s{ \s* \N{EM DASH} .* $}{}x; + + # underscore is a token for the whole page + write_line($data_fd, $VOLUME_KEY, $page_title, $base_url); + + my %by_section_key; + my $in_appendix = 0; + + # https://stackoverflow.com/a/254687 + for my $link ($mechanize->links) { + + next + unless length $link->text; + + next + if $link->text !~ qr{^ \s* ([A-Z]|[A-Z]?[.\d]+) \s+ (.+) $}x; + + my $section_key = $1; + my $section_title = $2; + + # drop final dots + $section_key =~ s{ [.]+ $}{}x; + + # reduce consecutive whitespace + $section_title =~ s{ \s+ }{ }gx; + + my $destination = $base_url . $link->url; + + next + if exists $by_section_key{$section_key} + && ( $by_section_key{$section_key}{title} eq $section_title + || $by_section_key{$section_key}{destination} eq $destination); + + # Some manuals reuse section numbers for different references, + # e.g. the Debian Policy's normal and appendix sections are + # numbers that clash with each other. Track if we've already + # seen a section pointing to some other URL than the current one, + # and prepend it with an indicator + $in_appendix = 1 + if exists $by_section_key{$section_key} + && $by_section_key{$section_key}{destination} ne $destination; + + $section_key = "appendix-$section_key" + if $in_appendix; + + $by_section_key{$section_key}{title} = $section_title; + $by_section_key{$section_key}{destination} = $destination; + + write_line($data_fd, $section_key, $section_title, $destination); + } + + return; +} + +=item refresh + +=cut + +sub refresh { + my ($self, $archive, $basedir) = @_; + + my $base_url = 'https://www.debian.org/doc/packaging-manuals/perl-policy/'; + + my $generated; + open(my $memory_fd, '>', \$generated) + or die encode_utf8('Cannot open scalar'); + + $self->extract_sections_from_links($memory_fd, $base_url); + + close $memory_fd; + + $self->write_data_file($basedir, $generated); + + return; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Data/Authority/PythonPolicy.pm b/lib/Lintian/Data/Authority/PythonPolicy.pm new file mode 100644 index 0000000..ebeda04 --- /dev/null +++ b/lib/Lintian/Data/Authority/PythonPolicy.pm @@ -0,0 +1,317 @@ +# -*- perl -*- +# +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2001 Colin Watson +# Copyright (C) 2008 Jorda Polo +# Copyright (C) 2009 Russ Allbery +# Copyright (C) 2017-2019 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Data::Authority::PythonPolicy; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(croak); +use Const::Fast; +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8); +use WWW::Mechanize (); + +use Lintian::Output::Markdown qw(markdown_authority); + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $SLASH => q{/}; +const my $COLON => q{:}; +const my $UNDERSCORE => q{_}; +const my $LEFT_PARENTHESIS => q{(}; +const my $RIGHT_PARENTHESIS => q{)}; + +const my $TWO_PARTS => 2; + +const my $VOLUME_KEY => $UNDERSCORE; +const my $SEPARATOR => $COLON x 2; + +use Moo; +use namespace::clean; + +with 'Lintian::Data::JoinedLines'; + +=head1 NAME + +Lintian::Data::Authority::PythonPolicy - Lintian interface for manual references + +=head1 SYNOPSIS + + use Lintian::Data::Authority::PythonPolicy; + +=head1 DESCRIPTION + +Lintian::Data::Authority::PythonPolicy provides a way to load data files for +manual references. + +=head1 CLASS METHODS + +=over 4 + +=item title + +=item shorthand + +=item location + +=item separator + +=cut + +has title => ( + is => 'rw', + default => 'Python Policy' +); + +has shorthand => ( + is => 'rw', + default => 'python-policy' +); + +has location => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return 'authority/' . $self->shorthand; + } +); + +has separator => ( + is => 'rw', + default => sub { qr/::/ } +); + +=item consumer + +=cut + +sub consumer { + my ($self, $key, $remainder, $previous) = @_; + + return undef + if defined $previous; + + my ($title, $url)= split($self->separator, $remainder, $TWO_PARTS); + + my %entry; + $entry{title} = $title; + $entry{url} = $url; + + return \%entry; +} + +=item markdown_citation + +=cut + +sub markdown_citation { + my ($self, $section_key) = @_; + + croak "Invalid section $section_key" + if $section_key eq $VOLUME_KEY; + + my $volume_entry = $self->value($VOLUME_KEY); + + # start with the citation to the overall manual. + my $volume_title = $volume_entry->{title}; + my $volume_url = $volume_entry->{url}; + + my $section_title; + my $section_url; + + if ($self->recognizes($section_key)) { + + my $section_entry = $self->value($section_key); + + $section_title = $section_entry->{title}; + $section_url = $section_entry->{url}; + } + + return markdown_authority( + $volume_title, $volume_url,$section_key, + $section_title, $section_url + ); +} + +=item write_line + +=cut + +sub write_line { + my ($data_fd, $section_key, $section_title, $destination) = @_; + + # drop final dots + $section_key =~ s{ [.]+ $}{}x; + + # reduce consecutive whitespace + $section_title =~ s{ \s+ }{ }gx; + + my $line= join($SEPARATOR,$section_key, $section_title, $destination); + + say {$data_fd} encode_utf8($line); + + return; +} + +=item write_data_file + +=cut + +sub write_data_file { + my ($self, $basedir, $generated) = @_; + + my $header =<<"HEADER"; +# Data about titles, sections, and URLs of manuals, used to expand references +# in tag descriptions and add links for HTML output. Each line of this file +# has three fields separated by double colons: +# +# <section> :: <title> :: <url> +# +# If <section> is an underscore, that line specifies the title and URL for the +# whole manual. + +HEADER + + my $data_path = "$basedir/" . $self->location; + my $parent_dir = path($data_path)->parent->stringify; + path($parent_dir)->mkpath + unless -e $parent_dir; + + my $output = encode_utf8($header) . $generated; + path($data_path)->spew($output); + + return; +} + +=item extract_sections_from_links + +=cut + +sub extract_sections_from_links { + my ($self, $data_fd, $base_url)= @_; + + my $mechanize = WWW::Mechanize->new(); + $mechanize->get($base_url); + + my $page_title = $mechanize->title; + + # strip explanatory remark + $page_title =~ s{ \s* \N{EM DASH} .* $}{}x; + + # underscore is a token for the whole page + write_line($data_fd, $VOLUME_KEY, $page_title, $base_url); + + my %by_section_key; + my $in_appendix = 0; + + # https://stackoverflow.com/a/254687 + for my $link ($mechanize->links) { + + next + unless length $link->text; + + next + if $link->text !~ qr{^ \s* ([.\d]+) \s+ (.+) $}x; + + my $section_key = $1; + my $section_title = $2; + + # drop final dots + $section_key =~ s{ [.]+ $}{}x; + + # reduce consecutive whitespace + $section_title =~ s{ \s+ }{ }gx; + + my $destination = $base_url . $link->url; + + next + if exists $by_section_key{$section_key} + && ( $by_section_key{$section_key}{title} eq $section_title + || $by_section_key{$section_key}{destination} eq $destination); + + # Some manuals reuse section numbers for different references, + # e.g. the Debian Policy's normal and appendix sections are + # numbers that clash with each other. Track if we've already + # seen a section pointing to some other URL than the current one, + # and prepend it with an indicator + $in_appendix = 1 + if exists $by_section_key{$section_key} + && $by_section_key{$section_key}{destination} ne $destination; + + $section_key = "appendix-$section_key" + if $in_appendix; + + $by_section_key{$section_key}{title} = $section_title; + $by_section_key{$section_key}{destination} = $destination; + + write_line($data_fd, $section_key, $section_title, $destination); + } + + return; +} + +=item refresh + +=cut + +sub refresh { + my ($self, $archive, $basedir) = @_; + + my $base_url + = 'https://www.debian.org/doc/packaging-manuals/python-policy/'; + + my $generated; + open(my $memory_fd, '>', \$generated) + or die encode_utf8('Cannot open scalar'); + + $self->extract_sections_from_links($memory_fd, $base_url); + + close $memory_fd; + + $self->write_data_file($basedir, $generated); + + return; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Data/Authority/VimPolicy.pm b/lib/Lintian/Data/Authority/VimPolicy.pm new file mode 100644 index 0000000..6ffbe91 --- /dev/null +++ b/lib/Lintian/Data/Authority/VimPolicy.pm @@ -0,0 +1,459 @@ +# -*- perl -*- +# +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2001 Colin Watson +# Copyright (C) 2008 Jorda Polo +# Copyright (C) 2009 Russ Allbery +# Copyright (C) 2017-2019 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Data::Authority::VimPolicy; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(croak); +use Const::Fast; +use File::Basename qw(basename); +use IPC::Run3; +use HTML::TokeParser::Simple; +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::Output::Markdown qw(markdown_authority); + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $SLASH => q{/}; +const my $COLON => q{:}; +const my $INDENT => $SPACE x 4; +const my $UNDERSCORE => q{_}; +const my $LEFT_PARENTHESIS => q{(}; +const my $RIGHT_PARENTHESIS => q{)}; + +const my $TWO_PARTS => 2; + +const my $VOLUME_KEY => $UNDERSCORE; +const my $SEPARATOR => $COLON x 2; + +const my $WAIT_STATUS_SHIFT => 8; + +use Moo; +use namespace::clean; + +with 'Lintian::Data::JoinedLines'; + +=head1 NAME + +Lintian::Data::Authority::VimPolicy - Lintian interface for manual references + +=head1 SYNOPSIS + + use Lintian::Data::Authority::VimPolicy; + +=head1 DESCRIPTION + +Lintian::Data::Authority::VimPolicy provides a way to load data files for +manual references. + +=head1 CLASS METHODS + +=over 4 + +=item title + +=item shorthand + +=item location + +=item separator + +=cut + +has title => ( + is => 'rw', + default => 'Vim Policy' +); + +has shorthand => ( + is => 'rw', + default => 'vim-policy' +); + +has location => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return 'authority/' . $self->shorthand; + } +); + +has separator => ( + is => 'rw', + default => sub { qr/::/ } +); + +=item consumer + +=cut + +sub consumer { + my ($self, $key, $remainder, $previous) = @_; + + return undef + if defined $previous; + + my ($title, $url)= split($self->separator, $remainder, $TWO_PARTS); + + my %entry; + $entry{title} = $title; + $entry{url} = $url; + + return \%entry; +} + +=item markdown_citation + +=cut + +sub markdown_citation { + my ($self, $section_key) = @_; + + croak "Invalid section $section_key" + if $section_key eq $VOLUME_KEY; + + my $volume_entry = $self->value($VOLUME_KEY); + + # start with the citation to the overall manual. + my $volume_title = $volume_entry->{title}; + my $volume_url = $volume_entry->{url}; + + my $section_title; + my $section_url; + + if ($self->recognizes($section_key)) { + + my $section_entry = $self->value($section_key); + + $section_title = $section_entry->{title}; + $section_url = $section_entry->{url}; + } + + return markdown_authority( + $volume_title, $volume_url,$section_key, + $section_title, $section_url + ); +} + +=item write_line + +=cut + +sub write_line { + my ($data_fd, $section_key, $section_title, $destination) = @_; + + # drop final dots + $section_key =~ s{ [.]+ $}{}x; + + # reduce consecutive whitespace + $section_title =~ s{ \s+ }{ }gx; + + my $line= join($SEPARATOR,$section_key, $section_title, $destination); + + say {$data_fd} encode_utf8($line); + + return; +} + +=item write_data_file + +=cut + +sub write_data_file { + my ($self, $basedir, $generated) = @_; + + my $header =<<"HEADER"; +# Data about titles, sections, and URLs of manuals, used to expand references +# in tag descriptions and add links for HTML output. Each line of this file +# has three fields separated by double colons: +# +# <section> :: <title> :: <url> +# +# If <section> is an underscore, that line specifies the title and URL for the +# whole manual. + +HEADER + + my $data_path = "$basedir/" . $self->location; + my $parent_dir = path($data_path)->parent->stringify; + path($parent_dir)->mkpath + unless -e $parent_dir; + + my $output = encode_utf8($header) . $generated; + path($data_path)->spew($output); + + return; +} + +=item find_installable_name + +=cut + +sub find_installable_name { + my ($self, $archive, $release, $liberty, $port, $requested_path) = @_; + + my @installed_by; + + # find installable package + for my $installable_architecture ('all', $port) { + + my $local_path + = $archive->contents_gz($release, $liberty, + $installable_architecture); + + open(my $fd, '<:gzip', $local_path) + or die encode_utf8("Cannot open $local_path."); + + while (my $line = <$fd>) { + + chomp $line; + + my ($path, $finder) = split($SPACE, $line, 2); + next + unless length $path + && length $finder; + + if ($path eq $requested_path) { + + my $name = $1; + + my @locations = split(m{,}, $finder); + for my $location (@locations) { + + my ($section, $installable)= split(m{/}, $location, 2); + + push(@installed_by, $installable); + } + + next; + } + } + + close $fd; + } + + die encode_utf8( + "The path $requested_path is not installed by any package.") + if @installed_by < 1; + + if (@installed_by > 1) { + warn encode_utf8( + "The path $requested_path is installed by multiple packages:\n"); + warn encode_utf8($INDENT . "- $_\n")for @installed_by; + } + + my $installable_name = shift @installed_by; + + return $installable_name; +} + +=item refresh + +=cut + +sub refresh { + my ($self, $archive, $basedir) = @_; + + # shipped as part of the vim installable + my $shipped_base = 'usr/share/doc/vim/vim-policy.html/'; + my $index_name = 'index.html'; + + my $shipped_path = $shipped_base . $index_name; + my $stored_uri = "file:///$shipped_base"; + + # neutral sort order + local $ENV{LC_ALL} = 'C'; + + my $release = 'stable'; + my $port = 'amd64'; + + my $installable_name + = $self->find_installable_name($archive, $release, 'main', $port, + $shipped_path); + + my $deb822_by_installable_name + = $archive->deb822_packages_by_installable_name($release, 'main', $port); + + my $work_folder + = Path::Tiny->tempdir( + TEMPLATE => 'refresh-doc-base-specification-XXXXXXXXXX'); + + die encode_utf8("Installable $installable_name not shipped in port $port") + unless exists $deb822_by_installable_name->{$installable_name}; + + my $deb822 = $deb822_by_installable_name->{$installable_name}; + + my $pool_path = $deb822->value('Filename'); + + my $deb_filename = basename($pool_path); + my $deb_local_path = "$work_folder/$deb_filename"; + my $deb_url = $archive->mirror_base . $SLASH . $pool_path; + + my $stderr; + run3([qw{wget --quiet}, "--output-document=$deb_local_path", $deb_url], + undef, \$stderr); + my $status = ($? >> $WAIT_STATUS_SHIFT); + + # stderr already in UTF-8 + die $stderr + if $status; + + my $extract_folder = "$work_folder/unpacked/$pool_path"; + path($extract_folder)->mkpath; + + run3([qw{dpkg-deb --extract}, $deb_local_path, $extract_folder], + undef, \$stderr); + $status = ($? >> $WAIT_STATUS_SHIFT); + + # stderr already in UTF-8 + die $stderr + if $status; + + unlink($deb_local_path) + or die encode_utf8("Cannot delete $deb_local_path"); + + my $generated; + open(my $memory_fd, '>', \$generated) + or die encode_utf8("Cannot open scalar: $!"); + + my $fresh_uri = URI::file->new_abs("/$extract_folder/$shipped_path"); + + my $parser = HTML::TokeParser::Simple->new(url => $fresh_uri); + my $in_title = 0; + my $in_dt_tag = 0; + my $after_a_tag = 0; + + my $page_title = $EMPTY; + my $section_key = $EMPTY; + my $section_title = $EMPTY; + my $relative_destination = $EMPTY; + + while (my $token = $parser->get_token) { + + if (length $token->get_tag) { + + if ($token->get_tag eq 'h1') { + + $in_title = ($token->is_start_tag + && $token->get_attr('class') eq 'title'); + + # not yet leaving title + next + if $in_title; + + # trim both ends + $page_title =~ s/^\s+|\s+$//g; + + # underscore is a token for the whole page + write_line($memory_fd, $VOLUME_KEY, $page_title, + $stored_uri . $index_name) + if length $page_title; + + $page_title = $EMPTY; + } + + if ($token->get_tag eq 'dt') { + + $in_dt_tag = $token->is_start_tag; + + # not yet leaving dt tag + next + if $in_dt_tag; + + # trim both ends + $section_key =~ s/^\s+|\s+$//g; + $section_title =~ s/^\s+|\s+$//g; + + my $full_destination = $stored_uri . $relative_destination; + + write_line( + $memory_fd, $section_key, + $section_title,$full_destination + )if length $section_title; + + $section_key = $EMPTY; + $section_title = $EMPTY; + $relative_destination = $EMPTY; + } + + if ($token->get_tag eq 'a') { + + $after_a_tag = $token->is_start_tag; + + $relative_destination = $token->get_attr('href') + if $token->is_start_tag; + } + + } else { + + # concatenate span objects + $page_title .= $token->as_is + if length $token->as_is + && $in_title + && $after_a_tag; + + $section_key = $token->as_is + if length $token->as_is + && $in_dt_tag + && !$after_a_tag; + + # concatenate span objects + $section_title .= $token->as_is + if length $token->as_is + && $in_dt_tag + && $after_a_tag; + } + } + + close $memory_fd; + + $self->write_data_file($basedir, $generated); + + return; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Data/Buildflags/Hardening.pm b/lib/Lintian/Data/Buildflags/Hardening.pm new file mode 100644 index 0000000..75056df --- /dev/null +++ b/lib/Lintian/Data/Buildflags/Hardening.pm @@ -0,0 +1,154 @@ +# -*- perl -*- + +# Copyright (C) 2011-2012 Niels Thykier <niels@thykier.net> +# - Based on a shell script by Raphael Geissert <atomo64@gmail.com> +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Data::Buildflags::Hardening; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(first_value uniq); +use Unicode::UTF8 qw(decode_utf8); + +use Lintian::Deb822; +use Lintian::IPC::Run3 qw(safe_qx); + +use Moo; +use namespace::clean; + +const my $EMPTY => q{}; +const my $SLASH => q{/}; + +const my $RECOMMENDED_FEATURES => q{recommended_features}; + +with 'Lintian::Data::PreambledJSON'; + +=encoding utf-8 + +=head1 NAME + +Lintian::Data::Buildflags::Hardening -- Lintian API for hardening build flags + +=head1 SYNOPSIS + + use Lintian::Data::Buildflags::Hardening; + +=head1 DESCRIPTION + +Lintian API for hardening build flags. + +=head1 INSTANCE METHODS + +=over 4 + +=item title + +=item location + +=item recommended_features + +=cut + +has title => ( + is => 'rw', + default => 'Hardening Flags from Dpkg' +); + +has location => ( + is => 'rw', + default => 'buildflags/hardening.json' +); + +has recommended_features => ( + is => 'rw', + default => sub { {} }, + coerce => sub { my ($hashref) = @_; return ($hashref // {}); } +); + +=item load + +=cut + +sub load { + my ($self, $search_space, $our_vendor) = @_; + + my @candidates = map { $_ . $SLASH . $self->location } @{$search_space}; + my $path = first_value { -e } @candidates; + + my $recommended_features; + return 0 + unless $self->read_file($path, \$recommended_features); + + $self->recommended_features($recommended_features); + + return 1; +} + +=item refresh + +=cut + +sub refresh { + my ($self, $archive, $basedir) = @_; + + # find all recommended hardening features + local $ENV{LC_ALL} = 'C'; + local $ENV{DEB_BUILD_MAINT_OPTIONS} = 'hardening=+all'; + + my @architectures + = split(/\n/, decode_utf8(safe_qx('dpkg-architecture', '-L'))); + chomp for @architectures; + + my %recommended_features; + for my $architecture (@architectures) { + + local $ENV{DEB_HOST_ARCH} = $architecture; + + my @command = qw{dpkg-buildflags --query-features hardening}; + my $feature_output = decode_utf8(safe_qx(@command)); + + my $deb822 = Lintian::Deb822->new; + my @sections = $deb822->parse_string($feature_output); + + my @enabled = grep { $_->value('Enabled') eq 'yes' } @sections; + my @features = uniq map { $_->value('Feature') } @enabled; + + $recommended_features{$architecture} = [sort @features]; + } + + my $data_path = "$basedir/" . $self->location; + my $status + = $self->write_file($RECOMMENDED_FEATURES, \%recommended_features, + $data_path); + + return $status; +} + +=back + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Data/Debhelper/Addons.pm b/lib/Lintian/Data/Debhelper/Addons.pm new file mode 100644 index 0000000..3b8dbb1 --- /dev/null +++ b/lib/Lintian/Data/Debhelper/Addons.pm @@ -0,0 +1,215 @@ +# -*- perl -*- +# +# Copyright (C) 2008 by Raphael Geissert <atomo64@gmail.com> +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Data::Debhelper::Addons; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(croak); +use Const::Fast; +use List::SomeUtils qw(first_value any uniq); +use PerlIO::gzip; +use Unicode::UTF8 qw(encode_utf8); + +const my $SPACE => q{ }; +const my $SLASH => q{/}; + +const my $WAIT_STATUS_SHIFT => 8; + +const my $ADD_ONS => 'add_ons'; + +use Moo; +use namespace::clean; + +with 'Lintian::Data::PreambledJSON'; + +=head1 NAME + +Lintian::Data::Debhelper::Addons - Lintian interface for debhelper addons. + +=head1 SYNOPSIS + + use Lintian::Data::Debhelper::Addons; + +=head1 DESCRIPTION + +This module provides a way to load data files for debhelper. + +=head1 INSTANCE METHODS + +=over 4 + +=item title + +=item location + +=item installable_names_by_add_on + +=cut + +has title => ( + is => 'rw', + default => 'Debhelper Add-ons' +); + +has location => ( + is => 'rw', + default => 'debhelper/add_ons.json' +); + +has installable_names_by_add_on => (is => 'rw', default => sub { {} }); + +=item all + +=cut + +sub all { + my ($self) = @_; + + return keys %{$self->installable_names_by_add_on}; +} + +=item installed_by + +=cut + +sub installed_by { + my ($self, $name) = @_; + + return () + unless exists $self->installable_names_by_add_on->{$name}; + + my @installed_by = @{$self->installable_names_by_add_on->{$name} // []}; + + push(@installed_by, 'debhelper-compat') + if any { $_ eq 'debhelper' } @installed_by; + + return @installed_by; +} + +=item load + +=cut + +sub load { + my ($self, $search_space, $our_vendor) = @_; + + my @candidates = map { $_ . $SLASH . $self->location } @{$search_space}; + my $path = first_value { -e } @candidates; + + my $reference; + return 0 + unless $self->read_file($path, \$reference); + + my %add_ons = %{$reference // {}}; + my %installable_names_by_add_on; + + for my $name (keys %add_ons) { + + my @installable_names; + push(@installable_names, @{$add_ons{$name}{installed_by}}); + + $installable_names_by_add_on{$name} = \@installable_names; + } + + $self->installable_names_by_add_on(\%installable_names_by_add_on); + + return 1; +} + +=item refresh + +=cut + +sub refresh { + my ($self, $archive, $basedir) = @_; + + # neutral sort order + local $ENV{LC_ALL} = 'C'; + + my $port = 'amd64'; + + my %add_ons; + + for my $installable_architecture ('all', $port) { + + my $local_path + = $archive->contents_gz('sid', 'main', $installable_architecture); + + open(my $fd, '<:gzip', $local_path) + or die encode_utf8("Cannot open $local_path."); + + while (my $line = <$fd>) { + + chomp $line; + + my ($path, $finder) = split($SPACE, $line, 2); + next + unless length $path + && length $finder; + + if ($path + =~ m{^ usr/share/perl5/Debian/Debhelper/Sequence/ (\S+) [.]pm $}x + ) { + + my $name = $1; + + my @locations = split(m{,}, $finder); + for my $location (@locations) { + + my ($section, $installable)= split(m{/}, $location, 2); + + $add_ons{$name}{installed_by} //= []; + push(@{$add_ons{$name}{installed_by}}, $installable); + } + + next; + } + } + + close $fd; + } + + my $data_path = "$basedir/" . $self->location; + my $status = $self->write_file($ADD_ONS, \%add_ons,$data_path); + + return $status; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Data/Debhelper/Commands.pm b/lib/Lintian/Data/Debhelper/Commands.pm new file mode 100644 index 0000000..bd1ea67 --- /dev/null +++ b/lib/Lintian/Data/Debhelper/Commands.pm @@ -0,0 +1,306 @@ +# -*- perl -*- +# +# Copyright (C) 2008 by Raphael Geissert <atomo64@gmail.com> +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Data::Debhelper::Commands; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use File::Basename; +use IPC::Run3; +use List::SomeUtils qw(first_value any uniq); +use Path::Tiny; +use PerlIO::gzip; +use Unicode::UTF8 qw(encode_utf8); + +const my $SPACE => q{ }; +const my $SLASH => q{/}; + +const my $WAIT_STATUS_SHIFT => 8; + +const my $COMMANDS => 'commands'; + +use Moo; +use namespace::clean; + +with 'Lintian::Data::PreambledJSON'; + +=head1 NAME + +Lintian::Data::Debhelper::Commands - Lintian interface for debhelper commands. + +=head1 SYNOPSIS + + use Lintian::Data::Debhelper::Commands; + +=head1 DESCRIPTION + +This module provides a way to load data files for debhelper. + +=head1 INSTANCE METHODS + +=over 4 + +=item title + +=item location + +=item installable_names_by_command + +=item maint_commands + +=item misc_depends_commands + +=cut + +has title => ( + is => 'rw', + default => 'Debhelper Commands' +); + +has location => ( + is => 'rw', + default => 'debhelper/commands.json' +); + +has installable_names_by_command => (is => 'rw', default => sub { {} }); +has maint_commands => (is => 'rw', default => sub { [] }); +has misc_depends_commands => (is => 'rw', default => sub { [] }); + +=item all + +=cut + +sub all { + my ($self) = @_; + + return keys %{$self->installable_names_by_command}; +} + +=item installed_by + +=cut + +sub installed_by { + my ($self, $name) = @_; + + return () + unless exists $self->installable_names_by_command->{$name}; + + my @installed_by = @{$self->installable_names_by_command->{$name} // []}; + + push(@installed_by, 'debhelper-compat') + if any { $_ eq 'debhelper' } @installed_by; + + return @installed_by; +} + +=item load + +=cut + +sub load { + my ($self, $search_space, $our_vendor) = @_; + + my @candidates = map { $_ . $SLASH . $self->location } @{$search_space}; + my $path = first_value { -e } @candidates; + + my $reference; + return 0 + unless $self->read_file($path, \$reference); + + my %commands = %{$reference // {}}; + + my %installable_names_by_command; + my @maint_commands; + my @misc_depends_commands; + + for my $name (keys %commands) { + + my @installable_names; + push(@installable_names, @{$commands{$name}{installed_by}}); + + $installable_names_by_command{$name} = \@installable_names; + + push(@maint_commands, $name) + if $commands{$name}{uses_autoscript}; + + push(@misc_depends_commands, $name) + if $commands{$name}{uses_misc_depends} + && $name ne 'dh_gencontrol'; + } + + $self->installable_names_by_command(\%installable_names_by_command); + $self->maint_commands(\@maint_commands); + $self->misc_depends_commands(\@misc_depends_commands); + + return 1; +} + +=item refresh + +=cut + +sub refresh { + my ($self, $archive, $basedir) = @_; + + # neutral sort order + local $ENV{LC_ALL} = 'C'; + + my $port = 'amd64'; + + my %commands; + + for my $installable_architecture ('all', $port) { + + my $local_path + = $archive->contents_gz('sid', 'main', $installable_architecture); + + open(my $fd, '<:gzip', $local_path) + or die encode_utf8("Cannot open $local_path."); + + while (my $line = <$fd>) { + + chomp $line; + + my ($path, $finder) = split($SPACE, $line, 2); + next + unless length $path + && length $finder; + + if ($path =~ m{^ usr/bin/ (dh_ \S+) $}x) { + + my $name = $1; + + my @locations = split(m{,}, $finder); + for my $location (@locations) { + + my ($section, $installable)= split(m{/}, $location, 2); + + $commands{$name}{installed_by} //= []; + push(@{$commands{$name}{installed_by}}, $installable); + } + + next; + } + } + + close $fd; + } + + my $deb822_by_installable_name + = $archive->deb822_packages_by_installable_name('sid', 'main', $port); + + my $work_folder + = Path::Tiny->tempdir( + TEMPLATE => 'refresh-debhelper-add-ons-XXXXXXXXXX'); + + my @uses_autoscript; + my @uses_misc_depends; + + my @installable_names= uniq map { @{$_->{installed_by}} }values %commands; + + for my $installable_name (sort @installable_names) { + + next + unless exists $deb822_by_installable_name->{$installable_name}; + + my $deb822 = $deb822_by_installable_name->{$installable_name}; + + my $pool_path = $deb822->value('Filename'); + + my $deb_filename = basename($pool_path); + my $deb_local_path = "$work_folder/$deb_filename"; + my $deb_url = $archive->mirror_base . $SLASH . $pool_path; + + my $stderr; + run3( + [qw{wget --quiet}, "--output-document=$deb_local_path", $deb_url], + undef, \$stderr + ); + my $status = ($? >> $WAIT_STATUS_SHIFT); + + # stderr already in UTF-8 + die $stderr + if $status; + + my $extract_folder = "$work_folder/pool/$pool_path"; + path($extract_folder)->mkpath; + + run3([qw{dpkg-deb --extract}, $deb_local_path, $extract_folder], + undef, \$stderr); + $status = ($? >> $WAIT_STATUS_SHIFT); + + # stderr already in UTF-8 + die $stderr + if $status; + + unlink($deb_local_path) + or die encode_utf8("Cannot delete $deb_local_path"); + + my $autoscript_rule = File::Find::Rule->file; + $autoscript_rule->name(qr{^dh_}); + $autoscript_rule->grep(qr{autoscript}); + my @autoscript_matches + = $autoscript_rule->in("$extract_folder/usr/bin"); + + push(@uses_autoscript, map { basename($_) } @autoscript_matches); + + my $misc_depends_rule = File::Find::Rule->file; + $misc_depends_rule->name(qr{^dh_}); + $misc_depends_rule->grep(qr{misc:Depends}); + my @misc_depends_matches + = $misc_depends_rule->in("$extract_folder/usr/bin"); + + push(@uses_misc_depends, map { basename($_) } @misc_depends_matches); + + path("$work_folder/pool")->remove_tree; + } + + $commands{$_}{uses_autoscript} = 1 for @uses_autoscript; + + $commands{$_}{uses_misc_depends} = 1 for @uses_misc_depends; + + my $data_path = "$basedir/" . $self->location; + my $status = $self->write_file($COMMANDS, \%commands,$data_path); + + return $status; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Data/Debhelper/Levels.pm b/lib/Lintian/Data/Debhelper/Levels.pm new file mode 100644 index 0000000..571ce2c --- /dev/null +++ b/lib/Lintian/Data/Debhelper/Levels.pm @@ -0,0 +1,89 @@ +# -*- perl -*- +# +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2009 Russ Allbery +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Data::Debhelper::Levels; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Data::JoinedLines'; + +=head1 NAME + +Lintian::Data::Debhelper::Levels - Lintian interface for debhelper +compat levels. + +=head1 SYNOPSIS + + use Lintian::Data::Debhelper::Levels; + +=head1 DESCRIPTION + +This module provides a way to load data files for debhelper. + +=head1 INSTANCE METHODS + +=over 4 + +=item title + +=item location + +=item separator + +=cut + +has title => ( + is => 'rw', + default => 'Debhelper Levels' +); + +has location => ( + is => 'rw', + default => 'debhelper/compat-level' +); + +has separator => ( + is => 'rw', + default => sub { qr/=/ } +); + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Data/Fonts.pm b/lib/Lintian/Data/Fonts.pm new file mode 100644 index 0000000..4820439 --- /dev/null +++ b/lib/Lintian/Data/Fonts.pm @@ -0,0 +1,216 @@ +# -*- 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Data::Fonts; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use File::Basename; +use List::SomeUtils qw(first_value uniq); +use PerlIO::gzip; +use Unicode::UTF8 qw(encode_utf8); + +const my $SPACE => q{ }; +const my $SLASH => q{/}; + +const my $FONTS => 'fonts'; + +use Moo; +use namespace::clean; + +with 'Lintian::Data::PreambledJSON'; + +=head1 NAME + +Lintian::Data::Fonts - Lintian interface for fonts. + +=head1 SYNOPSIS + + use Lintian::Data::Fonts; + +=head1 DESCRIPTION + +This module provides a way to load data files for fonts. + +=head1 INSTANCE METHODS + +=over 4 + +=item title + +=item location + +=item installable_names_by_font + +=cut + +has title => ( + is => 'rw', + default => 'Fonts Available for Installation' +); + +has location => ( + is => 'rw', + default => 'fonts.json' +); + +has installable_names_by_font => (is => 'rw', default => sub { {} }); + +=item all + +=cut + +sub all { + my ($self) = @_; + + return keys %{$self->installable_names_by_font}; +} + +=item installed_by + +=cut + +sub installed_by { + my ($self, $name) = @_; + + my $lowercase = lc $name; + + return () + unless exists $self->installable_names_by_font->{$lowercase}; + + my @installed_by = @{$self->installable_names_by_font->{$lowercase} // []}; + + return @installed_by; +} + +=item load + +=cut + +sub load { + my ($self, $search_space, $our_vendor) = @_; + + my @candidates = map { $_ . $SLASH . $self->location } @{$search_space}; + my $path = first_value { -e } @candidates; + + my $reference; + return 0 + unless $self->read_file($path, \$reference); + + my %fonts = %{$reference // {}}; + my %installable_names_by_font; + + for my $name (keys %fonts) { + + my @installable_names; + push(@installable_names, @{$fonts{$name}{installed_by}}); + + $installable_names_by_font{$name} = \@installable_names; + } + + $self->installable_names_by_font(\%installable_names_by_font); + + return 1; +} + +=item refresh + +=cut + +sub refresh { + my ($self, $archive, $basedir) = @_; + + # neutral sort order + local $ENV{LC_ALL} = 'C'; + + my $port = 'amd64'; + + my %fonts; + + for my $installable_architecture ('all', $port) { + + my $local_path + = $archive->contents_gz('sid', 'main', $installable_architecture); + + open(my $fd, '<:gzip', $local_path) + or die encode_utf8("Cannot open $local_path."); + + while (my $line = <$fd>) { + + chomp $line; + + my ($path, $finder) = split($SPACE, $line, 2); + next + unless length $path + && length $finder; + + if ($path =~ m{ [.] (?:[to]tf|pfb) $}ix) { + + my @locations = split(m{,}, $finder); + for my $location (@locations) { + + my ($section, $installable_name) + = split(m{/}, $location, 2); + + # Record only packages starting with ttf-, otf-, t1-, xfonts- or fonts- + next + unless $installable_name + =~ m{^ (?: [to]tf | t1 | x?fonts ) - }x; + + my $basename = basename($path); + my $lowercase = lc $basename; + + $fonts{$lowercase}{installed_by} //= []; + push(@{$fonts{$lowercase}{installed_by}}, + $installable_name); + } + + next; + } + } + + close $fd; + } + + my $data_path = "$basedir/" . $self->location; + my $status = $self->write_file($FONTS, \%fonts,$data_path); + + return $status; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Data/InitD/VirtualFacilities.pm b/lib/Lintian/Data/InitD/VirtualFacilities.pm new file mode 100644 index 0000000..fbb4030 --- /dev/null +++ b/lib/Lintian/Data/InitD/VirtualFacilities.pm @@ -0,0 +1,256 @@ +# -*- perl -*- +# +# Copyright (C) 2008, 2010 by Raphael Geissert <atomo64@gmail.com> +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Data::InitD::VirtualFacilities; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use File::Basename; +use IPC::Run3; +use List::SomeUtils qw(first_value uniq); +use Path::Tiny; +use PerlIO::gzip; +use Unicode::UTF8 qw(encode_utf8); + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $SLASH => q{/}; +const my $DOLLAR => q{$}; + +const my $NEWLINE => qq{\n}; + +const my $WAIT_STATUS_SHIFT => 8; + +use Moo; +use namespace::clean; + +with 'Lintian::Data::JoinedLines'; + +=head1 NAME + +Lintian::Data::InitD::VirtualFacilities - Lintian interface for init.d virtual facilities + +=head1 SYNOPSIS + + use Lintian::Data::InitD::VirtualFacilities; + +=head1 DESCRIPTION + +This module provides a way to load data files for init.d. + +=head1 INSTANCE METHODS + +=over 4 + +=item title + +=item location + +=item separator + +=cut + +has title => ( + is => 'rw', + default => 'Init.d Virtual Facilities' +); + +has location => ( + is => 'rw', + default => 'init.d/virtual_facilities' +); + +has separator => ( + is => 'rw', + default => sub { qr{ \s+ }x } +); + +=item refresh + +=cut + +sub refresh { + my ($self, $archive, $basedir) = @_; + + # neutral sort order + local $ENV{LC_ALL} = 'C'; + + my $port = 'amd64'; + + my %paths_by_installable_names; + + for my $installable_architecture ('all', $port) { + + my $local_path + = $archive->contents_gz('sid', 'main', $installable_architecture); + + open(my $fd, '<:gzip', $local_path) + or die encode_utf8("Cannot open $local_path."); + + while (my $line = <$fd>) { + + chomp $line; + + my ($path, $finder) = split($SPACE, $line, 2); + next + unless length $path + && length $finder; + + # catch both monolithic and split configurations + if ($path =~ m{^ etc/insserv[.]conf (?: $ | [.]d / )? }x) { + + my @locations = split(m{,}, $finder); + for my $location (@locations) { + + my ($section, $installable)= split(m{/}, $location, 2); + + $paths_by_installable_names{$installable} //= []; + push(@{$paths_by_installable_names{$installable}}, $path); + } + + next; + } + } + + close $fd; + } + + my $deb822_by_installable_name + = $archive->deb822_packages_by_installable_name('sid', 'main', $port); + + my $work_folder + = Path::Tiny->tempdir( + TEMPLATE => 'refresh-debhelper-add-ons-XXXXXXXXXX'); + + my @virtual_facilities; + + my @installable_names = keys %paths_by_installable_names; + + for my $installable_name (sort @installable_names) { + + next + unless exists $deb822_by_installable_name->{$installable_name}; + + my $deb822 = $deb822_by_installable_name->{$installable_name}; + + my $pool_path = $deb822->value('Filename'); + + my $deb_filename = basename($pool_path); + my $deb_local_path = "$work_folder/$deb_filename"; + my $deb_url = $archive->mirror_base . $SLASH . $pool_path; + + my $stderr; + run3( + [qw{wget --quiet}, "--output-document=$deb_local_path", $deb_url], + undef, \$stderr + ); + my $status = ($? >> $WAIT_STATUS_SHIFT); + + # stderr already in UTF-8 + die $stderr + if $status; + + my $extract_folder = "$work_folder/pool/$pool_path"; + path($extract_folder)->mkpath; + + run3([qw{dpkg-deb --extract}, $deb_local_path, $extract_folder], + undef, \$stderr); + $status = ($? >> $WAIT_STATUS_SHIFT); + + # stderr already in UTF-8 + die $stderr + if $status; + + unlink($deb_local_path) + or die encode_utf8("Cannot delete $deb_local_path"); + + my $monolithic_rule = File::Find::Rule->file; + $monolithic_rule->name('insserv.conf'); + my @files= $monolithic_rule->in("$extract_folder/etc"); + + my $split_files_rule = File::Find::Rule->file; + push(@files, + $split_files_rule->in("$extract_folder/etc/insserv.conf.d")); + + for my $path (@files) { + + open(my $fd, '<', $path) + or die encode_utf8("Cannot open $path."); + + while (my $line = <$fd>) { + + if ($line =~ m{^ ( \$\S+ ) }x) { + + my $virtual = $1; + push(@virtual_facilities, $virtual); + } + } + + close $fd; + } + + path("$work_folder/pool")->remove_tree; + } + + push(@virtual_facilities, $DOLLAR . 'all'); + + my $generated = $EMPTY; + + # still in UTF-8 + $generated .= $_ . $NEWLINE for sort +uniq @virtual_facilities; + + my $header =<<"HEADER"; +# The list of known virtual facilities that init scripts may depend on. +# + +HEADER + + my $data_path = "$basedir/" . $self->location; + my $parent_dir = path($data_path)->parent->stringify; + path($parent_dir)->mkpath + unless -e $parent_dir; + + my $output = encode_utf8($header) . $generated; + path($data_path)->spew($output); + + return 1; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Data/JoinedLines.pm b/lib/Lintian/Data/JoinedLines.pm new file mode 100644 index 0000000..a753430 --- /dev/null +++ b/lib/Lintian/Data/JoinedLines.pm @@ -0,0 +1,369 @@ +# -*- perl -*- +# Lintian::Data::JoinedLines -- interface to query lists of keywords + +# Copyright (C) 2008 Russ Allbery +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Data::JoinedLines; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(carp croak); +use Const::Fast; +use List::SomeUtils qw(any); +use Unicode::UTF8 qw(encode_utf8); + +use Moo::Role; +use namespace::clean; + +const my $EMPTY => q{}; +const my $SLASH => q{/}; + +=head1 NAME + +Lintian::Data::JoinedLines - Lintian interface to query lists of keywords + +=head1 SYNOPSIS + + my $keyword; + my $list = Lintian::Data::JoinedLines->new('type'); + if ($list->recognizes($keyword)) { + # do something ... + } + my $hash = Lintian::Data::JoinedLines->new('another-type', qr{\s++}); + if ($hash->value($keyword) > 1) { + # do something ... + } + if ($list->value($keyword) > 1) { + # do something ... + } + my @keywords = $list->all; + if ($list->matches_any($keyword)) { + # do something ... + } + +=head1 DESCRIPTION + +Lintian::Data::JoinedLines provides a way of loading a list of keywords or key/value +pairs from a file in the Lintian root and then querying that list. +The lists are stored in the F<data> directory of the Lintian root and +consist of one keyword or key/value pair per line. Blank lines and +lines beginning with C<#> are ignored. Leading and trailing whitespace +is stripped. + +If requested, the lines are split into key/value pairs with a given +separator regular expression. Otherwise, keywords are taken verbatim +as they are listed in the file and may include spaces. + +This module allows lists such as menu sections, doc-base sections, +obsolete packages, package fields, and so forth to be stored in simple, +easily editable files. + +NB: By default Lintian::Data::JoinedLines is lazy and defers loading of the data +file until it is actually needed. + +=head2 Interface for the CODE argument + +This section describes the interface between for the CODE argument +for the class method new. + +The sub will be called once for each key/pair with three arguments, +KEY, VALUE and CURVALUE. The first two are the key/value pair parsed +from the data file and CURVALUE is current value associated with the +key. CURVALUE will be C<undef> the first time the sub is called with +that KEY argument. + +The sub can then modify VALUE in some way and return the new value for +that KEY. If CURVALUE is not C<undef>, the sub may return C<undef> to +indicate that the current value should still be used. It is not +permissible for the sub to return C<undef> if CURVALUE is C<undef>. + +Where Perl semantics allow it, the sub can modify CURVALUE and the +changes will be reflected in the result. As an example, if CURVALUE +is a hashref, new keys can be inserted etc. + +=head1 INSTANCE METHODS + +=over 4 + +=item dataset + +=item C<keyorder> + +=cut + +has dataset => ( + is => 'rw', + coerce => sub { my ($hashref) = @_; return ($hashref // {}); }, + default => sub { {} } +); + +has keyorder => ( + is => 'rw', + coerce => sub { my ($arrayref) = @_; return ($arrayref // []); }, + default => sub { [] } +); + +=item all + +Returns all keywords listed in the data file as a list in original order. +In a scalar context, returns the number of keywords. + +=cut + +sub all { + my ($self) = @_; + + return @{$self->keyorder}; +} + +=item recognizes (KEY) + +Returns true if KEY was listed in the data file represented by this +Lintian::Data::JoinedLines instance and false otherwise. + +=cut + +sub recognizes { + my ($self, $key) = @_; + + return 0 + unless length $key; + + return 1 + if exists $self->dataset->{$key}; + + return 0; +} + +=item resembles (KEY) + +Returns true if the data file contains a key that is a case-insensitive match +to KEY, and false otherwise. + +=cut + +sub resembles { + my ($self, $key) = @_; + + return 0 + unless length $key; + + return 1 + if $self->recognizes($key); + + return 1 + if any { m{^\Q$key\E$}i } keys %{$self->dataset}; + + return 0; +} + +=item value (KEY) + +Returns the value attached to KEY if it was listed in the data +file represented by this Lintian::Data::JoinedLines instance and the undefined value +otherwise. + +=cut + +sub value { + my ($self, $key) = @_; + + return undef + unless length $key; + + return $self->dataset->{$key}; +} + +=item matches_any(KEYWORD[, MODIFIERS]) + +Returns true if KEYWORD matches any regular expression listed in the +data file. The optional MODIFIERS serve as modifiers on all regexes. + +=cut + +sub matches_any { + my ($self, $wanted, $modifiers) = @_; + + return 0 + unless length $wanted; + + $modifiers //= $EMPTY; + + return 1 + if any { $wanted =~ /(?$modifiers)$_/ } $self->all; + + return 0; +} + +=item load + +=cut + +sub load { + my ($self, $search_space, $our_vendor) = @_; + + my @remaining_lineage = @{$search_space // []}; + unless (@remaining_lineage) { + + carp encode_utf8('Unknown data file: ' . $self->location); + return 0; + } + + my $directory = shift @remaining_lineage; + + my $path = $directory . $SLASH . $self->location; + + return $self->load(\@remaining_lineage, $our_vendor) + unless -e $path; + + open(my $fd, '<:utf8_strict', $path) + or die encode_utf8("Cannot open $path: $!"); + + my $position = 1; + while (my $line = <$fd>) { + + # trim both ends + $line =~ s/^\s+|\s+$//g; + + next + unless length $line; + + next + if $line =~ m{^\#}; + + # a command + if ($line =~ s/^\@//) { + + my ($directive, $value) = split(/\s+/, $line, 2); + if ($directive eq 'delete') { + + croak encode_utf8( + "Missing key after \@delete in $path at line $position") + unless length $value; + + @{$self->keyorder} = grep { $_ ne $value } @{$self->keyorder}; + delete $self->dataset->{$value}; + + } elsif ($directive eq 'include-parent') { + + $self->load(\@remaining_lineage, $our_vendor) + or croak encode_utf8("No ancestor data file for $path"); + + } elsif ($directive eq 'if-vendor-is' + || $directive eq 'if-vendor-is-not') { + + my ($specified_vendor, $remain) = split(/\s+/, $value, 2); + + croak encode_utf8("Missing vendor name after \@$directive") + unless length $specified_vendor; + croak encode_utf8( + "Missing command after vendor name for \@$directive") + unless length $remain; + + $our_vendor =~ s{/.*$}{}; + + next + if $directive eq 'if-vendor-is' + && $our_vendor ne $specified_vendor; + + next + if $directive eq 'if-vendor-is-not' + && $our_vendor eq $specified_vendor; + + $line = $remain; + redo; + + } else { + croak encode_utf8( + "Unknown operation \@$directive in $path at line $position" + ); + } + next; + } + + my $key = $line; + my $remainder; + + ($key, $remainder) = split($self->separator, $line, 2) + if defined $self->separator; + + # do not autovivify; 'exists' below + my $previous; + $previous = $self->dataset->{$key} + if exists $self->dataset->{$key}; + + my $value; + if ($self->can('consumer')) { + + $value = $self->consumer($key, $remainder, $previous); + next + unless defined $value; + + } else { + $value = $remainder; + } + + push(@{$self->keyorder}, $key) + unless exists $self->dataset->{$key}; + + $self->dataset->{$key} = $value; + + } continue { + ++$position; + } + + close $fd; + + return 1; +} + +=back + +=head1 FILES + +=over 4 + +=item LINTIAN_INCLUDE_DIR/data + +The files loaded by this module must be located in this directory. +Relative paths containing a C</> are permitted, so files may be organized +in subdirectories in this directory. + +Note that lintian supports multiple LINTIAN_INCLUDE_DIRs. + +=back + +=head1 AUTHOR + +Originally written by Russ Allbery <rra@debian.org> for Lintian. + +=head1 SEE ALSO + +lintian(1), L<https://lintian.debian.org/manual/section-2.6.html> + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Data/Policy/Releases.pm b/lib/Lintian/Data/Policy/Releases.pm new file mode 100644 index 0000000..540da13 --- /dev/null +++ b/lib/Lintian/Data/Policy/Releases.pm @@ -0,0 +1,274 @@ +# -*- perl -*- +# +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2009 Russ Allbery +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Data::Policy::Releases; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Date::Parse qw(str2time); +use List::SomeUtils qw(first_value); +use IPC::Run3; +use HTTP::Tiny; +use List::SomeUtils qw(minmax); +use List::UtilsBy qw(rev_nsort_by); +use Path::Tiny; +use Time::Moment; +use Unicode::UTF8 qw(decode_utf8 encode_utf8); + +const my $SLASH => q{/}; + +const my $RELEASES => q{releases}; + +const my $WAIT_STATUS_SHIFT => 8; + +use Moo; +use namespace::clean; + +with 'Lintian::Data::PreambledJSON'; + +=head1 NAME + +Lintian::Data::Policy::Releases - Lintian interface for policy releases + +=head1 SYNOPSIS + + use Lintian::Data::Policy::Releases; + +=head1 DESCRIPTION + +This module provides a way to load data files for policy releases. + +=head1 INSTANCE METHODS + +=over 4 + +=item title + +=item location + +=item ordered_versions + +=item by_version + +=item max_dots + +=cut + +has title => ( + is => 'rw', + default => 'Debian Policy Releases' +); + +has location => ( + is => 'rw', + default => 'debian-policy/releases.json' +); + +has ordered_versions => (is => 'rw', default => sub { [] }); +has by_version => (is => 'rw', default => sub { {} }); +has max_dots => (is => 'rw'); + +=item latest_version + +=cut + +sub latest_version { + my ($self) = @_; + + return $self->ordered_versions->[0]; +} + +=item normalize + +=cut + +sub normalize { + my ($self, $version) = @_; + + my $have = $version =~ tr{\.}{}; + my $need = $self->max_dots - $have; + + $version .= '.0' for (1..$need); + + return $version; +} + +=item is_known + +=cut + +sub is_known { + my ($self, $version) = @_; + + my $normalized = $self->normalize($version); + + return exists $self->by_version->{$normalized}; +} + +=item epoch + +=cut + +sub epoch { + my ($self, $version) = @_; + + my $normalized = $self->normalize($version); + + my $release = $self->by_version->{$normalized}; + return undef + unless defined $release; + + return $release->{epoch}; +} + +=item author + +=cut + +sub author { + my ($self, $version) = @_; + + my $normalized = $self->normalize($version); + + my $release = $self->by_version->{$normalized}; + return undef + unless defined $release; + + return $release->{author}; +} + +=item load + +=cut + +sub load { + my ($self, $search_space, $our_vendor) = @_; + + my @candidates = map { $_ . $SLASH . $self->location } @{$search_space}; + my $path = first_value { -e } @candidates; + + my $reference; + return 0 + unless $self->read_file($path, \$reference); + + my @releases = @{$reference // []}; + + my @sorted = rev_nsort_by { $_->{epoch} } @releases; + my @ordered_versions = map { $_->{version} } @sorted; + $self->ordered_versions(\@ordered_versions); + + my @dot_count = map { tr{\.}{} } @ordered_versions; + my (undef, $max_dots) = minmax @dot_count; + $self->max_dots($max_dots); + + # normalize versions + $_->{version} = $self->normalize($_->{version}) for @releases; + + my %by_version; + $by_version{$_->{version}} = $_ for @releases; + + $self->by_version(\%by_version); + + return 1; +} + +=item refresh + +=cut + +sub refresh { + my ($self, $archive, $basedir) = @_; + + my $changelog_url + = 'https://salsa.debian.org/dbnpolicy/policy/-/raw/master/debian/changelog?inline=false'; + + my $response = HTTP::Tiny->new->get($changelog_url); + die encode_utf8("Failed to get $changelog_url!\n") + unless $response->{success}; + + my $tempfile_tiny = Path::Tiny->tempfile; + $tempfile_tiny->spew($response->{content}); + + my @command = ( + qw{dpkg-parsechangelog --format rfc822 --all --file}, + $tempfile_tiny->stringify + ); + my $rfc822; + my $stderr; + run3(\@command, \undef, \$rfc822, \$stderr); + my $dpkg_status = ($? >> $WAIT_STATUS_SHIFT); + + # already in UTF-8 + die $stderr + if $dpkg_status; + + my $deb822 = Lintian::Deb822->new; + my @sections = $deb822->parse_string(decode_utf8($rfc822)); + + my @releases; + for my $section (@sections) { + + my $epoch = str2time($section->value('Date'), 'GMT'); + my $moment = Time::Moment->from_epoch($epoch); + my $timestamp = $moment->strftime('%Y-%m-%dT%H:%M:%S%Z'); + + my @closes = sort { $a <=> $b } $section->trimmed_list('Closes'); + my @changes = split(/\n/, $section->text('Changes')); + + my %release; + $release{version} = $section->value('Version'); + $release{timestamp} = $timestamp; + $release{epoch} = $epoch; + $release{closes} = \@closes; + $release{changes} = \@changes; + $release{author} = $section->value('Maintainer'); + + push(@releases, \%release); + } + + my @sorted = rev_nsort_by { $_->{epoch} } @releases; + + my $data_path = "$basedir/" . $self->location; + my $write_status = $self->write_file($RELEASES, \@releases, $data_path); + + return $write_status; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Data/PreambledJSON.pm b/lib/Lintian/Data/PreambledJSON.pm new file mode 100644 index 0000000..e2af970 --- /dev/null +++ b/lib/Lintian/Data/PreambledJSON.pm @@ -0,0 +1,164 @@ +# -*- 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Data::PreambledJSON; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(carp); +use Const::Fast; +use JSON::MaybeXS; +use Path::Tiny; +use Time::Piece; +use Unicode::UTF8 qw(encode_utf8); + +use Moo::Role; +use namespace::clean; + +const my $EMPTY => q{}; + +const my $PREAMBLE => q{preamble}; +const my $TITLE => q{title}; +const my $CARGO => q{cargo}; + +=encoding utf-8 + +=head1 NAME + +Lintian::Data::PreambledJSON -- Data in preambled JSON format + +=head1 SYNOPSIS + + use Lintian::Data::PreambledJSON; + +=head1 DESCRIPTION + +Routines for access and management of preambled JSON data files. + +=head1 INSTANCE METHODS + +=over 4 + +=item last_modified + +=cut + +has cargo => ( + is => 'rw', + coerce => sub { my ($scalar) = @_; return ($scalar // $EMPTY); } +); + +=item read_file + +=cut + +sub read_file { + my ($self, $path, $double_reference) = @_; + + if (!length $path || !-e $path) { + + carp encode_utf8("Unknown data file: $path"); + return 0; + } + + my $json = path($path)->slurp; + my $data = decode_json($json); + + my %preamble = %{$data->{$PREAMBLE}}; + my $stored_title = $preamble{$TITLE}; + my $storage_key = $preamble{$CARGO}; + + unless (length $stored_title && length $storage_key) { + warn encode_utf8("Please refresh data file $path: invalid format"); + return 0; + } + + unless ($stored_title eq $self->title) { + warn encode_utf8( + "Please refresh data file $path: wrong title $stored_title"); + return 0; + } + + if ($storage_key eq $PREAMBLE) { + warn encode_utf8( + "Please refresh data file $path: disallowed cargo key $storage_key" + ); + return 0; + } + + if (!exists $data->{$storage_key}) { + warn encode_utf8( + "Please refresh data file $path: cargo key $storage_key not found" + ); + return 0; + } + + ${$double_reference} = $data->{$storage_key}; + + return 1; +} + +=item write_file + +=cut + +sub write_file { + my ($self, $storage_key, $reference, $path) = @_; + + die +"Cannot write preambled JSON data file $path: disallowed cargo key $storage_key" + if $storage_key eq $PREAMBLE; + + my %preamble; + $preamble{$TITLE} = $self->title; + $preamble{$CARGO} = $storage_key; + + my %combined; + $combined{$PREAMBLE} = \%preamble; + $combined{$storage_key} = $reference; + + # convert to UTF-8 prior to encoding in JSON + my $encoder = JSON->new; + $encoder->canonical; + $encoder->utf8; + $encoder->pretty; + + my $json = $encoder->encode(\%combined); + + my $parentdir = path($path)->parent->stringify; + path($parentdir)->mkpath + unless -e $parentdir; + + # already in UTF-8 + path($path)->spew($json); + + return 1; +} + +=back + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Data/Provides/MailTransportAgent.pm b/lib/Lintian/Data/Provides/MailTransportAgent.pm new file mode 100644 index 0000000..51818f2 --- /dev/null +++ b/lib/Lintian/Data/Provides/MailTransportAgent.pm @@ -0,0 +1,193 @@ +# -*- perl -*- +# +# Copyright (C) 2008 Niko Tyni +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Data::Provides::MailTransportAgent; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(carp); +use Const::Fast; +use List::SomeUtils qw(first_value any); +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +const my $SLASH => q{/}; + +const my $NEWLINE => qq{\n}; + +=head1 NAME + +Lintian::Data::Provides::MailTransportAgent - Lintian interface for mail transport agents. + +=head1 SYNOPSIS + + use Lintian::Data::Provides::MailTransportAgent; + +=head1 DESCRIPTION + +This module provides a way to load data files for mail transport agents. + +=head1 INSTANCE METHODS + +=over 4 + +=item title + +=item location + +=item mail_transport_agents + +=item deb822_by_installable_name + +=cut + +has title => ( + is => 'rw', + default => 'Mail Transport Agents' +); + +has location => ( + is => 'rw', + default => 'fields/mail-transport-agents' +); + +has mail_transport_agents => (is => 'rw', default => sub { [] }); + +=item all + +=cut + +sub all { + my ($self) = @_; + + return keys %{$self->mail_transport_agents}; +} + +=item load + +=cut + +sub load { + my ($self, $search_space, $our_vendor) = @_; + + my @candidates = map { $_ . $SLASH . $self->location } @{$search_space}; + my $path = first_value { -e } @candidates; + + unless (length $path) { + carp encode_utf8('Unknown data file: ' . $self->location); + return 0; + } + + open(my $fd, '<:utf8_strict', $path) + or die encode_utf8("Cannot open $path: $!"); + + my $position = 1; + while (my $line = <$fd>) { + + # trim both ends + $line =~ s/^\s+|\s+$//g; + + next + unless length $line; + + next + if $line =~ m{^ [#]}x; + + my $agent = $line; + + push(@{$self->mail_transport_agents}, $agent); + + } continue { + ++$position; + } + + close $fd; + + return 1; +} + +=item refresh + +=cut + +sub refresh { + my ($self, $archive, $basedir) = @_; + + my @mail_transport_agents; + + # neutral sort order + local $ENV{LC_ALL} = 'C'; + + my $port = 'amd64'; + + my $deb822_by_installable_name + = $archive->deb822_packages_by_installable_name('sid', 'main', $port); + + for my $installable_name (keys %{$deb822_by_installable_name}) { + + my $deb822 = $deb822_by_installable_name->{$installable_name}; + + my @provides = $deb822->trimmed_list('Provides', qr{ \s* , \s* }x); + + push(@mail_transport_agents, $installable_name) + if any { $_ eq 'mail-transport-agent' } @provides; + } + + my $text = encode_utf8(<<'EOF'); +# Packages that provide mail-transport-agent +# +EOF + + $text .= encode_utf8($_ . $NEWLINE)for sort @mail_transport_agents; + + my $datapath = "$basedir/" . $self->location; + my $parentdir = path($datapath)->parent->stringify; + path($parentdir)->mkpath + unless -e $parentdir; + + # already in UTF-8 + path($datapath)->spew($text); + + return 1; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Data/Stylesheet.pm b/lib/Lintian/Data/Stylesheet.pm new file mode 100644 index 0000000..bfc8c5b --- /dev/null +++ b/lib/Lintian/Data/Stylesheet.pm @@ -0,0 +1,139 @@ +# -*- 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Data::Stylesheet; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(carp); +use Const::Fast; +use HTTP::Tiny; +use List::SomeUtils qw(first_value); +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8); + +const my $EMPTY => q{}; +const my $SLASH => q{/}; + +use Moo; +use namespace::clean; + +=head1 NAME + +Lintian::Data::Stylesheet - Lintian interface to CSS style sheets + +=head1 SYNOPSIS + + use Lintian::Data::Stylesheet; + +=head1 DESCRIPTION + +This module provides a way to load data files to CSS style sheets + +=head1 INSTANCE METHODS + +=over 4 + +=item title + +=item location + +=item C<css> + +=cut + +has title => ( + is => 'rw', + default => 'Lintian CSS Style Sheet' +); + +has location => ( + is => 'rw', + default => 'stylesheets/lintian.css' +); + +has css => (is => 'rw', default => $EMPTY); + +=item load + +=cut + +sub load { + my ($self, $search_space, $our_vendor) = @_; + + my @candidates = map { $_ . $SLASH . $self->location } @{$search_space}; + my $path = first_value { -e } @candidates; + + unless (length $path) { + carp encode_utf8('Unknown data file: ' . $self->location); + return 0; + } + + my $style_sheet = path($path)->slurp_utf8; + + $self->css($style_sheet); + + return 1; +} + +=item refresh + +=cut + +sub refresh { + my ($self, $archive, $basedir) = @_; + + my $css_url = 'https://lintian.debian.org/stylesheets/lintian.css'; + + my $response = HTTP::Tiny->new->get($css_url); + die encode_utf8("Failed to get $css_url!\n") + unless $response->{success}; + + my $style_sheet = $response->{content}; + + my $data_path = "$basedir/" . $self->location; + my $parent_dir = path($data_path)->parent->stringify; + path($parent_dir)->mkpath + unless -e $parent_dir; + + # already in UTF-8 + path($data_path)->spew($style_sheet); + + return 1; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Data/Traditional.pm b/lib/Lintian/Data/Traditional.pm new file mode 100644 index 0000000..9deaf12 --- /dev/null +++ b/lib/Lintian/Data/Traditional.pm @@ -0,0 +1,73 @@ +# -*- 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Data::Traditional; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Data::JoinedLines'; + +=head1 NAME + +Lintian::Data::Traditional - Lintian interface for generic data + +=head1 SYNOPSIS + + use Lintian::Data::Traditional; + +=head1 DESCRIPTION + +Lintian::Data::Traditional provides a way to load generic, traditional +data files. + +=head1 CLASS METHODS + +=over 4 + +=item location + +=item separator + +=cut + +has location => (is => 'rw'); +has separator => (is => 'rw'); + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Deb822.pm b/lib/Lintian/Deb822.pm new file mode 100644 index 0000000..c153415 --- /dev/null +++ b/lib/Lintian/Deb822.pm @@ -0,0 +1,692 @@ +# Copyright (C) 1998 Christian Schwarz +# 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::Deb822; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Path::Tiny; +use Syntax::Keyword::Try; +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::Deb822::Constants qw(:constants); +use Lintian::Deb822::Section; + +const my $EMPTY => q{}; +const my $NUMBER_SIGN => q{#}; + +use Moo; +use namespace::clean; + +=encoding utf-8 + +=head1 NAME + +Lintian::Deb822 -- A deb822 control file + +=head1 SYNOPSIS + + use Lintian::Deb822; + +=head1 DESCRIPTION + +Represents a paragraph in a Deb822 control file. + +=head1 INSTANCE METHODS + +=over 4 + +=item sections + +Array of Deb822::Section objects in order of their original appearance. + +=item positions + +Line positions + +=cut + +has sections => (is => 'rw', default => sub { [] }); +has positions => (is => 'rw', default => sub { [] }); + +=item first_mention + +=cut + +sub first_mention { + my ($self, $name) = @_; + + my $earliest; + + # empty when field not present + $earliest ||= $_->value($name) for @{$self->sections}; + + return ($earliest // $EMPTY); +} + +=item last_mention + +=cut + +sub last_mention { + my ($self, $name) = @_; + + my $latest; + + for my $section (@{$self->sections}) { + + # empty when field not present + $latest = $section->value($name) + if $section->declares($name); + } + + return ($latest // $EMPTY); +} + +=item read_file + +=cut + +sub read_file { + my ($self, $path, $flags) = @_; + + my $contents = path($path)->slurp_utf8; + + return $self->parse_string($contents, $flags); +} + +=item parse_string + +=cut + +sub parse_string { + my ($self, $contents, $flags) = @_; + + my (@paragraphs, @positions); + + try { + @paragraphs= parse_dpkg_control_string($contents, $flags,\@positions); + + } catch { + # ignore syntax errors here + die map { encode_utf8($_) } $@ + unless $@ =~ /syntax error/; + } + + my $index = 0; + for my $paragraph (@paragraphs) { + + my $section = Lintian::Deb822::Section->new; + $section->verbatim($paragraph); + $section->positions($positions[$index]); + + push(@{$self->sections}, $section); + + } continue { + $index++; + } + + return @{$self->sections}; +} + +=back + +=head1 FUNCTIONS + +=head2 Debian control parsers + +At first glance, this module appears to contain several debian control +parsers. In practise, there is only one real parser +(L</visit_dpkg_paragraph_string>) - the rest are convenience functions around +it. + +=over 4 + +=item read_dpkg_control(FILE[, FLAGS[, LINES]]) + +This is a convenience function to ease using L</parse_dpkg_control> +with paths to files (rather than open handles). The first argument +must be the path to a FILE, which should be read as a debian control +file. If the file is empty, an empty list is returned. + +Otherwise, this behaves like: + + use autodie; + + open(my $fd, '<:encoding(UTF-8)', FILE); # or '<' + my @p = parse_dpkg_control($fd, FLAGS, LINES); + close($fd); + return @p; + +This goes without saying that may fail with any of the messages that +L</parse_dpkg_control(HANDLE[, FLAGS[, LINES]])> do. It can also emit +autodie exceptions if open or close fails. + +=cut + +sub read_dpkg_control { + my ($file, $flags, $field_starts) = @_; + + open(my $handle, '<:utf8_strict', $file) + or die encode_utf8("Cannot open $file"); + + local $/ = undef; + my $string = <$handle>; + close $handle; + + my @result; + + my $visitor = sub { + my ($paragraph, $line) = @_; + + push(@result, $paragraph); + push(@{$field_starts}, $line) if defined $field_starts; + }; + + visit_dpkg_paragraph_string($visitor, $string, $flags); + + return @result; +} + +=item read_dpkg_control_lc(FILE[, FLAGS[, LINES]]) + +=cut + +sub read_dpkg_control_lc { + my ($file, $flags, $field_starts) = @_; + + my @result = read_dpkg_control($file, $flags, $field_starts); + + lowercase_field_names(\@result); + lowercase_field_names($field_starts); + + return @result; +} + +=item parse_dpkg_control_string(STRING[, FLAGS[, LINES]]) + +Reads debian control data from STRING and returns a list of +paragraphs in it. A paragraph is represented via a hashref, which +maps (lower cased) field names to their values. + +FLAGS (if given) is a bitmask of the I<DCTRL_*> constants. Please +refer to L</CONSTANTS> for the list of constants and their meaning. +The default value for FLAGS is 0. + +If LINES is given, it should be a reference to an empty list. On +return, LINES will be populated with a hashref for each paragraph (in +the same order as the returned list). Each hashref will also have a +special key "I<START-OF-PARAGRAPH>" that gives the line number of the +first field in that paragraph. These hashrefs will map the field name +of the given paragraph to the line number where the field name +appeared. + +This is a convenience sub around L</visit_dpkg_paragraph> and can +therefore produce the same errors as it. Please see +L</visit_dpkg_paragraph> for the finer semantics of how the +control file is parsed. + +NB: parse_dpkg_control does I<not> close the handle for the caller. + +=cut + +sub parse_dpkg_control_string { + my ($string, $flags, $field_starts) = @_; + my @result; + + my $c = sub { + my ($para, $line) = @_; + + push(@result, $para); + push(@{$field_starts}, $line) + if defined $field_starts; + }; + + visit_dpkg_paragraph_string($c, $string, $flags); + + return @result; +} + +=item parse_dpkg_control_string_lc(STRING[, FLAGS[, LINES]]) + +=cut + +sub parse_dpkg_control_string_lc { + my ($string, $flags, $field_starts) = @_; + + my @result = parse_dpkg_control_string($string, $flags, $field_starts); + + lowercase_field_names(\@result); + lowercase_field_names($field_starts); + + return @result; +} + +=item lowercase_field_names + +=cut + +sub lowercase_field_names { + my ($arrayref) = @_; + + return + unless $arrayref; + + for my $paragraph (@{$arrayref}) { + + # magic marker should only appear in field starts + my @fields = grep { $_ ne 'START-OF-PARAGRAPH' } keys %{$paragraph}; + my @mixedcase = grep { $_ ne lc } @fields; + + for my $old (@mixedcase) { + $paragraph->{lc $old} = $paragraph->{$old}; + delete $paragraph->{$old}; + } + } + + return; +} + +=item visit_dpkg_paragraph_string (CODE, STRING[, FLAGS]) + +Reads debian control data from STRING and passes each paragraph to +CODE. A paragraph is represented via a hashref, which maps (lower +cased) field names to their values. + +FLAGS (if given) is a bitmask of the I<DCTRL_*> constants. Please +refer to L</CONSTANTS> for the list of constants and their meaning. +The default value for FLAGS is 0. + +If the file is empty (i.e. it contains no paragraphs), the method will +contain an I<empty> list. The deb822 contents may be inside a +I<signed> PGP message with a signature. + +visit_dpkg_paragraph will require the PGP headers to be correct (if +present) and require that the entire file is covered by the signature. +However, it will I<not> validate the signature (in fact, the contents +of the PGP SIGNATURE part can be empty). The signature should be +validated separately. + +visit_dpkg_paragraph will pass paragraphs to CODE as they are +completed. If CODE can process the paragraphs as they are seen, very +large control files can be processed without keeping all the +paragraphs in memory. + +As a consequence of how the file is parsed, CODE may be passed a +number of (valid) paragraphs before parsing is stopped due to a syntax +error. + +NB: visit_dpkg_paragraph does I<not> close the handle for the caller. + +CODE is expected to be a callable reference (e.g. a sub) and will be +invoked as the following: + +=over 4 + +=item CODE->(PARA, LINE_NUMBERS) + +The first argument, PARA, is a hashref to the most recent paragraph +parsed. The second argument, LINE_NUMBERS, is a hashref mapping each +of the field names to the line number where the field name appeared. +LINE_NUMBERS will also have a special key "I<START-OF-PARAGRAPH>" that +gives the line number of the first field in that paragraph. + +The return value of CODE is ignored. + +If the CODE invokes die (or similar) the error is propagated to the +caller. + +=back + + +I<On syntax errors>, visit_dpkg_paragraph will call die with the +following string: + + "syntax error at line %d: %s\n" + +Where %d is the line number of the issue and %s is one of: + +=over + +=item Duplicate field %s + +The field appeared twice in the paragraph. + +=item Continuation line outside a paragraph (maybe line %d should be " .") + +A continuation line appears outside a paragraph - usually caused by an +unintended empty line before it. + +=item Whitespace line not allowed (possibly missing a ".") + +An empty continuation line was found. This usually means that a +period is missing to denote an "empty line" in (e.g.) the long +description of a package. + +=item Cannot parse line "%s" + +Generic error containing the text of the line that confused the +parser. Note that all non-printables in %s will be replaced by +underscores. + +=item Comments are not allowed + +A comment line appeared and FLAGS contained DCTRL_NO_COMMENTS. + +=item PGP signature seen before start of signed message + +A "BEGIN PGP SIGNATURE" header is seen and a "BEGIN PGP MESSAGE" has +not been seen yet. + +=item Two PGP signatures (first one at line %d) + +Two "BEGIN PGP SIGNATURE" headers are seen in the same file. + +=item Unexpected %s header + +A valid PGP header appears (e.g. "BEGIN PUBLIC KEY BLOCK"). + +=item Malformed PGP header + +An invalid or malformed PGP header appears. + +=item Expected at most one signed message (previous at line %d) + +Two "BEGIN PGP MESSAGE" headers appears in the same message. + +=item End of file but expected an "END PGP SIGNATURE" header + +The file ended after a "BEGIN PGP SIGNATURE" header without being +followed by an "END PGP SIGNATURE". + +=item PGP MESSAGE header must be first content if present + +The file had content before PGP MESSAGE. + +=item Data after the PGP SIGNATURE + +The file had data after the PGP SIGNATURE block ended. + +=item End of file before "BEGIN PGP SIGNATURE" + +The file had a "BEGIN PGP MESSAGE" header, but no signature was +present. + +=back + +=cut + +sub visit_dpkg_paragraph_string { + my ($code, $string, $flags) = @_; + $flags//=0; + my $field_starts = {}; + my $section = {}; + my $open_section = 0; + my $last_tag; + my $debconf = $flags & DCTRL_DEBCONF_TEMPLATE; + my $signed = 0; + my $signature = 0; + + my @lines = split(/\n/, $string); + + my $position = 1; + + my $line; + while (defined($line = shift @lines)) { + chomp $line; + + if (substr($line, 0, 1) eq $NUMBER_SIGN) { + next + unless $flags & DCTRL_NO_COMMENTS; + die encode_utf8("No comments allowed (line $position).\n"); + } + + # empty line? + if ($line eq $EMPTY || (!$debconf && $line =~ /^\s*$/)) { + if ($open_section) { # end of current section + # pass the current section to the handler + $code->($section, $field_starts); + $section = {}; + $field_starts = {}; + $open_section = 0; + } + } + # pgp sig? Be strict here (due to #696230) + # According to http://tools.ietf.org/html/rfc4880#section-6.2 + # The header MUST start at the beginning of the line and MUST NOT have + # any other text (except whitespace) after the header. + elsif ($line =~ m/^-----BEGIN PGP SIGNATURE-----[ \r\t]*$/) + { # skip until end of signature + my $saw_end = 0; + + die encode_utf8("PGP signature before message (line $position).\n") + unless $signed; + + die encode_utf8( +"Found two PGP signatures (line $signature and line $position).\n" + )if $signature; + + $signature = $position; + while (defined($line = shift @lines)) { + if ($line =~ /^-----END PGP SIGNATURE-----[ \r\t]*$/) { + $saw_end = 1; + last; + } + }continue { + ++$position; + } + + # The "at line X" may seem a little weird, but it keeps the + # message format identical. + die encode_utf8("Cannot find END PGP SIGNATURE header.\n") + unless $saw_end; + } + # other pgp control? + elsif ($line =~ /^-----(?:BEGIN|END) PGP/) { + # At this point it could be a malformed PGP header or one + # of the following valid headers (RFC4880): + # * BEGIN PGP MESSAGE + # - Possibly a signed Debian CTRL, so okay (for now) + # * BEGIN PGP {PUBLIC,PRIVATE} KEY BLOCK + # - Valid header, but not a Debian CTRL file. + # * BEGIN PGP MESSAGE, PART X{,/Y} + # - Valid, but we don't support partial messages, so + # bail on those. + + unless ($line =~ /^-----BEGIN PGP SIGNED MESSAGE-----[ \r\t]*$/) { + # Not a (full) PGP MESSAGE; reject. + + my $key = qr/(?:BEGIN|END) PGP (?:PUBLIC|PRIVATE) KEY BLOCK/; + my $msgpart = qr{BEGIN PGP MESSAGE, PART \d+(?:/\d+)?}; + my $msg + = qr/(?:BEGIN|END) PGP (?:(?:COMPRESSED|ENCRYPTED) )?MESSAGE/; + + if ($line =~ /^-----($key|$msgpart|$msg)-----[ \r\t]*$/) { + die encode_utf8( + "Unexpected $1 header (line $position).\n"); + } + + die encode_utf8("Malformed PGP header (line $position).\n"); + + } else { + die encode_utf8( +"Multiple PGP messages (line $signed and line $position).\n" + )if $signed; + + # NB: If you remove this, keep in mind that it may + # allow two paragraphs to merge. Consider: + # + # Field-P1: some-value + # -----BEGIN PGP SIGNATURE----- + # + # Field-P2: another value + # + # At the time of writing: If $open_section is + # true, it will remain so until the empty line + # after the PGP header. + die encode_utf8( + "Expected PGP MESSAGE header (line $position).\n") + if $last_tag; + + $signed = $position; + } + + # skip until the next blank line + while (defined($line = shift @lines)) { + last + if $line =~ /^\s*$/; + }continue { + ++$position; + } + } + # did we see a signature already? We allow all whitespace/comment lines + # outside the signature. + elsif ($signature) { + # Accept empty lines after the signature. + next + if $line =~ /^\s*$/; + + # NB: If you remove this, keep in mind that it may allow + # two paragraphs to merge. Consider: + # + # Field-P1: some-value + # -----BEGIN PGP SIGNATURE----- + # [...] + # -----END PGP SIGNATURE----- + # Field-P2: another value + # + # At the time of writing: If $open_section is true, it + # will remain so until the empty line after the PGP + # header. + die encode_utf8("Data after PGP SIGNATURE (line $position).\n"); + } + # new empty field? + elsif ($line =~ /^([^: \t]+):\s*$/) { + $field_starts->{'START-OF-PARAGRAPH'} = $position + unless $open_section; + $open_section = 1; + + my $tag = $1; + $section->{$tag} = $EMPTY; + $field_starts->{$tag} = $position; + + $last_tag = $tag; + } + # new field? + elsif ($line =~ /^([^: \t]+):\s*(.*)$/) { + $field_starts->{'START-OF-PARAGRAPH'} = $position + unless $open_section; + $open_section = 1; + + # Policy: Horizontal whitespace (spaces and tabs) may occur + # immediately before or after the value and is ignored there. + my $tag = $1; + my $value = $2; + + # trim right + $value =~ s/\s+$//; + + if (exists $section->{$tag}) { + # Policy: A paragraph must not contain more than one instance + # of a particular field name. + die encode_utf8("Duplicate field $tag (line $position).\n"); + } + $value =~ s/#.*$// + if $flags & DCTRL_COMMENTS_AT_EOL; + $section->{$tag} = $value; + $field_starts->{$tag} = $position; + + $last_tag = $tag; + } + + # continued field? + elsif ($line =~ /^([ \t].*\S.*)$/) { + die encode_utf8( +"Continuation line not in paragraph (line $position). Missing a dot on the previous line?\n" + )unless $open_section; + + # Policy: Many fields' values may span several lines; in this case + # each continuation line must start with a space or a tab. Any + # trailing spaces or tabs at the end of individual lines of a + # field value are ignored. + my $value = $1; + + # trim right + $value =~ s/\s+$//; + + $value =~ s/#.*$// + if $flags & DCTRL_COMMENTS_AT_EOL; + $section->{$last_tag} .= "\n" . $value; + } + # None of the above => syntax error + else { + + die encode_utf8( + "Unexpected whitespace (line $position). Missing a dot?\n") + if $line =~ /^\s+$/; + + # Replace non-printables and non-space characters with + # "_" - just in case. + $line =~ s/[^[:graph:][:space:]]/_/g; + + die encode_utf8("Cannot parse line $position: $line\n"); + } + + }continue { + ++$position; + } + + # pass the last section (if not already done). + $code->($section, $field_starts) + if $open_section; + + # Given the API, we cannot use this check to prevent any + # paragraphs from being emitted to the code argument, so we might + # as well just do this last. + + die encode_utf8("Cannot find BEGIN PGP SIGNATURE\n.") + if $signed && !$signature; + + return; +} + +=back + +=head1 AUTHOR + +Originally written Christian Schwarz and many other people. + +Moo version by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Deb822/Constants.pm b/lib/Lintian/Deb822/Constants.pm new file mode 100644 index 0000000..a30e117 --- /dev/null +++ b/lib/Lintian/Deb822/Constants.pm @@ -0,0 +1,87 @@ +# Hey emacs! This is a -*- Perl -*- script! +# Lintian::Deb822::Constants -- Perl utility functions for parsing deb822 files + +# 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::Deb822::Constants; + +use v5.20; +use warnings; +use utf8; + +use constant { + DCTRL_DEBCONF_TEMPLATE => 1, + DCTRL_NO_COMMENTS => 2, + DCTRL_COMMENTS_AT_EOL => 4, +}; + +our %EXPORT_TAGS = (constants => + [qw(DCTRL_DEBCONF_TEMPLATE DCTRL_NO_COMMENTS DCTRL_COMMENTS_AT_EOL)],); + +our @EXPORT_OK = (@{ $EXPORT_TAGS{constants} }); + +use Exporter qw(import); + +=head1 NAME + +Lintian::Deb822::Constants - Lintian's generic Deb822 constants + +=head1 SYNOPSIS + + use Lintian::Deb822::Constants qw(DCTRL_NO_COMMENTS); + +=head1 DESCRIPTION + +This module contains a number of utility subs that are nice to have, +but on their own did not warrant their own module. + +Most subs are imported only on request. + +=head1 CONSTANTS + +The following constants can be passed to the Debian control file +parser functions to alter their parsing flag. + +=over 4 + +=item DCTRL_DEBCONF_TEMPLATE + +The file should be parsed as debconf template. These have slightly +syntax rules for whitespace in some cases. + +=item DCTRL_NO_COMMENTS + +The file do not allow comments. With this flag, any comment in the +file is considered a syntax error. + +=back + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Deb822/Section.pm b/lib/Lintian/Deb822/Section.pm new file mode 100644 index 0000000..5950ee4 --- /dev/null +++ b/lib/Lintian/Deb822/Section.pm @@ -0,0 +1,373 @@ +# 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::Deb822::Section; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::Compare; + +const my $EMPTY => q{}; + +const my $UNKNOWN_POSITION => -1; + +use Moo; +use namespace::clean; + +=encoding utf-8 + +=head1 NAME + +Lintian::Deb822::Section -- A paragraph in a control file + +=head1 SYNOPSIS + + use Lintian::Deb822::Section; + +=head1 DESCRIPTION + +Represents a paragraph in a Deb822 control file. + +=head1 INSTANCE METHODS + +=over 4 + +=item legend + +Returns exact field names for their lowercase versions. + +=item verbatim + +Returns a hash to the raw, unedited and verbatim field values. + +=item unfolded + +Returns a hash to unfolded field values. Continuations lines +have been connected. + +=item positions + +The original line positions. + +=cut + +has legend => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my %legend; + + for my $key (keys %{$self->verbatim}) { + + my $lowercase = lc $key; + $legend{$lowercase} = $key; + } + + return \%legend; + } +); + +has verbatim => (is => 'rw', default => sub { {} }); +has unfolded => (is => 'rw', default => sub { {} }); +has positions => (is => 'rw', default => sub { {} }); + +=item trimmed_list(FIELD [, SEPARATOR]) + +=cut + +sub trimmed_list { + my ($self, $name, $regex) = @_; + + $regex //= qr/\s+/; + + my $value = $self->value($name); + + # trim both ends + $value =~ s/^\s+|\s+$//g; + + my @list = split($regex, $value); + + # trim both ends of each element + s/^\s+|\s+$//g for @list; + + return grep { length } @list; +} + +=item unfolded_value (FIELD) + +This method returns the unfolded value of the control field FIELD in +the control file for the package. For a source package, this is the +*.dsc file; for a binary package, this is the control file in the +control section of the package. + +If FIELD is passed but not present, then this method returns undef. + +=cut + +sub unfolded_value { + my ($self, $name) = @_; + + return $EMPTY + unless length $name; + + my $lowercase = lc $name; + + my $unfolded = $self->unfolded->{$lowercase}; + return $unfolded + if defined $unfolded; + + my $value = $self->value($name); + + # will also replace a newline at the very end + $value =~ s/\n//g; + + # Remove leading space as it confuses some of the other checks + # that are anchored. This happens if the field starts with a + # space and a newline, i.e ($ marks line end): + # + # Vcs-Browser: $ + # http://somewhere.com/$ + $value =~ s/^\s*+//; + + $self->unfolded->{$lowercase} = $value; + + return $value; +} + +=item value (FIELD) + +If FIELD is given, this method returns the value of the control field +FIELD. + +=cut + +sub value { + my ($self, $name) = @_; + + return $EMPTY + unless length $name; + + my $exact = $self->legend->{lc $name}; + return $EMPTY + unless length $exact; + + my $trimmed = $self->verbatim->{$exact} // $EMPTY; + + # trim both ends + $trimmed =~ s/^\s+|\s+$//g; + + return $trimmed; +} + +=item untrimmed_value (FIELD) + +If FIELD is given, this method returns the value of the control field +FIELD. + +=cut + +sub untrimmed_value { + my ($self, $name) = @_; + + return $EMPTY + unless length $name; + + my $exact = $self->legend->{lc $name}; + return $EMPTY + unless length $exact; + + return $self->verbatim->{$exact} // $EMPTY; +} + +=item text (FIELD) + +=cut + +sub text { + my ($self, $name) = @_; + + my $text = $self->untrimmed_value($name); + + # remove leading space in each line + $text =~ s/^[ \t]//mg; + + # remove dot place holder for empty lines + $text =~ s/^\.$//mg; + + return $text; +} + +=item store (FIELD, VALUE) + +=cut + +sub store { + my ($self, $name, $value) = @_; + + $value //= $EMPTY; + + return + unless length $name; + + my $exact = $self->legend->{lc $name}; + + # add new value if key not found + unless (defined $exact) { + + $exact = $name; + + # update legend with exact spelling + $self->legend->{lc $exact} = $exact; + + # remove any old position + $self->positions->{$exact} = $UNKNOWN_POSITION; + } + + $self->verbatim->{$exact} = $value; + + # remove old unfolded value, if any + delete $self->unfolded->{$exact}; + + return; +} + +=item drop (FIELD) + +=cut + +sub drop { + my ($self, $name) = @_; + + return + unless length $name; + + my $exact = $self->legend->{lc $name}; + return + unless length $exact; + + delete $self->legend->{lc $exact}; + + delete $self->verbatim->{$exact}; + delete $self->unfolded->{$exact}; + delete $self->positions->{$exact}; + + return; +} + +=item declares (NAME) + +Returns a boolean for whether the named field exists. + +=cut + +sub declares { + my ($self, $name) = @_; + + return 1 + if defined $self->legend->{lc $name}; + + return 0; +} + +=item names + +Returns an array with the literal field names. + +=cut + +sub names { + my ($self) = @_; + + return keys %{$self->verbatim}; +} + +=item literal_name + +Returns an array with the literal, true case field names. + +=cut + +sub literal_name { + my ($self, $anycase) = @_; + + return $self->legend->{ lc $anycase }; +} + +=item position + +With an argument, returns the starting line of the named field. + +Without an argument, return the starting line of the paragraph. + +=cut + +sub position { + my ($self, $field) = @_; + + return $self->positions->{'START-OF-PARAGRAPH'} + unless length $field; + + my $exact = $self->legend->{lc $field}; + return undef + unless length $exact; + + return $self->positions->{$exact}; +} + +=item extra + +=cut + +sub extra { + my ($self, @reference) = @_; + + my @lowercase = map { lc } @reference; + + my $extra_lc + = List::Compare->new([keys %{$self->legend}], \@lowercase); + my @extra_lowercase = $extra_lc->get_Lonly; + + my @extra = map { $self->literal_name($_) } @extra_lowercase; + + return @extra; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Debian/Control.pm b/lib/Lintian/Debian/Control.pm new file mode 100644 index 0000000..cd99302 --- /dev/null +++ b/lib/Lintian/Debian/Control.pm @@ -0,0 +1,198 @@ +# -*- perl -*- +# Lintian::Debian::Control -- object for fields in d/control + +# Copyright (C) 2008 Russ Allbery +# Copyright (C) 2009 Raphael Geissert +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Debian::Control; + +use v5.20; +use warnings; +use utf8; + +use Path::Tiny; +use Syntax::Keyword::Try; +use Unicode::UTF8 qw(valid_utf8 decode_utf8 encode_utf8); + +use Lintian::Deb822; +use Lintian::Deb822::Section; +use Lintian::Util qw($PKGNAME_REGEX); + +use Moo; +use namespace::clean; + +=head1 NAME + +Lintian::Debian::Control - Lintian interface to d/control fields + +=head1 SYNOPSIS + + use Lintian::Debian::Control; + +=head1 DESCRIPTION + +Lintian::Debian::Control provides access to fields in d/control. + +=head1 INSTANCE METHODS + +=over 4 + +=item item +=item source_fields +=item installable_fields_by_name + +=cut + +has item => (is => 'rw'); + +has source_fields => ( + is => 'rw', + default => sub { return Lintian::Deb822::Section->new; }, + coerce => sub { + my ($blessedref) = @_; + return ($blessedref // Lintian::Deb822::Section->new); + }, +); + +has installable_fields_by_name => ( + is => 'rw', + default => sub { {} }, + coerce => sub { my ($hashref) = @_; return ($hashref // {}); }, +); + +=item load + +=cut + +sub load { + my ($self, $item) = @_; + + return + unless defined $item; + + $self->item($item); + + return + unless -r $item->unpacked_path; + + my $deb822 = Lintian::Deb822->new; + + my @sections; + try { + @sections = $deb822->read_file($item->unpacked_path); + + } catch { + # If it is a syntax error, ignore it (we emit + # syntax-error-in-control-file in this case via + # control-file). + die map { encode_utf8($_) } $@ + unless $@ =~ /syntax error/; + + return; + } + + # in theory, one could craft a package in which d/control is empty + my $source = shift @sections; + $self->source_fields($source); + + my @named + = grep { $_->value('Package') =~ m{\A $PKGNAME_REGEX \Z}x }@sections; + + my %by_name = map { $_->value('Package') => $_ } @named; + + $self->installable_fields_by_name(\%by_name); + + return; +} + +=item installables + +Returns a list of the binary and udeb packages listed in the +F<debian/control>. + +=cut + +sub installables { + my ($self) = @_; + + return keys %{$self->installable_fields_by_name}; +} + +=item installable_package_type (NAME) + +Returns package type based on value of the Package-Type (or if absent, +X-Package-Type) field. If the field is omitted, the default value +"deb" is used. + +If NAME is not an installable listed in the source packages +F<debian/control> file, this method return C<undef>. + +=cut + +sub installable_package_type { + my ($self, $name) = @_; + + my $type; + + my $fields = $self->installable_fields_by_name->{$name}; + + $type = $fields->value('Package-Type') || $fields->value('XC-Package-Type') + if defined $fields; + + $type ||= 'deb'; + + return lc $type; +} + +=item installable_fields (PACKAGE) + +Returns the Deb822::Section object for the installable. Returns an +empty object if the installable does not exist. + +=cut + +sub installable_fields { + my ($self, $package) = @_; + + my $per_package; + + $per_package = $self->installable_fields_by_name->{$package} + if length $package; + + return ($per_package // Lintian::Deb822::Section->new); +} + +=back + +=head1 AUTHOR + +Originally written by Russ Allbery <rra@debian.org> for Lintian. +Amended by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Elf/Section.pm b/lib/Lintian/Elf/Section.pm new file mode 100644 index 0000000..f5ff7af --- /dev/null +++ b/lib/Lintian/Elf/Section.pm @@ -0,0 +1,156 @@ +# Copyright (C) 2021 Felix Lechner <felix.lechner@lease-up.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::Elf::Section; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +const my $EMPTY => q{}; + +use Moo; +use namespace::clean; + +=head1 NAME + +Lintian::Elf::Section -- ELF Sections + +=head1 SYNOPSIS + + use Lintian::Elf::Section; + +=head1 DESCRIPTION + +A class for storing ELF section data + +=head1 INSTANCE METHODS + +=over 4 + +=item number + +=item name + +=item type + +=item address + +=item offset + +=item size + +=item entry_size + +=item flags + +=item index_link + +=item index_info + +=item alignment + +=cut + +has number => ( + is => 'rw', + coerce => sub { my ($number) = @_; return ($number // 0); }, + default => 0 +); + +has name => ( + is => 'rw', + coerce => sub { my ($text) = @_; return ($text // $EMPTY); }, + default => $EMPTY +); + +has type => ( + is => 'rw', + coerce => sub { my ($text) = @_; return ($text // $EMPTY); }, + default => $EMPTY +); + +has address => ( + is => 'rw', + coerce => sub { my ($number) = @_; return ($number // 0); }, + default => 0 +); + +has offset => ( + is => 'rw', + coerce => sub { my ($number) = @_; return ($number // 0); }, + default => 0 +); + +has size => ( + is => 'rw', + coerce => sub { my ($number) = @_; return ($number // 0); }, + default => 0 +); + +has entry_size => ( + is => 'rw', + coerce => sub { my ($number) = @_; return ($number // 0); }, + default => 0 +); + +has flags => ( + is => 'rw', + coerce => sub { my ($text) = @_; return ($text // $EMPTY); }, + default => $EMPTY +); + +has index_link => ( + is => 'rw', + coerce => sub { my ($number) = @_; return ($number // 0); }, + default => 0 +); + +has index_info => ( + is => 'rw', + coerce => sub { my ($number) = @_; return ($number // 0); }, + default => 0 +); + +has alignment => ( + is => 'rw', + coerce => sub { my ($text) = @_; return ($text // $EMPTY); }, + default => $EMPTY +); + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Elf/Symbol.pm b/lib/Lintian/Elf/Symbol.pm new file mode 100644 index 0000000..ae20dd0 --- /dev/null +++ b/lib/Lintian/Elf/Symbol.pm @@ -0,0 +1,90 @@ +# Copyright (C) 2021 Felix Lechner <felix.lechner@lease-up.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::Elf::Symbol; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +const my $EMPTY => q{}; + +use Moo; +use namespace::clean; + +=head1 NAME + +Lintian::Elf::Symbol -- ELF Symbols + +=head1 SYNOPSIS + + use Lintian::Elf::Symbol; + +=head1 DESCRIPTION + +A class for storing ELF symbol data + +=head1 INSTANCE METHODS + +=over 4 + +=item name + +=item version + +=item section + +=cut + +has name => ( + is => 'rw', + coerce => sub { my ($text) = @_; return ($text // $EMPTY); }, + default => $EMPTY +); +has version => ( + is => 'rw', + coerce => sub { my ($text) = @_; return ($text // $EMPTY); }, + default => $EMPTY +); +has section => ( + is => 'rw', + coerce => sub { my ($text) = @_; return ($text // $EMPTY); }, + default => $EMPTY +); + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Group.pm b/lib/Lintian/Group.pm new file mode 100644 index 0000000..010f42e --- /dev/null +++ b/lib/Lintian/Group.pm @@ -0,0 +1,794 @@ +# Copyright (C) 2011 Niels Thykier <niels@thykier.net> +# Copyright (C) 2019-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::Group; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(croak); +use Const::Fast; +use Cwd; +use Devel::Size qw(total_size); +use Email::Address::XS; +use File::Spec; +use List::Compare; +use List::SomeUtils qw(any none uniq firstval true); +use List::UtilsBy qw(sort_by); +use POSIX qw(ENOENT); +use Syntax::Keyword::Try; +use Time::HiRes qw(gettimeofday tv_interval); +use Time::Piece; +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::Hint::Pointed; +use Lintian::Mask; +use Lintian::Util qw(human_bytes match_glob); + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $UNDERSCORE => q{_}; + +const my $EXTRA_VERBOSE => 3; + +# A private table of supported types. +const my %SUPPORTED_TYPES => ( + 'binary' => 1, + 'buildinfo' => 1, + 'changes' => 1, + 'source' => 1, + 'udeb' => 1, +); + +use Moo; +use namespace::clean; + +=head1 NAME + +Lintian::Group -- A group of objects that Lintian can process + +=head1 SYNOPSIS + + use Lintian::Group; + + my $group = Lintian::Group->new('lintian_2.5.0_i386.changes'); + +=head1 DESCRIPTION + +Instances of this perl class are sets of +L<processables|Lintian::Processable>. It allows at most one source +and one changes or buildinfo package per set, but multiple binary packages +(provided that the binary is not already in the set). + +=head1 METHODS + +=over 4 + +=item $group->pooldir + +Returns or sets the pool directory used by this group. + +=item $group->source_name + +=item $group->source_version + +=item $group->binary + +Returns a hash reference to the binary processables in this group. + +=item $group->buildinfo + +Returns the buildinfo processable in this group. + +=item $group->changes + +Returns the changes processable in this group. + +=item $group->source + +Returns the source processable in this group. + +=item $group->udeb + +Returns a hash reference to the udeb processables in this group. + +=item jobs + +Returns or sets the max number of jobs to be processed in parallel. + +If the limit is 0, then there is no limit for the number of parallel +jobs. + +=item processing_start + +=item processing_end + +=item cache + +Cache for some items. + +=item profile + +Hash with active jobs. + +=item C<saved_direct_dependencies> + +=item C<saved_direct_reliants> + +=cut + +has pooldir => (is => 'rw', default => $EMPTY); +has source_name => (is => 'rw', default => $EMPTY); +has source_version => (is => 'rw', default => $EMPTY); + +has binary => (is => 'rw', default => sub{ {} }); +has buildinfo => (is => 'rw'); +has changes => (is => 'rw'); +has source => (is => 'rw'); +has udeb => (is => 'rw', default => sub{ {} }); + +has jobs => (is => 'rw', default => 1); +has processing_start => (is => 'rw', default => $EMPTY); +has processing_end => (is => 'rw', default => $EMPTY); + +has cache => (is => 'rw', default => sub { {} }); +has profile => (is => 'rw', default => sub { {} }); + +=item $group->name + +Returns a unique identifier for the group based on source and version. + +=cut + +sub name { + my ($self) = @_; + + return $EMPTY + unless length $self->source_name && length $self->source_version; + + return $self->source_name . $UNDERSCORE . $self->source_version; +} + +=item process + +Process group. + +=cut + +sub process { + my ($self, $ignored_overrides, $option)= @_; + + my $groupname = $self->name; + local $SIG{__WARN__} + = sub { warn encode_utf8("Warning in group $groupname: $_[0]") }; + + my $savedir = getcwd; + + $self->processing_start(gmtime->datetime . 'Z'); + say {*STDERR} encode_utf8('Starting on group ' . $self->name) + if $option->{debug}; + my $group_timer = [gettimeofday]; + + my $success = 1; + for my $processable ($self->get_processables){ + + my $path = $processable->path; + local $SIG{__WARN__} + = sub { warn encode_utf8("Warning in processable $path: $_[0]") }; + + my @hints; + my %enabled_overrides; + + say {*STDERR} + encode_utf8( + 'Base directory for processable: '. $processable->basedir) + if $option->{debug}; + + unless ($option->{'no-override'}) { + + say {*STDERR} encode_utf8('Loading overrides file (if any) ...') + if $option->{debug}; + + for my $override (@{$processable->overrides}) { + + my $pattern = $override->pattern; + + # catch renames + my $tag_name + = $self->profile->get_current_name($override->tag_name); + + # catches unknown tags + next + unless length $tag_name; + + next + unless $self->profile->tag_is_enabled($tag_name); + + my @architectures = @{$override->architectures}; + + # count negations + my $negations = true { /^!/ } @architectures; + + # strip negations if present + s/^!// for @architectures; + + # enable overrides for this architecture + # proceed when none specified + my $data = $self->profile->data; + next + if @architectures + && ( + $negations xor none { + $data->architectures->restriction_matches($_, + $processable->architecture) + }@architectures + ); + + if ($self->profile->is_durable($tag_name)) { + + ++$ignored_overrides->{$tag_name}; + next; + } + + $enabled_overrides{$tag_name}{$pattern} = $override; + } + } + + my @check_names = sort $self->profile->enabled_checks; + + my @from_checks; + for my $name (@check_names) { + + my $absolute = $self->profile->check_path_by_name->{$name}; + require $absolute; + + my $module = $self->profile->check_module_by_name->{$name}; + my $check = $module->new; + + $check->name($name); + $check->processable($processable); + $check->group($self); + $check->profile($self->profile); + + my $timer = [gettimeofday]; + my $procid = $processable->identifier; + say {*STDERR} encode_utf8("Running check: $name on $procid ...") + if $option->{debug}; + + try { + my @found_here = $check->run; + push(@from_checks, @found_here); + + } catch { + my $message = $@; + $message + .= "warning: cannot run $name check on package $procid\n"; + $message .= "skipping check of $procid\n"; + warn encode_utf8($message); + + $success = 0; + + next; + } + + my $raw_res = tv_interval($timer); + my $tres = sprintf('%.3fs', $raw_res); + + say {*STDERR} encode_utf8("Check $name for $procid done ($tres)") + if $option->{debug}; + say {*STDERR} encode_utf8("$procid,check/$name,$raw_res") + if $option->{'perf-output'}; + } + + my %context_tracker; + my %used_overrides; + + for my $hint (@from_checks) { + + my $as_issued = $hint->tag_name; + + croak encode_utf8('No tag name') + unless length $as_issued; + + my $issuer = $hint->issued_by; + + # try local name space + my $tag = $self->profile->get_tag("$issuer/$as_issued"); + + warn encode_utf8( +"Using tag $as_issued as name spaced while not so declared (in check $issuer)." + )if defined $tag && !$tag->name_spaced; + + # try global name space + $tag ||= $self->profile->get_tag($as_issued); + + unless (defined $tag) { + warn encode_utf8( + "Tried to issue unknown tag $as_issued in check $issuer."); + next; + } + + if ( !$tag->name_spaced && $tag->name ne $as_issued + || $tag->name_spaced && $tag->name ne "$issuer/$as_issued") { + + my $current_name = $tag->name; + warn encode_utf8( +"Tried to issue renamed tag $as_issued (current name $current_name) in check $issuer." + ); + + next; + } + + my $owner = $tag->check; + if ($issuer ne $owner) { + warn encode_utf8( + "Check $issuer has no tag $as_issued (but $owner does)."); + next; + } + + # pull name from tag; could be name-spaced + $hint->tag_name($tag->name); + my $tag_name = $hint->tag_name; + + # skip disabled tags + next + unless $self->profile->tag_is_enabled($tag_name); + + my $context = $hint->context; + + if (exists $context_tracker{$tag_name}{$context}) { + warn encode_utf8( +"Tried to issue duplicate hint in check $issuer: $tag_name $context\n" + ); + next; + } + + $context_tracker{$tag_name}{$context} = 1; + + my @masks; + for my $screen (@{$tag->screens}) { + + next + unless $screen->suppress($processable, $hint); + + my $mask = Lintian::Mask->new; + $mask->screen($screen->name); + + push(@masks, $mask); + } + + my @screen_names = map { $_->screen } @masks; + my $screen_list = join($SPACE, (sort @screen_names)); + + warn encode_utf8("Crossing screens for $tag_name ($screen_list)") + if @masks > 1; + + $hint->masks(\@masks) + if !$tag->show_always; + + if (exists $enabled_overrides{$tag_name}) { + + my $for_tag = $enabled_overrides{$tag_name}; + + if (exists $for_tag->{$EMPTY}) { + $hint->override($for_tag->{$EMPTY}); + + } else { + + # overrides without context handled above + my @patterns = grep { length } keys %{$for_tag}; + + # try short ones first + my @by_length = sort_by { length } @patterns; + + my $match = firstval { + match_glob($_, $hint->context) + } + @by_length; + + $hint->override($for_tag->{$match}) + if defined $match; + } + } + + # new hash values autovivify to 0 + ++$used_overrides{$tag_name}{$hint->override->pattern} + if defined $hint->override; + + push(@hints, $hint); + } + + # look for unused overrides + for my $tag_name (keys %enabled_overrides) { + + my @declared_patterns = keys %{$enabled_overrides{$tag_name}}; + my @used_patterns = keys %{$used_overrides{$tag_name} // {}}; + + my $pattern_lc + = List::Compare->new(\@declared_patterns, \@used_patterns); + my @unused_patterns = $pattern_lc->get_Lonly; + + for my $pattern (@unused_patterns) { + + my $override = $enabled_overrides{$tag_name}{$pattern}; + + my $override_item = $processable->override_file; + my $position = $override->position; + my $pointer = $override_item->pointer($position); + + my $unused = Lintian::Hint::Pointed->new; + $unused->issued_by('lintian'); + + $unused->tag_name('unused-override'); + $unused->tag_name('mismatched-override') + if exists $context_tracker{$tag_name}; + + # use the original name, in case the tag was renamed + my $original_name = $override->tag_name; + $unused->note($original_name . $SPACE . $pattern); + + $unused->pointer($pointer); + + # cannot be overridden or suppressed + push(@hints, $unused); + } + } + + # carry hints into the output modules + $processable->hints(\@hints); + } + + $self->processing_end(gmtime->datetime . 'Z'); + + my $raw_res = tv_interval($group_timer); + my $tres = sprintf('%.3fs', $raw_res); + say {*STDERR} + encode_utf8('Checking all of group ' . $self->name . " done ($tres)") + if $option->{debug}; + say {*STDERR} encode_utf8($self->name . ",total-group-check,$raw_res") + if $option->{'perf-output'}; + + if ($option->{'debug'} > 2) { + + # suppress warnings without reliable sizes + local $Devel::Size::warn = 0; + + my @processables = $self->get_processables; + my $pivot = shift @processables; + my $group_id + = $pivot->source_name . $UNDERSCORE . $pivot->source_version; + my $group_usage + = human_bytes(total_size([map { $_ } $self->get_processables])); + say {*STDERR} + encode_utf8("Memory usage [group:$group_id]: $group_usage") + if $option->{debug} >= $EXTRA_VERBOSE; + + for my $processable ($self->get_processables) { + my $id = $processable->identifier; + my $usage = human_bytes(total_size($processable)); + + say {*STDERR} encode_utf8("Memory usage [$id]: $usage") + if $option->{debug} >= $EXTRA_VERBOSE; + } + } + + # change to known folder; ealier failures could prevent removal below + chdir $savedir + or warn encode_utf8("Cannot change to directory $savedir"); + + return $success; +} + +=item $group->add_processable($proc) + +Adds $proc to $group. At most one source and one changes $proc can be +in a $group. There can be multiple binary $proc's, as long as they +are all unique. Successive buildinfo $proc's are silently ignored. + +This will error out if an additional source or changes $proc is added +to the group. Otherwise it will return a truth value if $proc was +added. + +=cut + +sub add_processable { + my ($self, $processable) = @_; + + if ($processable->tainted) { + warn encode_utf8( + sprintf( + "warning: tainted %1\$s package '%2\$s', skipping\n", + $processable->type, $processable->name + ) + ); + return 0; + } + + $self->source_name($processable->source_name) + unless length $self->source_name; + $self->source_version($processable->source_version) + unless length $self->source_version; + + return 0 + if $self->source_name ne $processable->source_name + || $self->source_version ne $processable->source_version; + + croak encode_utf8('Please set pool directory first.') + unless $self->pooldir; + + $processable->pooldir($self->pooldir); + + croak encode_utf8('Not a supported type (' . $processable->type . ')') + unless exists $SUPPORTED_TYPES{$processable->type}; + + if ($processable->type eq 'changes') { + die encode_utf8('Cannot add another ' . $processable->type . ' file') + if $self->changes; + $self->changes($processable); + + } elsif ($processable->type eq 'buildinfo') { + # Ignore multiple .buildinfo files; use the first one + $self->buildinfo($processable) + unless $self->buildinfo; + + } elsif ($processable->type eq 'source'){ + die encode_utf8('Cannot add another source package') + if $self->source; + $self->source($processable); + + } else { + my $type = $processable->type; + die encode_utf8('Unknown type ' . $type) + unless $type eq 'binary' || $type eq 'udeb'; + + # check for duplicate; should be rewritten with arrays + my $id = $processable->identifier; + return 0 + if exists $self->$type->{$id}; + + $self->$type->{$id} = $processable; + } + + return 1; +} + +=item get_processables + +Returns an array of all processables in $group. + +=cut + +sub get_processables { + my ($self) = @_; + + my @processables; + + push(@processables, $self->changes) + if defined $self->changes; + + push(@processables, $self->source) + if defined $self->source; + + push(@processables, $self->buildinfo) + if defined $self->buildinfo; + + push(@processables, $self->get_installables); + + return @processables; +} + +=item get_installables + +Returns all binary (and udeb) processables in $group. + +If $group does not have any binary processables then an empty list is +returned. + +=cut + +sub get_installables { + my ($self) = @_; + + my @installables; + + push(@installables, values %{$self->binary}); + push(@installables, values %{$self->udeb}); + + return @installables; +} + +=item direct_dependencies (PROC) + +If PROC is a part of the underlying processable group, this method +returns a listref containing all the direct dependencies of PROC. If +PROC is not a part of the group, this returns undef. + +Note: Only strong dependencies (Pre-Depends and Depends) are +considered. + +Note: Self-dependencies (if any) are I<not> included in the result. + +=cut + +has saved_direct_dependencies => (is => 'rw', default => sub { {} }); + +sub direct_dependencies { + my ($self, $processable) = @_; + + unless (keys %{$self->saved_direct_dependencies}) { + + my @processables = $self->get_installables; + + my %dependencies; + for my $that (@processables) { + + my $relation = $that->relation('strong'); + my @specific; + + for my $this (@processables) { + + # Ignore self deps - we have checks for that and it + # will just end up complicating "correctness" of + # otherwise simple checks. + next + if $this->name eq $that->name; + + push @specific, $this + if $relation->satisfies($this->name); + } + $dependencies{$that->name} = \@specific; + } + + $self->saved_direct_dependencies(\%dependencies); + } + + return $self->saved_direct_dependencies->{$processable->name} + if $processable; + + return $self->saved_direct_dependencies; +} + +=item direct_reliants (PROC) + +If PROC is a part of the underlying processable group, this method +returns a listref containing all the packages in the group that rely +on PROC. If PROC is not a part of the group, this returns undef. + +Note: Only strong dependencies (Pre-Depends and Depends) are +considered. + +Note: Self-dependencies (if any) are I<not> included in the result. + +=cut + +has saved_direct_reliants => (is => 'rw', default => sub { {} }); + +sub direct_reliants { + my ($self, $processable) = @_; + + unless (keys %{$self->saved_direct_reliants}) { + + my @processables = $self->get_installables; + + my %reliants; + foreach my $that (@processables) { + + my @specific; + foreach my $this (@processables) { + + # Ignore self deps - we have checks for that and it + # will just end up complicating "correctness" of + # otherwise simple checks. + next + if $this->name eq $that->name; + + my $relation = $this->relation('strong'); + push @specific, $this + if $relation->satisfies($that->name); + } + $reliants{$that->name} = \@specific; + } + + $self->saved_direct_reliants(\%reliants); + } + + return $self->saved_direct_reliants->{$processable->name} + if $processable; + + return $self->saved_direct_reliants; +} + +=item spelling_exceptions + +Returns a hashref of words, which the spell checker should ignore. +These words are generally based on the package names in the group to +avoid false-positive "spelling error" when packages have "fun" names. + +Example: Package alot-doc (#687464) + +=cut + +has spelling_exceptions => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my @acceptable; + + # this run may not have all types + for my $processable ($self->get_processables) { + + # all processables have those + my @package_names= ($processable->name, $processable->source_name); + + # for sources we have d/control + push(@package_names, $processable->debian_control->installables) + if $processable->type eq 'source'; + + push(@acceptable, @package_names); + + # exempt pieces, too + my @package_pieces = map { split(m{-}) } @package_names; + push(@acceptable, @package_pieces); + + my @people_names; + for my $role (qw(Maintainer Uploaders Changed-By)) { + + my $value = $processable->fields->value($role); + for my $parsed (Email::Address::XS->parse($value)) { + + push(@people_names, $parsed->phrase) + if length $parsed->phrase; + } + } + + push(@acceptable, @people_names); + + # exempt first and last name separately, too + my @people_pieces = map { split($SPACE) } @people_names; + push(@acceptable, @people_pieces); + } + + return [uniq @acceptable]; + } +); + +=back + +=head1 AUTHOR + +Originally written by Niels Thykier <niels@thykier.net> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +L<Lintian::Processable> + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Hint.pm b/lib/Lintian/Hint.pm new file mode 100644 index 0000000..ee45393 --- /dev/null +++ b/lib/Lintian/Hint.pm @@ -0,0 +1,88 @@ +# Copyright (C) 2019-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::Hint; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +const my $EMPTY => q{}; +const my $SPACE => q{ }; + +use Moo::Role; +use namespace::clean; + +=head1 NAME + +Lintian::Hint -- Common facilities for Lintian tags found and to be issued + +=head1 SYNOPSIS + + use Moo; + use namespace::clean; + + with 'Lintian::Hint'; + +=head1 DESCRIPTION + +Common facilities for Lintian tags found and to be issued + +=head1 INSTANCE METHODS + +=over 4 + +=item tag_name + +=item issued_by + +=item override + +=item masks + +=cut + +has tag_name => (is => 'rw', default => $EMPTY); +has issued_by => (is => 'rw', default => $EMPTY); + +has override => (is => 'rw'); +has masks => (is => 'rw', default => sub { [] }); + +no namespace::clean; + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Hint/Annotated.pm b/lib/Lintian/Hint/Annotated.pm new file mode 100644 index 0000000..137f8fe --- /dev/null +++ b/lib/Lintian/Hint/Annotated.pm @@ -0,0 +1,78 @@ +# Copyright (C) 2019-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::Hint::Annotated; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +const my $EMPTY => q{}; + +use Moo; +use namespace::clean; + +with 'Lintian::Hint'; + +=head1 NAME + +Lintian::Hint::Annotated - standard tag with arguments concatenated by space + +=head1 SYNOPSIS + + use Lintian::Hint::Annotated; + +=head1 DESCRIPTION + +Provides a standard tag whose arguments are concatenated by a space. + +=head1 INSTANCE METHODS + +=over 4 + +=item note + +=cut + +has note => (is => 'rw', default => $EMPTY); + +=item context + +=cut + +sub context { + my ($self) = @_; + + return $self->note; +} + +=back + +=cut + +1; + +__END__ + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Hint/Pointed.pm b/lib/Lintian/Hint/Pointed.pm new file mode 100644 index 0000000..be59731 --- /dev/null +++ b/lib/Lintian/Hint/Pointed.pm @@ -0,0 +1,88 @@ +# 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::Hint::Pointed; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +const my $EMPTY => q{}; +const my $SPACE => q{ }; + +use Moo; +use namespace::clean; + +with 'Lintian::Hint'; + +=head1 NAME + +Lintian::Hint::Pointed - pointed tag with arguments concatenated by space + +=head1 SYNOPSIS + + use Lintian::Hint::Pointed; + +=head1 DESCRIPTION + +Provides a pointed tag whose arguments are concatenated by a space. + +=head1 INSTANCE METHODS + +=over 4 + +=item note + +=cut + +has note => (is => 'rw', default => $EMPTY); + +=item pointer + +=cut + +has pointer => (is => 'rw'); + +=item context + +=cut + +sub context { + my ($self) = @_; + + my $pointer = $self->pointer->to_string; + my @pieces = grep { length } ($self->note, "[$pointer]"); + + return join($SPACE, @pieces); +} + +=back + +=cut + +1; + +__END__ + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/IO/Select.pm b/lib/Lintian/IO/Select.pm new file mode 100644 index 0000000..fec6a1e --- /dev/null +++ b/lib/Lintian/IO/Select.pm @@ -0,0 +1,259 @@ +# Hey emacs! This is a -*- Perl -*- script! +# +# Lintian::IO::Select -- Perl utility functions for lintian +# +# 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::IO::Select; + +use v5.20; +use warnings; +use utf8; + +use Exporter qw(import); + +our @EXPORT_OK; + +BEGIN { + + @EXPORT_OK = qw( + unpack_and_index_piped_tar + ); +} + +use Const::Fast; +use IPC::Open3; +use IO::Select; +use Symbol; +use Syntax::Keyword::Try; +use Unicode::UTF8 qw(encode_utf8); + +# read up to 40kB at a time. this happens to be 4096 "tar records" +# (with a block-size of 512 and a block factor of 20, which appear to +# be the defaults). when we do full reads and writes of READ_SIZE (the +# OS willing), the receiving end will never be with an incomplete +# record. +const my $TAR_RECORD_SIZE => 20 * 512; + +# using 4096 * $TAR_RECORD_SIZE tripped up older kernels < 5.7 +const my $READ_CHUNK => 4 * 1024; + +const my $EMPTY => q{}; + +=head1 NAME + +Lintian::IO::Select - process functions based on IO::Select + +=head1 SYNOPSIS + + use Lintian::IO::Select; + +=head1 DESCRIPTION + +This module contains process functions based on IO::Select. + +=head1 FUNCTIONS + +=over 4 + +=item unpack_and_index_piped_tar + +=cut + +sub unpack_and_index_piped_tar { + my ($command, $basedir) = @_; + + my @pids; + + my $select = IO::Select->new; + + my $produce_stdin; + my $produce_stdout; + my $produce_stderr = gensym; + + my @produce_command = @{$command}; + + my $produce_pid; + try { + $produce_pid = open3( + $produce_stdin, $produce_stdout, + $produce_stderr, @produce_command + ); + } catch { + die map { encode_utf8($_) } $@; + } + + close $produce_stdin; + + push(@pids, $produce_pid); + + $select->add($produce_stdout, $produce_stderr); + + my $extract_stdin; + my $extract_stdout; + my $extract_stderr = gensym; + + my @extract_command = ( + qw(tar --no-same-owner --no-same-permissions --touch --extract --file - -C), + $basedir + ); + + my $extract_pid; + try { + $extract_pid = open3( + $extract_stdin, $extract_stdout, + $extract_stderr, @extract_command + ); + } catch { + die map { encode_utf8($_) } $@; + } + + push(@pids, $extract_pid); + + $select->add($extract_stdout, $extract_stderr); + + my @index_options + = qw(--list --verbose --utc --full-time --quoting-style=c --file -); + + my $named_stdin; + my $named_stdout; + my $named_stderr = gensym; + + my @named_command = ('tar', @index_options); + + my $named_pid; + try { + $named_pid + = open3($named_stdin, $named_stdout, $named_stderr, @named_command); + } catch { + die map { encode_utf8($_) } $@; + } + + push(@pids, $named_pid); + + $select->add($named_stdout, $named_stderr); + + my $numeric_stdin; + my $numeric_stdout; + my $numeric_stderr = gensym; + + my @numeric_command = ('tar', '--numeric-owner', @index_options); + + my $numeric_pid; + try { + $numeric_pid = open3( + $numeric_stdin, $numeric_stdout, + $numeric_stderr, @numeric_command + ); + } catch { + die map { encode_utf8($_) } $@; + } + + push(@pids, $numeric_pid); + + $select->add($numeric_stdout, $numeric_stderr); + + my $named = $EMPTY; + my $numeric = $EMPTY; + + my $produce_errors = $EMPTY; + my $extract_errors = $EMPTY; + my $named_errors = $EMPTY; + + while (my @ready = $select->can_read) { + + for my $handle (@ready) { + + my $buffer; + my $length = sysread($handle, $buffer, $READ_CHUNK); + + die encode_utf8("Error from child: $!\n") + unless defined $length; + + if ($length == 0){ + if ($handle == $produce_stdout) { + close $extract_stdin; + close $named_stdin; + close $numeric_stdin; + } + $select->remove($handle); + next; + } + + if ($handle == $produce_stdout) { + print {$extract_stdin} $buffer; + print {$named_stdin} $buffer; + print {$numeric_stdin} $buffer; + + } elsif ($handle == $named_stdout) { + $named .= $buffer; + + } elsif ($handle == $numeric_stdout) { + $numeric .= $buffer; + + } elsif ($handle == $produce_stderr) { + $produce_errors .= $buffer; + + } elsif ($handle == $extract_stderr) { + $extract_errors .= $buffer; + + } elsif ($handle == $named_stderr) { + $named_errors .= $buffer; + + # } else { + # die encode_utf8("Shouldn't be here\n"); + } + } + } + + close $produce_stdout; + close $produce_stderr; + + close $extract_stdout; + close $extract_stderr; + + close $named_stdout; + close $named_stderr; + + close $numeric_stdout; + close $numeric_stderr; + + waitpid($_, 0) for @pids; + + my $tar_errors = ($produce_errors // $EMPTY) . ($extract_errors // $EMPTY); + my $index_errors = $named_errors; + + return ($named, $numeric, $tar_errors, $index_errors); +} + +=back + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/IPC/Run3.pm b/lib/Lintian/IPC/Run3.pm new file mode 100644 index 0000000..e762be5 --- /dev/null +++ b/lib/Lintian/IPC/Run3.pm @@ -0,0 +1,135 @@ +# Hey emacs! This is a -*- Perl -*- script! +# +# Lintian::IPC::Run3 -- Perl utility functions for lintian +# +# 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::IPC::Run3; + +use v5.20; +use warnings; +use utf8; + +use Exporter qw(import); + +our @EXPORT_OK; + +BEGIN { + + @EXPORT_OK = qw( + safe_qx + xargs + ); +} + +use Const::Fast; +use IPC::Run3; + +const my $EMPTY => q{}; +const my $NULL => qq{\0}; + +const my $WAIT_STATUS_SHIFT => 8; + +=head1 NAME + +Lintian::IPC::Run3 - process functions based on IPC::Run3 + +=head1 SYNOPSIS + + use Lintian::IPC::Run3 qw(safe_qx); + +=head1 DESCRIPTION + +This module contains process functions based on IPC::Run3. + +=head1 FUNCTIONS + +=over 4 + +=item C<safe_qx(@cmd)> + +Emulates the C<qx()> operator but with array argument only. + +=cut + +sub safe_qx { + my @command = @_; + + my $stdout; + my $stderr; + + run3(\@command, \undef, \$stdout, \$stderr); + + my $exitcode = $?; + my $status = ($exitcode >> $WAIT_STATUS_SHIFT); + + $? = $status; + + return $stdout . $stderr + if $?; + + return $stdout; +} + +=item C<xargs> + +=cut + +sub xargs { + my ($command, $arguments, $processor) = @_; + + $command //= []; + $arguments //= []; + + return + unless @{$arguments}; + + my $input = $EMPTY; + $input .= $_ . $NULL for @{$arguments}; + + my $stdout; + my $stderr; + + my @combined = (qw(xargs --null --no-run-if-empty), @{$command}); + + run3(\@combined, \$input, \$stdout, \$stderr); + + my $exitcode = $?; + my $status = ($exitcode >> $WAIT_STATUS_SHIFT); + + $processor->($stdout, $stderr, $status, @{$arguments}); + + return; +} + +=back + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Index.pm b/lib/Lintian/Index.pm new file mode 100644 index 0000000..b442455 --- /dev/null +++ b/lib/Lintian/Index.pm @@ -0,0 +1,878 @@ +# -*- perl -*- Lintian::Index +# +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Index; + +use v5.20; +use warnings; +use utf8; + +use Carp; +use Const::Fast; +use Cwd; +use IPC::Run3; +use List::SomeUtils qw(any); +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8 decode_utf8); + +use Lintian::Index::Item; +use Lintian::IO::Select qw(unpack_and_index_piped_tar); +use Lintian::IPC::Run3 qw(safe_qx); + +use Lintian::Util qw(perm2oct); + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $SLASH => q{/}; +const my $BACKSLASH => q{\\}; +const my $ZERO => q{0}; +const my $HYPHEN => q{-}; +const my $PERCENT => q{%}; +const my $NEWLINE => qq{\n}; + +const my $WAIT_STATUS_SHIFT => 8; +const my $NO_LIMIT => -1; +const my $LINES_PER_FILE => 3; +const my $WIDELY_READABLE_FOLDER => oct(755); +const my $WORLD_WRITABLE_FOLDER => oct(777); + +use Moo; +use namespace::clean; + +with + 'Lintian::Index::Ar', + 'Lintian::Index::Elf', + 'Lintian::Index::FileTypes', + 'Lintian::Index::Java', + 'Lintian::Index::Md5sums', + 'Lintian::Index::Strings'; + +my %FILE_CODE2LPATH_TYPE = ( + $HYPHEN => Lintian::Index::Item::TYPE_FILE + | Lintian::Index::Item::OPEN_IS_OK, + 'h' => Lintian::Index::Item::TYPE_HARDLINK + | Lintian::Index::Item::OPEN_IS_OK, + 'd' => Lintian::Index::Item::TYPE_DIR| Lintian::Index::Item::FS_PATH_IS_OK, + 'l' => Lintian::Index::Item::TYPE_SYMLINK, + 'b' => Lintian::Index::Item::TYPE_BLOCK_DEV, + 'c' => Lintian::Index::Item::TYPE_CHAR_DEV, + 'p' => Lintian::Index::Item::TYPE_PIPE, +); + +=head1 NAME + +Lintian::Index - access to collected data about the upstream (orig) sources + +=head1 SYNOPSIS + + use Lintian::Index; + +=head1 DESCRIPTION + +Lintian::Processable::Source::Orig::Index provides an interface to collected data about the upstream (orig) sources. + +=head1 INSTANCE METHODS + +=over 4 + +=item identifier + +=item catalog + +Returns a reference to a hash with elements catalogued by path names. + +=item C<basedir> + +Returns the base directory for file references. + +=item C<anchored> + +=item unpack_messages + +=cut + +has identifier => (is => 'rw', default => 'unnamed'); + +has catalog => ( + is => 'rw', + default => sub { + my ($self) = @_; + + # create an empty root + my $root = Lintian::Index::Item->new; + + # associate with this index + $root->index($self); + + my %catalog; + $catalog{$EMPTY} = $root; + + return \%catalog; + } +); + +has basedir => ( + is => 'rw', + trigger => sub { + my ($self, $folder) = @_; + + return + unless length $folder; + + # create directory + path($folder)->mkpath({ chmod => $WORLD_WRITABLE_FOLDER }) + unless -e $folder; + }, + default => $EMPTY +); + +has anchored => (is => 'rw', default => 0); +has unpack_messages => (is => 'rw', default => sub { [] }); + +has sorted_list => ( + is => 'ro', + lazy => 1, + default => sub { + my ($self) = @_; + + my @sorted = sort { $a->name cmp $b->name } values %{$self->catalog}; + + # remove automatic root dir; list is sorted + shift @sorted; + + const my @IMMUTABLE => @sorted; + + return \@IMMUTABLE; + } +); + +=item lookup (FILE) + +Like L</index> except orig_index is based on the "orig tarballs" of +the source packages. + +For native packages L</index> and L</orig_index> are generally +identical. + +NB: If sorted_index includes a debian packaging, it is was +contained in upstream part of the source package (or the package is +native). + +=cut + +sub lookup { + my ($self, $name) = @_; + + # get root dir by default + $name //= $EMPTY; + + croak encode_utf8($self->identifier . ': Name is not a string') + unless ref $name eq $EMPTY; + + my $found = $self->catalog->{$name}; + + return $found + if defined $found; + + return undef; +} + +=item resolve_path + +=cut + +sub resolve_path { + my ($self, $name) = @_; + + return $self->lookup->resolve_path($name); +} + +=item create_from_basedir + +=cut + +sub create_from_basedir { + my ($self) = @_; + + my $savedir = getcwd; + chdir($self->basedir) + or die encode_utf8( + $self->identifier . ': Cannot change to directory ' . $self->basedir); + + # get times in UTC + my $TIME_STAMP + = $PERCENT . q{M} . $SPACE . $PERCENT . q{s} . $SPACE . $PERCENT . q{A+}; + my $FILE_NAME = $PERCENT . q{p}; + my $LINK_DESTINATION = $PERCENT . q{l}; + my $NULL_BREAK = $BACKSLASH . $ZERO; + + my @REQUESTED_FIELDS + = map { $_ . $NULL_BREAK } ($TIME_STAMP, $FILE_NAME, $LINK_DESTINATION); + + my @index_command + = ('env', 'TZ=UTC', 'find', '-printf', join($EMPTY, @REQUESTED_FIELDS)); + my $index_output; + my $index_errors; + + run3(\@index_command, \undef, \$index_output, \$index_errors); + + chdir($savedir) + or die encode_utf8( + $self->identifier . ": Cannot change to directory $savedir"); + + # allow processing of file names with non UTF-8 bytes + $index_errors = decode_utf8($index_errors) + if length $index_errors; + + my $permissionspattern = qr/\S{10}/; + my $sizepattern = qr/\d+/; + my $datepattern = qr/\d{4}-\d{2}-\d{2}/; + my $timepattern = qr/\d{2}:\d{2}:\d{2}\.\d+/; + my $pathpattern = qr/[^\0]*/; + + my %all; + + $index_output =~ s/\0$//; + + my @lines = split(/\0/, $index_output, $NO_LIMIT); + die encode_utf8($self->identifier + . ": Did not get a multiple of $LINES_PER_FILE lines from find.") + unless @lines % $LINES_PER_FILE == 0; + + while (defined(my $first = shift @lines)) { + + my $entry = Lintian::Index::Item->new; + $entry->index($self); + + $first + =~ /^($permissionspattern)\ ($sizepattern)\ ($datepattern)\+($timepattern)$/s; + + $entry->perm($1); + $entry->size($2); + $entry->date($3); + $entry->time($4); + + my $name = shift @lines; + + my $linktarget = shift @lines; + + # for non-links, string is empty + $entry->link($linktarget) + if length $linktarget; + + # find prints single dot for base; removed in next step + $name =~ s{^\.$}{\./}s; + + # strip relative prefix + $name =~ s{^\./+}{}s; + + # make sure directories end with a slash, except root + $name .= $SLASH + if length $name + && $entry->perm =~ /^d/ + && $name !~ m{ /$ }msx; + $entry->name($name); + + $all{$entry->name} = $entry; + } + + $self->catalog(\%all); + + my $load_errors = $self->load; + + return $index_errors . $load_errors; +} + +=item create_from_piped_tar + +=cut + +sub create_from_piped_tar { + my ($self, $command) = @_; + + my $extract_dir = $self->basedir; + + my ($named, $numeric, $extract_errors, $index_errors) + = unpack_and_index_piped_tar($command, $extract_dir); + + # fix permissions + safe_qx('chmod', '-R', 'u+rwX,go-w', $extract_dir); + + # allow processing of file names with non UTF-8 bytes + my @named_owner = split(/\n/, $named); + my @numeric_owner = split(/\n/, $numeric); + + my %catalog; + + for my $line (@named_owner) { + + my $entry = Lintian::Index::Item->new; + $entry->init_from_tar_output($line); + $entry->index($self); + + $catalog{$entry->name} = $entry; + } + + # get numerical owners from second list + for my $line (@numeric_owner) { + + # entry not used outside this loop + my $entry = Lintian::Index::Item->new; + $entry->init_from_tar_output($line); + + die encode_utf8($self->identifier + . ': Numerical index lists extra files for file name ' + . $entry->name) + unless exists $catalog{$entry->name}; + + # keep numerical uid and gid + $catalog{$entry->name}->uid($entry->owner); + $catalog{$entry->name}->gid($entry->group); + } + + # tar produces spurious root entry when stripping slashes from member names + delete $catalog{$SLASH} + unless $self->anchored; + + $self->catalog(\%catalog); + + my $load_errors = $self->load; + + return $extract_errors . $index_errors . $load_errors; +} + +=item load + +=cut + +sub load { + my ($self) = @_; + + my $errors = $EMPTY; + + my %all = %{$self->catalog}; + + # set internal permissions flags + for my $entry (values %all) { + + my $raw_type = substr($entry->perm, 0, 1); + + my $operm = perm2oct($entry->perm); + $entry->path_info( + $operm | ( + $FILE_CODE2LPATH_TYPE{$raw_type} + // Lintian::Index::Item::TYPE_OTHER + ) + ); + } + + # find all entries that are not regular files + my @nosize + = grep { !$_->path_info & Lintian::Index::Item::TYPE_FILE } values %all; + + # reset size for anything but regular files + $_->size(0) for @nosize; + + if ($self->anchored) { + + my %relative; + for my $name (keys %all) { + my $entry = $all{$name}; + + # remove leading slash from absolute names + my $name = $entry->name; + $name =~ s{^/+}{}s; + $entry->name($name); + + # remove leading slash from absolute hardlink targets + if ($entry->is_hardlink) { + my $target = $entry->link; + $target =~ s{^/+}{}s; + $entry->link($target); + } + + $relative{$name} = $entry; + } + + %all = %relative; + } + + # disallow absolute names + die encode_utf8($self->identifier . ': Index contains absolute path names') + if any { $_->name =~ m{^/}s } values %all; + + # disallow absolute hardlink targets + die encode_utf8( + $self->identifier . ': Index contains absolute hardlink targets') + if any { $_->link =~ m{^/}s } grep { $_->is_hardlink } values %all; + + # add entries for missing directories + for my $entry (values %all) { + + my $current = $entry; + my $parentname; + + # travel up the directory tree + do { + $parentname = $current->dirname; + + # insert new entry for missing intermediate directories + unless (exists $all{$parentname}) { + + my $added = Lintian::Index::Item->new; + $added->index($self); + + $added->name($parentname); + $added->path_info( + $FILE_CODE2LPATH_TYPE{'d'} | $WIDELY_READABLE_FOLDER); + + # random but fixed date; hint, it's a good read. :) + $added->date('1998-01-25'); + $added->time('22:55:34'); + $added->faux(1); + + $all{$parentname} = $added; + } + + $current = $all{$parentname}; + + } while ($parentname ne $EMPTY); + } + + # insert root for empty tarfies like suckless-tools_45.orig.tar.xz + unless (exists $all{$EMPTY}) { + + my $root = Lintian::Index::Item->new; + $root->index($self); + + $root->name($EMPTY); + $root->path_info($FILE_CODE2LPATH_TYPE{'d'} | $WIDELY_READABLE_FOLDER); + + # random but fixed date; hint, it's a good read. :) + $root->date('1998-01-25'); + $root->time('22:55:34'); + $root->faux(1); + + $all{$EMPTY} = $root; + } + + my @directories + = grep { $_->path_info & Lintian::Index::Item::TYPE_DIR } values %all; + + # make space for children + my %children; + $children{$_->name} = [] for @directories; + + # record children + for my $entry (values %all) { + + my $parentname = $entry->dirname; + + # Ensure the "root" is not its own child. It is not really helpful + # from an analysis PoV and it creates ref cycles (and by extension + # leaks like #695866). + push(@{ $children{$parentname} }, $entry) + unless $parentname eq $entry->name; + } + + foreach my $entry (@directories) { + my %childnames + = map {$_->basename => $_->name }@{ $children{$entry->name} }; + $entry->childnames(\%childnames); + } + + # ensure root is not its own child; may create leaks like #695866 + die encode_utf8($self->identifier . ': Root directory is its own parent') + if defined $all{$EMPTY} && defined $all{$EMPTY}->parent_dir; + + # find all hard links + my @hardlinks + = grep { $_->path_info & Lintian::Index::Item::TYPE_HARDLINK } + values %all; + + # catalog where they point + my %backlinks; + push(@{$backlinks{$_->link}}, $_) for @hardlinks; + + # add the master files for proper sort results + push(@{$backlinks{$_}}, $all{$_}) for keys %backlinks; + + # point hard links to shortest path + for my $mastername (keys %backlinks) { + + my @group = @{$backlinks{$mastername}}; + + # sort for path length + my @links = sort { $a->name cmp $b->name } @group; + + # pick the shortest path + my $preferred = shift @links; + + # get the previous master entry + my $master = $all{$mastername}; + + # skip if done + next + if $preferred->name eq $master->name; + + # unset link for preferred + $preferred->link($EMPTY); + + # copy size from original + $preferred->size($master->size); + + $preferred->path_info( + ($preferred->path_info& ~Lintian::Index::Item::TYPE_HARDLINK) + | Lintian::Index::Item::TYPE_FILE); + + foreach my $pointer (@links) { + + # turn into a hard link + $pointer->path_info( + ($pointer->path_info & ~Lintian::Index::Item::TYPE_FILE) + | Lintian::Index::Item::TYPE_HARDLINK); + + # set link to preferred path + $pointer->link($preferred->name); + + # no size for hardlinks + $pointer->size(0); + } + } + + # make sure recorded names match hash keys + $all{$_}->name($_) for keys %all; + + $self->catalog(\%all); + + $errors .= $self->add_md5sums; + $errors .= $self->add_file_types; + + $errors .= $self->add_ar; + $errors .= $self->add_elf; + $errors .= $self->add_java; + $errors .= $self->add_strings; + + return $errors; +} + +=item merge_in + +=cut + +sub merge_in { + my ($self, $other) = @_; + + die encode_utf8($self->identifier + . ': Need same base directory (' + . $self->basedir . ' vs ' + . $other->basedir . ')') + unless $self->basedir eq $other->basedir; + + die encode_utf8($self->identifier . ': Need same anchoring status') + unless $self->anchored == $other->anchored; + + # associate all new items with this index + $_->index($self) for values %{$other->catalog}; + + for my $item (values %{$other->catalog}) { + + # do not transfer root + next + if $item->name eq $EMPTY; + + # duplicates on disk are dropped with basedir segments + $self->catalog->{$item->name} = $item; + + # when adding folder, delete potential file entry + my $noslash = $item->name; + if ($noslash =~ s{/$}{}) { + delete $self->catalog->{$noslash}; + } + } + + # add children that came from other root to current + my @other_childnames = keys %{$other->catalog->{$EMPTY}->childnames}; + for my $name (@other_childnames) { + + $self->catalog->{$EMPTY}->childnames->{$name} + = $self->catalog->{$name}; + } + + # remove items from other index + $other->catalog({}); + + # unset other base directory + $other->basedir($EMPTY); + + return; +} + +=item capture_common_prefix + +=cut + +sub capture_common_prefix { + my ($self) = @_; + + my $new_basedir = path($self->basedir)->parent; + + # do nothing in root + return + if $new_basedir eq $SLASH; + + my $segment = path($self->basedir)->basename; + die encode_utf8($self->identifier . ': Common path segment has no length') + unless length $segment; + + my $prefix; + if ($self->anchored) { + $prefix = $SLASH . $segment; + } else { + $prefix = $segment . $SLASH; + } + + my $new_root = Lintian::Index::Item->new; + + # associate new item with this index + $new_root->index($self); + + $new_root->name($EMPTY); + $new_root->childnames({ $segment => $prefix }); + + # random but fixed date; hint, it's a good read. :) + $new_root->date('1998-01-25'); + $new_root->time('22:55:34'); + $new_root->path_info($FILE_CODE2LPATH_TYPE{'d'} | $WIDELY_READABLE_FOLDER); + $new_root->faux(1); + + my %new_catalog; + for my $item (values %{$self->catalog}) { + + # drop common prefix from name + my $new_name = $prefix . $item->name; + $item->name($new_name); + + if (length $item->link) { + + # add common prefix from link target + my $new_link = $prefix . $item->link; + $item->link($new_link); + } + + # adjust references to children + for my $basename (keys %{$item->childnames}) { + $item->childnames->{$basename} + = $prefix . $item->childnames->{$basename}; + } + + $new_catalog{$new_name} = $item; + } + + $new_catalog{$EMPTY} = $new_root; + $new_catalog{$prefix}->parent_dir($new_root); + + $self->catalog(\%new_catalog); + + # remove segment from base directory + $self->basedir($new_basedir); + + return; +} + +=item drop_common_prefix + +=cut + +sub drop_common_prefix { + my ($self) = @_; + + my $errors = $EMPTY; + + my @childnames = keys %{$self->catalog->{$EMPTY}->childnames}; + + die encode_utf8($self->identifier . ': Not exactly one top-level child') + unless @childnames == 1; + + my $segment = $childnames[0]; + die encode_utf8($self->identifier . ': Common path segment has no length') + unless length $segment; + + my $new_root = $self->lookup($segment . $SLASH); + die encode_utf8($self->identifier . ': New root is not a directory') + unless $new_root->is_dir; + + my $prefix; + if ($self->anchored) { + $prefix = $SLASH . $segment; + } else { + $prefix = $segment . $SLASH; + } + + my $regex = quotemeta($prefix); + + delete $self->catalog->{$EMPTY}; + + my %new_catalog; + for my $item (values %{$self->catalog}) { + + # drop common prefix from name + my $new_name = $item->name; + $new_name =~ s{^$regex}{}; + $item->name($new_name); + + if (length $item->link) { + + # drop common prefix from link target + my $new_link = $item->link; + $new_link =~ s{^$regex}{}; + $item->link($new_link); + } + + # adjust references to children + for my $basename (keys %{$item->childnames}) { + $item->childnames->{$basename} =~ s{^$regex}{}; + } + + # unsure this works, but orig not anchored + $new_name = $EMPTY + if $new_name eq $SLASH && $self->anchored; + + $new_catalog{$new_name} = $item; + } + + $self->catalog(\%new_catalog); + + # add dropped segment to base directory + $self->basedir($self->basedir . $SLASH . $segment); + + my $other_errors = $self->drop_basedir_segment; + + return $errors . $other_errors; +} + +=item drop_basedir_segment + +=cut + +sub drop_basedir_segment { + my ($self) = @_; + + my $errors = $EMPTY; + + my $obsolete = path($self->basedir)->basename; + die encode_utf8($self->identifier . ': Base directory has no name') + unless length $obsolete; + + my $parent_dir = path($self->basedir)->parent->stringify; + die encode_utf8($self->identifier . ': Base directory has no parent') + if $parent_dir eq $SLASH; + + my $grandparent_dir = path($parent_dir)->parent->stringify; + die encode_utf8( + $self->identifier . ': Will not do anything in file system root') + if $grandparent_dir eq $SLASH; + + # destroyed when object is lost + my $tempdir_tiny + = path($grandparent_dir)->tempdir(TEMPLATE => 'customXXXXXXXX'); + + my $tempdir = $tempdir_tiny->stringify; + + # avoids conflict in case of repeating path segments + for my $child (path($self->basedir)->children) { + my $old_name = $child->stringify; + + # Perl unicode bug + utf8::downgrade $old_name; + utf8::downgrade $tempdir; + + my @command = ('mv', $old_name, $tempdir); + my $stderr; + run3(\@command, \undef, \undef, \$stderr); + my $status = ($? >> $WAIT_STATUS_SHIFT); + + # already in UTF-8 + die $stderr + if $status; + } + + rmdir $self->basedir; + $self->basedir($parent_dir); + + for my $child ($tempdir_tiny->children) { + my $old_name = $child->stringify; + + my $target_dir = $parent_dir . $SLASH . $child->basename; + + # Perl unicode bug + utf8::downgrade $target_dir; + + if (-e $target_dir) { + + # catalog items were dropped when index was merged + my @command = (qw{rm -rf}, $target_dir); + my $stderr; + run3(\@command, \undef, \undef, \$stderr); + my $status = ($? >> $WAIT_STATUS_SHIFT); + + # already in UTF-8 + die $stderr + if $status; + + my $display_dir + = path($parent_dir)->basename . $SLASH . $child->basename; + $errors .= "removed existing $display_dir" . $NEWLINE; + } + + # Perl unicode bug + utf8::downgrade $old_name; + utf8::downgrade $parent_dir; + + my @command = ('mv', $old_name, $parent_dir); + my $stderr; + run3(\@command, \undef, \undef, \$stderr); + my $status = ($? >> $WAIT_STATUS_SHIFT); + + # already in UTF-8 + die $stderr + if $status; + } + + return $errors; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for +Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Index/Ar.pm b/lib/Lintian/Index/Ar.pm new file mode 100644 index 0000000..01f3e6b --- /dev/null +++ b/lib/Lintian/Index/Ar.pm @@ -0,0 +1,128 @@ +# -*- perl -*- Lintian::Index::Ar +# +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Index::Ar; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Cwd; +use Path::Tiny; +use Unicode::UTF8 qw(decode_utf8 encode_utf8); + +use Lintian::IPC::Run3 qw(safe_qx); + +use Moo::Role; +use namespace::clean; + +const my $EMPTY => q{}; +const my $NEWLINE => qq{\n}; + +=head1 NAME + +Lintian::Index::Ar - binary symbol information. + +=head1 SYNOPSIS + + use Lintian::Index; + +=head1 DESCRIPTION + +Lintian::Index::Ar binary symbol information. + +=head1 INSTANCE METHODS + +=over 4 + +=item add_ar + +=cut + +sub add_ar { + my ($self) = @_; + + my $savedir = getcwd; + chdir($self->basedir) + or die encode_utf8( + $self->identifier . ': Cannot change to directory ' . $self->basedir); + + my $errors = $EMPTY; + + my @archives + = grep { $_->name =~ / [.]a $/msx && $_->is_regular_file } + @{$self->sorted_list}; + + for my $archive (@archives) { + + # skip empty archives to avoid ar error message; happens in tests + next + unless $archive->size; + + my %ar_info; + + # fails silently for non-ar files (#934899); probably creates empty entries + my $bytes = safe_qx(qw{ar t}, $archive); + if ($?) { + $errors .= "ar failed for $archive" . $NEWLINE; + next; + } + + my $output = decode_utf8($bytes); + my @members = split(/\n/, $output); + + my $count = 1; + for my $member (@members) { + + # more info could be added with -v above + $ar_info{$count}{name} = $member; + + } continue { + $count++; + } + + $archive->ar_info(\%ar_info); + } + + chdir($savedir) + or die encode_utf8( + $self->identifier . ": Cannot change to directory $savedir"); + + return $errors; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for +Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Index/Elf.pm b/lib/Lintian/Index/Elf.pm new file mode 100644 index 0000000..1fe4d7a --- /dev/null +++ b/lib/Lintian/Index/Elf.pm @@ -0,0 +1,739 @@ +# -*- perl -*- Lintian::Index::Elf +# +# Copyright (C) 1998 Christian Schwarz +# Copyright (C) 2008 Adam D. Barratt +# Copyright (C) 2017-2018 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020-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, see <http://www.gnu.org/licenses/>. + +package Lintian::Index::Elf; + +use v5.20; +use warnings; +use utf8; + +use bignum qw(hex); + +use Const::Fast; +use Cwd; +use IPC::Run3; +use Unicode::UTF8 qw(encode_utf8 valid_utf8 decode_utf8); + +use Lintian::Elf::Section; +use Lintian::Elf::Symbol; +use Lintian::Storage::MLDBM; + +use Moo::Role; +use namespace::clean; + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $HYPHEN => q{-}; +const my $NEWLINE => qq{\n}; + +const my $LINES_PER_FILE => 3; + +=head1 NAME + +Lintian::Index::Elf - binary symbol information. + +=head1 SYNOPSIS + + use Lintian::Index; + +=head1 DESCRIPTION + +Lintian::Index::Elf binary symbol information. + +=head1 INSTANCE METHODS + +=over 4 + +=item elf_storage + +=cut + +has elf_storage => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $storage = Lintian::Storage::MLDBM->new; + $storage->create('elf'); + + return $storage; + } +); + +=item elf_storage_by_member + +=cut + +has elf_storage_by_member => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $storage = Lintian::Storage::MLDBM->new; + $storage->create('elf-by-member'); + + return $storage; + } +); + +=item add_elf + +=cut + +sub add_elf { + my ($self) = @_; + + my $savedir = getcwd; + chdir($self->basedir) + or die encode_utf8( + $self->identifier . ': Cannot change to directory ' . $self->basedir); + + my $errors = $EMPTY; + + my @files = grep { $_->is_file } @{$self->sorted_list}; + + # must be ELF or static library + my @with_objects = grep { + $_->file_type =~ /\bELF\b/ + || ( $_->file_type =~ /\bcurrent ar archive\b/ + && $_->name =~ /\.a$/) + } @files; + + for my $file (@with_objects) { + + local $SIG{__WARN__}= sub { + warn encode_utf8($self->identifier + . ': Warning while running readelf on' + . $file->name + . ": $_[0]"); + }; + + my @command = (qw{readelf --all --wide}, $file->name); + my $combined_bytes; + + run3(\@command, \undef, \$combined_bytes, \$combined_bytes); + + next + unless length $combined_bytes; + + my $combined_output; + + if (valid_utf8($combined_bytes)) { + $combined_output = decode_utf8($combined_bytes); + + } else { + $combined_output = $combined_bytes; + $errors .= "Output from '@command' is not valid UTF-8" . $NEWLINE; + } + + # each object file in an archive gets its own File section + my @per_files = split(/^(File): (.*)$/m, $combined_output); + shift @per_files while @per_files && $per_files[0] ne 'File'; + + @per_files = ($combined_output) + unless @per_files; + + # Special case - readelf will not prefix the output with "File: + # $name" if it only gets one ELF file argument, so act as if it did... + # (but it does "the right thing" if passed a static lib >.>) + # + # - In fact, if readelf always emitted that File: header, we could + # simply use xargs directly on readelf and just parse its output + # in the loop below. + if (@per_files == 1) { + unshift(@per_files, $file->name); + unshift(@per_files, 'File'); + } + + unless (@per_files % $LINES_PER_FILE == 0) { + + $errors + .= "Parsed data from readelf is not a multiple of $LINES_PER_FILE for $file" + . $NEWLINE; + next; + } + + while (defined(my $fixed = shift @per_files)) { + + my $recorded_name = shift @per_files; + my $per_file = shift @per_files; + + unless ($fixed eq 'File') { + $errors .= "Unknown output from readelf for $file" . $NEWLINE; + next; + } + + unless (length $recorded_name) { + $errors .= "No file name from readelf for $file" . $NEWLINE; + next; + } + + my ($container, $member) = ($recorded_name =~ /^(.*)\(([^)]+)\)$/); + + $container = $recorded_name + unless defined $container && defined $member; + + unless ($container eq $file->name) { + $errors + .= "Container not same as file name ($container vs $file)" + . $NEWLINE; + next; + } + + # ignore empty archives, such as in musl-dev_1.2.1-1_amd64.deb + next + unless length $per_file; + + my $object_name; + if ($recorded_name =~ m{^(?:.+)\(([^/\)]+)\)$}){ + + # object file in a static lib. + $object_name = $1; + } + + parse_per_file($file, $object_name, $per_file); + } + } + + chdir($savedir) + or die encode_utf8( + $self->identifier . ": Cannot change to directory $savedir"); + + return $errors; +} + +=item parse_per_file + +=cut + +sub parse_per_file { + my ($file, $object_name, $from_readelf) = @_; + + my %by_object; + + $by_object{READELF} = $from_readelf; + + # sometimes there are three blank lines; seen on armhf + my @paragraphs = split(/\n{2,}/, $from_readelf); + + for my $paragraph (@paragraphs) { + + my ($first, $bulk) = split(m{\n}, $paragraph, 2); + + if ($first =~ /^ELF Header:/) { + elf_header($bulk, \%by_object); + next; + } + + if ($first =~ /^Program Headers:/) { + program_headers($bulk, \%by_object); + next; + } + + if ($first =~ /^Dynamic section at offset .*:/) { + dynamic_section($bulk, \%by_object); + next; + } + + if ($first =~ /^Section Headers:/) { + section_headers($bulk, \%by_object); + next; + } + + if ($first =~ /^Symbol table '.dynsym'/) { + symbol_table($bulk, \%by_object); + next; + } + + if ($first =~ /^Version symbols section /) { + version_symbols($bulk, \%by_object); + next; + } + + if ($first =~ /^There is no dynamic section in this file/) { + # a dynamic section was declared but it's empty. + $by_object{'BAD-DYNAMIC-TABLE'} = 1 + if exists $by_object{PH}{DYNAMIC}; + next; + } + } + + my %section_name_by_number; + for my $name (keys %{$by_object{SH} // {}}) { + + my $number = $by_object{SH}{$name}{number}; + $section_name_by_number{$number} = $name; + } + + for my $symbol_number (keys %{$by_object{'DYNAMIC-SYMBOLS'}}) { + + my $symbol_name + = $by_object{'DYNAMIC-SYMBOLS'}{$symbol_number}{symbol_name}; + my $section_number + = $by_object{'DYNAMIC-SYMBOLS'}{$symbol_number}{section_number}; + + my $symbol_version; + + if ($symbol_name =~ m{^ (.*) @ (.*) \s [(] .* [)] $}x) { + + $symbol_name = $1; + $symbol_version = $2; + + } else { + $symbol_version = $by_object{'SYMBOL-VERSIONS'}{$symbol_number} + // $EMPTY; + + if ( $symbol_version eq '*local*' + || $symbol_version eq '*global*'){ + + if ($section_number eq 'UND') { + $symbol_version = $EMPTY; + + } else { + $symbol_version = 'Base'; + } + + } elsif ($symbol_version eq '()') { + $symbol_version = '(Base)'; + } + } + + # happens once or twice for regular binaries + next + unless length $symbol_name; + + # look up numbered section + my $section_name = $section_name_by_number{$section_number} + // $section_number; + + my $symbol = Lintian::Elf::Symbol->new; + $symbol->section($section_name); + $symbol->version($symbol_version); + $symbol->name($symbol_name); + + push(@{ $by_object{SYMBOLS} }, $symbol); + } + + if (length $object_name) { + + # object file in a static lib. + $file->elf_by_member($object_name, \%by_object); + + } else { + $file->elf(\%by_object); + } + + return; +} + +=item elf_header + +=cut + +sub elf_header { + my ($text, $by_object) = @_; + + my @lines = split(m{\n}, $text); + + for my $line (@lines) { + + next + if divert_error('ELF header', $line, $by_object); + + my ($field, $value) = split(/:/, $line, 2); + + # trim both ends + $field =~ s/^\s+|\s+$//g; + $value =~ s/^\s+|\s+$//g; + + next + unless length $field && length $value; + + $by_object->{'ELF-HEADER'}{$field} = $value; + } + + return; +} + +=item program_headers + +=cut + +sub program_headers { + my ($text, $by_object) = @_; + + my @lines = split(m{\n}, $text); + + while (defined(my $line = shift @lines)) { + + next + if divert_error('program headers', $line, $by_object); + + if ($line =~ m{^ \s* (\S+) \s* (?:(?:\S+\s+){4}) \S+ \s (...) }x) { + + my $header = $1; + my $flags = $2; + + $header =~ s/^GNU_//g; + + next + if $header eq 'Type'; + + my $newflags = $EMPTY; + $newflags .= ($flags =~ /R/) ? 'r' : $HYPHEN; + $newflags .= ($flags =~ /W/) ? 'w' : $HYPHEN; + $newflags .= ($flags =~ /E/) ? 'x' : $HYPHEN; + + $by_object->{PH}{$header}{flags} = $newflags; + + if ($header eq 'INTERP' && @lines) { + # Check if the next line is the "requesting an interpreter" + # (readelf appears to always emit on the next line if at all) + my $next_line = $lines[0]; + + if ($next_line + =~ m{ [[] Requesting \s program \s interpreter: \s ([^\]]+) []] }x + ){ + + my $interpreter = $1; + + $by_object->{INTERP} = $interpreter; + + # discard line + shift @lines; + } + } + } + } + + return; +} + +=item dynamic_section + +=cut + +sub dynamic_section { + my ($text, $by_object) = @_; + + my @lines = split(m{\n}, $text); + + while (defined(my $line = shift @lines)) { + + next + if divert_error('dynamic section', $line, $by_object); + + if ($line + =~ m{^ \s* 0x (?:[0-9A-F]+) \s+ [(] (.*?) [)] \s+ ([\x21-\x7f][\x20-\x7f]*) \Z}ix + ) { + + my $type = $1; + my $remainder = $2; + + my $keep = 0; + + if ($type eq 'RPATH' || $type eq 'RUNPATH') { + $remainder =~ s{^ .* [[] }{}x; + $remainder =~ s{ []] \s* $}{}x; + $keep = 1; + + } elsif ($type eq 'TEXTREL' || $type eq 'DEBUG') { + $keep = 1; + + } elsif ($type eq 'FLAGS_1') { + # Will contain "NOW" if the binary was built with -Wl,-z,now + $remainder =~ s/^Flags:\s*//i; + $keep = 1; + + } elsif (($type eq 'FLAGS' && $remainder =~ m/\bBIND_NOW\b/) + || $type eq 'BIND_NOW') { + + # Variants of bindnow + $type = 'FLAGS_1'; + $remainder = 'NOW'; + $keep = 1; + } + + $keep = 1 + if $remainder + =~ s{^ (?: Shared \s library | Library \s soname ) : \s [[] (.*) []] }{$1}x; + + next + unless $keep; + + # Here we just need RPATH and NEEDS, so ignore the rest for now + if ($type eq 'RPATH' || $type eq 'RUNPATH') { + + # RPATH is like PATH + my @components = split(/:/, $remainder); + $by_object->{$type}{$_} = 1 for @components; + + } elsif ($type eq 'NEEDED' || $type eq 'SONAME') { + push(@{ $by_object->{$type} }, $remainder); + + } elsif ($type eq 'TEXTREL' || $type eq 'DEBUG') { + $by_object->{$type} = 1; + + } elsif ($type eq 'FLAGS_1') { + + my @flags = split(/\s+/, $remainder); + $by_object->{$type}{$_} = 1 for @flags; + } + } + } + + return; +} + +=item section_headers + +=cut + +sub section_headers { + my ($text, $by_object) = @_; + + const my $TOTAL_FIELDS => 11; + + my @lines = split(m{\n}, $text); + + die 'No column labels.' + unless @lines; + + my $first = shift @lines; + + my %labels_by_column; + + my $column = 1; + for my $label (split($SPACE, $first)) { + + $label =~ s{^ [[] }{}x; + $label =~ s{ []] $}{}x; + + $labels_by_column{$column} = $label; + + } continue { + ++$column; + } + + die 'Not enough column labels.' + if keys %labels_by_column != $TOTAL_FIELDS; + + my $row = 1; + while (defined(my $line = shift @lines)) { + + next + if divert_error('section headers', $line, $by_object); + + last + if $line =~ /^Key to Flags:/; + + my %section_header; + + my @matches = ( + $line =~ m{^ \s* + [[] \s* (\S+) []] \s # Nr + (\S+)? \s+ # Name + (\S+) \s+ # Type + ([0-9a-f]+) \s # Address/Addr + ([0-9a-f]+) \s # Off + ([0-9a-f]+) \s # Size + (\S+) \s+ # ES + (\S+)? \s+ # Flg + (\S+) \s+ # Lk + (\S+) \s+ # Inf + (\S+) # Al + $}x + ); + + if (@matches != $TOTAL_FIELDS) { + + warn "Parse error in readelf section headers [row $row]: $line"; + next; + } + + for my $column (keys %labels_by_column) { + + my $label = $labels_by_column{$column}; + my $value = $matches[$column -1] // $EMPTY; + + $section_header{$label} = $value; + } + + # http://sco.com/developers/gabi/latest/ch4.sheader.html + my $section = Lintian::Elf::Section->new; + $section->number($section_header{Nr}); + $section->name($section_header{Name}); + $section->type($section_header{Type}); + + # readelf uses both + $section->address( + hex($section_header{Address} // $section_header{Addr})); + $section->offset(hex($section_header{Off})); + $section->size(hex($section_header{Size})); + $section->entry_size(hex($section_header{ES})); + $section->flags($section_header{Flg}); + $section->index_link(hex($section_header{Lk})); + $section->index_info(hex($section_header{Inf})); + $section->alignment(hex($section_header{Al})); + + die 'No section number.' + unless length $section->number; + + $by_object->{'SECTION-HEADERS'}{$section->number} = $section; + + } continue { + ++$row; + } + + return; +} + +=item symbol_table + +=cut + +sub symbol_table { + my ($text, $by_object) = @_; + + # We (sometimes) need to read the "Version symbols section" first to + # use this data and readelf tends to print after this section, so + # save for later. + + my @lines = split(m{\n}, $text); + + while (defined(my $line = shift @lines)) { + + next + if divert_error('symbol table', $line, $by_object); + + if ($line + =~ m{^ \s* (\d+) : \s* [0-9a-f]+ \s+ \d+ \s+ (?:(?:\S+\s+){3}) (?: [[] .* []] \s+)? (\S+) \s+ (.*) \Z}x + ) { + + my $symbol_number = $1; + my $section_number = $2; + my $symbol_name = $3; + + $by_object->{'DYNAMIC-SYMBOLS'}{$symbol_number}{section_number} + = $section_number; + $by_object->{'DYNAMIC-SYMBOLS'}{$symbol_number}{symbol_name} + = $symbol_name; + } + } + + return; +} + +=item version_symbols + +=cut + +sub version_symbols { + my ($text, $by_object) = @_; + + my @lines = split(m{\n}, $text); + + while (defined(my $line = shift @lines)) { + + next + if divert_error('version symbols', $line, $by_object); + + if ($line + =~ m{^ \s* [0-9a-f]+ : \s* \S+ \s* (?: [(] \S+ [)] )? (?: \s | \Z ) }xi + ){ + + while ($line + =~ m{ ([0-9a-f]+ h?) \s* (?: [(] (\S+) [)] )? (?: \s | \Z ) }cgix + ) { + + my $symbol_number = $1; + my $symbol_version = $2; + + # for libfuse2_2.9.9-3_amd64.deb + next + unless length $symbol_version; + + $symbol_version = "($symbol_version)" + if $symbol_number =~ m{ h $}x; + + $by_object->{'SYMBOL-VERSIONS'}{$symbol_number} + = $symbol_version; + } + } + } + + return; +} + +=item divert_error + +=cut + +sub divert_error { + my ($section, $line, $by_object) = @_; + + return 0 + unless $line =~ s{^ readelf: \s+ }{}x; + + if ($line =~ s{^ Error: \s+ }{}x) { + + my $message = "In $section: $line"; + + $by_object->{ERRORS} //= []; + push(@{$by_object->{ERRORS}}, $message); + + return 1; + } + + if ($line =~ s{^ Warning: \s+ }{}x) { + + my $message = "In $section: $line"; + + $by_object->{WARNINGS} //= []; + push(@{$by_object->{WARNINGS}}, $message); + + return 1; + } + + return 0; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for +Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Index/FileTypes.pm b/lib/Lintian/Index/FileTypes.pm new file mode 100644 index 0000000..a71efb3 --- /dev/null +++ b/lib/Lintian/Index/FileTypes.pm @@ -0,0 +1,195 @@ +# -*- perl -*- Lintian::Index::FileTypes +# +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Index::FileTypes; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Cwd; +use Unicode::UTF8 qw(encode_utf8 decode_utf8); + +use Lintian::IPC::Run3 qw(xargs); + +use Moo::Role; +use namespace::clean; + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $COMMA => q{,}; +const my $NEWLINE => qq{\n}; + +const my $KEEP_EMPTY_FIELDS => -1; +const my $GZIP_MAGIC_SIZE => 9; +const my $GZIP_MAGIC_BYTES => 0x1f8b; + +=head1 NAME + +Lintian::Index::FileTypes - determine file type via magic. + +=head1 SYNOPSIS + + use Lintian::Index; + +=head1 DESCRIPTION + +Lintian::Index::FileTypes determine file type via magic. + +=head1 INSTANCE METHODS + +=over 4 + +=item add_file_types + +=cut + +sub add_file_types { + my ($self) = @_; + + my $savedir = getcwd; + chdir $self->basedir + or die encode_utf8( + $self->identifier . ': Cannot change to directory ' . $self->basedir); + + my $errors = $EMPTY; + + my @files = grep { $_->is_file } @{$self->sorted_list}; + my @names = map { $_->name } @files; + + my @command = qw(file --raw --no-pad --print0 --print0 --); + + my %file_types; + + xargs( + \@command, + \@names, + sub { + my ($stdout, $stderr, $status, @partial) = @_; + + # ignore failures if possible; file returns non-zero and + # "ERROR" on parse errors but output is still usable + + # undecoded split allows names with non UTF-8 bytes + $stdout =~ s{ \0 $}{}x; + + my @lines = split(m{\0}, $stdout, $KEEP_EMPTY_FIELDS); + + unless (@lines % 2 == 0) { + $errors + .= 'Did not get an even number lines from file command.' + . $NEWLINE; + return; + } + + while (defined(my $path = shift @lines)) { + + my $type = shift @lines; + + unless (length $path && length $type) { + $errors + .= "syntax error in file-info output: '$path' '$type'" + . $NEWLINE; + next; + } + + # drop relative prefix, if present + $path =~ s{^ [.]/ }{}x; + + $file_types{$path} = $self->adjust_type($path, $type); + } + + return; + } + ); + + $_->file_type($file_types{$_->name}) for @files; + + chdir $savedir + or die encode_utf8( + $self->identifier . ": Cannot change to directory $savedir"); + + return $errors; +} + +=item adjust_type + +=cut + +# some files need to be corrected +sub adjust_type { + my ($self, $name, $file_type) = @_; + + if ($name =~ m{ [.]gz $}ix && $file_type !~ /compressed/) { + + my $item = $self->lookup($name); + + die encode_utf8("Cannot find file $name in index") + unless $item; + + my $buffer = $item->magic($GZIP_MAGIC_SIZE); + if (length $buffer) { + + # translation of the unpack + # nn nn , NN NN NN NN, nn nn, cc - bytes read + # $magic, __ __ __ __, __ __, $comp - variables + my ($magic, undef, undef, $compression) = unpack('nNnc', $buffer); + + # gzip file magic + if ($magic == $GZIP_MAGIC_BYTES) { + + my $augment = 'gzip compressed data'; + + # 2 for max compression; RFC1952 suggests this is a + # flag and not a value, hence bit operation + $augment .= $COMMA . $SPACE . 'max compression' + if $compression & 2; + + return $file_type . $COMMA . $SPACE . $augment; + } + } + } + + # some TFMs are categorized as gzip, see Bug#963589 + return 'data' + if $name =~ m{ [.]tfm $}ix + && $file_type =~ /gzip compressed data/; + + return $file_type; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for +Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Index/Item.pm b/lib/Lintian/Index/Item.pm new file mode 100644 index 0000000..7ef6c09 --- /dev/null +++ b/lib/Lintian/Index/Item.pm @@ -0,0 +1,1567 @@ +# -*- perl -*- +# Lintian::Index::Item -- Representation of path entry in a package +# +# Copyright (C) 2011 Niels Thykier +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Index::Item; + +use v5.20; +use warnings; +use utf8; +use autodie qw(open); + +use Carp qw(croak confess); +use Const::Fast; +use Date::Parse qw(str2time); +use List::SomeUtils qw(all); +use Path::Tiny; +use Syntax::Keyword::Try; +use Text::Balanced qw(extract_delimited); +use Unicode::UTF8 qw(valid_utf8 decode_utf8 encode_utf8); + +use Lintian::Pointer::Item; +use Lintian::SlidingWindow; +use Lintian::Util qw(normalize_link_target); + +use Moo; +use namespace::clean; + +use constant { + TYPE_FILE => 0x00_01_00_00, + TYPE_HARDLINK => 0x00_02_00_00, + TYPE_DIR => 0x00_04_00_00, + TYPE_SYMLINK => 0x00_08_00_00, + TYPE_BLOCK_DEV => 0x00_10_00_00, + TYPE_CHAR_DEV => 0x00_20_00_00, + TYPE_PIPE => 0x00_40_00_00, + TYPE_OTHER => 0x00_80_00_00, + TYPE_MASK => 0x00_ff_00_00, + + UNSAFE_PATH => 0x01_00_00_00, + FS_PATH_IS_OK => 0x02_00_00_00, + OPEN_IS_OK => 0x06_00_00_00, # Implies FS_PATH_IS_OK + ACCESS_INFO => 0x07_00_00_00, + # 0o6777 == 0xdff, which covers set[ug]id + sticky bit. Accordingly, + # 0xffff should be more than sufficient for the foreseeable future. + OPERM_MASK => 0x00_00_ff_ff, +}; + +use overload ( + q{""} => \&_as_string, + 'qr' => \&_as_regex_ref, + 'bool' => \&_bool, + q{!} => \&_bool_not, + q{.} => \&_str_concat, + 'cmp' => \&_str_cmp, + 'eq' => \&_str_eq, + 'ne' => \&_str_ne, + 'fallback' => 0, +); + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $SLASH => q{/}; +const my $DOT => q{.}; +const my $DOUBLE_DOT => q{..}; +const my $DOUBLE_QUOTE => q{"}; +const my $BACKSLASH => q{\\}; +const my $HASHBANG => q{#!}; + +const my $MAXIMUM_LINK_DEPTH => 18; + +const my $BYTE_MAXIMUM => 255; +const my $SINGLE_OCTAL_MASK => oct(7); +const my $DUAL_OCTAL_MASK => oct(77); + +const my $ELF_MAGIC_SIZE => 4; +const my $LINCITY_MAGIC_SIZE => 6; +const my $SHELL_SCRIPT_MAGIC_SIZE => 2; + +const my $READ_BITS => oct(444); +const my $WRITE_BITS => oct(222); +const my $EXECUTABLE_BITS => oct(111); + +const my $SETUID => oct(4000); +const my $SETGID => oct(2000); + +=head1 NAME + +Lintian::Index::Item - Lintian representation of a path entry in a package + +=head1 SYNOPSIS + + my ($name, $type, $dir) = ('lintian', 'source', '/path/to/entry'); + +=head1 INSTANCE METHODS + +=over 4 + +=item init_from_tar_output + +=item get_quoted_filename + +=item unescape_c_style + +=cut + +my $datepattern = qr/\d{4}-\d{2}-\d{2}/; +my $timepattern = qr/\d{2}\:\d{2}(?:\:\d{2}(?:\.\d+)?)?/; +my $symlinkpattern = qr/\s+->\s+/; +my $hardlinkpattern = qr/\s+link\s+to\s+/; + +# adapted from https://www.perlmonks.org/?node_id=1056606 +my %T = ( + (map {chr() => chr} 0..$BYTE_MAXIMUM), + (map {sprintf('%o',$_) => chr} 0..($BYTE_MAXIMUM & $SINGLE_OCTAL_MASK)), + (map {sprintf('%02o',$_) => chr} 0..($BYTE_MAXIMUM & $DUAL_OCTAL_MASK)), + (map {sprintf('%03o',$_) => chr} 0..$BYTE_MAXIMUM), + (split //, "r\rn\nb\ba\af\ft\tv\013") +); + +sub unescape_c_style { + my ($escaped) = @_; + + (my $result = $escaped) =~ s/\\([0-7]{1,3}|.)/$T{$1}/g; + + return $result; +} + +sub get_quoted_filename { + my ($unknown, $skip) = @_; + + # extract quoted file name + my ($delimited, $extra) + = extract_delimited($unknown, $DOUBLE_QUOTE, $skip, $BACKSLASH); + + return (undef, undef) + unless defined $delimited; + + # drop quotes + my $cstylename = substr($delimited, 1, (length $delimited) - 2); + + # convert c-style escapes + my $name = unescape_c_style($cstylename); + + return ($name, $extra); +} + +sub init_from_tar_output { + my ($self, $line) = @_; + + chomp $line; + + # allow spaces in ownership and filenames (#895175 and #950589) + + my ($initial, $size, $date, $time, $remainder) + = split(/\s+(\d+)\s+($datepattern)\s+($timepattern)\s+/, $line,2); + + die encode_utf8( + $self->index->identifier . ": Cannot parse tar output: $line") + unless all { defined } ($initial, $size, $date, $time, $remainder); + + $self->size($size); + $self->date($date); + $self->time($time); + + my ($permissions, $ownership) = split(/\s+/, $initial, 2); + die encode_utf8($self->index->identifier + .": Cannot parse permissions and ownership in tar output: $line") + unless all { defined } ($permissions, $ownership); + + $self->perm($permissions); + + my ($owner, $group) = split(qr{/}, $ownership, 2); + die encode_utf8($self->index->identifier + . ": Cannot parse owner and group in tar output: $line") + unless all { defined } ($owner, $group); + + $self->owner($owner); + $self->group($group); + + my ($name, $extra) = get_quoted_filename($remainder, $EMPTY); + die encode_utf8($self->index->identifier + . ": Cannot parse file name in tar output: $line") + unless all { defined } ($name, $extra); + + # strip relative prefix + $name =~ s{^\./+}{}s; + + # slashes cannot appear in names but are sometimes doubled + # as in emboss-explorer_2.2.0-10.dsc + # better implemented in a Moo trigger on the attribute + $name =~ s{/+}{/}g; + + # make sure directories end with a slash, except root + $name .= $SLASH + if length $name + && $self->perm =~ / ^d /msx + && $name !~ m{ /$ }msx; + + $self->name($name); + + # look for symbolic link target + if ($self->perm =~ /^l/) { + + my ($linktarget, undef) = get_quoted_filename($extra, $symlinkpattern); + die encode_utf8($self->index->identifier + .": Cannot parse symbolic link target in tar output: $line") + unless defined $linktarget; + + # do not remove multiple slashes from symlink targets + # caught by symlink-has-double-slash, which is tested + # leaves resolution of these links unsolved + + # do not strip relative prefix for symbolic links + $self->link($linktarget); + } + + # look for hard link target + if ($self->perm =~ /^h/) { + + my ($linktarget, undef)= get_quoted_filename($extra, $hardlinkpattern); + die encode_utf8($self->index->identifier + . ": Cannot parse hard link target in tar output: $line") + unless defined $linktarget; + + # strip relative prefix + $linktarget =~ s{^\./+}{}s; + + # slashes cannot appear in names but are sometimes doubled + # as in emboss-explorer_2.2.0-10.dsc + # better implemented in a Moo trigger on the attribute, but requires + # separate attributes for hard and symbolic link targets + $linktarget =~ s{/+}{/}g; + + $self->link($linktarget); + } + + return; +} + +=item bytes_match(REGEX) + +Returns the matched string if REGEX matches the file's byte contents, +or $EMPTY otherwise. + +=cut + +sub bytes_match { + my ($self, $regex) = @_; + + return $EMPTY + unless $self->is_file; + + return $EMPTY + unless $self->is_open_ok; + + return $EMPTY + unless length $regex; + + open(my $fd, '<:raw', $self->unpacked_path); + my $sfd = Lintian::SlidingWindow->new; + $sfd->handle($fd); + + my $match; + while (my $block = $sfd->readwindow) { + + if ($block =~ /($regex)/) { + + $match = $1; + last; + } + } + + close $fd; + + return $match // $EMPTY; +} + +=item mentions_in_operation(REGEX) + +Returns the matched string if REGEX matches in a file location +that is likely an operation (vs text), or $EMPTY otherwise. + +=cut + +sub mentions_in_operation { + my ($self, $regex) = @_; + + # prefer strings(1) output (eg. for ELF) if we have it + # may not work as expected on ELF due to ld's SHF_MERGE + my $match; + if (length $self->strings && $self->strings =~ /($regex)/) { + $match = $1; + + } elsif ($self->is_script) { + $match = $self->bytes_match($regex); + } + + return $match // $EMPTY; +} + +=item magic(COUNT) + +Returns the specified COUNT of magic bytes for the file. + +=cut + +sub magic { + my ($self, $count) = @_; + + return $EMPTY + if length $self->link; + + return $EMPTY + if $self->size < $count; + + return $EMPTY + unless $self->is_open_ok; + + my $magic; + + open(my $fd, '<', $self->unpacked_path); + die encode_utf8($self->index->identifier + . ": Could not read $count bytes from " + . $self->name) + unless read($fd, $magic, $count) == $count; + close $fd; + + return $magic; +} + +=item C<hashbang> + +Returns the C<hashbang> for the file if it is a script. + +=cut + +has hashbang => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return $EMPTY + unless $self->is_script; + + my $trimmed_bytes = $EMPTY; + my $magic; + + open(my $fd, '<', $self->unpacked_path); + if (read($fd, $magic, 2) && $magic eq $HASHBANG && !eof($fd)) { + $trimmed_bytes = <$fd>; + } + close $fd; + + # decoding UTF-8 fails on magyarispell_1.6.1-2.dsc and ldc_1.24.0-1.dsc + + # remove comment, if any + $trimmed_bytes =~ s/^([^#]*)/$1/; + + # trim both ends + $trimmed_bytes =~ s/^\s+|\s+$//g; + + return $trimmed_bytes; + } +); + +=item interpreter_with_options + +Returns the interpreter requested by a script with options +after stripping C<env>. + +=cut + +has interpreter_with_options => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $with_options = $self->hashbang; + + $with_options =~ s{^/usr/bin/env\s+}{}; + + return $with_options; + } +); + +=item interpreter + +Returns the interpreter requested by a script but strips C<env>. + +=cut + +has interpreter => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $interpreter = $self->interpreter_with_options; + + # keep base command without options + $interpreter =~ s/^(\S+).*/$1/; + + return $interpreter; + } +); + +=item C<calls_env> + +Returns true if file is a script that calls C<env>. + +=cut + +has calls_env => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + # must return a boolean success value #943724 + return 1 + if $self->hashbang =~ m{^/usr/bin/env\s+}; + + return 0; + } +); + +=item C<is_shell_script> + +Returns true if file is a script requesting a recognized shell +interpreter. + +=cut + +has is_shell_script => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $interpreter = $self->interpreter; + + # keep basename + my ($basename) = ($interpreter =~ m{([^/]*)/?$}s); + + return 1 + if $basename =~ /^(?:[bd]?a|t?c|(?:pd|m)?k|z)?sh$/; + + return 0; + } +); + +=item is_elf + +Returns true if file is an ELF executable, and false otherwise. + +=cut + +has is_elf => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return 1 + if $self->magic($ELF_MAGIC_SIZE) eq "\x7FELF"; + + return 0; + } +); + +=item is_script + +Returns true if file is a script and false otherwise. + +=cut + +has is_script => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + # skip lincity data files; magic: #!#!#! + return 0 + if $self->magic($LINCITY_MAGIC_SIZE) eq '#!#!#!'; + + return 0 + unless $self->magic($SHELL_SCRIPT_MAGIC_SIZE) eq $HASHBANG; + + return 1; + } +); + +=item is_maintainer_script + +Returns true if file is a maintainer script and false otherwise. + +=cut + +has is_maintainer_script => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return 1 + if $self->name =~ /^ config | (?:pre|post)(?:inst|rm) $/x + && $self->is_open_ok; + + return 0; + } +); + +=item identity + +Returns the owner and group of the path, separated by a slash. + +NB: If only numerical owner information is available in the package, +this may return a numerical owner (except uid 0 is always mapped to +"root") + +=cut + +sub identity { + my ($self) = @_; + + return $self->owner . $SLASH . $self->group; +} + +=item operm + +Returns the file permissions of this object in octal (e.g. 0644). + +NB: This is only well defined for file entries that are subject to +permissions (e.g. files). Particularly, the value is not well defined +for symlinks. + +=cut + +sub operm { + my ($self) = @_; + + return $self->path_info & OPERM_MASK; +} + +=item octal_permissions + +=cut + +sub octal_permissions { + my ($self) = @_; + + return sprintf('%04o', $self->operm); +} + +=item children + +Returns a list of children (as Lintian::File::Path objects) of this entry. +The list and its contents should not be modified. + +Only returns direct children of this directory. The entries are sorted by name. + +NB: Returns the empty list for non-dir entries. + +=cut + +sub children { + my ($self) = @_; + + croak encode_utf8('No index in ' . $self->name) + unless defined $self->index; + + my @names = values %{$self->childnames}; + + return map { $self->index->lookup($_) } @names; +} + +=item descendants + +Returns a list of children (as Lintian::File::Path objects) of this entry. +The list and its contents should not be modified. + +Descends recursively into subdirectories and return the descendants in +breadth-first order. Children of a given directory will be sorted by +name. + +NB: Returns the empty list for non-dir entries. + +=cut + +sub descendants { + my ($self) = @_; + + my @descendants = $self->children; + + my @directories = grep { $_->is_dir } @descendants; + push(@descendants, $_->descendants) for @directories; + + return @descendants; +} + +=item timestamp + +Returns a Unix timestamp for the given path. This is a number of +seconds since the start of Unix epoch in UTC. + +=cut + +sub timestamp { + my ($self) = @_; + + my $timestamp = $self->date . $SPACE . $self->time; + + return str2time($timestamp, 'GMT'); +} + +=item child(BASENAME) + +Returns the child named BASENAME if it is a child of this directory. +Otherwise, this method returns C<undef>. + +Even for directories, BASENAME should not end with a slash. + +When invoked on non-dirs, this method always returns C<undef>. + +Example: + + $dir_entry->child('foo') => $entry OR undef + +=cut + +sub child { + my ($self, $basename) = @_; + + croak encode_utf8('No index in ' . $self->name) + unless defined $self->index; + + croak encode_utf8($self->index->identifier . ': Basename is required') + unless length $basename; + + my $childname = $self->childnames->{$basename}; + return undef + unless $childname; + + return $self->index->lookup($childname); +} + +=item is_symlink + +Returns a truth value if this entry is a symlink. + +=item is_hardlink + +Returns a truth value if this entry is a hardlink to a regular file. + +NB: The target of a hardlink is always a regular file (and not a dir etc.). + +=item is_dir + +Returns a truth value if this entry is a dir. + +NB: Unlike the "-d $dir" operator this will never return true for +symlinks, even if the symlink points to a dir. + +=item is_file + +Returns a truth value if this entry is a regular file (or a hardlink to one). + +NB: Unlike the "-f $file" operator this will never return true for +symlinks, even if the symlink points to a file (or hardlink). + +=item is_regular_file + +Returns a truth value if this entry is a regular file. + +This is eqv. to $path->is_file and not $path->is_hardlink. + +NB: Unlike the "-f $file" operator this will never return true for +symlinks, even if the symlink points to a file. + +=cut + +sub is_symlink { + my ($self) = @_; + + return $self->path_info & TYPE_SYMLINK ? 1 : 0; +} + +sub is_hardlink { + my ($self) = @_; + + return $self->path_info & TYPE_HARDLINK ? 1 : 0; +} + +sub is_dir { + my ($self) = @_; + + return $self->path_info & TYPE_DIR ? 1 : 0; +} + +sub is_file { + my ($self) = @_; + + return $self->path_info & (TYPE_FILE | TYPE_HARDLINK) ? 1 : 0; +} + +sub is_regular_file { + my ($self) = @_; + + return $self->path_info & TYPE_FILE ? 1 : 0; +} + +=item link_normalized + +Returns the target of the link normalized against it's directory name. +If the link cannot be normalized or normalized path might escape the +package root, this method returns C<undef>. + +NB: This method will return the empty string for links pointing to the +root dir of the package. + +Only available on "links" (i.e. symlinks or hardlinks). On non-links +this will croak. + +I<Symlinks only>: If you want the symlink target as a L<Lintian::File::Path> +object, use the L<resolve_path|/resolve_path([PATH])> method with no +arguments instead. + +=cut + +has link_normalized => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $name = $self->name; + my $link = $self->link; + + croak encode_utf8($self->index->identifier . ": $name is not a link") + unless length $link; + + my $dir = $self->dirname; + + # hardlinks are always relative to the package root + $dir = $SLASH + if $self->is_hardlink; + + my $target = normalize_link_target($dir, $link); + + return $target; + } +); + +=item is_readable + +Returns a truth value if the permission bits of this entry have +at least one bit denoting readability set (bitmask 0444). + +=item is_writable + +Returns a truth value if the permission bits of this entry have +at least one bit denoting writability set (bitmask 0222). + +=item is_executable + +Returns a truth value if the permission bits of this entry have +at least one bit denoting executability set (bitmask 0111). + +=cut + +sub is_readable { + my ($self) = @_; + + return $self->path_info & $READ_BITS; +} + +sub is_writable { + my ($self) = @_; + + return $self->path_info & $WRITE_BITS; +} + +sub is_executable { + my ($self) = @_; + + return $self->path_info & $EXECUTABLE_BITS; +} + +=item all_bits_set + +=cut + +sub all_bits_set { + my ($self, $bits) = @_; + + return ($self->operm & $bits) == $bits; +} + +=item is_setuid + +=cut + +sub is_setuid { + my ($self) = @_; + + return $self->operm & $SETUID; +} + +=item is_setgid + +=cut + +sub is_setgid { + my ($self) = @_; + + return $self->operm & $SETGID; +} + +=item unpacked_path + +Returns the path to this object on the file system, which must be a +regular file, a hardlink or a directory. + +This method may fail if: + +=over 4 + +=item * The object is neither a directory or a file-like object (e.g. a +named pipe). + +=item * If the object is dangling symlink or the path traverses a symlink +outside the package root. + +=back + +To test if this is safe to call, if the target is (supposed) to be a: + +=over 4 + +=item * file or hardlink then test with L</is_open_ok>. + +=item * dir then assert L<resolve_path|/resolve_path([PATH])> returns a +defined entry, for which L</is_dir> returns a truth value. + +=back + +=cut + +sub unpacked_path { + my ($self) = @_; + + $self->_check_access; + + croak encode_utf8('No index in ' . $self->name) + unless defined $self->index; + + my $basedir = $self->index->basedir; + + croak encode_utf8($self->index->identifier . ': No base directory') + unless length $basedir; + + my $unpacked = path($basedir)->child($self->name)->stringify; + + # bug in perl, file operator should not care but does + # https://github.com/Perl/perl5/issues/10550 + # also, https://github.com/Perl/perl5/issues/9674 + utf8::downgrade $unpacked; + + return $unpacked; +} + +=item is_open_ok + +Returns a truth value if it is safe to attempt open a read handle to +the underlying file object. + +Returns a truth value if the path may be opened. + +=cut + +sub is_open_ok { + my ($self) = @_; + + my $path_info = $self->path_info; + + return 1 + if ($path_info & OPEN_IS_OK) == OPEN_IS_OK; + + return 0 + if $path_info & ACCESS_INFO; + + try { + $self->_check_open; + + } catch { + return 0; + + # perlcritic 1.140-1 requires the semicolon on the next line + }; + + return 1; +} + +sub _check_access { + my ($self) = @_; + + my $path_info = $self->path_info; + + return 1 + if ($path_info & FS_PATH_IS_OK) == FS_PATH_IS_OK; + + return 0 + if $path_info & ACCESS_INFO; + + my $resolvable = $self->resolve_path; + unless ($resolvable) { + $self->path_info($self->path_info | UNSAFE_PATH); + # NB: We are deliberately vague here to avoid suggesting + # whether $path exists. In some cases (e.g. lintian.d.o) + # the output is readily available to wider public. + confess encode_utf8($self->index->identifier + .': Attempt to access through broken or unsafe symlink: ' + . $self->name); + } + + $self->path_info($self->path_info | FS_PATH_IS_OK); + + return 1; +} + +sub _check_open { + my ($self) = @_; + + $self->_check_access; + + # Symlinks can point to a "non-file" object inside the + # package root + # Leave "_path_access" here as _check_access marks it either as + # "UNSAFE_PATH" or "FS_PATH_IS_OK" + + confess encode_utf8($self->index->identifier + .': Opening of irregular file not supported: ' + . $self->name) + unless $self->is_file || ($self->is_symlink && -e $self->unpacked_path); + + $self->path_info($self->path_info | OPEN_IS_OK); + + return 1; +} + +=item follow + +Return dereferenced link if applicable + +=cut + +sub follow { + my ($self, $maxlinks) = @_; + + return $self + unless length $self->link; + + return $self->dereferenced + if defined $self->dereferenced; + + # set limit + $maxlinks //= $MAXIMUM_LINK_DEPTH; + + # catch recursive links + return undef + if $maxlinks <= 0; + + # reduce counter + $maxlinks--; + + my $reference; + + croak encode_utf8('No index in ' . $self->name) + unless defined $self->index; + + if ($self->is_hardlink) { + # hard links are resolved against package root + $reference = $self->index->lookup; + + } else { + # otherwise resolve against the parent + $reference = $self->parent_dir; + } + + croak encode_utf8($self->index->identifier + . ': No parent reference for link in ' + . $self->name) + unless defined $reference; + + # follow link + my $dereferenced = $reference->resolve_path($self->link, $maxlinks); + $self->dereferenced($dereferenced); + + return $self->dereferenced; +} + +=item resolve_path([PATH]) + +Resolve PATH relative to this path entry. + +If PATH starts with a slash and the file hierarchy has a well-defined +root directory, then PATH will instead be resolved relatively to the +root dir. If the file hierarchy does not have a well-defined root dir +(e.g. for source packages), this method will return C<undef>. + +If PATH is omitted, then the entry is resolved and the target is +returned if it is valid. Except for symlinks, all entries always +resolve to themselves. NB: hardlinks also resolve as themselves. + +It is an error to attempt to resolve a PATH against a non-directory +and non-symlink entry - as such resolution would always fail +(i.e. foo/../bar is an invalid path unless foo is a directory or a +symlink to a dir). + + +The resolution takes symlinks into account and following them provided +that the target path is valid (and can be followed safely). If the +path is invalid or circular (symlinks), escapes the root directory or +follows an unsafe symlink, the method returns C<undef>. Otherwise, it +returns the path entry that denotes the target path. + + +If PATH contains at least one path segment and ends with a slash, then +the resolved path will end in a directory (or fail). Otherwise, the +resolved PATH can end in any entry I<except> a symlink. + +Examples: + + $symlink_entry->resolve_path => $nonsymlink_entry OR undef + + $x->resolve_path => $x + + For directory or symlink entries (dol), you can also resolve a path: + + $dol_entry->resolve_path('some/../where') => $nonsymlink_entry OR undef + + # Note the trailing slash + $dol_entry->resolve_path('some/../where/') => $dir_entry OR undef + +=cut + +sub resolve_path { + my ($self, $request, $maxlinks) = @_; + + croak encode_utf8('No index in ' . $self->name) + unless defined $self->index; + + croak encode_utf8( + $self->index->identifier . ': Can only resolve string arguments') + if defined $request && ref($request) ne $EMPTY; + + $request //= $EMPTY; + + if (length $self->link) { + # follow the link + my $dereferenced = $self->follow($maxlinks); + return undef + unless defined $dereferenced; + + # and use that to resolve the request + return $dereferenced->resolve_path($request, $maxlinks); + } + + my $reference; + + # check for absolute reference; remove slash + if ($request =~ s{^/+}{}s) { + + # require anchoring for absolute references + return undef + unless $self->index->anchored; + + # get root entry + $reference = $self->index->lookup; + + } elsif ($self->is_dir) { + # directories are their own starting point + $reference = $self; + + } else { + # otherwise, use parent directory + $reference = $self->parent_dir; + } + + return undef + unless defined $reference; + + # read first segment; strip all trailing slashes for recursive use + if ($request =~ s{^([^/]+)/*}{}) { + + my $segment = $1; + + # single dot, or two slashes in a row + return $reference->resolve_path($request, $maxlinks) + if $segment eq $DOT || !length $segment; + + # for double dot, go up a level + if ($segment eq $DOUBLE_DOT) { + my $parent = $reference->parent_dir; + return undef + unless defined $parent; + + return $parent->resolve_path($request, $maxlinks); + } + + # look for child otherwise + my $child = $reference->child($segment); + return undef + unless defined $child; + + return $child->resolve_path($request, $maxlinks); + } + + croak encode_utf8($self->index->identifier + . ": Cannot parse path resolution request: $request") + if length $request; + + # nothing else to resolve + return $self; +} + +=item name + +Returns the name of the file (relative to the package root). + +NB: It will never have any leading "./" (or "/") in it. + +=item basename + +Returns the "filename" part of the name, similar basename(1) or +File::Basename::basename (without passing a suffix to strip in either +case). + +NB: Returns the empty string for the "root" dir. + +=item dirname + +Returns the "directory" part of the name, similar to dirname(1) or +File::Basename::dirname. The dirname will end with a trailing slash +(except the "root" dir - see below). + +NB: Returns the empty string for the "root" dir. + +=item link + +If this is a link (i.e. is_symlink or is_hardlink returns a truth +value), this method returns the target of the link. + +If this is not a link, then this returns undef. + +If the path is a symlink this method can be used to determine if the +symlink is relative or absolute. This is I<not> true for hardlinks, +where the link target is always relative to the root. + +NB: Even for symlinks, a leading "./" will be stripped. + +=item normalized + +=item faux + +Returns a truth value if this entry absent in the package. This can +happen if a package does not include all intermediate directories. + +=item size + +Returns the size of the path in bytes. + +NB: Only regular files can have a non-zero file size. + +=item date + +Return the modification date as YYYY-MM-DD. + +=item time + +=item perm + +=item path_info + +=item owner + +Returns the owner of the path entry as a username. + +NB: If only numerical owner information is available in the package, +this may return a numerical owner (except uid 0 is always mapped to +"root") + +=item group + +Returns the group of the path entry as a username. + +NB: If only numerical owner information is available in the package, +this may return a numerical group (except gid 0 is always mapped to +"root") + +=item uid + +Returns the uid of the owner of the path entry. + +NB: If the uid is not available, 0 will be returned. +This usually happens if the numerical data is not collected (e.g. in +source packages) + +=item gid + +Returns the gid of the owner of the path entry. + +NB: If the gid is not available, 0 will be returned. +This usually happens if the numerical data is not collected (e.g. in +source packages) + +=item file_type + +Return the data from L<file(1)> if it has been collected. + +Note this is only defined for files as Lintian only runs L<file(1)> on +files. + +=item java_info + +=item strings + +=item C<basedir> + +=item index + +=item parent_dir + +=item child_table + +=item sorted_children + +Returns the parent directory entry of this entry as a +L<Lintian::File::Path>. + +NB: Returns C<undef> for the "root" dir. + +=item C<childnames> + +=item parent_dir + +Return the parent dir entry of this the path entry. + +=item dereferenced + +=cut + +has name => ( + is => 'rw', + lazy => 1, + coerce => sub { my ($string) = @_; return $string // $EMPTY;}, + trigger => sub { + my ($self, $name) = @_; + + my ($basename) = ($name =~ m{([^/]*)/?$}s); + $self->basename($basename); + + # allow newline in names; need /s for dot matching (#929729) + my ($dirname) = ($name =~ m{^(.+/)?(?:[^/]+/?)$}s); + $self->dirname($dirname); + }, + default => $EMPTY +); +has basename => ( + is => 'rw', + lazy => 1, + coerce => sub { my ($string) = @_; return $string // $EMPTY;}, + default => $EMPTY +); +has dirname => ( + is => 'rw', + lazy => 1, + coerce => sub { my ($string) = @_; return $string // $EMPTY;}, + default => $EMPTY +); + +has link => ( + is => 'rw', + coerce => sub { my ($string) = @_; return $string // $EMPTY;}, + default => $EMPTY +); +has normalized => ( + is => 'rw', + coerce => sub { my ($string) = @_; return $string // $EMPTY;}, + default => $EMPTY +); +has faux => (is => 'rw', default => 0); + +has size => (is => 'rw', default => 0); +has date => ( + is => 'rw', + default => sub { + my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime; + return sprintf('%04d-%02d-%02d', $year, $mon, $mday); + } +); +has time => ( + is => 'rw', + default => sub { + my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime; + return sprintf('%02d:%02d:%02d', $hour, $min, $sec); + } +); + +has perm => (is => 'rw'); +has path_info => (is => 'rw'); + +has owner => ( + is => 'rw', + coerce => sub { my ($string) = @_; return $string // 'root'; }, + default => 'root' +); +has group => ( + is => 'rw', + coerce => sub { my ($string) = @_; return $string // 'root'; }, + default => 'root' +); +has uid => ( + is => 'rw', + coerce => sub { my ($value) = @_; return int($value // 0); }, + default => 0 +); +has gid => ( + is => 'rw', + coerce => sub { my ($value) = @_; return int($value // 0); }, + default => 0 +); + +has md5sum => ( + is => 'rw', + coerce => sub { my ($checksum) = @_; return ($checksum // 0); }, + default => 0 +); +has file_type => ( + is => 'rw', + coerce => sub { my ($text) = @_; return ($text // $EMPTY); }, + default => $EMPTY +); +has java_info => ( + is => 'rw', + coerce => sub { my ($hashref) = @_; return ($hashref // {}); }, + default => sub { {} } +); +has strings => ( + is => 'rw', + coerce => sub { my ($text) = @_; return ($text // $EMPTY); }, + default => $EMPTY +); +has ar_info => ( + is => 'rw', + coerce => sub { my ($hashref) = @_; return ($hashref // {}); }, + default => sub { {} } +); + +has index => (is => 'rw'); +has childnames => (is => 'rw', default => sub { {} }); +has parent_dir => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + # do not return root as its own parent + return + if $self->name eq $EMPTY; + + croak encode_utf8('No index in ' . $self->name) + unless defined $self->index; + + # returns root by default + return $self->index->lookup($self->dirname); + } +); +has dereferenced => (is => 'rw'); + +=item elf + +=cut + +sub elf { + my ($self, @args) = @_; + + if (@args) { + + $self->index->elf_storage->{$self->name} = $args[0]; + + return (); + } + + my %copy = %{$self->index->elf_storage->{$self->name} // {} }; + + return \%copy; +} + +=item elf_by_member + +=cut + +sub elf_by_member { + my ($self, @args) = @_; + + if (@args) { + + my $object_name = $args[0]; + my $by_object = $args[1]; + + my $tmp = $self->index->elf_storage_by_member->{$self->name} // {}; + $tmp->{$object_name} = $by_object; + $self->index->elf_storage_by_member->{$self->name} = $tmp; + + return (); + } + + my %copy = %{$self->index->elf_storage_by_member->{$self->name} // {} }; + + return \%copy; +} + +=item pointer + +=cut + +sub pointer { + my ($self, $position) = @_; + + my $pointer = Lintian::Pointer::Item->new; + $pointer->item($self); + $pointer->position($position); + + return $pointer; +} + +=item bytes + +Returns verbatim file contents as a scalar. + +=item is_valid_utf8 + +Boolean true if file contents are valid UTF-8. + +=item decoded_utf8 + +Returns a decoded, wide-character string if file contents are valid UTF-8. + +=cut + +sub bytes { + my ($self) = @_; + + return $EMPTY + unless $self->is_open_ok; + + my $bytes = path($self->unpacked_path)->slurp; + + return $bytes; +} + +sub is_valid_utf8 { + my ($self) = @_; + + my $bytes = $self->bytes; + return 0 + unless defined $bytes; + + return valid_utf8($bytes); +} + +sub decoded_utf8 { + my ($self) = @_; + + return $EMPTY + unless $self->is_valid_utf8; + + return decode_utf8($self->bytes); +} + +### OVERLOADED OPERATORS ### + +# overload apparently does not like the mk_ro_accessor, so use a level +# of indirection + +sub _as_regex_ref { + my ($self) = @_; + my $name = $self->name; + return qr{ \Q$name\E }xsm; +} + +sub _as_string { + my ($self) = @_; + return $self->name; +} + +sub _bool { + # Always true (used in "if ($info->index('some/path')) {...}") + return 1; +} + +sub _bool_not { + my ($self) = @_; + return !$self->_bool; +} + +sub _str_cmp { + my ($self, $str, $swap) = @_; + return $str cmp $self->name if $swap; + return $self->name cmp $str; +} + +sub _str_concat { + my ($self, $str, $swap) = @_; + return $str . $self->name if $swap; + return $self->name . $str; +} + +sub _str_eq { + my ($self, $str) = @_; + return $self->name eq $str; +} + +sub _str_ne { + my ($self, $str) = @_; + return $self->name ne $str; +} + +=back + +=head1 AUTHOR + +Originally written by Niels Thykier <niels@thykier.net> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et + diff --git a/lib/Lintian/Index/Java.pm b/lib/Lintian/Index/Java.pm new file mode 100644 index 0000000..4b33bec --- /dev/null +++ b/lib/Lintian/Index/Java.pm @@ -0,0 +1,258 @@ +# -*- perl -*- Lintian::Index::Java +# +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Index::Java; + +use v5.20; +use warnings; +use utf8; + +use Archive::Zip qw( :ERROR_CODES :CONSTANTS ); +use Const::Fast; +use Cwd; +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8); + +use Moo::Role; +use namespace::clean; + +const my $EMPTY => q{}; +const my $NEWLINE => qq{\n}; +const my $SPACE => q{ }; +const my $DASH => q{-}; + +const my $JAVA_MAGIC_SIZE => 8; +const my $JAVA_MAGIC_BYTES => 0xCAFEBABE; + +=head1 NAME + +Lintian::Index::Java - java information. + +=head1 SYNOPSIS + + use Lintian::Index; + +=head1 DESCRIPTION + +Lintian::Index::Java java information. + +=head1 INSTANCE METHODS + +=over 4 + +=item add_java + +=cut + +sub add_java { + my ($self) = @_; + + my $savedir = getcwd; + chdir($self->basedir) + or die encode_utf8( + $self->identifier . ': Cannot change to directory ' . $self->basedir); + + my $errors = $EMPTY; + + my @files = grep { $_->is_file } @{$self->sorted_list}; + + # Wheezy's version of file calls "jar files" for "Zip archive". + # Newer versions seem to call them "Java Jar file". + # Jessie also introduced "Java archive data (JAR)"... + my @java_files = grep { + $_->file_type=~ m{ + Java [ ] (?:Jar [ ] file|archive [ ] data) + | Zip [ ] archive + | JAR }x; + } @files; + + my @lines; + for my $file (@java_files) { + + push(@lines, parse_jar($file->name)) + if $file->name =~ /\S+\.jar$/i; + } + + my $file; + my $file_list; + my $manifest = 0; + local $_ = undef; + + my %java_info; + + for my $line (@lines) { + chomp $line; + next if $line =~ /^\s*$/; + + if ($line =~ /^-- ERROR:\s*(\S.+)$/) { + $java_info{$file}{error} = $1; + + } elsif ($line =~ m{^-- MANIFEST: (?:\./)?(?:.+)$}) { + # TODO: check $file == $1 ? + $java_info{$file}{manifest} = {}; + $manifest = $java_info{$file}{manifest}; + $file_list = 0; + + } elsif ($line =~ m{^-- (?:\./)?(.+)$}) { + $file = $1; + $java_info{$file}{files} = {}; + $file_list = $java_info{$file}{files}; + $manifest = 0; + } else { + if ($manifest && $line =~ m{^ (\S+):\s(.*)$}) { + $manifest->{$1} = $2; + } elsif ($file_list) { + my ($fname, $clmajor) = ($line =~ m{^([^-].*):\s*([-\d]+)$}); + $file_list->{$fname} = $clmajor; + } + } + } + + $_->java_info($java_info{$_->name}) for @java_files; + + chdir($savedir) + or die encode_utf8( + $self->identifier . ": Cannot change to directory $savedir"); + + return $errors; +} + +=item parse_jar + +=cut + +sub parse_jar { + my ($path) = @_; + + my @lines; + + # This script needs unzip, there's no way around. + push(@lines, "-- $path"); + + # Without this Archive::Zip will emit errors to standard error for + # faulty zip files - but that is not what we want. AFAICT, it is + # the only way to get a textual error as well, so (ab)use it for + # this purpose while we are at it. + my $errorhandler = sub { + my ($err) = @_; + $err =~ s/\r?\n/ /g; + + # trim right + $err =~ s/\s+$//; + + push(@lines, "-- ERROR: $err"); + }; + my $oldhandler = Archive::Zip::setErrorHandler($errorhandler); + + my $azip = Archive::Zip->new; + if($azip->read($path) == AZ_OK) { + + # save manifest for the end + my $manifest; + + # file list comes first + foreach my $member ($azip->members) { + my $name = $member->fileName; + + next + if $member->isDirectory; + + # store for later processing + $manifest = $member + if $name =~ m{^META-INF/MANIFEST.MF$}i; + + # add version if we can find it + my $jversion; + if ($name =~ /\.class$/) { + # Collect the Major version of the class file. + my ($contents, $zerr) = $member->contents; + + # bug in Archive::Zip; seen in android-platform-libcore_10.0.0+r36-1.dsc + last + unless defined $zerr; + + last + unless $zerr == AZ_OK; + + # Ensure we can read at least 8 bytes for the unpack. + next + if length $contents < $JAVA_MAGIC_SIZE; + + # translation of the unpack + # NN NN NN NN, nn nn, nn nn - bytes read + # $magic , __ __, $major - variables + my ($magic, undef, $major) = unpack('Nnn', $contents); + $jversion = $major + if $magic == $JAVA_MAGIC_BYTES; + } + push(@lines, "$name: " . ($jversion // $DASH)); + } + + if ($manifest) { + push(@lines, "-- MANIFEST: $path"); + + my ($contents, $zerr) = $manifest->contents; + + # bug in Archive::Zip; seen in android-platform-libcore_10.0.0+r36-1.dsc + return () + unless defined $zerr; + + if ($zerr == AZ_OK) { + my $partial = $EMPTY; + my $first = 1; + my @list = split($NEWLINE, $contents); + foreach my $line (@list) { + + # remove DOS type line feeds + $line =~ s/\r//g; + + if ($line =~ /^(\S+:)\s*(.*)/) { + push(@lines, $SPACE . $SPACE . "$1 $2"); + } + if ($line =~ /^ (.*)/) { + push(@lines, $1); + } + } + } + } + } + + Archive::Zip::setErrorHandler($oldhandler); + + return @lines; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for +Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Index/Md5sums.pm b/lib/Lintian/Index/Md5sums.pm new file mode 100644 index 0000000..c1d0583 --- /dev/null +++ b/lib/Lintian/Index/Md5sums.pm @@ -0,0 +1,127 @@ +# -*- perl -*- Lintian::Index::Md5sums +# +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Index::Md5sums; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Cwd; +use Unicode::UTF8 qw(encode_utf8 decode_utf8); + +use Lintian::IPC::Run3 qw(xargs); +use Lintian::Util qw(read_md5sums); + +use Moo::Role; +use namespace::clean; + +const my $EMPTY => q{}; +const my $NEWLINE => qq{\n}; + +const my $WAIT_STATUS_SHIFT => 8; +const my $NULL => qq{\0}; + +=head1 NAME + +Lintian::Index::Md5sums - calculate checksums for index. + +=head1 SYNOPSIS + + use Lintian::Index; + +=head1 DESCRIPTION + +Lintian::Index::Md5sums calculates checksums for an index. + +=head1 INSTANCE METHODS + +=over 4 + +=item add_md5sums + +=cut + +sub add_md5sums { + my ($self) = @_; + + my $savedir = getcwd; + chdir($self->basedir) + or die encode_utf8( + $self->identifier . ': Cannot change to directory ' . $self->basedir); + + my $errors = $EMPTY; + + # get the regular files in the index + my @files = grep { $_->is_file } @{$self->sorted_list}; + my @names = map { $_->name } @files; + + my @command = qw(md5sum --); + + my %md5sums; + + xargs( + \@command, + \@names, + sub { + my ($stdout, $stderr, $status, @partial) = @_; + + $stderr = decode_utf8($stderr) + if length $stderr; + + if ($status) { + $errors .= "Cannot run @command: $stderr" . $NEWLINE; + return; + } + + # undecoded split allows names with non UTF-8 bytes + my ($partial_sums, undef) = read_md5sums($stdout); + + $md5sums{$_} = $partial_sums->{$_}for @partial; + } + ); + + $_->md5sum($md5sums{$_->name}) for @files; + + chdir($savedir) + or die encode_utf8( + $self->identifier . ": Cannot change to directory $savedir"); + + return $errors; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for +Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Index/Strings.pm b/lib/Lintian/Index/Strings.pm new file mode 100644 index 0000000..f0e4fa1 --- /dev/null +++ b/lib/Lintian/Index/Strings.pm @@ -0,0 +1,99 @@ +# -*- perl -*- Lintian::Index::Strings +# +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Index::Strings; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Path::Tiny; +use Unicode::UTF8 qw(decode_utf8); + +use Lintian::IPC::Run3 qw(safe_qx); + +use Moo::Role; +use namespace::clean; + +const my $EMPTY => q{}; + +=head1 NAME + +Lintian::Index::Strings - strings in binary files. + +=head1 SYNOPSIS + + use Lintian::Index; + +=head1 DESCRIPTION + +Lintian::Index::Strings strings in binary files. + +=head1 INSTANCE METHODS + +=over 4 + +=item add_strings + +=cut + +sub add_strings { + my ($self) = @_; + + my $errors = $EMPTY; + + my @files = grep { $_->is_file } @{$self->sorted_list}; + for my $file (@files) { + + next + if $file->name =~ m{^usr/lib/debug/}; + + # skip non-binaries + next + unless $file->file_type =~ /\bELF\b/; + + # prior implementations sometimes made the list unique + my $allstrings + = decode_utf8(safe_qx(qw{strings --all --}, $file->unpacked_path)); + + $file->strings($allstrings); + } + + return $errors; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for +Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Mask.pm b/lib/Lintian/Mask.pm new file mode 100644 index 0000000..475e65c --- /dev/null +++ b/lib/Lintian/Mask.pm @@ -0,0 +1,76 @@ +# -*- perl -*- Lintian::Mask +# +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Mask; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +const my $EMPTY => q{}; + +use Moo; +use namespace::clean; + +=head1 NAME + +Lintian::Mask - access to mask data + +=head1 SYNOPSIS + + use Lintian::Mask; + +=head1 DESCRIPTION + +Lintian::Mask provides access to mask data. + +=head1 INSTANCE METHODS + +=over 4 + +=item screen + +=item excuse + +=cut + +has screen => (is => 'rw', default => $EMPTY); + +has excuse => (is => 'rw', default => $EMPTY); + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for +Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Output/EWI.pm b/lib/Lintian/Output/EWI.pm new file mode 100644 index 0000000..af0fac6 --- /dev/null +++ b/lib/Lintian/Output/EWI.pm @@ -0,0 +1,614 @@ +# Copyright (C) 2008 Frank Lichtenheld <frank@lichtenheld.de> +# 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::Output::EWI; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use HTML::HTML5::Entities; +use List::Compare; +use Term::ANSIColor (); +use Text::Wrap; +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::Output::Markdown qw(markdown_citation); + +# for tty hyperlinks +const my $OSC_HYPERLINK => qq{\033]8;;}; +const my $OSC_DONE => qq{\033\\}; +const my $BEL => qq{\a}; + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $COLON => q{:}; +const my $DOT => q{.}; +const my $NEWLINE => qq{\n}; +const my $PARAGRAPH_BREAK => $NEWLINE x 2; + +const my $YES => q{yes}; +const my $NO => q{no}; + +const my $COMMENT_PREFIX => q{N:} . $SPACE; + +const my $DESCRIPTION_INDENTATION => 2; +const my $DESCRIPTION_PREFIX => $COMMENT_PREFIX + . $SPACE x $DESCRIPTION_INDENTATION; + +const my $SCREEN_INDENTATION => 4; +const my $SCREEN_PREFIX => $COMMENT_PREFIX . $SPACE x $SCREEN_INDENTATION; + +const my %COLORS => ( + 'E' => 'bright_white on_bright_red', + 'W' => 'black on_bright_yellow', + 'I' => 'bright_white on_bright_blue', + 'P' => 'bright_white on_green', + 'C' => 'bright_white on_bright_magenta', + 'X' => 'bright_white on_yellow', + 'O' => 'bright_white on_bright_black', + 'M' => 'bright_black on_bright_white', +); + +const my %CODE_PRIORITY => ( + 'E' => 30, + 'W' => 40, + 'I' => 50, + 'P' => 60, + 'X' => 70, + 'C' => 80, + 'O' => 90, + 'M' => 100, +); + +const my %TYPE_PRIORITY => ( + 'source' => 30, + 'binary' => 40, + 'udeb' => 50, + 'changes' => 60, + 'buildinfo' => 70, +); + +use Moo; +use namespace::clean; + +with 'Lintian::Output::Grammar'; + +=head1 NAME + +Lintian::Output::EWI - standard hint output + +=head1 SYNOPSIS + + use Lintian::Output::EWI; + +=head1 DESCRIPTION + +Provides standard hint output. + +=head1 INSTANCE METHODS + +=over 4 + +=item tag_count_by_processable + +=cut + +has tag_count_by_processable => (is => 'rw', default => sub { {} }); + +=item issue_hints + +=cut + +sub issue_hints { + my ($self, $profile, $groups, $option) = @_; + + my %sorter; + for my $group (@{$groups // []}) { + + for my $processable ($group->get_processables) { + + my $type = $processable->type; + my $type_priority = $TYPE_PRIORITY{$type}; + + for my $hint (@{$processable->hints}) { + + my $tag = $profile->get_tag($hint->tag_name); + + my $override_status = 0; + $override_status = 1 + if defined $hint->override || @{$hint->masks}; + + my $ranking_code = $tag->code; + $ranking_code = 'X' + if $tag->experimental; + $ranking_code = 'O' + if defined $hint->override; + $ranking_code = 'M' + if @{$hint->masks}; + + my $code_priority = $CODE_PRIORITY{$ranking_code}; + + my %for_output; + $for_output{hint} = $hint; + $for_output{processable} = $processable; + + push( + @{ + $sorter{$override_status}{$code_priority}{$tag->name} + {$type_priority}{$processable->name}{$hint->context} + }, + \%for_output + ); + } + } + } + + for my $override_status (sort keys %sorter) { + + my %by_code_priority = %{$sorter{$override_status}}; + + for my $code_priority (sort { $a <=> $b } keys %by_code_priority) { + + my %by_tag_name = %{$by_code_priority{$code_priority}}; + + for my $tag_name (sort keys %by_tag_name) { + + my %by_type_priority = %{$by_tag_name{$tag_name}}; + + for + my $type_priority (sort { $a <=> $b }keys %by_type_priority){ + + my %by_processable_name + = %{$by_type_priority{$type_priority}}; + + for my $processable_name (sort keys %by_processable_name) { + + my %by_context + = %{$by_processable_name{$processable_name}}; + + for my $context (sort keys %by_context) { + + my $for_output + = $sorter{$override_status}{$code_priority} + {$tag_name}{$type_priority}{$processable_name} + {$context}; + + for my $each (@{$for_output}) { + + my $hint = $each->{hint}; + my $processable = $each->{processable}; + + $self->print_hint($profile, $hint, + $processable,$option) + if ( !defined $hint->override + && !@{$hint->masks}) + || $option->{'show-overrides'}; + } + } + } + } + } + } + } + + return; +} + +=item C<print_hint> + +=cut + +sub print_hint { + my ($self, $profile, $hint, $processable, $option) = @_; + + my $tag_name = $hint->tag_name; + my $tag = $profile->get_tag($tag_name); + + my @want_references = @{$option->{'display-source'} // []}; + my @have_references = @{$tag->see_also}; + + # keep only the first word + s{^ ([\w-]+) \s }{$1}x for @have_references; + + # drop anything in parentheses at the end + s{ [(] \S+ [)] $}{}x for @have_references; + + # check if hint refers to the selected references + my $reference_lc= List::Compare->new(\@have_references, \@want_references); + + my @found_references = $reference_lc->get_intersection; + + return + if @want_references + && !@found_references; + + my $information = $hint->context; + $information = $SPACE . $self->_quote_print($information) + unless $information eq $EMPTY; + + # Limit the output so people do not drown in hints. Some hints are + # insanely noisy (hi static-library-has-unneeded-section) + my $limit = $option->{'tag-display-limit'}; + if ($limit) { + + my $processable_id = $processable->identifier; + my $emitted_count + = $self->tag_count_by_processable->{$processable_id}{$tag_name}++; + + return + if $emitted_count >= $limit; + + my $msg + = ' ... use "--tag-display-limit 0" to see all (or pipe to a file/program)'; + $information = $self->_quote_print($msg) + if $emitted_count >= $limit-1; + } + + say encode_utf8('N:') + if $option->{info}; + + my $text = $tag_name; + + my $code = $tag->code; + $code = 'X' if $tag->experimental; + $code = 'O' if defined $hint->override; + $code = 'M' if @{$hint->masks}; + + my $tag_color = $COLORS{$code}; + + $text = Term::ANSIColor::colored($tag_name, $tag_color) + if $option->{color}; + + my $output; + if ($option->{hyperlinks} && $option->{color}) { + my $target= 'https://lintian.debian.org/tags/' . $tag_name; + $output .= $self->osc_hyperlink($text, $target); + } else { + $output .= $text; + } + + local $Text::Wrap::columns + = $option->{'output-width'} - length $COMMENT_PREFIX; + + # do not wrap long words such as urls; see #719769 + local $Text::Wrap::huge = 'overflow'; + + if ($hint->override && length $hint->override->justification) { + + my $wrapped = wrap($COMMENT_PREFIX, $COMMENT_PREFIX, + $hint->override->justification); + say encode_utf8($wrapped); + } + + for my $mask (@{$hint->masks}) { + + say encode_utf8($COMMENT_PREFIX . 'masked by screen ' . $mask->screen); + + next + unless length $mask->excuse; + + my $wrapped= wrap($COMMENT_PREFIX, $COMMENT_PREFIX, $mask->excuse); + say encode_utf8($wrapped); + } + + my $type = $EMPTY; + $type = $SPACE . $processable->type + unless $processable->type eq 'binary'; + + say encode_utf8($code + . $COLON + . $SPACE + . $processable->name + . $type + . $COLON + . $SPACE + . $output + . $information); + + if ($option->{info}) { + + # show only on first issuance + $self->describe_tag($profile->data, $tag, $option->{'output-width'}) + unless $self->issued_tag($tag->name); + } + + return; +} + +=item C<_quote_print($string)> + +Called to quote a string. By default it will replace all +non-printables with "?". Sub-classes can override it if +they allow non-ascii printables etc. + +=cut + +sub _quote_print { + my ($self, $string) = @_; + + $string =~ s/[^[:print:]]/?/g; + + return $string; +} + +=item C<osc_hyperlink> + +=cut + +sub osc_hyperlink { + my ($self, $text, $target) = @_; + + my $start = $OSC_HYPERLINK . $target . $BEL; + my $end = $OSC_HYPERLINK . $BEL; + + return $start . $text . $end; +} + +=item issuedtags + +Hash containing the names of tags which have been issued. + +=cut + +has issuedtags => (is => 'rw', default => sub { {} }); + +=item C<issued_tag($tag_name)> + +Indicate that the named tag has been issued. Returns a boolean value +indicating whether the tag had previously been issued by the object. + +=cut + +sub issued_tag { + my ($self, $tag_name) = @_; + + return $self->issuedtags->{$tag_name}++ ? 1 : 0; +} + +=item describe_tags + +=cut + +sub describe_tags { + my ($self, $data, $tags, $columns) = @_; + + for my $tag (@{$tags}) { + + my $name; + my $code; + + if (defined $tag) { + $name = $tag->name; + $code = $tag->code; + + } else { + $name = 'unknown-tag'; + $code = 'N'; + } + + say encode_utf8('N:'); + say encode_utf8("$code: $name"); + + $self->describe_tag($data, $tag, $columns); + } + + return; +} + +=item describe_tag + +=cut + +sub describe_tag { + my ($self, $data, $tag, $columns) = @_; + + local $Text::Wrap::columns = $columns; + + # do not wrap long words such as urls; see #719769 + local $Text::Wrap::huge = 'overflow'; + + my $wrapped = $COMMENT_PREFIX . $NEWLINE; + + if (defined $tag) { + + my $plain_explanation = markdown_to_plain($tag->explanation, + $columns - length $DESCRIPTION_PREFIX); + + $wrapped .= $DESCRIPTION_PREFIX . $_ . $NEWLINE + for split(/\n/, $plain_explanation); + + if (@{$tag->see_also}) { + + $wrapped .= $COMMENT_PREFIX . $NEWLINE; + + my @see_also_markdown + = map { markdown_citation($data, $_) } @{$tag->see_also}; + my $markdown + = 'Please refer to ' + . $self->oxford_enumeration('and', @see_also_markdown) + . ' for details.' + . $NEWLINE; + my $plain = markdown_to_plain($markdown, + $columns - length $DESCRIPTION_PREFIX); + + $wrapped .= $DESCRIPTION_PREFIX . $_ . $NEWLINE + for split(/\n/, $plain); + } + + $wrapped .= $COMMENT_PREFIX . $NEWLINE; + + my $visibility_prefix = 'Visibility: '; + $wrapped.= wrap( + $DESCRIPTION_PREFIX . $visibility_prefix, + $DESCRIPTION_PREFIX . $SPACE x length $visibility_prefix, + $tag->visibility . $NEWLINE + ); + + $wrapped .= wrap($DESCRIPTION_PREFIX, $DESCRIPTION_PREFIX, + 'Show-Always: '. ($tag->show_always ? $YES : $NO) . $NEWLINE); + + my $check_prefix = 'Check: '; + $wrapped .= wrap( + $DESCRIPTION_PREFIX . $check_prefix, + $DESCRIPTION_PREFIX . $SPACE x length $check_prefix, + $tag->check . $NEWLINE + ); + + if (@{$tag->renamed_from}) { + + $wrapped .= wrap($DESCRIPTION_PREFIX, $DESCRIPTION_PREFIX, + 'Renamed from: ' + . join($SPACE, @{$tag->renamed_from}) + . $NEWLINE); + } + + $wrapped + .= wrap($DESCRIPTION_PREFIX, $DESCRIPTION_PREFIX, + 'This tag is experimental.' . $NEWLINE) + if $tag->experimental; + + $wrapped .= wrap($DESCRIPTION_PREFIX, $DESCRIPTION_PREFIX, + 'This tag is a classification. There is no issue in your package.' + . $NEWLINE) + if $tag->visibility eq 'classification'; + + for my $screen (@{$tag->screens}) { + + $wrapped .= $COMMENT_PREFIX . $NEWLINE; + + $wrapped + .= wrap($DESCRIPTION_PREFIX, $DESCRIPTION_PREFIX, + 'Screen: ' . $screen->name . $NEWLINE); + + $wrapped .= wrap($SCREEN_PREFIX, $SCREEN_PREFIX, + 'Advocates: '. join(', ', @{$screen->advocates}). $NEWLINE); + + my $combined = $screen->reason . $NEWLINE; + if (@{$screen->see_also}) { + + $combined .= $NEWLINE; + + my @see_also_markdown + = map { markdown_citation($data, $_) } @{$screen->see_also}; + $combined + .= 'Read more in ' + . $self->oxford_enumeration('and', @see_also_markdown) + . $DOT + . $NEWLINE; + } + + my $reason_prefix = 'Reason: '; + my $plain = markdown_to_plain($combined, + $columns - length($SCREEN_PREFIX . $reason_prefix)); + + my @lines = split(/\n/, $plain); + $wrapped + .= $SCREEN_PREFIX . $reason_prefix . (shift @lines) . $NEWLINE; + $wrapped + .= $SCREEN_PREFIX + . $SPACE x (length $reason_prefix) + . $_ + . $NEWLINE + for @lines; + } + + } else { + $wrapped + .= wrap($DESCRIPTION_PREFIX, $DESCRIPTION_PREFIX, 'Unknown tag.'); + } + + $wrapped .= $COMMENT_PREFIX . $NEWLINE; + + print encode_utf8($wrapped); + + return; +} + +=item markdown_to_plain + +=cut + +sub markdown_to_plain { + my ($markdown, $columns) = @_; + + # use angular brackets for emphasis + $markdown =~ s{<i>|<em>}{<}g; + $markdown =~ s{</i>|</em>}{>}g; + + # drop Markdown hyperlinks + $markdown =~ s{\[([^\]]+)\]\([^\)]+\)}{$1}g; + + # drop all HTML tags except Markdown shorthand <$url> + $markdown =~ s{<(?![a-z]+://)[^>]+>}{}g; + + # drop brackets around Markdown shorthand <$url> + $markdown =~ s{<([a-z]+://[^>]+)>}{$1}g; + + # substitute HTML entities + my $plain = decode_entities($markdown); + + local $Text::Wrap::columns = $columns + if defined $columns; + + # do not wrap long words such as urls; see #719769 + local $Text::Wrap::huge = 'overflow'; + + my @paragraphs = split(/\n{2,}/, $plain); + + my @lines; + for my $paragraph (@paragraphs) { + + # do not wrap preformatted paragraphs + unless ($paragraph =~ /^\s/) { + + # reduce whitespace throughout, including newlines + $paragraph =~ s/\s+/ /g; + + # trim beginning and end of each line + $paragraph =~ s/^\s+|\s+$//mg; + + $paragraph = wrap($EMPTY, $EMPTY, $paragraph); + } + + push(@lines, $EMPTY); + push(@lines, split(/\n/, $paragraph)); + } + + # drop leading blank line + shift @lines; + + my $wrapped; + $wrapped .= $_ . $NEWLINE for @lines; + + return $wrapped; +} + +=back + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Output/Grammar.pm b/lib/Lintian/Output/Grammar.pm new file mode 100644 index 0000000..e9d62bd --- /dev/null +++ b/lib/Lintian/Output/Grammar.pm @@ -0,0 +1,84 @@ +# 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::Output::Grammar; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +use Moo::Role; +use namespace::clean; + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $COMMA => q{,}; + +=head1 NAME + +Lintian::Output::Grammar - sentence helpers + +=head1 SYNOPSIS + + use Lintian::Output::Grammar; + +=head1 DESCRIPTION + +Helps with human readable output. + +=head1 INSTANCE METHODS + +=over 4 + +=item oxford_enumeration + +=cut + +sub oxford_enumeration { + my ($self, $conjunctive, @alternatives) = @_; + + return $EMPTY + unless @alternatives; + + # remove and save last element + my $final = pop @alternatives; + + my $maybe_comma = (@alternatives > 1 ? $COMMA : $EMPTY); + + my $text = $EMPTY; + $text = join($COMMA . $SPACE, @alternatives) . "$maybe_comma $conjunctive " + if @alternatives; + + $text .= $final; + + return $text; +} + +=back + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Output/HTML.pm b/lib/Lintian/Output/HTML.pm new file mode 100644 index 0000000..8fd1126 --- /dev/null +++ b/lib/Lintian/Output/HTML.pm @@ -0,0 +1,331 @@ +# 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::Output::HTML; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Path::Tiny; +use Text::Markdown::Discount qw(markdown); +use Text::Xslate qw(mark_raw); +use Time::Duration; +use Time::Moment; +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::Output::Markdown qw(markdown_citation); + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $NEWLINE => qq{\n}; +const my $PARAGRAPH_BREAK => $NEWLINE x 2; + +const my %CODE_PRIORITY => ( + 'E' => 30, + 'W' => 40, + 'I' => 50, + 'P' => 60, + 'X' => 70, + 'C' => 80, + 'O' => 90, + 'M' => 100, +); + +use Moo; +use namespace::clean; + +with 'Lintian::Output::Grammar'; + +=head1 NAME + +Lintian::Output::HTML - standalone HTML hint output + +=head1 SYNOPSIS + + use Lintian::Output::HTML; + +=head1 DESCRIPTION + +Provides standalone HTML hint output. + +=head1 INSTANCE METHODS + +=over 4 + +=item issue_hints + +Print all hints passed in array. A separate arguments with processables +is necessary to report in case no hints were found. + +=cut + +sub issue_hints { + my ($self, $profile, $groups) = @_; + + $groups //= []; + + my %output; + + my $lintian_version = $ENV{LINTIAN_VERSION}; + $output{'lintian-version'} = $lintian_version; + + my @allgroups_output; + $output{groups} = \@allgroups_output; + + for my $group (sort { $a->name cmp $b->name } @{$groups}) { + + my %group_output; + + $group_output{'group-id'} = $group->name; + $group_output{name} = $group->source_name; + $group_output{version} = $group->source_version; + + my $start = Time::Moment->from_string($group->processing_start); + my $end = Time::Moment->from_string($group->processing_end); + $group_output{start} = $start->strftime('%c'); + $group_output{end} = $end->strftime('%c'); + $group_output{duration} = duration($start->delta_seconds($end)); + + my @processables = $group->get_processables; + my $any_processable = shift @processables; + $group_output{'maintainer'} + = $any_processable->fields->value('Maintainer'); + + push(@allgroups_output, \%group_output); + + my @allfiles_output; + $group_output{'input-files'} = \@allfiles_output; + + for my $processable (sort {$a->path cmp $b->path} + $group->get_processables) { + my %file_output; + $file_output{filename} = path($processable->path)->basename; + $file_output{hints} + = $self->hintlist($profile, $processable->hints); + push(@allfiles_output, \%file_output); + } + } + + my $style_sheet = $profile->data->style_sheet->css; + + my $templatedir = "$ENV{LINTIAN_BASE}/templates"; + my $tx = Text::Xslate->new(path => [$templatedir]); + my $page = $tx->render( + 'standalone-html.tx', + { + title => 'Lintian Tags', + style_sheet => mark_raw($style_sheet), + output => \%output, + } + ); + + print encode_utf8($page); + + return; +} + +=item C<hintlist> + +=cut + +sub hintlist { + my ($self, $profile, $arrayref) = @_; + + my %sorter; + for my $hint (@{$arrayref // []}) { + + my $tag = $profile->get_tag($hint->tag_name); + + my $override_status = 0; + $override_status = 1 + if defined $hint->override || @{$hint->masks}; + + my $ranking_code = $tag->code; + $ranking_code = 'X' + if $tag->experimental; + $ranking_code = 'O' + if defined $hint->override; + $ranking_code = 'M' + if @{$hint->masks}; + + my $code_priority = $CODE_PRIORITY{$ranking_code}; + + push( + @{ + $sorter{$override_status}{$code_priority}{$tag->name} + {$hint->context} + }, + $hint + ); + } + + my @sorted; + for my $override_status (sort keys %sorter) { + my %by_code_priority = %{$sorter{$override_status}}; + + for my $code_priority (sort { $a <=> $b } keys %by_code_priority) { + my %by_tag_name = %{$by_code_priority{$code_priority}}; + + for my $tag_name (sort keys %by_tag_name) { + my %by_context = %{$by_tag_name{$tag_name}}; + + for my $context (sort keys %by_context) { + + my $hints + = $sorter{$override_status}{$code_priority}{$tag_name} + {$context}; + + push(@sorted, $_)for @{$hints}; + } + } + } + } + + my @html_hints; + for my $hint (@sorted) { + + my $tag = $profile->get_tag($hint->tag_name); + + my %html_hint; + push(@html_hints, \%html_hint); + + $html_hint{tag_name} = $hint->tag_name; + + $html_hint{url} = 'https://lintian.debian.org/tags/' . $hint->tag_name; + + $html_hint{context} = $hint->context + if length $hint->context; + + $html_hint{visibility} = $tag->visibility; + + $html_hint{visibility} = 'experimental' + if $tag->experimental; + + my @comments; + if ($hint->override) { + + $html_hint{visibility} = 'override'; + + push(@comments, $hint->override->justification) + if length $hint->override->justification; + } + + # order matters + $html_hint{visibility} = 'mask' + if @{ $hint->masks }; + + for my $mask (@{$hint->masks}) { + + push(@comments, 'masked by screen ' . $mask->screen); + push(@comments, $mask->excuse) + if length $mask->excuse; + } + + $html_hint{comments} = \@comments + if @comments; + } + + return \@html_hints; +} + +=item describe_tags + +=cut + +sub describe_tags { + my ($self, $data, $tags) = @_; + + for my $tag (@{$tags}) { + + say encode_utf8('<p>Name: ' . $tag->name . '</p>'); + say encode_utf8($EMPTY); + + print encode_utf8(markdown($self->markdown_description($data, $tag))); + } + + return; +} + +=item markdown_description + +=cut + +sub markdown_description { + my ($self, $data, $tag) = @_; + + my $description = $tag->explanation; + + my @extras; + + if (@{$tag->see_also}) { + + my @markdown + = map { markdown_citation($data, $_) } @{$tag->see_also}; + my $references + = 'Please refer to ' + . $self->oxford_enumeration('and', @markdown) + . ' for details.'; + + push(@extras, $references); + } + + push(@extras, 'Visibility: '. $tag->visibility); + + push(@extras, 'Check: ' . $tag->check) + if length $tag->check; + + push(@extras, 'Renamed from: ' . join($SPACE, @{$tag->renamed_from})) + if @{$tag->renamed_from}; + + push(@extras, 'This tag is experimental.') + if $tag->experimental; + + push(@extras, + 'This tag is a classification. There is no issue in your package.') + if $tag->visibility eq 'classification'; + + for my $screen (@{$tag->screens}) { + + my $screen_description = 'Screen: ' . $screen->name . $NEWLINE; + $screen_description + .= 'Advocates: ' . join(', ', @{$screen->advocates}) . $NEWLINE; + $screen_description .= 'Reason: ' . $screen->reason . $NEWLINE; + + $screen_description .= 'See-Also: ' . $NEWLINE; + + push(@extras, $screen_description); + } + + $description .= $PARAGRAPH_BREAK . $_ for @extras; + + return $description; +} + +=back + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Output/JSON.pm b/lib/Lintian/Output/JSON.pm new file mode 100644 index 0000000..08996e2 --- /dev/null +++ b/lib/Lintian/Output/JSON.pm @@ -0,0 +1,322 @@ +# 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::Output::JSON; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Time::Piece; +use JSON::MaybeXS; + +use Lintian::Output::Markdown qw(markdown_citation); + +const my $EMPTY => q{}; + +const my %CODE_PRIORITY => ( + 'E' => 30, + 'W' => 40, + 'I' => 50, + 'P' => 60, + 'X' => 70, + 'C' => 80, + 'O' => 90, + 'M' => 100, +); + +use Moo; +use namespace::clean; + +=head1 NAME + +Lintian::Output::JSON - JSON hint output + +=head1 SYNOPSIS + + use Lintian::Output::JSON; + +=head1 DESCRIPTION + +Provides JSON hint output. + +=head1 INSTANCE METHODS + +=over 4 + +=item issue_hints + +Print all hints passed in array. A separate arguments with processables +is necessary to report in case no hints were found. + +=cut + +sub issue_hints { + my ($self, $profile, $groups) = @_; + + $groups //= []; + + my %output; + + $output{lintian_version} = $ENV{LINTIAN_VERSION}; + + my @allgroups_output; + $output{groups} = \@allgroups_output; + + for my $group (sort { $a->name cmp $b->name } @{$groups}) { + + my %group_output; + $group_output{group_id} = $group->name; + $group_output{source_name} = $group->source_name; + $group_output{source_version} = $group->source_version; + + push(@allgroups_output, \%group_output); + + my @allfiles_output; + $group_output{input_files} = \@allfiles_output; + + for my $processable (sort {$a->path cmp $b->path} + $group->get_processables) { + + my %file_output; + $file_output{path} = $processable->path; + $file_output{hints} + = $self->hintlist($profile, $processable->hints); + + push(@allfiles_output, \%file_output); + } + } + + # convert to UTF-8 prior to encoding in JSON + my $encoder = JSON->new; + $encoder->canonical; + $encoder->utf8; + $encoder->pretty; + + my $json = $encoder->encode(\%output); + + # output encoded JSON; is already in UTF-8 + print $json; + + return; +} + +=item C<hintlist> + +=cut + +sub hintlist { + my ($self, $profile, $arrayref) = @_; + + my %sorter; + for my $hint (@{$arrayref // []}) { + + my $tag = $profile->get_tag($hint->tag_name); + + my $override_status = 0; + $override_status = 1 + if defined $hint->override || @{$hint->masks}; + + my $ranking_code = $tag->code; + $ranking_code = 'X' + if $tag->experimental; + $ranking_code = 'O' + if defined $hint->override; + $ranking_code = 'M' + if @{$hint->masks}; + + my $code_priority = $CODE_PRIORITY{$ranking_code}; + + push( + @{ + $sorter{$override_status}{$code_priority}{$tag->name} + {$hint->context} + }, + $hint + ); + } + + my @sorted; + for my $override_status (sort keys %sorter) { + my %by_code_priority = %{$sorter{$override_status}}; + + for my $code_priority (sort { $a <=> $b } keys %by_code_priority) { + my %by_tag_name = %{$by_code_priority{$code_priority}}; + + for my $tag_name (sort keys %by_tag_name) { + my %by_context = %{$by_tag_name{$tag_name}}; + + for my $context (sort keys %by_context) { + + my $hints + = $sorter{$override_status}{$code_priority}{$tag_name} + {$context}; + + push(@sorted, $_)for @{$hints}; + } + } + } + } + + my @hint_dictionaries; + for my $hint (@sorted) { + + my $tag = $profile->get_tag($hint->tag_name); + + my %hint_dictionary; + push(@hint_dictionaries, \%hint_dictionary); + + $hint_dictionary{tag} = $tag->name; + $hint_dictionary{note} = $hint->note; + + if ($hint->can('pointer')) { + my $pointer = $hint->pointer; + + my %pointer_dictionary; + + if ($pointer->can('item')) { + my $item = $pointer->item; + + my %item_dictionary; + $item_dictionary{name} = $item->name; + $item_dictionary{index} = $item->index->identifier; + + $pointer_dictionary{item} = \%item_dictionary; + + # numerify to force JSON integer + # https://metacpan.org/pod/JSON::XS#simple-scalars + $pointer_dictionary{line_position} = $pointer->position + 0; + } + + $hint_dictionary{pointer} = \%pointer_dictionary; + } + + $hint_dictionary{visibility} = $tag->visibility; + $hint_dictionary{experimental} + = ($tag->experimental ? JSON()->true : JSON()->false); + + for my $mask (@{ $hint->masks }) { + + my %mask_dictionary; + $mask_dictionary{screen} = $mask->screen; + $mask_dictionary{excuse} = $mask->excuse; + + push(@{$hint_dictionary{masks}}, \%mask_dictionary); + } + + if ($hint->override) { + + my %override_dictionary; + $override_dictionary{justification} + = $hint->override->justification; + + $hint_dictionary{override} = \%override_dictionary; + } + } + + return \@hint_dictionaries; +} + +=item describe_tags + +=cut + +sub describe_tags { + my ($self, $data, $tags) = @_; + + my @tag_dictionaries; + + for my $tag (@{$tags}) { + + my %tag_dictionary; + push(@tag_dictionaries, \%tag_dictionary); + + $tag_dictionary{name} = $tag->name; + $tag_dictionary{name_spaced} + = ($tag->name_spaced ? JSON()->true : JSON()->false); + $tag_dictionary{show_always} + = ($tag->show_always ? JSON()->true : JSON()->false); + + $tag_dictionary{explanation} = $tag->explanation; + + my @tag_see_also_markdown + = map { markdown_citation($data, $_) } @{$tag->see_also}; + $tag_dictionary{see_also} = \@tag_see_also_markdown; + + $tag_dictionary{check} = $tag->check; + $tag_dictionary{visibility} = $tag->visibility; + $tag_dictionary{experimental} + = ($tag->experimental ? JSON()->true : JSON()->false); + + $tag_dictionary{renamed_from} = $tag->renamed_from; + + my @screen_dictionaries; + + for my $screen (@{$tag->screens}) { + + my %screen_dictionary; + push(@screen_dictionaries, \%screen_dictionary); + + $screen_dictionary{name} = $screen->name; + + my @advocate_emails = map { $_->format } @{$screen->advocates}; + $screen_dictionary{advocates} = \@advocate_emails; + + $screen_dictionary{reason} = $screen->reason; + + my @screen_see_also_markdown + = map { markdown_citation($data, $_) } @{$screen->see_also}; + $screen_dictionary{see_also} = \@screen_see_also_markdown; + } + + $tag_dictionary{screens} = \@screen_dictionaries; + + $tag_dictionary{lintian_version} = $ENV{LINTIAN_VERSION}; + } + + # convert to UTF-8 prior to encoding in JSON + my $encoder = JSON->new; + $encoder->canonical; + $encoder->utf8; + $encoder->pretty; + + # encode single tags without array bracketing + my $object = \@tag_dictionaries; + $object = shift @tag_dictionaries + if @tag_dictionaries == 1; + + my $json = $encoder->encode($object); + + # output encoded JSON; is already in UTF-8 + print $json; + + return; +} + +=back + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Output/Markdown.pm b/lib/Lintian/Output/Markdown.pm new file mode 100644 index 0000000..5786612 --- /dev/null +++ b/lib/Lintian/Output/Markdown.pm @@ -0,0 +1,224 @@ +# -*- perl -*- +# +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2009 Russ Allbery +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Output::Markdown; + +use v5.20; +use warnings; +use utf8; + +use Exporter qw(import); + +our @EXPORT_OK = qw( + markdown_citation + markdown_authority + markdown_bug + markdown_manual_page + markdown_uri + markdown_hyperlink +); + +use Const::Fast; + +const my $EMPTY => q{}; +const my $SPACE => q{ }; + +=head1 NAME + +Lintian::Output::Markdown - Lintian interface for markdown output + +=head1 SYNOPSIS + + use Lintian::Output::Markdown; + +=head1 DESCRIPTION + +Lintian::Output::Markdown provides functions for Markdown output. + +=head1 FUNCTIONS + +=over 4 + +=item markdown_citation + +=cut + +sub markdown_citation { + my ($data, $citation) = @_; + + if ($citation =~ m{^ ([\w-]+) \s+ (.+) $}x) { + + my $volume = $1; + my $section = $2; + + my $markdown = $data->markdown_authority_reference($volume, $section); + + $markdown ||= $citation; + + return $markdown; + } + + if ($citation =~ m{^ ([\w.-]+) [(] (\d\w*) [)] $}x) { + + my $name = $1; + my $section = $2; + + return markdown_manual_page($name, $section); + } + + if ($citation =~ m{^(?:Bug)?#(\d+)$}) { + + my $number = $1; + return markdown_bug($number); + } + + # turn bare file into file uris + $citation =~ s{^ / }{file://}x; + + # strip scheme from uri + if ($citation =~ s{^ (\w+) : // }{}x) { + + my $scheme = $1; + + return markdown_uri($scheme, $citation); + } + + return $citation; +} + +=item markdown_authority + +=cut + +sub markdown_authority { + my ($volume_title, $volume_url, $section_key, $section_title,$section_url) + = @_; + + my $directed_link; + $directed_link = markdown_hyperlink($section_title, $section_url) + if length $section_title + && length $section_url; + + my $pointer; + if (length $section_key) { + + if ($section_key =~ /^[A-Z]+$/ || $section_key =~ /^appendix-/) { + $pointer = "Appendix $section_key"; + + } elsif ($section_key =~ /^\d+$/) { + $pointer = "Chapter $section_key"; + + } else { + $pointer = "Section $section_key"; + } + } + + # overall manual. + my $volume_link = markdown_hyperlink($volume_title, $volume_url); + + if (length $directed_link) { + + return "$directed_link ($pointer) in the $volume_title" + if length $pointer; + + return "$directed_link in the $volume_title"; + } + + return "$pointer of the $volume_link" + if length $pointer; + + return "the $volume_link"; +} + +=item markdown_bug + +=cut + +sub markdown_bug { + my ($number) = @_; + + return markdown_hyperlink("Bug#$number","https://bugs.debian.org/$number"); +} + +=item markdown_manual_page + +=cut + +sub markdown_manual_page { + my ($name, $section) = @_; + + my $url + ="https://manpages.debian.org/cgi-bin/man.cgi?query=$name&sektion=$section"; + my $hyperlink = markdown_hyperlink("$name($section)", $url); + + return "the $hyperlink manual page"; +} + +=item markdown_uri + +=cut + +sub markdown_uri { + my ($scheme, $locator) = @_; + + my $url = "$scheme://$locator"; + + # use plain path as label for files + return markdown_hyperlink($locator, $url) + if $scheme eq 'file'; + + # or nothing for everything else + return markdown_hyperlink($EMPTY, $url); +} + +=item markdown_hyperlink + +=cut + +sub markdown_hyperlink { + my ($text, $url) = @_; + + return $text + unless length $url; + + return "<$url>" + unless length $text; + + return "[$text]($url)"; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Output/Universal.pm b/lib/Lintian/Output/Universal.pm new file mode 100644 index 0000000..a16da49 --- /dev/null +++ b/lib/Lintian/Output/Universal.pm @@ -0,0 +1,151 @@ +# Copyright (C) 2019-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::Output::Universal; + +use v5.20; +use warnings; +use utf8; + +use Carp; +use Const::Fast; +use List::SomeUtils qw(all); +use Unicode::UTF8 qw(encode_utf8); + +const my $SPACE => q{ }; +const my $COLON => q{:}; +const my $LEFT_PARENTHESIS => q{(}; +const my $RIGHT_PARENTHESIS => q{)}; + +use Moo; +use namespace::clean; + +=head1 NAME + +Lintian::Output::Universal -- Facilities for printing universal hints + +=head1 SYNOPSIS + + use Lintian::Output::Universal; + +=head1 DESCRIPTION + +A class for printing hints using the 'universal' format. + +=head1 INSTANCE METHODS + +=over 4 + +=item issue_hints + +Passing all groups with all processables in case no hints were found. + +=cut + +sub issue_hints { + my ($self, $profile, $groups) = @_; + + for my $group (@{$groups // []}) { + + my @by_group; + for my $processable ($group->get_processables) { + + for my $hint (@{$processable->hints}) { + + my $line + = $processable->name + . $SPACE + . $LEFT_PARENTHESIS + . $processable->type + . $RIGHT_PARENTHESIS + . $COLON + . $SPACE + . $hint->tag_name; + + $line .= $SPACE . $hint->context + if length $hint->context; + + push(@by_group, $line); + } + } + + my @sorted + = reverse sort { order($a) cmp order($b) } @by_group; + + say encode_utf8($_) for @sorted; + } + + return; +} + +=item order + +=cut + +sub order { + my ($line) = @_; + + return package_type($line) . $line; +} + +=item package_type + +=cut + +sub package_type { + my ($line) = @_; + + my (undef, $type, undef, undef) = parse_line($line); + return $type; +} + +=item parse_line + +=cut + +sub parse_line { + my ($line) = @_; + + my ($package, $type, $name, $details) + = $line =~ qr/^(\S+)\s+\(([^)]+)\):\s+(\S+)(?:\s+(.*))?$/; + + croak encode_utf8("Cannot parse line $line") + unless all { length } ($package, $type, $name); + + return ($package, $type, $name, $details); +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Override.pm b/lib/Lintian/Override.pm new file mode 100644 index 0000000..c62788d --- /dev/null +++ b/lib/Lintian/Override.pm @@ -0,0 +1,86 @@ +# -*- perl -*- Lintian::Override +# +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Override; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +const my $EMPTY => q{}; + +use Moo; +use namespace::clean; + +=head1 NAME + +Lintian::Override - access to override data + +=head1 SYNOPSIS + + use Lintian::Override; + +=head1 DESCRIPTION + +Lintian::Override provides access to override data. + +=head1 INSTANCE METHODS + +=over 4 + +=item tag_name + +=item architectures + +=item pattern + +=item justification + +=item position + +=cut + +has tag_name => (is => 'rw', default => $EMPTY); +has architectures => (is => 'rw', default => sub { [] }); + +has pattern => (is => 'rw', default => $EMPTY); + +has justification => (is => 'rw', default => $EMPTY); +has position => (is => 'rw'); + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for +Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Pointer/Item.pm b/lib/Lintian/Pointer/Item.pm new file mode 100644 index 0000000..6622fc8 --- /dev/null +++ b/lib/Lintian/Pointer/Item.pm @@ -0,0 +1,100 @@ +# Copyright (C) 2021 Felix Lechner <felix.lechner@lease-up.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::Pointer::Item; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(croak); +use Const::Fast; +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +const my $EMPTY => q{}; +const my $COLON => q{:}; + +=head1 NAME + +Lintian::Pointer::Item -- Facilities for pointing into specific index items + +=head1 SYNOPSIS + +use Lintian::Pointer::Item; + +=head1 DESCRIPTION + +A class for item pointers + +=head1 INSTANCE METHODS + +=over 4 + +=item item + +=item position + +=cut + +has item => (is => 'rw'); +has position => ( + is => 'rw', + coerce => sub { my ($number) = @_; return $number // 0;}, + default => 0 +); + +=item to_string + +=cut + +sub to_string { + my ($self) = @_; + + croak encode_utf8('No item') + unless defined $self->item; + + my $text = $self->item->name; + + $text .= $COLON . $self->position + if $self->position > 0; + + return $text; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Pool.pm b/lib/Lintian/Pool.pm new file mode 100644 index 0000000..db153f9 --- /dev/null +++ b/lib/Lintian/Pool.pm @@ -0,0 +1,412 @@ +# Copyright (C) 2011 Niels Thykier <niels@thykier.net> +# 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. + +## Represents a pool of processables (Lintian::Processable) +package Lintian::Pool; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Cwd qw(getcwd); +use List::SomeUtils qw(any); +use Time::HiRes qw(gettimeofday tv_interval); +use Path::Tiny; +use POSIX qw(:sys_wait_h); +use Proc::ProcessTable; +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::Group; + +const my $SPACE => q{ }; +const my $COMMA => q{,}; +const my $SEMICOLON => q{;}; +const my $LEFT_PARENS => q{(}; +const my $RIGHT_PARENS => q{)}; +const my $PLURAL_S => q{s}; + +const my $ANY_CHILD => -1; +const my $WORLD_WRITABLE_FOLDER => oct(777); + +use Moo; +use namespace::clean; + +=head1 NAME + +Lintian::Pool -- Pool of processables + +=head1 SYNOPSIS + + use Lintian::Pool; + + my $pool = Lintian::Pool->new; + $pool->add_file('foo.changes'); + $pool->add_file('bar.dsc'); + $pool->add_file('baz.deb'); + $pool->add_file('qux.buildinfo'); + foreach my $gname ($pool->get_group_names){ + my $group = $pool->get_group($gname); + process($gname, $group); + } + +=head1 METHODS + +=over 4 + +=item $pool->groups + +Returns a hash reference to the list of processable groups that are currently +in the pool. The key is a unique identifier based on name and version. + +=item C<savedir> + +=cut + +has groups => (is => 'rw', default => sub{ {} }); + +has savedir => (is => 'rw', default => sub{ getcwd; }); + +# must be absolute; frontend/lintian depends on it +has basedir => ( + is => 'rw', + default => sub { + + my $absolute + = Path::Tiny->tempdir(TEMPLATE => 'lintian-pool-XXXXXXXXXX'); + + $absolute->mkpath({mode => $WORLD_WRITABLE_FOLDER}); + + return $absolute; + } +); + +=item $pool->basedir + +Returns the base directory for the pool. Most likely it's a temporary directory. + +=item $pool->add_group($group) + +Adds a group to the pool. + +=cut + +sub add_group { + my ($self, $group) = @_; + + my $name = $group->name; + + unless (exists $self->groups->{$name}){ + + # group does not exist; just add whole + $self->groups->{$name} = $group; + + return 1; + } + + # group exists; merge & accept all new + my $added = 0; + + my $old = $self->groups->{$name}; + + for my $type (qw/source buildinfo changes/) { + + if (!defined $old->$type && defined $group->$type) { + $old->add_processable($group->$type); + $added = 1; + } + } + + for my $installable ($group->get_installables){ + # New binary package ? + my $was_new = $old->add_processable($installable); + $added ||= $was_new; + } + + return $added; +} + +=item $pool->process + +Process the pool. + +=cut + +sub process{ + my ($self, $PROFILE, $exit_code_ref, $option)= @_; + + if ($self->empty) { + say {*STDERR} encode_utf8('No packages selected.'); + return; + } + + my %reported_count; + my %override_count; + my %ignored_overrides; + my $unused_overrides = 0; + + for my $group (values %{$self->groups}) { + + my $total_start = [gettimeofday]; + + $group->profile($PROFILE); + $group->jobs($option->{'jobs'}); + + my $success= $group->process(\%ignored_overrides, $option); + + for my $processable ($group->get_processables){ + + my @keep; + for my $hint (@{$processable->hints}) { + + my $tag = $PROFILE->get_tag($hint->tag_name); + + # discard experimental tags + next + if $tag->experimental + && !$option->{'display-experimental'}; + + # discard overridden tags + next + if defined $hint->override + && !$option->{'show-overrides'}; + + # discard outside the selected display level + next + unless $PROFILE->display_level_for_tag($hint->tag_name); + + if (!defined $hint->override) { + + ++$reported_count{$tag->visibility} + if !$tag->experimental; + + ++$reported_count{experimental} + if $tag->experimental; + } + + ++$reported_count{override} + if defined $hint->override; + + ++$unused_overrides + if $hint->tag_name eq 'unused-override' + || $hint->tag_name eq 'mismatched-override'; + + push(@keep, $hint); + } + + $processable->hints(\@keep); + } + + ${$exit_code_ref} = 2 + if $success && any { $reported_count{$_} } @{$option->{'fail-on'}}; + + # interruptions can leave processes behind (manpages); wait and reap + if (${$exit_code_ref} == 1) { + 1 while waitpid($ANY_CHILD, WNOHANG) > 0; + } + + if ($option->{debug}) { + my $process_table = Proc::ProcessTable->new; + my @leftover= grep { $_->ppid == $$ } @{$process_table->table}; + + # announce left over processes, see commit 3bbcc3b + if (@leftover) { + warn encode_utf8( + "\nSome processes were left over (maybe unreaped):\n"); + + my $FORMAT = ' %-12s %-12s %-8s %-24s %s'; + say encode_utf8( + sprintf( + $FORMAT,'PID', 'TTY', 'STATUS', 'START', 'COMMAND' + ) + ); + + say encode_utf8( + sprintf($FORMAT, + $_->pid,$_->ttydev, + $_->state,scalar(localtime($_->start)), + $_->cmndline) + )for @leftover; + + ${$exit_code_ref} = 1; + die encode_utf8("Aborting.\n"); + } + } + + my $total_raw_res = tv_interval($total_start); + my $total_tres = sprintf('%.3fs', $total_raw_res); + + my $status = $success ? 'complete' : 'error'; + say {*STDERR} + encode_utf8($status . $SPACE . $group->name . " ($total_tres)") + if $option->{'status-log'}; + say {*STDERR} encode_utf8('Finished processing group ' . $group->name) + if $option->{debug}; + + ${$exit_code_ref} = 1 + unless $success; + } + + my $OUTPUT; + if ($option->{'output-format'} eq 'html') { + require Lintian::Output::HTML; + $OUTPUT = Lintian::Output::HTML->new; + } elsif ($option->{'output-format'} eq 'json') { + require Lintian::Output::JSON; + $OUTPUT = Lintian::Output::JSON->new; + } elsif ($option->{'output-format'} eq 'universal') { + require Lintian::Output::Universal; + $OUTPUT = Lintian::Output::Universal->new; + } else { + require Lintian::Output::EWI; + $OUTPUT = Lintian::Output::EWI->new; + } + + # pass everything, in case some groups or processables have no hints + $OUTPUT->issue_hints($PROFILE, [values %{$self->groups}], $option); + + my $errors = $override_count{error} // 0; + my $warnings = $override_count{warning} // 0; + my $info = $override_count{info} // 0; + my $total = $errors + $warnings + $info; + + if ( $option->{'output-format'} eq 'ewi' + && !$option->{'no-override'} + && !$option->{'show-overrides'} + && ($total > 0 || $unused_overrides > 0)) { + + my @details; + push(@details, quantity($errors, 'error')) + if $errors; + push(@details, quantity($warnings, 'warning')) + if $warnings; + push(@details, "$info info") + if $info; + + my $text = quantity($total, 'hint') . ' overridden'; + $text + .= $SPACE + . $LEFT_PARENS + . join($COMMA . $SPACE, @details) + . $RIGHT_PARENS + if @details; + $text + .= $SEMICOLON + . $SPACE + . quantity($unused_overrides, 'unused override'); + + say encode_utf8("N: $text"); + } + + if ($option->{'output-format'} eq 'ewi' && %ignored_overrides) { + say encode_utf8('N: Some overrides were ignored.'); + + if ($option->{verbose}) { + say encode_utf8( +'N: The following tags had at least one override but are mandatory:' + ); + say encode_utf8("N: - $_") for sort keys %ignored_overrides; + + } else { + say encode_utf8('N: Use --verbose for more information.'); + } + } + + path($self->basedir)->remove_tree + if length $self->basedir && -d $self->basedir; + + return; +} + +=item quantity + +=cut + +sub quantity { + my ($count, $unit) = @_; + + my $text = $count . $SPACE . $unit; + $text .= $PLURAL_S + unless $count == 1; + + return $text; +} + +=item $pool->get_group_names + +Returns the name of all the groups in this pool. + +Do not modify the list nor its contents. + +=cut + +sub get_group_names{ + my ($self) = @_; + + return keys %{ $self->groups }; +} + +=item $pool->get_group($name) + +Returns the group called $name or C<undef> +if there is no group called $name. + +=cut + +sub get_group{ + my ($self, $group) = @_; + + return $self->groups->{$group}; +} + +=item $pool->empty + +Returns true if the pool is empty. + +=cut + +sub empty{ + my ($self) = @_; + + return scalar keys %{$self->groups} == 0; +} + +=back + +=head1 AUTHOR + +Originally written by Niels Thykier <niels@thykier.net> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +L<Lintian::Processable> + +L<Lintian::Group> + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Processable.pm b/lib/Lintian/Processable.pm new file mode 100644 index 0000000..c89a1fc --- /dev/null +++ b/lib/Lintian/Processable.pm @@ -0,0 +1,302 @@ +# Copyright (C) 2011 Niels Thykier <niels@thykier.net> +# 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::Processable; + +use v5.20; +use warnings; +use utf8; +use warnings::register; + +use Const::Fast; +use File::Basename; +use Path::Tiny; + +use Moo::Role; +use MooX::Aliases; +use namespace::clean; + +const my $EMPTY => q{}; +const my $COLON => q{:}; +const my $SLASH => q{/}; +const my $UNDERSCORE => q{_}; +const my $EVIL_CHARACTERS => qr{[/&|;\$"'<>]}; + +=encoding utf-8 + +=head1 NAME + +Lintian::Processable -- An (abstract) object that Lintian can process + +=head1 SYNOPSIS + + use Lintian::Processable; + +=head1 DESCRIPTION + +Instances of this perl class are objects that Lintian can process (e.g. +deb files). Multiple objects can then be combined into +L<groups|Lintian::Group>, which Lintian will process +together. + +=head1 INSTANCE METHODS + +=over 4 + +=item name + +Returns the name of the package. + +=item type + +Returns the type of package (e.g. binary, source, udeb ...) + +=item hints + +=item $proc->version + +Returns the version of the package. + +=item $proc->path + +Returns the path to the packaged version of actual package. This path +is used in case the data needs to be extracted from the package. + +=item basename + +Returns the basename of the package path. + +=item $proc->architecture + +Returns the architecture(s) of the package. May return multiple values +from changes processables. For source processables it is "source". + +=item $proc->source_name + +Returns the name of the source package. + +=item $proc->source_version + +Returns the version of the source package. + +=item $proc->tainted + +Returns a truth value if one or more fields in this Processable is +tainted. On a best effort basis tainted fields will be sanitized +to less dangerous (but possibly invalid) values. + +=item fields + +Lintian::Deb822::Section with primary field values. + +=item $proc->pooldir + +Returns a reference to lab this Processable is in. + +=item $proc->basedir + +Returns the base directory of this package inside the lab. + +=cut + +has path => ( + is => 'rw', + default => $EMPTY, + trigger => sub { + my ($self, $path) = @_; + + my $basename = basename($path); + $self->basename($basename); + } +); +has basename => (is => 'rw', default => $EMPTY); +has type => (is => 'rw', default => $EMPTY); + +has hints => (is => 'rw', default => sub { [] }); + +has architecture => ( + is => 'rw', + coerce => sub { + my ($value) = @_; + return clean_field($value); + }, + default => $EMPTY +); +has name => ( + is => 'rw', + coerce => sub { + my ($value) = @_; + return clean_field($value); + }, + default => $EMPTY +); +has source_name => ( + is => 'rw', + coerce => sub { + my ($value) = @_; + return clean_field($value); + }, + default => $EMPTY +); +has source_version =>( + is => 'rw', + coerce => sub { + my ($value) = @_; + return clean_field($value); + }, + default => $EMPTY +); +has version => ( + is => 'rw', + coerce => sub { + my ($value) = @_; + return clean_field($value); + }, + default => $EMPTY +); + +has tainted => (is => 'rw', default => 0); + +has fields => (is => 'rw', default => sub { Lintian::Deb822::Section->new; }); + +has pooldir => (is => 'rw', default => $EMPTY); +has basedir => ( + is => 'rw', + lazy => 1, + trigger => sub { + my ($self, $folder) = @_; + + return + unless length $folder; + + # create directory + path($folder)->mkpath + unless -e $folder; + }, + default => sub { + my ($self) = @_; + + my $path + = $self->source_name + . $SLASH + . $self->name + . $UNDERSCORE + . $self->version; + $path .= $UNDERSCORE . $self->architecture + unless $self->type eq 'source'; + $path .= $UNDERSCORE . $self->type; + + # architectures can contain spaces in changes files + $path =~ s/\s/-/g; + + # colon can be a path separator + $path =~ s/:/_/g; + + my $basedir = $self->pooldir . "/$path"; + + return $basedir; + } +); + +=item C<identifier> + +Produces an identifier for this processable. The identifier is +based on the type, name, version and architecture of the package. + +=cut + +sub identifier { + my ($self) = @_; + + my $id = $self->type . $COLON . $self->name . $UNDERSCORE . $self->version; + + # add architecture unless it is source + $id .= $UNDERSCORE . $self->architecture + unless $self->type eq 'source'; + + $id =~ s/\s+/_/g; + + return $id; +} + +=item clean_field + +Cleans a field of evil characters to prevent traversal or worse. + +=cut + +sub clean_field { + my ($value) = @_; + + # make sure none of the fields can cause traversal + my $clean = $value; + $clean =~ s/${$EVIL_CHARACTERS}/_/g; + + return $clean; +} + +=item guess_name + +=cut + +sub guess_name { + my ($self, $path) = @_; + + my $guess = path($path)->basename; + + # drop extension, to catch fields-general-missing.deb + $guess =~ s/\.[^.]*$//; + + # drop everything after the first underscore, if any + $guess =~ s/_.*$//; + + # 'path/lintian_2.5.2_amd64.changes' became 'lintian' + return $guess; +} + +=back + +=head1 AUTHOR + +Originally written by Niels Thykier <niels@thykier.net> for Lintian. +Substantial portions written by Russ Allbery <rra@debian.org> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +L<Lintian::Processable::Installable> + +L<Lintian::Processable::Buildinfo> + +L<Lintian::Processable::Changes> + +L<Lintian::Processable::Source> + +L<Lintian::Group> + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Processable/Buildinfo.pm b/lib/Lintian/Processable/Buildinfo.pm new file mode 100644 index 0000000..f5983fa --- /dev/null +++ b/lib/Lintian/Processable/Buildinfo.pm @@ -0,0 +1,133 @@ +# 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::Processable::Buildinfo; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(croak); +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::Deb822; + +use Moo; +use namespace::clean; + +with + 'Lintian::Processable', + 'Lintian::Processable::Fields::Files', + 'Lintian::Processable::Buildinfo::Overrides'; + +=for Pod::Coverage BUILDARGS + +=head1 NAME + +Lintian::Processable::Buildinfo -- A buildinfo file Lintian can process + +=head1 SYNOPSIS + + use Lintian::Processable::Buildinfo; + + my $processable = Lintian::Processable::Buildinfo->new; + $processable->init_from_file('path'); + +=head1 DESCRIPTION + +This class represents a 'buildinfo' file that Lintian can process. Objects +of this kind are often part of a L<Lintian::Group>, which +represents all the files in a changes or buildinfo file. + +=head1 INSTANCE METHODS + +=over 4 + +=item init_from_file (PATH) + +Initializes a new object from PATH. + +=cut + +sub init_from_file { + my ($self, $file) = @_; + + croak encode_utf8("File $file does not exist") + unless -e $file; + + $self->path($file); + $self->type('buildinfo'); + + my $primary = Lintian::Deb822->new; + my @sections = $primary->read_file($self->path) + or croak encode_utf8( + $self->path. ' is not a valid '. $self->type . ' file'); + + $self->fields($sections[0]); + + my $name = $self->fields->value('Source'); + my $version = $self->fields->value('Version'); + my $architecture = $self->fields->value('Architecture'); + + unless (length $name) { + $name = $self->guess_name($self->path); + croak encode_utf8('Cannot determine the name from '. $self->path) + unless length $name; + } + + my $source_name = $name; + my $source_version = $version; + + $self->name($name); + $self->version($version); + $self->architecture($architecture); + $self->source_name($source_name); + $self->source_version($source_version); + + # make sure none of these fields can cause traversal + $self->tainted(1) + if $self->name ne $name + || $self->version ne $version + || $self->architecture ne $architecture + || $self->source_name ne $source_name + || $self->source_version ne $source_version; + + return; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +L<Lintian::Processable> + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Processable/Buildinfo/Overrides.pm b/lib/Lintian/Processable/Buildinfo/Overrides.pm new file mode 100644 index 0000000..136c01c --- /dev/null +++ b/lib/Lintian/Processable/Buildinfo/Overrides.pm @@ -0,0 +1,94 @@ +# -*- perl -*- Lintian::Processable::Buildinfo::Overrides +# +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Processable::Buildinfo::Overrides; + +use v5.20; +use warnings; +use utf8; + +use Moo::Role; +use namespace::clean; + +with 'Lintian::Processable::Overrides'; + +=head1 NAME + +Lintian::Processable::Buildinfo::Overrides - access to override data + +=head1 SYNOPSIS + + use Lintian::Processable; + +=head1 DESCRIPTION + +Lintian::Processable::Buildinfo::Overrides provides an interface for overrides. + +=head1 INSTANCE METHODS + +=over 4 + +=item override_file + +=cut + +has override_file => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return undef; + } +); + +=item overrides + +=cut + +has overrides => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my @overrides; + + return \@overrides; + } +); + +1; + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for +Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Processable/Changelog/Version.pm b/lib/Lintian/Processable/Changelog/Version.pm new file mode 100644 index 0000000..7721b17 --- /dev/null +++ b/lib/Lintian/Processable/Changelog/Version.pm @@ -0,0 +1,108 @@ +# -*- perl -*- +# Lintian::Processable::Changelog::Version -- interface to source package data collection + +# Copyright (C) 2008 Russ Allbery +# Copyright (C) 2009 Raphael Geissert +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Processable::Changelog::Version; + +use v5.20; +use warnings; +use utf8; + +use Syntax::Keyword::Try; + +use Lintian::Changelog::Version; + +use Moo::Role; +use namespace::clean; + +=head1 NAME + +Lintian::Processable::Changelog::Version - Lintian interface to source package data collection + +=head1 SYNOPSIS + + my ($name, $type, $dir) = ('foobar', 'source', '/path/to/lab-entry'); + my $collect = Lintian::Processable::Changelog::Version->new($name); + if ($collect->native) { + print "Package is native\n"; + } + +=head1 DESCRIPTION + +Lintian::Processable::Changelog::Version provides an interface to package data for source +packages. It implements data collection methods specific to source +packages. + +This module is in its infancy. Most of Lintian still reads all data from +files in the laboratory whenever that data is needed and generates that +data via collect scripts. The goal is to eventually access all data about +source packages via this module so that the module can cache data where +appropriate and possibly retire collect scripts in favor of caching that +data in memory. + +=head1 INSTANCE METHODS + +=over 4 + +=item changelog_version + +Returns a fully parsed Lintian::Changelog::Version for the +source package's version string. + +=cut + +has changelog_version => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $versionstring = $self->fields->value('Version'); + + my $version = Lintian::Changelog::Version->new; + try { + $version->assign($versionstring, $self->native); + + } catch { + } + + return $version; + } +); + +=back + +=head1 AUTHOR + +Originally written by Russ Allbery <rra@debian.org> for Lintian. +Amended by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Processable/Changes.pm b/lib/Lintian/Processable/Changes.pm new file mode 100644 index 0000000..65eb8e4 --- /dev/null +++ b/lib/Lintian/Processable/Changes.pm @@ -0,0 +1,145 @@ +# 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::Processable::Changes; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(croak); +use Path::Tiny; +use Unicode::UTF8 qw(valid_utf8 decode_utf8 encode_utf8); + +use Lintian::Deb822; + +use Moo; +use namespace::clean; + +with + 'Lintian::Processable', + 'Lintian::Processable::Fields::Files', + 'Lintian::Processable::Changes::Overrides'; + +=for Pod::Coverage BUILDARGS + +=head1 NAME + +Lintian::Processable::Changes -- A changes file Lintian can process + +=head1 SYNOPSIS + + use Lintian::Processable::Changes; + + my $processable = Lintian::Processable::Changes->new; + $processable->init_from_file('path'); + +=head1 DESCRIPTION + +This class represents a 'changes' file that Lintian can process. Objects +of this kind are often part of a L<Lintian::Group>, which +represents all the files in a changes or buildinfo file. + +=head1 INSTANCE METHODS + +=over 4 + +=item init_from_file (PATH) + +Initializes a new object from PATH. + +=cut + +sub init_from_file { + my ($self, $file) = @_; + + croak encode_utf8("File $file does not exist") + unless -e $file; + + $self->path($file); + $self->type('changes'); + + # dpkg will include news items in national encoding + my $bytes = path($self->path)->slurp; + + my $contents; + if (valid_utf8($bytes)) { + $contents = decode_utf8($bytes); + } else { + # try to proceed with nat'l encoding; stopping here breaks tests + $contents = $bytes; + } + + my $primary = Lintian::Deb822->new; + my @sections = $primary->parse_string($contents) + or croak encode_utf8( + $self->path. ' is not a valid '. $self->type . ' file'); + + $self->fields($sections[0]); + + my $name = $self->fields->value('Source'); + my $version = $self->fields->value('Version'); + my $architecture = $self->fields->value('Architecture'); + + unless (length $name) { + $name = $self->guess_name($self->path); + croak encode_utf8('Cannot determine the name from ' . $self->path) + unless length $name; + } + + my $source_name = $name; + my $source_version = $version; + + $self->name($name); + $self->version($version); + $self->architecture($architecture); + $self->source_name($source_name); + $self->source_version($source_version); + + # make sure none of these fields can cause traversal + $self->tainted(1) + if $self->name ne $name + || $self->version ne $version + || $self->architecture ne $architecture + || $self->source_name ne $source_name + || $self->source_version ne $source_version; + + return; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +L<Lintian::Processable> + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Processable/Changes/Overrides.pm b/lib/Lintian/Processable/Changes/Overrides.pm new file mode 100644 index 0000000..78bd04d --- /dev/null +++ b/lib/Lintian/Processable/Changes/Overrides.pm @@ -0,0 +1,94 @@ +# -*- perl -*- Lintian::Processable::Changes::Overrides +# +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Processable::Changes::Overrides; + +use v5.20; +use warnings; +use utf8; + +use Moo::Role; +use namespace::clean; + +with 'Lintian::Processable::Overrides'; + +=head1 NAME + +Lintian::Processable::Changes::Overrides - access to override data + +=head1 SYNOPSIS + + use Lintian::Processable; + +=head1 DESCRIPTION + +Lintian::Processable::Changes::Overrides provides an interface for overrides. + +=head1 INSTANCE METHODS + +=over 4 + +=item override_file + +=cut + +has override_file => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return undef; + } +); + +=item overrides + +=cut + +has overrides => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my @overrides; + + return \@overrides; + } +); + +1; + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for +Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Processable/Debian/Control.pm b/lib/Lintian/Processable/Debian/Control.pm new file mode 100644 index 0000000..a4c1cf9 --- /dev/null +++ b/lib/Lintian/Processable/Debian/Control.pm @@ -0,0 +1,90 @@ +# -*- perl -*- +# Lintian::Processable::Debian::Control -- interface to source package data collection + +# Copyright (C) 2008 Russ Allbery +# Copyright (C) 2009 Raphael Geissert +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Processable::Debian::Control; + +use v5.20; +use warnings; +use utf8; + +use Lintian::Debian::Control; + +use Moo::Role; +use namespace::clean; + +=head1 NAME + +Lintian::Processable::Debian::Control - Lintian interface to d/control fields + +=head1 SYNOPSIS + + use Lintian::Processable; + +=head1 DESCRIPTION + +Lintian::Processable::Debian::Control provides an interface to package data +from d/control. + +=head1 INSTANCE METHODS + +=over 4 + +=item debian_control + +=cut + +has debian_control => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $control = Lintian::Debian::Control->new; + + my $item = $self->patched->resolve_path('debian/control'); + return $control + unless defined $item; + + $control->load($item); + + return $control; + } +); + +=back + +=head1 AUTHOR + +Originally written by Russ Allbery <rra@debian.org> for Lintian. +Amended by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Processable/Diffstat.pm b/lib/Lintian/Processable/Diffstat.pm new file mode 100644 index 0000000..82a3b28 --- /dev/null +++ b/lib/Lintian/Processable/Diffstat.pm @@ -0,0 +1,162 @@ +# -*- perl -*- Lintian::Processable::Diffstat -- access to collected diffstat data +# +# Copyright (C) 1998 Richard Braakman +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Processable::Diffstat; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use IPC::Run3; +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8 decode_utf8); + +use Moo::Role; +use namespace::clean; + +const my $COLON => q{:}; +const my $UNDERSCORE => q{_}; +const my $NEWLINE => qq{\n}; + +const my $OPEN_PIPE => q{-|}; +const my $WAIT_STATUS_SHIFT => 8; + +=head1 NAME + +Lintian::Processable::Diffstat - access to collected diffstat data + +=head1 SYNOPSIS + + use Lintian::Processable; + +=head1 DESCRIPTION + +Lintian::Processable::Diffstat provides an interface to diffstat data. + +=head1 INSTANCE METHODS + +=over 4 + +=item diffstat + +Returns the path to diffstat output run on the Debian packaging diff +(a.k.a. the "diff.gz") for 1.0 non-native packages. For source +packages without a "diff.gz" component, this returns the path to an +empty file (this may be a device like /dev/null). + +=cut + +has diffstat => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $noepoch = $self->fields->value('Version'); + + # strip epoch + $noepoch =~ s/^\d://; + + # look for a format 1.0 diff.gz near the input file + my $diffname = $self->name . $UNDERSCORE . $noepoch . '.diff.gz'; + return {} + unless exists $self->files->{$diffname}; + + my $diffpath = path($self->path)->parent->child($diffname)->stringify; + return {} + unless -e $diffpath; + + my @gunzip_command = ('gunzip', '--stdout', $diffpath); + my $gunzip_pid = open(my $from_gunzip, $OPEN_PIPE, @gunzip_command) + or die encode_utf8("Cannot run @gunzip_command: $!"); + + my $stdout; + my $stderr; + my @diffstat_command = qw(diffstat -p1); + run3(\@diffstat_command, $from_gunzip, \$stdout, \$stderr); + my $status = ($? >> $WAIT_STATUS_SHIFT); + + $stdout = decode_utf8($stdout) + if length $stdout; + $stderr = decode_utf8($stderr) + if length $stderr; + + if ($status) { + + my $message= "Non-zero status $status from @diffstat_command"; + $message .= $COLON . $NEWLINE . $stderr + if length $stderr; + + die encode_utf8($message); + } + + close $from_gunzip + or + warn encode_utf8("close failed for handle from @gunzip_command: $!"); + + waitpid($gunzip_pid, 0); + + # remove summary in last line + chomp $stdout; + $stdout =~ s/.*\Z//; + + my %diffstat; + + my @lines = split(/\n/, $stdout); + for my $line (@lines) { + + next + unless $line =~ s/\|\s*([^|]*)\s*$//; + + my $stats = $1; + my $file = $line; + + # trim both ends + $file =~ s/^\s+|\s+$//g; + + die encode_utf8("syntax error in diffstat file: $line") + unless length $file; + + $diffstat{$file} = $stats; + } + + return \%diffstat; + } +); + +1; + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for +Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Processable/Fields/Files.pm b/lib/Lintian/Processable/Fields/Files.pm new file mode 100644 index 0000000..df21352 --- /dev/null +++ b/lib/Lintian/Processable/Fields/Files.pm @@ -0,0 +1,181 @@ +# -*- perl -*- +# Lintian::Processable::Fields::Files -- interface to .buildinfo file data collection +# +# Copyright (C) 2010 Adam D. Barratt +# Copyright (C) 2018 Chris Lamb +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Processable::Fields::Files; + +use v5.20; +use warnings; +use utf8; + +use Moo::Role; +use namespace::clean; + +=head1 NAME + +Lintian::Processable::Fields::Files - Lintian interface to .buildinfo or changes file data collection + +=head1 SYNOPSIS + + use Moo; + + with 'Lintian::Processable::Fields::Files'; + +=head1 DESCRIPTION + +Lintian::Processable::Fields::Files provides an interface to data for .buildinfo +and changes files. It implements data collection methods specific to .buildinfo +and changes files. + +=head1 INSTANCE METHODS + +=over 4 + +=item files + +Returns a reference to a hash containing information about files listed +in the .buildinfo file. Each hash may have the following keys: + +=over 4 + +=item name + +Name of the file. + +=item size + +The size of the file in bytes. + +=item section + +The archive section to which the file belongs. + +=item priority + +The priority of the file. + +=item checksums + +A hash with the keys being checksum algorithms and the values themselves being +hashes containing + +=over 4 + +=item sum + +The result of applying the given algorithm to the file. + +=item filesize + +The size of the file as given in the .buildinfo section relating to the given +checksum. + +=back + +=back + +=cut + +has files => ( + is => 'rw', + lazy => 1, + default => + + sub { + my ($self) = @_; + + my %files; + + my @files_lines = split(/\n/, $self->fields->value('Files')); + + # trim both ends of each line + s/^\s+|\s+$//g for @files_lines; + + for my $line (grep { length } @files_lines) { + + my @fields = split(/\s+/, $line); + my $basename = $fields[-1]; + + # ignore traversals + next + if $basename =~ m{/}; + + my ($md5sum, $size, $section, $priority) = @fields; + + $files{$basename}{checksums}{Md5} = { + 'sum' => $md5sum, + 'filesize' => $size, + }; + + $files{$basename}{name} = $basename; + $files{$basename}{size} = $size; + + unless ($self->type eq 'source') { + + $files{$basename}{section} = $section; + $files{$basename}{priority} = $priority; + } + } + + for my $algorithm (qw(Sha1 Sha256)) { + + my @lines + = split(/\n/, $self->fields->value("Checksums-$algorithm")); + + # trim both ends of each line + s/^\s+|\s+$//g for @lines; + + for my $line (grep { length } @lines) { + + my ($checksum, $size, $basename) = split(/\s+/, $line); + + # ignore traversals + next + if $basename =~ m{/}; + + $files{$basename}{checksums}{$algorithm} = { + 'sum' => $checksum, + 'filesize' => $size + }; + } + } + + return \%files; + } +); + +=back + +=head1 AUTHOR + +Originally written by Adam D. Barratt <adsb@debian.org> for Lintian. + +=head1 SEE ALSO + +lintian(1), L<Lintian::Processable> + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Processable/Hardening.pm b/lib/Lintian/Processable/Hardening.pm new file mode 100644 index 0000000..4bf24bd --- /dev/null +++ b/lib/Lintian/Processable/Hardening.pm @@ -0,0 +1,105 @@ +# -*- perl -*- Lintian::Processable::Hardening +# +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Processable::Hardening; + +use v5.20; +use warnings; +use utf8; + +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8); + +use Moo::Role; +use namespace::clean; + +=head1 NAME + +Lintian::Processable::Hardening - access to collected hardening data + +=head1 SYNOPSIS + + use Lintian::Processable; + +=head1 DESCRIPTION + +Lintian::Processable::Hardening provides an interface to collected hardening data. + +=head1 INSTANCE METHODS + +=over 4 + +=item hardening_info + +Returns a hashref mapping a FILE to its hardening issues. + +NB: This is generally only useful for checks/binaries to emit the +hardening-no-* tags. + +=cut + +sub hardening_info { + my ($self) = @_; + + return $self->{hardening_info} + if exists $self->{hardening_info}; + + my $hardf = path($self->basedir)->child('hardening-info')->stringify; + + my %hardening_info; + + if (-e $hardf) { + open(my $idx, '<:utf8_strict', $hardf) + or die encode_utf8("Cannot open $hardf"); + + while (my $line = <$idx>) { + chomp($line); + + if ($line =~ m{^([^:]+):(?:\./)?(.*)$}) { + my ($tag, $file) = ($1, $2); + + push(@{$hardening_info{$file}}, $tag); + } + } + close($idx); + } + + $self->{hardening_info} = \%hardening_info; + + return $self->{hardening_info}; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for +Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Processable/Installable.pm b/lib/Lintian/Processable/Installable.pm new file mode 100644 index 0000000..54ae406 --- /dev/null +++ b/lib/Lintian/Processable/Installable.pm @@ -0,0 +1,201 @@ +# 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::Processable::Installable; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(croak); +use Const::Fast; +use IPC::Run3; +use Unicode::UTF8 qw(encode_utf8 decode_utf8 valid_utf8); + +use Lintian::Deb822; + +use Moo; +use namespace::clean; + +with + 'Lintian::Processable', + 'Lintian::Processable::Installable::Changelog', + 'Lintian::Processable::Installable::Class', + 'Lintian::Processable::Installable::Conffiles', + 'Lintian::Processable::Installable::Control', + 'Lintian::Processable::Installable::Installed', + 'Lintian::Processable::Installable::Overrides', + 'Lintian::Processable::Installable::Relation', + 'Lintian::Processable::IsNonFree', + 'Lintian::Processable::Hardening', + 'Lintian::Processable::NotJustDocs'; + +# read up to 40kB at a time. this happens to be 4096 "tar records" +# (with a block-size of 512 and a block factor of 20, which appear to +# be the defaults). when we do full reads and writes of READ_SIZE (the +# OS willing), the receiving end will never be with an incomplete +# record. +const my $TAR_RECORD_SIZE => 20 * 512; + +const my $COLON => q{:}; +const my $NEWLINE => qq{\n}; +const my $OPEN_PIPE => q{-|}; + +const my $WAIT_STATUS_SHIFT => 8; + +=for Pod::Coverage BUILDARGS + +=head1 NAME + +Lintian::Processable::Installable -- An installation package Lintian can process + +=head1 SYNOPSIS + + use Lintian::Processable::Installable; + + my $processable = Lintian::Processable::Installable->new; + $processable->init_from_file('path'); + +=head1 DESCRIPTION + +This class represents a 'deb' or 'udeb' file that Lintian can process. Objects +of this kind are often part of a L<Lintian::Group>, which +represents all the files in a changes or buildinfo file. + +=head1 INSTANCE METHODS + +=over 4 + +=item init_from_file (PATH) + +Initializes a new object from PATH. + +=cut + +sub init_from_file { + my ($self, $file) = @_; + + croak encode_utf8("File $file does not exist") + unless -e $file; + + $self->path($file); + + # get control.tar.gz; dpkg-deb -f $file is slow; use tar instead + my @dpkg_command = ('dpkg-deb', '--ctrl-tarfile', $self->path); + + my $dpkg_pid = open(my $from_dpkg, $OPEN_PIPE, @dpkg_command) + or die encode_utf8("Cannot run @dpkg_command: $!"); + + # would like to set buffer size to 4096 & $TAR_RECORD_SIZE + + # get binary control file + my $stdout_bytes; + my $stderr_bytes; + my @tar_command = qw{tar --wildcards -xO -f - *control}; + run3(\@tar_command, $from_dpkg, \$stdout_bytes, \$stderr_bytes); + my $status = ($? >> $WAIT_STATUS_SHIFT); + + if ($status) { + + my $message= "Non-zero status $status from @tar_command"; + $message .= $COLON . $NEWLINE . decode_utf8($stderr_bytes) + if length $stderr_bytes; + + croak encode_utf8($message); + } + + close $from_dpkg + or warn encode_utf8("close failed for handle from @dpkg_command: $!"); + + waitpid($dpkg_pid, 0); + + croak encode_utf8('Nationally encoded control data in ' . $self->path) + unless valid_utf8($stdout_bytes); + + my $stdout = decode_utf8($stdout_bytes); + + my $deb822 = Lintian::Deb822->new; + my @sections = $deb822->parse_string($stdout); + croak encode_utf8( + 'Not exactly one section with installable control data in ' + . $self->path) + unless @sections == 1; + + $self->fields($sections[0]); + + my $name = $self->fields->value('Package'); + my $version = $self->fields->value('Version'); + my $architecture = $self->fields->value('Architecture'); + my $source_name = $self->fields->value('Source'); + + my $source_version = $version; + + unless (length $name) { + $name = $self->guess_name($self->path); + croak encode_utf8('Cannot determine the name from ' . $self->path) + unless length $name; + } + + # source may be left out if same as $name + $source_name = $name + unless length $source_name; + + # source probably contains the version in parentheses + if ($source_name =~ m/(\S++)\s*\(([^\)]+)\)/){ + $source_name = $1; + $source_version = $2; + } + + $self->name($name); + $self->version($version); + $self->architecture($architecture); + $self->source_name($source_name); + $self->source_version($source_version); + + # make sure none of these fields can cause traversal + $self->tainted(1) + if $self->name ne $name + || $self->version ne $version + || $self->architecture ne $architecture + || $self->source_name ne $source_name + || $self->source_version ne $source_version; + + return; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +L<Lintian::Processable> + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Processable/Installable/Changelog.pm b/lib/Lintian/Processable/Installable/Changelog.pm new file mode 100644 index 0000000..c43a17b --- /dev/null +++ b/lib/Lintian/Processable/Installable/Changelog.pm @@ -0,0 +1,151 @@ +# -*- perl -*- Lintian::Processable::Installable::Changelog -- access to collected changelog data +# +# Copyright (C) 1998 Richard Braakman +# Copyright (C) 2019-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, see <http://www.gnu.org/licenses/>. + +package Lintian::Processable::Installable::Changelog; + +use v5.20; +use warnings; +use utf8; + +use File::Copy qw(copy); +use List::SomeUtils qw(first_value); +use Path::Tiny; +use Unicode::UTF8 qw(valid_utf8 decode_utf8 encode_utf8); + +use Lintian::IPC::Run3 qw(safe_qx); + +use Moo::Role; +use namespace::clean; + +=head1 NAME + +Lintian::Processable::Installable::Changelog - access to collected changelog data + +=head1 SYNOPSIS + + use Lintian::Processable; + +=head1 DESCRIPTION + +Lintian::Processable::Installable::Changelog provides an interface to changelog data. + +=head1 INSTANCE METHODS + +=over 4 + +=item changelog_item + +=cut + +has changelog_item => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my @candidate_names = ( + 'changelog.Debian.gz','changelog.Debian', + 'changelog.debian.gz','changelog.debian', + 'changelog.gz','changelog', + ); + + my $package_path = 'usr/share/doc/' . $self->name; + my @candidate_items = grep { defined } + map { $self->installed->lookup("$package_path/$_") }@candidate_names; + + # pick the first existing file + my $item + = first_value { $_->is_file || length $_->link } @candidate_items; + + return $item; + } +); + +=item changelog + +For binary: + +Returns the changelog of the binary package as a Parse::DebianChangelog +object, or an empty object if the changelog doesn't exist. The changelog-file +collection script must have been run to create the changelog file, which +this method expects to find in F<changelog>. + +=cut + +has changelog => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $changelog = Lintian::Changelog->new; + + my $unresolved = $self->changelog_item; + return $changelog + unless defined $unresolved; + + # stop for dangling symbolic link + my $item = $unresolved->resolve_path; + return $changelog + unless defined $item; + + # return empty changelog + return $changelog + unless $item->is_file && $item->is_open_ok; + + if ($item->basename =~ m{ [.]gz $}x) { + + my $bytes = safe_qx('gunzip', '-c', $item->unpacked_path); + + return $changelog + unless valid_utf8($bytes); + + $changelog->parse(decode_utf8($bytes)); + + return $changelog; + } + + return $changelog + unless $item->is_valid_utf8; + + $changelog->parse($item->decoded_utf8); + + return $changelog; + } +); + +1; + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for +Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Processable/Installable/Class.pm b/lib/Lintian/Processable/Installable/Class.pm new file mode 100644 index 0000000..00520be --- /dev/null +++ b/lib/Lintian/Processable/Installable/Class.pm @@ -0,0 +1,139 @@ +# -*- perl -*- +# Lintian::Processable::Installable::Class -- interface to binary package data collection + +# Copyright (C) 2008, 2009 Russ Allbery +# Copyright (C) 2008 Frank Lichtenheld +# Copyright (C) 2012 Kees Cook +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Processable::Installable::Class; + +use v5.20; +use warnings; +use utf8; + +use Moo::Role; +use namespace::clean; + +=head1 NAME + +Lintian::Processable::Installable::Class - Lintian interface to binary package data collection + +=head1 SYNOPSIS + + my ($name, $type, $dir) = ('foobar', 'binary', '/path/to/lab-entry'); + my $collect = Lintian::Processable::Installable::Class->new($name); + +=head1 DESCRIPTION + +Lintian::Processable::Installable::Class provides an interface to package data for binary +packages. + +=head1 INSTANCE METHODS + +=over 4 + +=item is_debug_package + +The package probably contains only debug symbols. + +=cut + +sub is_debug_package { + my ($self) = @_; + + return 1 + if $self->name =~ /-dbg(?:sym)?/; + + return 0; +} + +=item is_auto_generated + +The package was probably generated automatically. + +=cut + +sub is_auto_generated { + my ($self) = @_; + + return 1 + if $self->fields->declares('Auto-Built-Package'); + + return 0; +} + +=item is_transitional + +The package is probably transitional, i.e. it probably depends + on stuff will eventually disappear. + +=cut + +sub is_transitional { + my ($self) = @_; + + return 1 + if $self->fields->value('Description') =~ /transitional package/i; + + return 0; +} + +=item is_meta_package + +This package is probably some kind of meta or task package. A meta +package is usually empty and just depend on stuff. It also returns +a true value for "tasks" (i.e. tasksel "tasks"). + +=cut + +sub is_meta_package { + my ($self) = @_; + + return 1 + if $self->fields->value('Description') + =~ /meta[ -]?package|(?:dependency|dummy|empty) package/i; + + # section "tasks" or "metapackages" qualifies too + return 1 + if $self->fields->value('Section') =~ m{(?:^|/)(?:tasks|metapackages)$}; + + return 1 + if $self->name =~ /^task-/; + + return 0; +} + +=back + +=head1 AUTHOR + +Originally written by Frank Lichtenheld <djpig@debian.org> for Lintian. +Amended by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Processable/Installable/Conffiles.pm b/lib/Lintian/Processable/Installable/Conffiles.pm new file mode 100644 index 0000000..50db7f7 --- /dev/null +++ b/lib/Lintian/Processable/Installable/Conffiles.pm @@ -0,0 +1,97 @@ +# -*- perl -*- Lintian::Processable::Installable::Conffiles +# +# Copyright (C) 2019-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, see <http://www.gnu.org/licenses/>. + +package Lintian::Processable::Installable::Conffiles; + +use v5.20; +use warnings; +use utf8; + +use Lintian::Conffiles; + +use Moo::Role; +use namespace::clean; + +=head1 NAME + +Lintian::Processable::Installable::Conffiles - access to collected control data for conffiles + +=head1 SYNOPSIS + + use Lintian::Processable; + +=head1 DESCRIPTION + +Lintian::Processable::Installable::Conffiles provides an interface to control data for conffiles. + +=head1 INSTANCE METHODS + +=over 4 + +=item conffiles_item + +=cut + +has conffiles_item => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return $self->control->resolve_path('conffiles'); + } +); + +=item declared_conffiles + +=cut + +has declared_conffiles => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $item = $self->conffiles_item; + + my $conffiles = Lintian::Conffiles->new; + $conffiles->parse($item, $self); + + return $conffiles; + } +); + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for +Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Processable/Installable/Control.pm b/lib/Lintian/Processable/Installable/Control.pm new file mode 100644 index 0000000..b6a72d8 --- /dev/null +++ b/lib/Lintian/Processable/Installable/Control.pm @@ -0,0 +1,99 @@ +# -*- perl -*- Lintian::Processable::Installable::Control +# +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Processable::Installable::Control; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(uniq); + +use Lintian::Index; + +const my $SLASH => q{/}; + +use Moo::Role; +use namespace::clean; + +=head1 NAME + +Lintian::Processable::Installable::Control - access to collected control file data + +=head1 SYNOPSIS + + use Lintian::Processable; + +=head1 DESCRIPTION + +Lintian::Processable::Installable::Control provides an interface to control file data. + +=head1 INSTANCE METHODS + +=over 4 + +=item control + +Returns the index for a binary control file. + +=cut + +has control => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $index = Lintian::Index->new; + my $archive = $self->basename; + $index->identifier("$archive (control)"); + $index->basedir($self->basedir . $SLASH . 'control'); + + # control files are not installed relative to the system root + # disallow absolute paths and symbolic links + + my @command = (qw(dpkg-deb --ctrl-tarfile), $self->path); + my $errors = $index->create_from_piped_tar(\@command); + + my @messages = uniq split(/\n/, $errors); + push(@{$index->unpack_messages}, @messages); + + return $index; + } +); + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for +Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Processable/Installable/Installed.pm b/lib/Lintian/Processable/Installable/Installed.pm new file mode 100644 index 0000000..61444ac --- /dev/null +++ b/lib/Lintian/Processable/Installable/Installed.pm @@ -0,0 +1,103 @@ +# -*- perl -*- Lintian::Processable::Installable::Installed +# +# Copyright (C) 2008, 2009 Russ Allbery +# Copyright (C) 2008 Frank Lichtenheld +# Copyright (C) 2012 Kees Cook +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Processable::Installable::Installed; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(uniq); + +use Lintian::Index; + +const my $SLASH => q{/}; + +use Moo::Role; +use namespace::clean; + +=head1 NAME + +Lintian::Processable::Installable::Installed - access to collected data about the upstream (orig) sources + +=head1 SYNOPSIS + + use Lintian::Processable; + +=head1 DESCRIPTION + +Lintian::Processable::Installable::Installed provides an interface to collected data about the upstream (orig) sources. + +=head1 INSTANCE METHODS + +=over 4 + +=item installed + +Returns a index object representing installed files from a binary package. + +=cut + +has installed => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $index = Lintian::Index->new; + my $archive = $self->basename; + $index->identifier("$archive (installed)"); + $index->basedir($self->basedir . $SLASH . 'unpacked'); + + # binary packages are anchored to the system root + # allow absolute paths and symbolic links + $index->anchored(1); + + my @command = (qw(dpkg-deb --fsys-tarfile), $self->path); + my $errors = $index->create_from_piped_tar(\@command); + + my @messages = uniq split(/\n/, $errors); + push(@{$index->unpack_messages}, @messages); + + return $index; + } +); + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for +Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Processable/Installable/Overrides.pm b/lib/Lintian/Processable/Installable/Overrides.pm new file mode 100644 index 0000000..0da551f --- /dev/null +++ b/lib/Lintian/Processable/Installable/Overrides.pm @@ -0,0 +1,131 @@ +# -*- perl -*- Lintian::Processable::Installable::Overrides +# +# Copyright (C) 2019-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, see <http://www.gnu.org/licenses/>. + +package Lintian::Processable::Installable::Overrides; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use PerlIO::gzip; +use List::SomeUtils qw(first_value); +use Unicode::UTF8 qw(valid_utf8 decode_utf8 encode_utf8); + +use Moo::Role; +use namespace::clean; + +with 'Lintian::Processable::Overrides'; + +const my $EMPTY => q{}; + +=head1 NAME + +Lintian::Processable::Installable::Overrides - access to override data + +=head1 SYNOPSIS + + use Lintian::Processable; + +=head1 DESCRIPTION + +Lintian::Processable::Installable::Overrides provides an interface for overrides. + +=head1 INSTANCE METHODS + +=over 4 + +=item override_file + +=cut + +has override_file => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $unzipped = 'usr/share/lintian/overrides/' . $self->name; + + my @candidates = map { $unzipped . $_ } ($EMPTY, '.gz'); + + # pick the first + my $override_item= first_value { defined } + map { $self->installed->lookup($_) } @candidates; + + return $override_item; + } +); + +=item overrides + +=cut + +has overrides => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return [] + unless defined $self->override_file; + + my $contents = $EMPTY; + + if ($self->override_file->name =~ m{ [.]gz $}x) { + + my $local_path = $self->override_file->unpacked_path; + + open(my $fd, '<:gzip', $local_path) + or die encode_utf8("Cannot open $local_path."); + + local $/ = undef; + my $bytes = <$fd>; + + $contents = decode_utf8($bytes) + if valid_utf8($bytes); + + close $fd; + + } else { + $contents = $self->override_file->decoded_utf8; + } + + return $self->parse_overrides($contents); + } +); + +1; + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for +Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Processable/Installable/Relation.pm b/lib/Lintian/Processable/Installable/Relation.pm new file mode 100644 index 0000000..ac94489 --- /dev/null +++ b/lib/Lintian/Processable/Installable/Relation.pm @@ -0,0 +1,154 @@ +# -*- perl -*- +# Lintian::Processable::Installable::Relation -- interface to binary package data collection + +# Copyright (C) 2008, 2009 Russ Allbery +# Copyright (C) 2008 Frank Lichtenheld +# Copyright (C) 2012 Kees Cook +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Processable::Installable::Relation; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(croak); +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::Relation; + +use Moo::Role; +use namespace::clean; + +=head1 NAME + +Lintian::Processable::Installable::Relation - Lintian interface to binary package data collection + +=head1 SYNOPSIS + + my ($name, $type, $dir) = ('foobar', 'binary', '/path/to/lab-entry'); + my $collect = Lintian::Processable::Installable::Relation->new($name); + +=head1 DESCRIPTION + +Lintian::Processable::Installable::Relation provides an interface to package data for binary +packages. It implements data collection methods specific to binary +packages. + +This module is in its infancy. Most of Lintian still reads all data from +files in the laboratory whenever that data is needed and generates that +data via collect scripts. The goal is to eventually access all data about +binary packages via this module so that the module can cache data where +appropriate and possibly retire collect scripts in favor of caching that +data in memory. + +Native heuristics are only available in source packages. + +=head1 INSTANCE METHODS + +=over 4 + +=item relation (FIELD) + +Returns a L<Lintian::Relation> object for the specified FIELD, which should +be one of the possible relationship fields of a Debian package or one of +the following special values: + +=over 4 + +=item All + +The concatenation of Pre-Depends, Depends, Recommends, and Suggests. + +=item Strong + +The concatenation of Pre-Depends and Depends. + +=item Weak + +The concatenation of Recommends and Suggests. + +=back + +If FIELD isn't present in the package, the returned Lintian::Relation +object will be empty (always present and satisfies nothing). + +=item saved_relations + +=cut + +has saved_relations => ( + is => 'rw', + coerce => sub { my ($hashref) = @_; return ($hashref // {}); }, + default => sub { {} } +); + +my %alias = ( + all => [qw(Pre-Depends Depends Recommends Suggests)], + strong => [qw(Pre-Depends Depends)], + weak => [qw(Recommends Suggests)] +); + +my %known = map { $_ => 1 } + qw(pre-depends depends recommends suggests enhances breaks + conflicts provides replaces); + +sub relation { + my ($self, $name) = @_; + + my $lowercase = lc $name; + + my $relation = $self->saved_relations->{$lowercase}; + unless (defined $relation) { + + if (exists $alias{$lowercase}) { + $relation + = Lintian::Relation->new->logical_and(map { $self->relation($_) } + @{ $alias{$lowercase} }); + } else { + croak encode_utf8("unknown relation field $name") + unless $known{$lowercase}; + + my $value = $self->fields->value($name); + $relation = Lintian::Relation->new->load($value); + } + + $self->saved_relations->{$lowercase} = $relation; + } + + return $relation; +} + +=back + +=head1 AUTHOR + +Originally written by Frank Lichtenheld <djpig@debian.org> for Lintian. +Amended by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Processable/IsNonFree.pm b/lib/Lintian/Processable/IsNonFree.pm new file mode 100644 index 0000000..bd6f246 --- /dev/null +++ b/lib/Lintian/Processable/IsNonFree.pm @@ -0,0 +1,109 @@ +# -*- perl -*- +# Lintian::Processable::IsNonFree -- interface to source package data collection + +# Copyright (C) 2008 Russ Allbery +# Copyright (C) 2009 Raphael Geissert +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Processable::IsNonFree; + +use v5.20; +use warnings; +use utf8; + +use Moo::Role; +use namespace::clean; + +=head1 NAME + +Lintian::Processable::IsNonFree - Lintian interface to source package data collection + +=head1 SYNOPSIS + + my ($name, $type, $dir) = ('foobar', 'source', '/path/to/lab-entry'); + my $collect = Lintian::Processable::IsNonFree->new($name); + if ($collect->native) { + print encode_utf8("Package is native\n"); + } + +=head1 DESCRIPTION + +Lintian::Processable::IsNonFree provides an interface to package data for source +packages. It implements data collection methods specific to source +packages. + +This module is in its infancy. Most of Lintian still reads all data from +files in the laboratory whenever that data is needed and generates that +data via collect scripts. The goal is to eventually access all data about +source packages via this module so that the module can cache data where +appropriate and possibly retire collect scripts in favor of caching that +data in memory. + +=head1 INSTANCE METHODS + +=over 4 + +=item is_non_free + +Returns a truth value if the package appears to be non-free (based on +the section field; "non-free/*" and "restricted/*") + +=cut + +has is_non_free => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $section; + + if ($self->type eq 'source') { + $section = $self->debian_control->source_fields->value('Section'); + } else { + $section = $self->fields->value('Section'); + } + + $section ||= 'main'; + + return 1 + if $section + =~ m{^(?:non-free|non-free-firmware|restricted|multiverse)/}; + + return 0; + } +); + +=back + +=head1 AUTHOR + +Originally written by Russ Allbery <rra@debian.org> for Lintian. +Amended by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Processable/NotJustDocs.pm b/lib/Lintian/Processable/NotJustDocs.pm new file mode 100644 index 0000000..1e08760 --- /dev/null +++ b/lib/Lintian/Processable/NotJustDocs.pm @@ -0,0 +1,112 @@ +# -*- perl -*- +# Lintian::Processable::NotJustDocs + +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Processable::NotJustDocs; + +use v5.20; +use warnings; +use utf8; + +use Moo::Role; +use namespace::clean; + +=head1 NAME + +Lintian::Processable::NotJustDocs - Lintian interface to installable package data collection + +=head1 SYNOPSIS + + my $processable = Lintian::Processable::Installable->new; + + my $is_empty = $processable->not_just_docs; + +=head1 DESCRIPTION + +Lintian::Processable::NotJustDocs provides an interface to package data for installation +packages. + +=head1 INSTANCE METHODS + +=over 4 + +=item not_just_docs + +Returns a truth value if the package appears to be empty. + +=cut + +has not_just_docs => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $quoted_name = quotemeta($self->name); + + my $empty = 1; + for my $item (@{$self->installed->sorted_list}) { + + # ignore directories + next + if $item->is_dir; + + # skip /usr/share/doc/$name symlinks. + next + if $item->name eq 'usr/share/doc/' . $self->name; + + # only look outside /usr/share/doc/$name directory + next + if $item->name =~ m{^usr/share/doc/$quoted_name}; + + # except if it is a lintian override. + next + if $item->name =~ m{\A + # Except for: + usr/share/ (?: + # lintian overrides + lintian/overrides/$quoted_name(?:\.gz)? + # reportbug scripts/utilities + | bug/$quoted_name(?:/(?:control|presubj|script))? + )\Z}xsm; + + return 0; + } + + return 1; + } +); + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Processable/Overrides.pm b/lib/Lintian/Processable/Overrides.pm new file mode 100644 index 0000000..0de05a4 --- /dev/null +++ b/lib/Lintian/Processable/Overrides.pm @@ -0,0 +1,219 @@ +# -*- perl -*- Lintian::Processable::Overrides +# +# Copyright (C) 2019-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, see <http://www.gnu.org/licenses/>. + +package Lintian::Processable::Overrides; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +use Lintian::Override; + +const my $EMPTY => q{}; +const my $SPACE => q{ }; + +use Moo::Role; +use namespace::clean; + +=head1 NAME + +Lintian::Processable::Overrides - access to override data + +=head1 SYNOPSIS + + use Lintian::Processable; + +=head1 DESCRIPTION + +Lintian::Processable::Overrides provides an interface to overrides. + +=head1 INSTANCE METHODS + +=over 4 + +=item override_errors + +=cut + +has override_errors => (is => 'rw', default => sub { [] }); + +=item parse_overrides + +=cut + +sub parse_overrides { + my ($self, $contents) = @_; + + $contents //= $EMPTY; + + my @declared_overrides; + + my $justification = $EMPTY; + my $previous = Lintian::Override->new; + + my @lines = split(/\n/, $contents); + + my $position = 1; + for my $line (@lines) { + + my $remaining = $line; + + # trim both ends + $remaining =~ s/^\s+|\s+$//g; + + if ($remaining eq $EMPTY) { + # Throw away comments, as they are not attached to a tag + # also throw away the option of "carrying over" the last + # comment + $justification = $EMPTY; + $previous = Lintian::Override->new; + next; + } + + if ($remaining =~ s{^ [#] \s* }{}x) { + + if (length $remaining) { + + $justification .= $SPACE + if length $justification; + + $justification .= $remaining; + } + + next; + } + + # reduce white space + $remaining =~ s/\s+/ /g; + + # [[pkg-name] [arch-list] [pkg-type]:] <tag> [context] + my $require_colon = 0; + my @architectures; + + # strip package name, if present; require name + # parsing overrides is ambiguous (see #699628) + my $package = $self->name; + if ($remaining =~ s/^\Q$package\E(?=\s|:)//) { + + # both spaces or colon were unmatched lookhead + $remaining =~ s/^\s+//; + $require_colon = 1; + } + + # remove architecture list + if ($remaining =~ s{^ \[ ([^\]]*) \] (?=\s|:)}{}x) { + + my $list = $1; + + @architectures = split($SPACE, $list); + + # both spaces or colon were unmatched lookhead + $remaining =~ s/^\s+//; + $require_colon = 1; + } + + # remove package type + my $type = $self->type; + if ($remaining =~ s/^\Q$type\E(?=\s|:)//) { + + # both spaces or colon were unmatched lookhead + $remaining =~ s/^\s+//; + $require_colon = 1; + } + + my $pointer = $self->override_file->pointer($position); + + # require and remove colon when any package details are present + if ($require_colon && $remaining !~ s/^\s*:\s*//) { + + my %error; + $error{message} = 'Expected a colon'; + $error{pointer} = $pointer; + push(@{$self->override_errors}, \%error); + + next; + } + + my $hint_like = $remaining; + + my ($tag_name, $pattern) = split($SPACE, $hint_like, 2); + + if (!length $tag_name) { + + my %error; + $error{message} = "Cannot parse line: $line"; + $error{pointer} = $pointer; + push(@{$self->override_errors}, \%error); + + next; + } + + $pattern //= $EMPTY; + + # There are no new comments, no "empty line" in between and + # this tag is the same as the last, so we "carry over" the + # comment from the previous override (if any). + $justification = $previous->justification + if !length $justification + && $tag_name eq $previous->tag_name; + + my $current = Lintian::Override->new; + + $current->tag_name($tag_name); + $current->architectures(\@architectures); + $current->pattern($pattern); + $current->position($position); + + # combine successive white space + $justification =~ s{ \s+ }{ }gx; + + $current->justification($justification); + $justification = $EMPTY; + + push(@declared_overrides, $current); + + $previous = $current; + + } continue { + $position++; + } + + return \@declared_overrides; +} + +1; + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for +Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Processable/Source.pm b/lib/Lintian/Processable/Source.pm new file mode 100644 index 0000000..e4dc001 --- /dev/null +++ b/lib/Lintian/Processable/Source.pm @@ -0,0 +1,142 @@ +# 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::Processable::Source; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(croak); +use File::Spec; +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::Deb822; + +use Moo; +use namespace::clean; + +with + 'Lintian::Processable', + 'Lintian::Processable::Diffstat', + 'Lintian::Processable::Changelog::Version', + 'Lintian::Processable::Debian::Control', + 'Lintian::Processable::Fields::Files', + 'Lintian::Processable::IsNonFree', + 'Lintian::Processable::Source::Changelog', + 'Lintian::Processable::Source::Components', + 'Lintian::Processable::Source::Format', + 'Lintian::Processable::Source::Orig', + 'Lintian::Processable::Source::Overrides', + 'Lintian::Processable::Source::Patched', + 'Lintian::Processable::Source::Relation', + 'Lintian::Processable::Source::Repacked'; + +=for Pod::Coverage BUILDARGS + +=head1 NAME + +Lintian::Processable::Source -- A dsc source package Lintian can process + +=head1 SYNOPSIS + + use Lintian::Processable::Source; + + my $processable = Lintian::Processable::Source->new; + $processable->init_from_file('path'); + +=head1 DESCRIPTION + +This class represents a 'dsc' file that Lintian can process. Objects +of this kind are often part of a L<Lintian::Group>, which +represents all the files in a changes or buildinfo file. + +=head1 INSTANCE METHODS + +=over 4 + +=item init_from_file (PATH) + +Initializes a new object from PATH. + +=cut + +sub init_from_file { + my ($self, $file) = @_; + + croak encode_utf8("File $file does not exist") + unless -e $file; + + $self->path($file); + $self->type('source'); + + my $primary = Lintian::Deb822->new; + my @sections = $primary->read_file($self->path) + or croak encode_utf8($self->path . ' is not valid dsc file'); + + $self->fields($sections[0]); + + my $name = $self->fields->value('Source'); + my $version = $self->fields->value('Version'); + my $architecture = 'source'; + + # it is its own source package + my $source_name = $name; + my $source_version = $version; + + croak encode_utf8($self->path . ' is missing Source field') + unless length $name; + + $self->name($name); + $self->version($version); + $self->architecture($architecture); + $self->source_name($source_name); + $self->source_version($source_version); + + # make sure none of these fields can cause traversal + $self->tainted(1) + if $self->name ne $name + || $self->version ne $version + || $self->architecture ne $architecture + || $self->source_name ne $source_name + || $self->source_version ne $source_version; + + return; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +L<Lintian::Processable> + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Processable/Source/Changelog.pm b/lib/Lintian/Processable/Source/Changelog.pm new file mode 100644 index 0000000..a781057 --- /dev/null +++ b/lib/Lintian/Processable/Source/Changelog.pm @@ -0,0 +1,109 @@ +# -*- perl -*- Lintian::Processable::Source::Changelog -- access to collected changelog data +# +# Copyright (C) 1998 Richard Braakman +# Copyright (C) 2019-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, see <http://www.gnu.org/licenses/>. + +package Lintian::Processable::Source::Changelog; + +use v5.20; +use warnings; +use utf8; + +use Moo::Role; +use namespace::clean; + +=head1 NAME + +Lintian::Processable::Source::Changelog - access to collected changelog data + +=head1 SYNOPSIS + + use Lintian::Processable; + +=head1 DESCRIPTION + +Lintian::Processable::Source::Changelog provides an interface to changelog data. + +=head1 INSTANCE METHODS + +=over 4 + +=item changelog_item + +=cut + +has changelog_item => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $item = $self->patched->resolve_path('debian/changelog'); + + return $item; + } +); + +=item changelog + +Returns the changelog of the source package as a Parse::DebianChangelog +object, or an empty object if the changelog cannot be resolved safely. + +=cut + +has changelog => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $changelog = Lintian::Changelog->new; + + my $item = $self->changelog_item; + + # return empty changelog + return $changelog + unless defined $item && $item->is_open_ok; + + return $changelog + unless $item->is_valid_utf8; + + $changelog->parse($item->decoded_utf8); + + return $changelog; + } +); + +1; + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for +Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Processable/Source/Components.pm b/lib/Lintian/Processable/Source/Components.pm new file mode 100644 index 0000000..1541abe --- /dev/null +++ b/lib/Lintian/Processable/Source/Components.pm @@ -0,0 +1,126 @@ +# -*- perl -*- +# Lintian::Processable::Source::Components -- interface to orig tag components +# +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Processable::Source::Components; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Unicode::UTF8 qw(encode_utf8); + +use Moo::Role; +use namespace::clean; + +const my $EMPTY => q{}; + +=head1 NAME + +Lintian::Processable::Source::Components - interface to orig tar components + +=head1 SYNOPSIS + + use Moo; + + with 'Lintian::Processable::Source::Components'; + +=head1 DESCRIPTION + +Lintian::Processable::Source::Components provides an interface to data for +upstream source components. Most sources only use one tarball. + +=head1 INSTANCE METHODS + +=over 4 + +=item components + +Returns a reference to a hash containing information about source components +listed in the .dsc file. The key is the filename, and the value is the name +of the component. + +=cut + +has components => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + # determine source and version; handle missing fields + my $name = $self->fields->value('Source'); + my $version = $self->fields->value('Version'); + my $architecture = 'source'; + + # it is its own source package + my $source = $name; + my $source_version = $version; + + # version handling based on Dpkg::Version::parseversion. + my $noepoch = $source_version; + if ($noepoch =~ /:/) { + $noepoch =~ s/^(?:\d+):(.+)/$1/ + or die encode_utf8("Bad version number '$noepoch'"); + } + + my $baserev = $source . '_' . $noepoch; + + # strip debian revision + $noepoch =~ s/(.+)-(?:.*)$/$1/; + my $base = $source . '_' . $noepoch; + + my $files = $self->files; + + my %components; + for my $name (keys %{$files}) { + + # Look for $pkg_$version.orig(-$comp)?.tar.$ext (non-native) + # or $pkg_$version.tar.$ext (native) + # - This deliberately does not look for the debian packaging + # even when this would be a tarball. + if ($name + =~ /^(?:\Q$base\E\.orig(?:-(.*))?|\Q$baserev\E)\.tar\.(?:gz|bz2|lzma|xz)$/ + ) { + $components{$name} = $1 // $EMPTY; + } + } + + return \%components; + } +); + +=back + +=head1 AUTHOR + +Originally written by Adam D. Barratt <adsb@debian.org> for Lintian. + +=head1 SEE ALSO + +lintian(1), L<Lintian::Processable> + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Processable/Source/Format.pm b/lib/Lintian/Processable/Source/Format.pm new file mode 100644 index 0000000..551f93e --- /dev/null +++ b/lib/Lintian/Processable/Source/Format.pm @@ -0,0 +1,136 @@ +# -*- perl -*- +# Lintian::Processable::Source::Format -- interface to source package data collection + +# Copyright (C) 2008 Russ Allbery +# Copyright (C) 2009 Raphael Geissert +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Processable::Source::Format; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Path::Tiny; + +use Moo::Role; +use namespace::clean; + +const my $UNDERSCORE => q{_}; + +=head1 NAME + +Lintian::Processable::Source::Format - Lintian interface to source format + +=head1 SYNOPSIS + + my $collect = Lintian::Processable::Source::Format->new; + +=head1 DESCRIPTION + +Lintian::Processable::Source::Format provides an interface to source format +information. + +=head1 INSTANCE METHODS + +=over 4 + +=item source_format + +=cut + +has source_format => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $format = $self->fields->value('Format') || '1.0'; + + return $format; + } +); + +=item native + +Returns true if the source package is native and false otherwise. +This is generally determined from the source format, though in the 1.0 +case the nativeness is determined by looking for the diff.gz (using +the name of the source package and its version). + +If the source format is 1.0 and the version number is absent, this +will return false (as native packages are a lot rarer than non-native +ones). + +Note if the source format is missing, it is assumed to be a 1.0 +package. + +=cut + +has native => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $format = $self->source_format; + + return 0 + if $format =~ /^\s*2\.0\s*$/; + + return 0 + if $format =~ /^\s*3\.0\s+\(quilt|git\)\s*$/; + + return 1 + if $format =~ /^\s*3\.0\s+\(native\)\s*$/; + + my $version = $self->fields->value('Version'); + return 0 + unless length $version; + + # strip epoch + $version =~ s/^\d+://; + + my $diffname = $self->name . $UNDERSCORE . "$version.diff.gz"; + + return 0 + if exists $self->files->{$diffname}; + + return 1; + } +); + +=back + +=head1 AUTHOR + +Originally written by Russ Allbery <rra@debian.org> for Lintian. +Amended by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1), Lintian::Relation(3) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Processable/Source/Orig.pm b/lib/Lintian/Processable/Source/Orig.pm new file mode 100644 index 0000000..dd263f5 --- /dev/null +++ b/lib/Lintian/Processable/Source/Orig.pm @@ -0,0 +1,200 @@ +# -*- perl -*- Lintian::Processable::Source::Orig +# +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Processable::Source::Orig; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(uniq); +use List::UtilsBy qw(sort_by); +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::Index; + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $SLASH => q{/}; + +use Moo::Role; +use namespace::clean; + +=head1 NAME + +Lintian::Processable::Source::Orig - access to collected data about the upstream (orig) sources + +=head1 SYNOPSIS + + use Lintian::Processable; + +=head1 DESCRIPTION + +Lintian::Processable::Source::Orig provides an interface to collected data about the upstream (orig) sources. + +=head1 INSTANCE METHODS + +=over 4 + +=item orig + +Returns the index for orig.tar.gz. + +=cut + +my %DECOMPRESS_COMMAND = ( + 'gz' => 'gzip --decompress --stdout', + 'bz2' => 'bzip2 --decompress --stdout', + 'xz' => 'xz --decompress --stdout', +); + +has orig => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $index = Lintian::Index->new; + my $archive = $self->basename; + $index->identifier("$archive (orig)"); + $index->basedir($self->basedir . $SLASH . 'orig'); + + return $index + if $self->native; + + # source packages can be unpacked anywhere; no anchored roots + $index->anchored(0); + + my %components = %{$self->components}; + + # keep sort order; root is missing below otherwise + my @tarballs = sort_by { $components{$_} } keys %components; + + for my $tarball (@tarballs) { + + my $component = $components{$tarball}; + + # so far, all archives with components had an extra level + my $component_dir = $index->basedir; + $component_dir .= $SLASH . $component + if length $component; + + my $subindex = Lintian::Index->new; + $subindex->basedir($component_dir); + + # source packages can be unpacked anywhere; no anchored roots + $index->anchored(0); + + my ($extension) = ($tarball =~ /\.([^.]+)$/); + die encode_utf8("Source component $tarball has no file exension\n") + unless length $extension; + + my $decompress = $DECOMPRESS_COMMAND{lc $extension}; + die encode_utf8("Don't know how to decompress $tarball") + unless $decompress; + + my @command + = (split($SPACE, $decompress), + $self->basedir . $SLASH . $tarball); + + my $errors = $subindex->create_from_piped_tar(\@command); + + push(@{$index->unpack_messages}, "$tarball . $_") + for grep { !/^tar: Ignoring / } uniq split(/\n/, $errors); + + # treat hard links like regular files + my @hardlinks = grep { $_->is_hardlink } @{$subindex->sorted_list}; + for my $item (@hardlinks) { + + my $target = $subindex->lookup($item->link); + + $item->unpacked_path($target->unpacked_path); + $item->size($target->size); + $item->link($EMPTY); + + # turn into a regular file + my $perm = $item->perm; + $perm =~ s/^-/h/; + $item->perm($perm); + + $item->path_info( + ($item->path_info & ~Lintian::Index::Item::TYPE_HARDLINK) + | Lintian::Index::Item::TYPE_FILE); + } + + my @prefixes = @{$subindex->sorted_list}; + + # keep top level prefixes; no trailing slashes + s{^([^/]+).*$}{$1}s for @prefixes; + + # squash identical values; ignore root entry ('') + my @unique = grep { length } uniq @prefixes; + + # check for single common value + if (@unique == 1) { + + # no trailing slash for directories + my $common = $unique[0]; + + # proceed if no file with that name (lacks slash) + my $conflict = $subindex->lookup($common); + unless (defined $conflict) { + + if ($common ne $component || length $component) { + + # shortens paths; keeps same base directory + my $sub_errors = $subindex->drop_common_prefix; + + push(@{$index->unpack_errors}, "$tarball . $_") + for uniq split(/\n/, $sub_errors); + } + } + } + + # lowers base directory to match index being merged into + $subindex->capture_common_prefix + if length $component; + + $index->merge_in($subindex); + } + + return $index; + } +); + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for +Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Processable/Source/Overrides.pm b/lib/Lintian/Processable/Source/Overrides.pm new file mode 100644 index 0000000..d4c446f --- /dev/null +++ b/lib/Lintian/Processable/Source/Overrides.pm @@ -0,0 +1,109 @@ +# -*- perl -*- Lintian::Processable::Source::Overrides +# +# Copyright (C) 2019-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, see <http://www.gnu.org/licenses/>. + +package Lintian::Processable::Source::Overrides; + +use v5.20; +use warnings; +use utf8; + +use List::SomeUtils qw(first_value); + +use Moo::Role; +use namespace::clean; + +with 'Lintian::Processable::Overrides'; + +=head1 NAME + +Lintian::Processable::Source::Overrides - access to override data + +=head1 SYNOPSIS + + use Lintian::Processable; + +=head1 DESCRIPTION + +Lintian::Processable::Source::Overrides provides an interface to overrides. + +=head1 INSTANCE METHODS + +=over 4 + +=item override_file + +=cut + +has override_file => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + # prefer source/lintian-overrides to source.lintian-overrides + my @candidates = ( + 'debian/source/lintian-overrides', + 'debian/source.lintian-overrides' + ); + + # pick the first + my $override_item= first_value { defined } + map { $self->patched->lookup($_) } @candidates; + + return $override_item; + } +); + +=item overrides + +=cut + +has overrides => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + return [] + unless defined $self->override_file; + + my $contents = $self->override_file->decoded_utf8; + + return $self->parse_overrides($contents); + } +); + +1; + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for +Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Processable/Source/Patched.pm b/lib/Lintian/Processable/Source/Patched.pm new file mode 100644 index 0000000..229311f --- /dev/null +++ b/lib/Lintian/Processable/Source/Patched.pm @@ -0,0 +1,161 @@ +# -*- perl -*- Lintian::Processable::Source::Patched +# +# Copyright (C) 2008 Russ Allbery +# Copyright (C) 2009 Raphael Geissert +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Processable::Source::Patched; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Cwd; +use List::SomeUtils qw(uniq); +use IPC::Run3; +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8 decode_utf8); + +use Lintian::Index; +use Lintian::Index::Item; + +const my $COLON => q{:}; +const my $SLASH => q{/}; +const my $NEWLINE => qq{\n}; + +const my $NO_UMASK => 0000; +const my $WAIT_STATUS_SHIFT => 8; + +use Moo::Role; +use namespace::clean; + +=head1 NAME + +Lintian::Processable::Source::Patched - access to sources with Debian patches applied + +=head1 SYNOPSIS + + use Lintian::Processable; + +=head1 DESCRIPTION + +Lintian::Processable::Source::Patched provides an interface to collected data about patched sources. + +=head1 INSTANCE METHODS + +=over 4 + +=item patched + +Returns a index object representing a patched source tree. + +=cut + +has patched => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $index = Lintian::Index->new; + my $archive = $self->basename; + $index->identifier("$archive (patched)"); + $index->basedir($self->basedir . $SLASH . 'unpacked'); + + # source packages can be unpacked anywhere; no anchored roots + $index->anchored(0); + + path($index->basedir)->remove_tree + if -d $index->basedir; + + print encode_utf8("N: Using dpkg-source to unpack\n") + if $ENV{'LINTIAN_DEBUG'}; + + my $saved_umask = umask; + umask $NO_UMASK; + + my @unpack_command= ( + qw(dpkg-source -q --no-check --extract), + $self->path, $index->basedir + ); + + # ignore STDOUT; older versions are not completely quiet with -q + my $unpack_errors; + + run3(\@unpack_command, \undef, \undef, \$unpack_errors); + my $status = ($? >> $WAIT_STATUS_SHIFT); + + $unpack_errors = decode_utf8($unpack_errors) + if length $unpack_errors; + + if ($status) { + my $message = "Non-zero status $status from @unpack_command"; + $message .= $COLON . $NEWLINE . $unpack_errors + if length $unpack_errors; + + die encode_utf8($message); + } + + umask $saved_umask; + + my $index_errors = $index->create_from_basedir; + + my $savedir = getcwd; + chdir($index->basedir) + or die encode_utf8('Cannot change to directory ' . $index->basedir); + + # fix permissions + my @permissions_command + = ('chmod', '-R', 'u+rwX,o+rX,o-w', $index->basedir); + my $permissions_errors; + + run3(\@permissions_command, \undef, \undef, \$permissions_errors); + + $permissions_errors = decode_utf8($permissions_errors) + if length $permissions_errors; + + chdir($savedir) + or die encode_utf8("Cannot change to directory $savedir"); + + my @messages = grep { !/^tar: Ignoring / } + split(/\n/, $unpack_errors . $index_errors . $permissions_errors); + push(@{$index->unpack_messages}, @messages); + + return $index; + } +); + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for +Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Processable/Source/Relation.pm b/lib/Lintian/Processable/Source/Relation.pm new file mode 100644 index 0000000..e66297c --- /dev/null +++ b/lib/Lintian/Processable/Source/Relation.pm @@ -0,0 +1,267 @@ +# -*- perl -*- +# Lintian::Processable::Source::Relation -- interface to source package data collection + +# Copyright (C) 2008 Russ Allbery +# Copyright (C) 2009 Raphael Geissert +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Processable::Source::Relation; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(croak); +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::Relation; + +use Moo::Role; +use namespace::clean; + +=head1 NAME + +Lintian::Processable::Source::Relation - Lintian interface to source package data collection + +=head1 SYNOPSIS + + my ($name, $type, $dir) = ('foobar', 'source', '/path/to/lab-entry'); + my $collect = Lintian::Processable::Source::Relation->new($name); + if ($collect->native) { + print encode_utf8("Package is native\n"); + } + +=head1 DESCRIPTION + +Lintian::Processable::Source::Relation provides an interface to package data for source +packages. It implements data collection methods specific to source +packages. + +This module is in its infancy. Most of Lintian still reads all data from +files in the laboratory whenever that data is needed and generates that +data via collect scripts. The goal is to eventually access all data about +source packages via this module so that the module can cache data where +appropriate and possibly retire collect scripts in favor of caching that +data in memory. + +=head1 INSTANCE METHODS + +=over 4 + +=item binary_relation (PACKAGE, FIELD) + +Returns a L<Lintian::Relation> object for the specified FIELD in the +binary package PACKAGE in the F<debian/control> file. FIELD should be +one of the possible relationship fields of a Debian package or one of +the following special values: + +=over 4 + +=item All + +The concatenation of Pre-Depends, Depends, Recommends, and Suggests. + +=item Strong + +The concatenation of Pre-Depends and Depends. + +=item Weak + +The concatenation of Recommends and Suggests. + +=back + +If FIELD isn't present in the package, the returned Lintian::Relation +object will be empty (present but satisfies nothing). + +Any substvars in F<debian/control> will be represented in the returned +relation as packages named after the substvar. + +=item saved_binary_relations + +=cut + +has saved_binary_relations => ( + is => 'rw', + coerce => sub { my ($hashref) = @_; return ($hashref // {}); }, + default => sub { {} } +); + +my %alias = ( + all => [qw(Pre-Depends Depends Recommends Suggests)], + strong => [qw(Pre-Depends Depends)], + weak => [qw(Recommends Suggests)] +); + +my %known = map { $_ => 1 } + qw(pre-depends depends recommends suggests enhances breaks + conflicts provides replaces); + +sub binary_relation { + my ($self, $package, $name) = @_; + + return undef + unless length $name; + + my $lowercase = lc $name; + + return undef + unless length $package; + + my $relation = $self->saved_binary_relations->{$package}{$lowercase}; + unless (defined $relation) { + + if (length $alias{$lowercase}) { + $relation + = Lintian::Relation->new->logical_and( + map { $self->binary_relation($package, $_) } + @{ $alias{$lowercase} }); + + } else { + croak encode_utf8("unknown relation field $name") + unless $known{$lowercase}; + + my $value + = $self->debian_control->installable_fields($package) + ->value($name); + $relation = Lintian::Relation->new->load($value); + } + + $self->saved_binary_relations->{$package}{$lowercase} = $relation; + } + + return $relation; +} + +=item relation (FIELD) + +Returns a L<Lintian::Relation> object for the given build relationship +field FIELD. In addition to the normal build relationship fields, the +following special field names are supported: + +=over 4 + +=item Build-Depends-All + +The concatenation of Build-Depends, Build-Depends-Arch and +Build-Depends-Indep. + +=item Build-Conflicts-All + +The concatenation of Build-Conflicts, Build-Conflicts-Arch and +Build-Conflicts-Indep. + +=back + +If FIELD isn't present in the package, the returned Lintian::Relation +object will be empty (present but satisfies nothing). + +=item saved_relation + +=cut + +has saved_relations => ( + is => 'rw', + coerce => sub { my ($hashref) = @_; return ($hashref // {}); }, + default => sub { {} } +); + +sub relation { + my ($self, $name) = @_; + + return undef + unless length $name; + + my $lowercase = lc $name; + + my $relation = $self->saved_relations->{$lowercase}; + unless (defined $relation) { + + if ($name =~ /^Build-(Depends|Conflicts)-All$/i) { + my $type = $1; + my @fields + = ("Build-$type", "Build-$type-Indep", "Build-$type-Arch"); + $relation + = Lintian::Relation->new->logical_and(map { $self->relation($_) } + @fields); + + } elsif ($name =~ /^Build-(Depends|Conflicts)(?:-(?:Arch|Indep))?$/i){ + my $value = $self->fields->value($name); + $relation = Lintian::Relation->new->load($value); + + } else { + croak encode_utf8("unknown relation field $name"); + } + + $self->saved_relations->{$lowercase} = $relation; + } + + return $relation; +} + +=item relation_norestriction (FIELD) + +The same as L</relation (FIELD)>, but ignores architecture +restrictions and build profile restrictions in the FIELD field. + +=item saved_relations_norestriction + +=cut + +has saved_relations_norestriction => ( + is => 'rw', + coerce => sub { my ($hashref) = @_; return ($hashref // {}); }, + default => sub { {} } +); + +sub relation_norestriction { + my ($self, $name) = @_; + + return undef + unless length $name; + + my $lowercase = lc $name; + + my $relation = $self->saved_relations_norestriction->{$lowercase}; + unless (defined $relation) { + + $relation = $self->relation($name)->restriction_less; + $self->saved_relations_norestriction->{$lowercase} = $relation; + } + + return $relation; +} + +=back + +=head1 AUTHOR + +Originally written by Russ Allbery <rra@debian.org> for Lintian. +Amended by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Processable/Source/Repacked.pm b/lib/Lintian/Processable/Source/Repacked.pm new file mode 100644 index 0000000..4cf057b --- /dev/null +++ b/lib/Lintian/Processable/Source/Repacked.pm @@ -0,0 +1,99 @@ +# -*- perl -*- +# Lintian::Processable::Source::Repacked -- interface to source package data collection + +# Copyright (C) 2008 Russ Allbery +# Copyright (C) 2009 Raphael Geissert +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Processable::Source::Repacked; + +use v5.20; +use warnings; +use utf8; + +use Lintian::Util qw($PKGREPACK_REGEX); + +use Moo::Role; +use namespace::clean; + +=head1 NAME + +Lintian::Processable::Source::Repacked - Lintian interface to source package data collection + +=head1 SYNOPSIS + + my ($name, $type, $dir) = ('foobar', 'source', '/path/to/lab-entry'); + my $collect = Lintian::Processable::Source::Repacked->new($name); + if ($collect->native) { + print encode_utf8("Package is native\n"); + } + +=head1 DESCRIPTION + +Lintian::Processable::Source::Repacked provides an interface to package data for source +packages. It implements data collection methods specific to source +packages. + +This module is in its infancy. Most of Lintian still reads all data from +files in the laboratory whenever that data is needed and generates that +data via collect scripts. The goal is to eventually access all data about +source packages via this module so that the module can cache data where +appropriate and possibly retire collect scripts in favor of caching that +data in memory. + +=head1 INSTANCE METHODS + +=over 4 + +=item repacked + +Returns true if the source package has been "repacked" and false otherwise. +This is determined from the version name containing "dfsg" or similar. + +=cut + +has repacked => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $upstream = $self->changelog_version->upstream; + + return $upstream =~ $PKGREPACK_REGEX; + } +); + +=back + +=head1 AUTHOR + +Originally written by Russ Allbery <rra@debian.org> for Lintian. +Amended by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Profile.pm b/lib/Lintian/Profile.pm new file mode 100644 index 0000000..643e21f --- /dev/null +++ b/lib/Lintian/Profile.pm @@ -0,0 +1,941 @@ +# Copyright (C) 2011 Niels Thykier <niels@thykier.net> +# 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::Profile; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(carp croak); +use Const::Fast; +use Cwd qw(realpath); +use File::BaseDir qw(config_home config_files data_home); +use File::Find::Rule; +use List::Compare; +use List::SomeUtils qw(any none uniq first_value); +use Path::Tiny; +use POSIX qw(ENOENT); +use Unicode::UTF8 qw(encode_utf8); + +use Dpkg::Vendor qw(get_current_vendor get_vendor_info); + +use Lintian::Data; +use Lintian::Deb822; +use Lintian::Tag; +use Lintian::Util qw(match_glob); + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $HYPHEN => q{-}; +const my $EQUAL => q{=}; + +const my $FIELD_SEPARATOR => qr/ \s+ | \s* , \s* /sx; + +const my @VALID_HEADER_FIELDS => qw( + Profile + Extends + Enable-Tags-From-Check + Disable-Tags-From-Check + Enable-Tags + Disable-Tags +); + +const my @VALID_BODY_FIELDS => qw( + Tags + Overridable +); + +use Moo; +use namespace::clean; + +=head1 NAME + +Lintian::Profile - Profile parser for Lintian + +=head1 SYNOPSIS + + my $profile = Lintian::Profile->new ('debian'); + +=head1 DESCRIPTION + +Lintian::Profile handles finding, parsing and implementation of +Lintian Profiles as well as loading the relevant Lintian checks. + +=head1 INSTANCE METHODS + +=over 4 + +=item $prof->known_aliases() + +Returns a hash with old names that have new names. + +=item $prof->profile_list + +Returns a list ref of the (normalized) names of the profile and its +parents. The first element of the list is the name of the profile +itself, the second is its parent and so on. + +Note: This list is a reference. The contents should not be modified. + +=item our_vendor + +=item $prof->name + +Returns the name of the profile, which may differ from the name used +to create this instance of the profile (e.g. due to symlinks). + +=cut + +has known_aliases => ( + is => 'rw', + coerce => sub { my ($hashref) = @_; return ($hashref // {}); }, + default => sub { {} } +); + +has check_module_by_name => ( + is => 'rw', + coerce => sub { my ($hashref) = @_; return ($hashref // {}); }, + default => sub { {} } +); + +has check_path_by_name => ( + is => 'rw', + coerce => sub { my ($hashref) = @_; return ($hashref // {}); }, + default => sub { {} } +); + +has tag_names_for_check => ( + is => 'rw', + coerce => sub { my ($hashref) = @_; return ($hashref // {}); }, + default => sub { {} } +); + +has display_level_lookup => ( + is => 'rw', + coerce => sub { my ($hashref) = @_; return ($hashref // {}); }, + default => sub { + { + classification => 0, + pedantic => 0, + info => 0, + warning => 1, + error => 1, + } + } +); + +has enabled_checks_by_name => ( + is => 'rw', + coerce => sub { my ($hashref) = @_; return ($hashref // {}); }, + default => sub { {} } +); + +has enabled_tags_by_name => ( + is => 'rw', + coerce => sub { my ($hashref) = @_; return ($hashref // {}); }, + default => sub { {} } +); + +has files => ( + is => 'rw', + coerce => sub { my ($hashref) = @_; return ($hashref // {}); }, + default => sub { {} } +); + +has known_tags_by_name => ( + is => 'rw', + coerce => sub { my ($hashref) = @_; return ($hashref // {}); }, + default => sub { {} } +); + +has name => ( + is => 'rw', + coerce => sub { my ($string) = @_; return $string // $EMPTY;}, + default => $EMPTY +); + +has durable_tags_by_name => ( + is => 'rw', + coerce => sub { my ($hashref) = @_; return ($hashref // {}); }, + default => sub { {} } +); + +has data => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $data = Lintian::Data->new; + + my @DATA_PATHS = $self->search_space('data'); + $data->data_paths(\@DATA_PATHS); + $data->vendor($self->our_vendor); + + return $data; + } +); + +has parent_map => ( + is => 'rw', + coerce => sub { my ($hashref) = @_; return ($hashref // {}); }, + default => sub { {} } +); + +has profile_list => ( + is => 'rw', + coerce => sub { my ($arrayref) = @_; return ($arrayref // []); }, + default => sub { [] } +); + +has our_vendor => (is => 'rw'); + +has include_dirs => ( + is => 'rw', + coerce => sub { my ($arrayref) = @_; return ($arrayref // []); }, + default => sub { [] } +); + +# Temporary until aptdaemon (etc.) has been upgraded to handle +# Lintian loading code from user dirs. +# LP: #1162947 +has safe_include_dirs => ( + is => 'rw', + coerce => sub { my ($arrayref) = @_; return ($arrayref // []); }, + default => sub { [] } +); + +has known_vendors => ( + is => 'rw', + lazy => 1, + coerce => sub { my ($arrayref) = @_; return ($arrayref // []); }, + default => sub { + + my $vendor = Dpkg::Vendor::get_current_vendor(); + croak encode_utf8('Could not determine the current vendor') + unless $vendor; + + my @vendors; + push(@vendors, lc $vendor); + + while ($vendor) { + my $info = Dpkg::Vendor::get_vendor_info($vendor); + # Cannot happen atm, but in case Dpkg::Vendor changes its internals + # or our code changes + croak encode_utf8("Could not look up the parent vendor of $vendor") + unless $info; + + $vendor = $info->{'Parent'}; + push(@vendors, lc $vendor) + if $vendor; + } + + return \@vendors; + } +); + +has user_dirs => ( + is => 'ro', + lazy => 1, + coerce => sub { my ($arrayref) = @_; return ($arrayref // []); }, + default => sub { + my ($self) = @_; + + my @user_data; + + # XDG user data + push(@user_data, data_home('lintian')); + + # legacy per-user data + push(@user_data, "$ENV{HOME}/.lintian") + if length $ENV{HOME}; + + # system wide user data + push(@user_data, '/etc/lintian'); + + const my @IMMUTABLE => grep { length && -e } @user_data; + + return \@IMMUTABLE; + } +); + +=item load ([$profname[, $ipath[, $extra]]]) + +Loads a new profile. $profname is the name of the profile and $ipath +is a list reference containing the path to one (or more) Lintian +"roots". + +If $profname is C<undef>, the default vendor will be loaded based on +Dpkg::Vendor::get_current_vendor. + +If $ipath is not given, a default one will be used. + +=cut + +sub load { + my ($self, $profile_name, $requested_dirs, $allow_user_dirs) = @_; + + $requested_dirs //= []; + + my @distribution_dirs = ($ENV{LINTIAN_BASE} // '/usr/share/lintian'); + + const my @SAFE_INCLUDE_DIRS => (@{$requested_dirs}, @distribution_dirs); + $self->safe_include_dirs(\@SAFE_INCLUDE_DIRS); + + my @all_dirs; + + push(@all_dirs, @{$self->user_dirs}) + if $allow_user_dirs && @{$self->user_dirs}; + + push(@all_dirs, @{$self->safe_include_dirs}); + + const my @ALL_INCLUDE_DIRS => @all_dirs; + $self->include_dirs(\@ALL_INCLUDE_DIRS); + + for + my $tagdir (map { ($_ // q{.}) . '/tags' } @{$self->safe_include_dirs}) { + + next + unless -d $tagdir; + + my @tagpaths + = File::Find::Rule->file->name(qw(*.tag *.desc))->in($tagdir); + for my $tagpath (@tagpaths) { + + my $tag = Lintian::Tag->new; + $tag->load($self, $tagpath); + + die encode_utf8("Tag in $tagpath is not associated with a check") + unless length $tag->check; + + next + if exists $self->known_tags_by_name->{$tag->name}; + + $self->known_tags_by_name->{$tag->name} = $tag; + $self->tag_names_for_check->{$tag->check} //= []; + push(@{$self->tag_names_for_check->{$tag->check}},$tag->name); + + # record known aliases + my @taken + = grep { exists $self->known_aliases->{$_} } + @{$tag->renamed_from}; + + die encode_utf8('These aliases of the tag ' + . $tag->name + . ' are taken already: ' + . join($SPACE, @taken)) + if @taken; + + for my $old_name (@{$tag->renamed_from}) { + + if (exists $self->known_aliases->{$old_name}) { + + my $taken = $self->known_aliases->{$old_name}; + my $tag_name = $tag->name; + warn encode_utf8( +"Alias $old_name for $tag_name ignored; already taken by $taken" + ); + + } else { + $self->known_aliases->{$old_name} = $tag->name; + } + } + } + } + + my @check_bases + = map {(($_ // q{.}).'/lib/Lintian/Check', ($_ // q{.}).'/checks')} + @{$self->safe_include_dirs}; + for my $check_base (@check_bases) { + + next + unless -d $check_base; + + my @check_paths= File::Find::Rule->file->name('*.pm')->in($check_base); + + for my $absolute (@check_paths) { + + my $relative = path($absolute)->relative($check_base)->stringify; + $relative =~ s{\.pm$}{}; + + my $name = $relative; + $name =~ s{([[:upper:]])}{-\L$1}g; + $name =~ s{^-}{}; + $name =~ s{/-}{/}g; + + # ignore duplicates + next + if exists $self->check_module_by_name->{$name}; + + $self->check_path_by_name->{$name} = $absolute; + + my $module = $relative; + + # replace slashes with double colons + $module =~ s{/}{::}g; + + $self->check_module_by_name->{$name} = "Lintian::Check::$module"; + } + } + + $self->read_profile($profile_name); + + return; +} + +=item $prof->known_tags + +=cut + +sub known_tags { + my ($self) = @_; + + return keys %{ $self->known_tags_by_name }; +} + +=item $prof->enabled_tags + +=cut + +sub enabled_tags { + my ($self) = @_; + + return keys %{ $self->enabled_tags_by_name }; +} + +=item $prof->get_tag ($name) + +Returns the Lintian::Tag for $tag if known. +Otherwise it returns undef. + +=cut + +sub get_tag { + my ($self, $maybe_historical) = @_; + + my $name = $self->get_current_name($maybe_historical); + return undef + unless length $name; + + return $self->known_tags_by_name->{$name} + if exists $self->known_tags_by_name->{$name}; + + return undef; +} + +=item get_current_name + +=cut + +sub get_current_name { + my ($self, $tag_name) = @_; + + return $self->known_aliases->{$tag_name} + if exists $self->known_aliases->{$tag_name}; + + return $tag_name + if exists $self->known_tags_by_name->{$tag_name}; + + return $EMPTY; +} + +=item set_durable ($tag) + +=cut + +sub set_durable { + my ($self, $maybe_historical, $status) = @_; + + my $tag = $self->get_tag($maybe_historical); + croak encode_utf8("Unknown tag $maybe_historical.") + unless defined $tag; + + $self->durable_tags_by_name->{$tag->name} = 1 + if $status; + + # settings from tag govern + delete $self->durable_tags_by_name->{$tag->name} + if !$status && !$tag->show_always; + + return; +} + +=item $prof->is_durable ($tag) + +Returns a false value if the tag has been marked as +"non-overridable". Otherwise it returns a truth value. + +=cut + +sub is_durable { + my ($self, $maybe_historical) = @_; + + my $tag = $self->get_tag($maybe_historical); + croak encode_utf8("Unknown tag $maybe_historical.") + unless defined $tag; + + return 1 + if $tag->show_always + || exists $self->durable_tags_by_name->{$tag->name}; + + return 0; +} + +=item $prof->known_checks + +=cut + +sub known_checks { + my ($self) = @_; + + return keys %{ $self->check_module_by_name }; +} + +=item $prof->enabled_checks + +=cut + +sub enabled_checks { + my ($self) = @_; + + return keys %{ $self->enabled_checks_by_name }; +} + +=item $prof->enable_tag ($name) + +Enables a tag. + +=cut + +sub enable_tag { + my ($self, $maybe_historical) = @_; + + my $tag = $self->get_tag($maybe_historical); + croak encode_utf8("Unknown tag $maybe_historical.") + unless defined $tag; + + $self->enabled_checks_by_name->{$tag->check}++ + unless exists $self->enabled_tags_by_name->{$tag->name}; + + $self->enabled_tags_by_name->{$tag->name} = 1; + + return; +} + +=item $prof->disable_tag ($name) + +Disable a tag. + +=cut + +sub disable_tag { + my ($self, $maybe_historical) = @_; + + my $tag = $self->get_tag($maybe_historical); + croak encode_utf8("Unknown tag $maybe_historical.") + unless defined $tag; + + delete $self->enabled_checks_by_name->{$tag->check} + unless exists $self->enabled_tags_by_name->{$tag->name} + && --$self->enabled_checks_by_name->{$tag->check}; + + delete $self->enabled_tags_by_name->{$tag->name}; + + return; +} + +=item read_profile + +=cut + +sub read_profile { + my ($self, $requested_name) = @_; + + my @search_space; + + if (!defined $requested_name) { + @search_space = map { "$_/main" } @{$self->known_vendors}; + + } elsif ($requested_name !~ m{/}) { + @search_space = ("$requested_name/main"); + + } elsif ($requested_name =~ m{^[^.]+/[^/.]+$}) { + @search_space = ($requested_name); + + } else { + croak encode_utf8("$requested_name is not a valid profile name"); + } + + my @candidates; + for my $include_dir ( map { ($_ // q{.}) . '/profiles' } + @{$self->include_dirs} ) { + push(@candidates, map { "$include_dir/$_.profile" } @search_space); + } + + my $path = first_value { -e } @candidates; + + croak encode_utf8( + 'Could not find a profile matching: ' . join($SPACE, @search_space)) + unless length $path; + + my $deb822 = Lintian::Deb822->new; + my @paragraphs = $deb822->read_file($path); + + my ($header, @sections) = @paragraphs; + + croak encode_utf8("Profile has no header in $path") + unless defined $header; + + my $profile_name = $header->unfolded_value('Profile'); + croak encode_utf8("Profile has no name in $path") + unless length $profile_name; + + croak encode_utf8("Invalid Profile field in $path") + if $profile_name =~ m{^/} || $profile_name =~ m{\.}; + + # normalize name + $profile_name .= '/main' + unless $profile_name =~ m{/}; + + croak encode_utf8("Recursive definition of $profile_name") + if exists $self->parent_map->{$profile_name}; + + # Mark as being loaded. + $self->parent_map->{$profile_name} = 0; + + $self->name($profile_name) + unless length $self->name; + + $self->read_profile($header->unfolded_value('Extends')) + if $header->declares('Extends'); + + # prepend profile name after loading any parent + unshift(@{$self->profile_list}, $profile_name); + + my @have_comma + = grep { $header->value($_) =~ / , /sx } @VALID_HEADER_FIELDS; + for my $section (@sections) { + push(@have_comma, + grep { $section->value($_) =~ / , /sx } @VALID_BODY_FIELDS); + } + + warn +"Please use spaces as separators in field $_ instead of commas in profile $path\n" + for uniq @have_comma; + + my @unknown_header_fields = $header->extra(@VALID_HEADER_FIELDS); + croak encode_utf8("Unknown fields in header of profile $profile_name: " + . join($SPACE, @unknown_header_fields)) + if @unknown_header_fields; + + my @enable_check_patterns + = $header->trimmed_list('Enable-Tags-From-Check', $FIELD_SEPARATOR); + my @disable_check_patterns + = $header->trimmed_list('Disable-Tags-From-Check', $FIELD_SEPARATOR); + + my @enable_checks; + for my $pattern (@enable_check_patterns) { + push(@enable_checks, match_glob($pattern, $self->known_checks)); + } + + my @disable_checks; + for my $pattern (@disable_check_patterns) { + push(@disable_checks, match_glob($pattern, $self->known_checks)); + } + + my @action_checks = uniq(@enable_checks, @disable_checks); + + # make sure checks are loaded + my @needed_checks + = grep { !exists $self->check_module_by_name->{$_} } @action_checks; + + croak encode_utf8("Profile $profile_name references unknown checks: " + . join($SPACE, @needed_checks)) + if @needed_checks; + + my @enable_tag_patterns + = $header->trimmed_list('Enable-Tags', $FIELD_SEPARATOR); + my @disable_tag_patterns + = $header->trimmed_list('Disable-Tags', $FIELD_SEPARATOR); + + my @enable_tags; + for my $pattern (@enable_tag_patterns) { + push(@enable_tags, match_glob($pattern, $self->known_tags)); + } + + my @disable_tags; + for my $pattern (@disable_tag_patterns) { + push(@disable_tags, match_glob($pattern, $self->known_tags)); + } + + push(@enable_tags, @{$self->tag_names_for_check->{$_} // []}) + for uniq @enable_checks; + + push(@disable_tags, @{$self->tag_names_for_check->{$_} // []}) + for uniq @disable_checks; + + # disabling after enabling + $self->enable_tag($_) for uniq @enable_tags; + $self->disable_tag($_) for uniq @disable_tags; + + my $section_number = 2; + + for my $section (@sections){ + + my @unknown_fields = $section->extra(@VALID_BODY_FIELDS); + croak encode_utf8( +"Unknown fields in section $section_number of profile $profile_name: " + . join($SPACE, @unknown_fields)) + if @unknown_fields; + + my @tags = $section->trimmed_list('Tags', $FIELD_SEPARATOR); + croak encode_utf8( +"Tags field missing or empty in section $section_number of profile $profile_name" + )unless @tags; + + my $overridable = $section->unfolded_value('Overridable') || 'yes'; + if ($overridable !~ / ^ -? \d+ $ /msx) { + my $lowercase = lc $overridable; + + if ($lowercase =~ / ^ y(?:es)? | true $ /msx) { + $overridable = 1; + + } elsif ($lowercase =~ / ^ n[o]? | false $ /msx) { + $overridable = 0; + + } else { + my $position = $section->position('Overridable'); + croak encode_utf8( +"$overridable is not a boolean value in profile $profile_name (line $position)" + ); + } + } + + for my $tag_name (@tags) { + + if ($overridable) { + delete $self->durable_tags_by_name->{$tag_name}; + } else { + $self->durable_tags_by_name->{$tag_name} = 1; + } + } + + } continue { + $section_number++; + } + + $self->our_vendor($self->profile_list->[0]); + + # honor tag settings regardless of profile + my @show_always + = grep { $_->show_always } values %{$self->known_tags_by_name}; + + $self->durable_tags_by_name->{$_} = 1 for map { $_->name } @show_always; + + return; +} + +=item display_level_for_tag + +=cut + +sub display_level_for_tag { + my ($self, $tag_name) = @_; + + my $tag = $self->get_tag($tag_name); + croak encode_utf8("Unknown tag $tag_name") + unless defined $tag; + + return $self->display_level_lookup->{$tag->visibility}; +} + +=item tag_is_enabled(TAG) + +=cut + +sub tag_is_enabled { + my ($self, $maybe_historical) = @_; + + my $tag = $self->get_tag($maybe_historical); + croak encode_utf8("Unknown tag $maybe_historical.") + unless defined $tag; + + return 1 + if exists $self->enabled_tags_by_name->{$tag->name}; + + return 0; +} + +=item display(OPERATION, RELATION, VISIBILITY) + +Configure which tags are displayed by visibility. OPERATION +is C<+> to display the indicated tags, C<-> to not display the indicated +tags, or C<=> to not display any tags except the indicated ones. RELATION +is one of C<< < >>, C<< <= >>, C<=>, C<< >= >>, or C<< > >>. The +OPERATION will be applied to all values of visibility that +match the given RELATION on the VISIBILITY argument. If +either of those arguments are undefined, the action applies to any value +for that variable. For example: + + $tags->display('=', '>=', 'error'); + +turns off display of all tags and then enables display of any tag of +visibility error or higher. + + $tags->display('+', '>', 'warning'); + +adds to the current configuration display of all tags with a visibility +higher than warning. + + $tags->display('-', '=', 'info'); + +turns off display of tags of visibility info. + +This method throws an exception on errors, such as an unknown visibility or +an impossible constraint (like C<< > serious >>). + +=cut + +# Generate a subset of a list given the element and the relation. This +# function makes a hard assumption that $rel will be one of <, <=, =, >=, +# or >. It is not syntax-checked. +sub _relation_subset { + my ($self, $element, $rel, @list) = @_; + + if ($rel eq $EQUAL) { + return grep { $_ eq $element } @list; + } + + if (substr($rel, 0, 1) eq '<') { + @list = reverse @list; + } + + my $found; + for my $i (0..$#list) { + if ($element eq $list[$i]) { + $found = $i; + last; + } + } + + return () + unless defined($found); + + if (length($rel) > 1) { + return @list[$found .. $#list]; + + } + + return () + if $found == $#list; + + return @list[($found + 1) .. $#list]; +} + +# Given the operation, relation, and visibility, produce a +# human-readable representation of the display level string for errors. +sub _format_level { + my ($self, $op, $rel, $visibility) = @_; + + if (not defined $visibility) { + return "$op $rel"; + } else { + return "$op $rel $visibility (visibility)"; + } +} + +sub display { + my ($self, $op, $rel, $visibility) = @_; + + unless ($op =~ /^[+=-]\z/ and $rel =~ /^(?:[<>]=?|=)\z/) { + my $error = $self->_format_level($op, $rel, $visibility); + die encode_utf8('invalid display constraint ' . $error); + } + + if ($op eq $EQUAL) { + for my $s (@Lintian::Tag::VISIBILITIES) { + $self->display_level_lookup->{$s} = 0; + } + } + + my $status = ($op eq $HYPHEN ? 0 : 1); + + my @visibilities; + if ($visibility) { + @visibilities + = $self->_relation_subset($visibility, $rel, + @Lintian::Tag::VISIBILITIES); + } else { + @visibilities = @Lintian::Tag::VISIBILITIES; + } + + unless (@visibilities) { + my $error = $self->_format_level($op, $rel, $visibility); + die encode_utf8('invalid display constraint ' . $error); + } + + for my $s (@visibilities) { + $self->display_level_lookup->{$s} = $status; + } + + return; +} + +=item search_space + +=cut + +sub search_space { + my ($self, $relative) = @_; + + my @base_dirs; + for my $vendor (@{ $self->profile_list }) { + + push(@base_dirs, map { "$_/vendors/$vendor" } @{$self->include_dirs}); + } + + push(@base_dirs, @{$self->include_dirs}); + + my @candidates = map { "$_/$relative" } @base_dirs; + my @search_space = grep { -e } @candidates; + + return @search_space; +} + +=back + +=head1 AUTHOR + +Originally written by Niels Thykier <niels@thykier.net> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Relation.pm b/lib/Lintian/Relation.pm new file mode 100644 index 0000000..b7b4b67 --- /dev/null +++ b/lib/Lintian/Relation.pm @@ -0,0 +1,788 @@ +# -*- perl -*- +# Lintian::Relation -- operations on dependencies and relationships + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2004-2009 Russ Allbery <rra@debian.org> +# Copyright (C) 2018 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Relation; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(confess); +use Const::Fast; +use List::SomeUtils qw(any); +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::Relation::Predicate; + +use Moo; +use namespace::clean; + +use constant { + VISIT_PRED_NAME => 0, + VISIT_PRED_FULL => 1, + VISIT_OR_CLAUSE_FULL => 3, + VISIT_STOP_FIRST_MATCH => 4, +}; + +const my $EMPTY => q{}; + +const my $BRANCH_TYPE => 0; +const my $PREDICATE => 1; + +const my $FALSE => 0; + +=head1 NAME + +Lintian::Relation - Lintian operations on dependencies and relationships + +=head1 SYNOPSIS + + my $depends = Lintian::Relation->new('foo | bar, baz'); + print encode_utf8("yes\n") if $depends->satisfies('baz'); + print encode_utf8("no\n") if $depends->satisfies('foo'); + +=head1 DESCRIPTION + +This module provides functions for parsing and evaluating package +relationship fields such as Depends and Recommends for binary packages and +Build-Depends for source packages. It parses a relationship into an +internal format and can then answer questions such as "does this +dependency require that a given package be installed" or "is this +relationship a superset of another relationship." + +A dependency line is viewed as a predicate formula. The comma separator +means "and", and the alternatives separator means "or". A bare package +name is the predicate "a package of this name is available". A package +name with a version clause is the predicate "a package of this name that +satisfies this version clause is available." Architecture restrictions, +as specified in Policy for build dependencies, are supported and also +checked in the implication logic unless the new_norestriction() +constructor is used. With that constructor, architecture restrictions +are ignored. + +=head1 INSTANCE METHODS + +=over 4 + +=item trunk + +=cut + +has trunk => (is => 'rw', default => sub { ['AND'] }); + +=item load (RELATION) + +Creates a new Lintian::Relation object corresponding to the parsed +relationship RELATION. This object can then be used to ask questions +about that relationship. RELATION may be C<undef> or the empty string, in +which case the returned Lintian::Relation object is empty (always +satisfied). + +=cut + +sub load { + my ($self, $condition, $with_restrictions) = @_; + + $condition //= $EMPTY; + + my @trunk = ('AND'); + + my @requirements = grep { length } split(/\s*,\s*/, $condition); + for my $requirement (@requirements) { + + my @predicates; + + my @alternatives = split(/\s*\|\s*/, $requirement); + for my $alternative (@alternatives) { + + my $predicate = Lintian::Relation::Predicate->new; + $predicate->parse($alternative, $with_restrictions); + + push(@predicates, ['PRED', $predicate]); + } + + push(@trunk, @predicates) + if @predicates == 1; + + push(@trunk, ['OR', @predicates]) + if @predicates > 1; + } + + $self->trunk(\@trunk); + + return $self; +} + +=item load_norestriction (RELATION) + +Creates a new Lintian::Relation object corresponding to the parsed +relationship RELATION, ignoring architecture restrictions and restriction +lists. This should be used in cases where we only care if a dependency is +present in some cases and we don't want to require that the architectures +match (such as when checking for proper build dependencies, since if there +are architecture constraints the maintainer is doing something beyond +Lintian's ability to analyze) or that the restrictions list match (Lintian +can't handle dependency implications with build profiles yet). RELATION +may be C<undef> or the empty string, in which case the returned +Lintian::Relation object is empty (always satisfied). + +=cut + +sub load_norestriction { + my ($self, $condition) = @_; + + return $self->load($condition, $FALSE); +} + +=item logical_and(RELATION, ...) + +Creates a new Lintian::Relation object produced by AND'ing all the +relations together. Semantically it is the similar to: + + Lintian::Relation->new (join (', ', @relations)) + +Except it can avoid some overhead and it works if some of the elements +are Lintian::Relation objects already. + +=cut + +sub logical_and { + my ($self, @conditions) = @_; + + my @tree = ('AND'); + + # make sure to add $self + for my $condition (@conditions, $self) { + + my $relation; + + if (ref $condition eq $EMPTY) { + # allow string conditions + $relation = Lintian::Relation->new->load($condition); + + } else { + $relation = $condition; + } + + next + if $relation->is_empty; + + if ( $tree[$BRANCH_TYPE] eq 'AND' + && $relation->trunk->[$BRANCH_TYPE] eq 'AND') { + + my @anded = @{$relation->trunk}; + shift @anded; + push(@tree, @anded); + + } else { + push(@tree, $relation->trunk); + } + } + + my $created = Lintian::Relation->new; + $created->trunk(\@tree); + + return $created; +} + +=item redundancies() + +Returns a list of duplicated elements within the relation object. Each +element of the returned list will be a reference to an anonymous array +holding a set of relations considered redundancies of each other. Two +relations are considered redundancies if one satisfies the other, meaning that +if one relationship is satisfied, the other is necessarily satisfied. +This relationship does not have to be commutative: the opposite +implication may not hold. + +=cut + +sub redundancies { + my ($self) = @_; + + # there are no redundancies unless the top-level relationship is AND. + return () + unless $self->trunk->[$BRANCH_TYPE] eq 'AND'; + +# The logic here is a bit complex in order to merge sets of duplicate +# dependencies. We want foo (<< 2), foo (>> 1), foo (= 1.5) to end up as +# one set of redundancies, even though the first doesn't satisfy the second. +# +# $redundant_sets holds a hash, where the key is the earliest dependency in a set +# and the value is a hash whose keys are the other dependencies in the +# set. $seen holds a map from package names to the duplicate sets that +# they're part of, if they're not the earliest package in a set. If +# either of the dependencies in a duplicate pair were already seen, add +# the missing one of the pair to the existing set rather than creating a +# new one. + my %redundant_sets; + + my @remaining = @{$self->trunk}; + + # discard AND identifier + shift @remaining; + my $i = 1; + + my %seen; + while (@remaining > 1) { + + my $branch_i = shift @remaining; + my $j = $i + 1; + + # run against all others + for my $branch_j (@remaining) { + + my $forward = implies_array($branch_i, $branch_j); + my $reverse = implies_array($branch_j, $branch_i); + + if ($forward or $reverse) { + my $one = $self->to_string($branch_i); + my $two = $self->to_string($branch_j); + + if ($seen{$one}) { + $redundant_sets{$seen{$one}}{$two} = $j; + $seen{$two} = $seen{$one}; + + } elsif ($seen{$two}) { + $redundant_sets{$seen{$two}}{$one} = $i; + $seen{$one} = $seen{$two}; + + } else { + $redundant_sets{$one} ||= {}; + $redundant_sets{$one}{$two} = $j; + $seen{$two} = $one; + } + } + } continue { + $j++; + } + } continue { + $i++; + } + + return map { [$_, keys %{ $redundant_sets{$_}}] } keys %redundant_sets; +} + +=item restriction_less + +Returns a restriction-less variant of this relation. + +=cut + +sub restriction_less { + my ($self) = @_; + + my $unrestricted + = Lintian::Relation->new->load_norestriction($self->to_string); + + return $unrestricted; +} + +=item satisfies(RELATION) + +Returns true if the relationship satisfies RELATION, meaning that if the +Lintian::Relation object is satisfied, RELATION will always be satisfied. +RELATION may be either a string or another Lintian::Relation object. + +By default, architecture restrictions are honored in RELATION if it is a +string. If architecture restrictions should be ignored in RELATION, +create a Lintian::Relation object with new_norestriction() and pass that +in as RELATION instead of the string. + +=item implies_array + +=cut + +# This internal function does the heavy of AND, OR, and NOT logic. It expects +# two references to arrays instead of an object and a relation. +sub implies_array { + my ($p, $q) = @_; + + my $i; + my $q0 = $q->[$BRANCH_TYPE]; + my $p0 = $p->[$BRANCH_TYPE]; + + if ($q0 eq 'PRED') { + if ($p0 eq 'PRED') { + return $p->[$PREDICATE]->satisfies($q->[$PREDICATE]); + } elsif ($p0 eq 'AND') { + $i = 1; + while ($i < @{$p}) { + return 1 if implies_array($p->[$i++], $q); + } + return 0; + } elsif ($p0 eq 'OR') { + $i = 1; + while ($i < @{$p}) { + return 0 if not implies_array($p->[$i++], $q); + } + return 1; + } elsif ($p0 eq 'NOT') { + return implies_array_inverse($p->[1], $q); + } + } elsif ($q0 eq 'AND') { + # Each of q's clauses must be deduced from p. + $i = 1; + while ($i < @{$q}) { + return 0 if not implies_array($p, $q->[$i++]); + } + return 1; + + } elsif ($q0 eq 'OR') { + # If p is something other than OR, p needs to satisfy one of the + # clauses of q. If p is an AND clause, q is satisfied if any of the + # clauses of p satisfy it. + # + # The interesting case is OR. In this case, do an OR to OR comparison + # to determine if q's clause is a superset of p's clause as follows: + # take each branch of p and see if it satisfies a branch of q. If + # each branch of p satisfies some branch of q, return 1. Otherwise, + # return 0. + # + # Simple logic that requires that p satisfy at least one of the + # clauses of q considered in isolation will miss that a|b satisfies + # a|b|c, since a|b doesn't satisfy any of a, b, or c in isolation. + if ($p0 eq 'PRED') { + $i = 1; + while ($i < @{$q}) { + return 1 if implies_array($p, $q->[$i++]); + } + return 0; + } elsif ($p0 eq 'AND') { + $i = 1; + while ($i < @{$p}) { + return 1 if implies_array($p->[$i++], $q); + } + return 0; + } elsif ($p0 eq 'OR') { + + my @p_branches = @{$p}; + shift @p_branches; + + my @q_branches = @{$q}; + shift @q_branches; + + for my $p_branch (@p_branches) { + + return 0 + unless any { implies_array($p_branch, $_) }@q_branches; + } + + return 1; + + } elsif ($p->[$BRANCH_TYPE] eq 'NOT') { + return implies_array_inverse($p->[1], $q); + } + + } elsif ($q0 eq 'NOT') { + if ($p0 eq 'NOT') { + return implies_array($q->[1], $p->[1]); + } + return implies_array_inverse($p, $q->[1]); + } + + return undef; +} + +# The public interface. +sub satisfies { + my ($self, $condition) = @_; + + my $relation; + if (ref $condition eq $EMPTY) { + # allow string conditions + $relation = Lintian::Relation->new->load($condition); + + } else { + $relation = $condition; + } + + return implies_array($self->trunk, $relation->trunk) // 0; +} + +=item satisfies_inverse(RELATION) + +Returns true if the relationship satisfies that RELATION is certainly false, +meaning that if the Lintian::Relation object is satisfied, RELATION cannot +be satisfied. RELATION may be either a string or another +Lintian::Relation object. + +As with satisfies(), by default, architecture restrictions are honored in +RELATION if it is a string. If architecture restrictions should be +ignored in RELATION, create a Lintian::Relation object with +new_norestriction() and pass that in as RELATION instead of the string. + +=item implies_array_inverse + +=cut + +# This internal function does the heavily lifting for AND, OR, and NOT +# handling for inverse implications. It takes two references to arrays and +# returns true iff the falsehood of the second can be deduced from the truth +# of the first. +sub implies_array_inverse { + my ($p, $q) = @_; + my $i; + my $q0 = $q->[$BRANCH_TYPE]; + my $p0 = $p->[$BRANCH_TYPE]; + if ($q0 eq 'PRED') { + if ($p0 eq 'PRED') { + return $p->[$PREDICATE]->satisfies_inverse($q->[$PREDICATE]); + } elsif ($p0 eq 'AND') { + # q's falsehood can be deduced from any of p's clauses + $i = 1; + while ($i < @{$p}) { + return 1 if implies_array_inverse($p->[$i++], $q); + } + return 0; + } elsif ($p0 eq 'OR') { + # q's falsehood must be deduced from each of p's clauses + $i = 1; + while ($i < @{$p}) { + return 0 if not implies_array_inverse($p->[$i++], $q); + } + return 1; + } elsif ($p0 eq 'NOT') { + return implies_array($q, $p->[1]); + } + } elsif ($q0 eq 'AND') { + # Any of q's clauses must be falsified by p. + $i = 1; + while ($i < @{$q}) { + return 1 if implies_array_inverse($p, $q->[$i++]); + } + return 0; + } elsif ($q0 eq 'OR') { + # Each of q's clauses must be falsified by p. + $i = 1; + while ($i < @{$q}) { + return 0 if not implies_array_inverse($p, $q->[$i++]); + } + return 1; + } elsif ($q0 eq 'NOT') { + return implies_array($p, $q->[1]); + } + + return 0; +} + +# The public interface. +sub satisfies_inverse { + my ($self, $condition) = @_; + + my $relation; + if (ref $condition eq $EMPTY) { + # allow string conditions + $relation = Lintian::Relation->new->load($condition); + + } else { + $relation = $condition; + } + + return implies_array_inverse($self->trunk, $relation->trunk) // 0; +} + +=item to_string + +Returns the textual form of a relationship. This converts the internal +form back into the textual representation and returns that, not the +original argument, so the spacing is standardized. Returns undef on +internal failures (such as an object in an unexpected format). + +=cut + +# The second argument isn't part of the public API. It's a partial relation +# that's not a blessed object and is used by to_string() internally so that it +# can recurse. +sub to_string { + my ($self, $branch) = @_; + + my $tree = $branch // $self->trunk; + + my $text; + if ($tree->[$BRANCH_TYPE] eq 'PRED') { + + $text = $tree->[$PREDICATE]->to_string; + + } elsif ($tree->[$BRANCH_TYPE] eq 'AND' || $tree->[$BRANCH_TYPE] eq 'OR') { + + my $connector = ($tree->[$BRANCH_TYPE] eq 'AND') ? ', ' : ' | '; + my @separated = map { $self->to_string($_) } @{$tree}[1 .. $#{$tree}]; + $text = join($connector, @separated); + + } elsif ($tree->[$BRANCH_TYPE] eq 'NOT') { + + # currently not generated by any relation + $text = '! ' . $tree->[$PREDICATE]->to_string; + + } else { + confess encode_utf8("Case $tree->[$BRANCH_TYPE] not implemented"); + } + + return $text; +} + +=item matches (REGEX[, WHAT]) + +Check if one of the predicates in this relation matches REGEX. WHAT +determines what is tested against REGEX and if not given, defaults to +VISIT_PRED_NAME. + +This method will return a truth value if REGEX matches at least one +predicate or clause (as defined by the WHAT parameter - see below). + +NOTE: Often L</satisfies> (or L</satisfies_inverse>) is a better choice +than this method. This method should generally only be used when +checking for a "pattern" package (e.g. phpapi-[\d\w+]+). + + +WHAT can be one of: + +=over 4 + +=item VISIT_PRED_NAME + +Match REGEX against the package name in each predicate (i.e. version +and architecture constrains are ignored). Each predicate is tested in +isolation. As an example: + + my $rel = Lintian::Relation->new ('somepkg | pkg-0 (>= 1)'); + # Will match (version is ignored) + $rel->matches (qr/^pkg-\d$/, VISIT_PRED_NAME); + +=item VISIT_PRED_FULL + +Match REGEX against the full (normalized) predicate (i.e. including +version and architecture). Each predicate is tested in isolation. +As an example: + + my $vrel = Lintian::Relation->new ('somepkg | pkg-0 (>= 1)'); + my $uvrel = Lintian::Relation->new ('somepkg | pkg-0'); + + # Will NOT match (does not match with version) + $vrel->matches (qr/^pkg-\d$/, VISIT_PRED_FULL); + # Will match (this relation does not have a version) + $uvrel->matches (qr/^pkg-\d$/, VISIT_PRED_FULL); + + # Will match (but only because there is a version) + $vrel->matches (qr/^pkg-\d \(.*\)$/, VISIT_PRED_FULL); + # Will NOT match (there is no version in the relation) + $uvrel->matches (qr/^pkg-\d \(.*\)$/, VISIT_PRED_FULL); + +=item VISIT_OR_CLAUSE_FULL + +Match REGEX against the full (normalized) OR clause. Each predicate +will have both version and architecture constrains present. As an +example: + + + my $vpred = Lintian::Relation->new ('pkg-0 (>= 1)'); + my $orrel = Lintian::Relation->new ('somepkg | pkg-0 (>= 1)'); + my $rorrel = Lintian::Relation->new ('pkg-0 (>= 1) | somepkg'); + + # Will match + $vrel->matches (qr/^pkg-\d(?: \([^\)]\))?$/, VISIT_OR_CLAUSE_FULL); + # These Will NOT match (does not match the "|" and the "somepkg" part) + $orrel->matches (qr/^pkg-\d(?: \([^\)]\))?$/, VISIT_OR_CLAUSE_FULL); + $rorrel->matches (qr/^pkg-\d(?: \([^\)]\))?$/, VISIT_OR_CLAUSE_FULL); + +=back + +=cut + +sub matches { + my ($self, $regex, $what) = @_; + $what //= VISIT_PRED_NAME; + return $self->visit(sub { m/$regex/ }, $what | VISIT_STOP_FIRST_MATCH); +} + +=item equals + +Same for full-string matches. Satisfies the perlcritic policy +RegularExpressions::ProhibitFixedStringMatches. + +=cut + +sub equals { + my ($self, $string, $what) = @_; + $what //= VISIT_PRED_NAME; + return $self->visit(sub { $_ eq $string }, $what | VISIT_STOP_FIRST_MATCH); +} + +=item visit (CODE[, FLAGS]) + +Visit clauses or predicates of this relation. Each clause or +predicate is passed to CODE as first argument and will be available as +C<$_>. + +The optional bitmask parameter, FLAGS, can be used to control what is +visited and such. If FLAGS is not given, it defaults to +VISIT_PRED_NAME. The possible values of FLAGS are: + +=over 4 + +=item VISIT_PRED_NAME + +The package name in each predicate is visited, but the version and +architecture part(s) are left out (if any). + +=item VISIT_PRED_FULL + +The full predicates are visited in turn. The predicate will be +normalized (by L</to_string>). + +=item VISIT_OR_CLAUSE_FULL + +CODE will be passed the full OR clauses of this relation. The clauses +will be normalized (by L</to_string>) + +Note: It will not visit the underlying predicates in the clause. + +=item VISIT_STOP_FIRST_MATCH + +Stop the visits the first time CODE returns a truth value. This is +similar to L<first|List::Util/first>, except visit will return the +value returned by CODE. + +=back + +Except where a given flag specifies otherwise, the return value of +visit is last value returned by CODE (or C<undef> for the empty +relation). + +=cut + +# The last argument is not part of the public API. It's a partial +# relation that's not a blessed object and is used by visit() +# internally so that it can recurse. + +sub visit { + my ($self, $code, $flags, $branch) = @_; + + my $tree = $branch // $self->trunk; + my $rel_type = $tree->[$BRANCH_TYPE]; + + $flags //= 0; + + if ($rel_type eq 'PRED') { + my $predicate = $tree->[$PREDICATE]; + my $against = $predicate->name; + $against = $predicate->to_string + if $flags & VISIT_PRED_FULL; + + local $_ = $against; + return scalar $code->($against); + + } elsif (($flags & VISIT_OR_CLAUSE_FULL) == VISIT_OR_CLAUSE_FULL + and $rel_type eq 'OR') { + + my $against = $self->to_string($tree); + + local $_ = $against; + return scalar $code->($against); + + } elsif ($rel_type eq 'AND' + or $rel_type eq 'OR' + or $rel_type eq 'NOT') { + + for my $rel (@{$tree}[1 .. $#{$tree}]) { + my $ret = scalar $self->visit($code, $flags, $rel); + if ($ret && ($flags & VISIT_STOP_FIRST_MATCH)) { + return $ret; + } + } + return 0; + } + + return 0; +} + +=item is_empty + +Returns a truth value if this relation is empty (i.e. it contains no +predicates). + +=cut + +sub is_empty { + my ($self) = @_; + + return 1 + if $self->trunk->[$BRANCH_TYPE] eq 'AND' && !$self->trunk->[1]; + + return 0; +} + +=item unparsable_predicates + +Returns a list of predicates that were unparsable. + +They are returned in the original textual representation and are also +sorted by said representation. + +=cut + +sub unparsable_predicates { + my ($self) = @_; + + my @worklist = ($self->trunk); + my @unparsable; + + while (my $current = pop(@worklist)) { + + my $rel_type = $current->[$BRANCH_TYPE]; + + if ($rel_type ne 'PRED') { + + push(@worklist, @{$current}[1 .. $#{$current}]); + next; + } + + my $predicate = $current->[$PREDICATE]; + + push(@unparsable, $predicate->literal) + unless $predicate->parsable; + } + + my @sorted = sort @unparsable; + + return @sorted; +} + +=back + +=head1 AUTHOR + +Originally written by Russ Allbery <rra@debian.org> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Relation/Predicate.pm b/lib/Lintian/Relation/Predicate.pm new file mode 100644 index 0000000..4714197 --- /dev/null +++ b/lib/Lintian/Relation/Predicate.pm @@ -0,0 +1,553 @@ +# -*- perl -*- +# Lintian::Relation::Predicate -- relationship predicates + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2004-2009 Russ Allbery <rra@debian.org> +# Copyright (C) 2018 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Relation::Predicate; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; + +use Lintian::Relation::Version qw(:all); + +use Moo; +use namespace::clean; + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $COLON => q{:}; + +const my $EQUAL => q{=}; +const my $LESS_THAN => q{<}; +const my $LESS_THAN_OR_EQUAL => q{<=}; +const my $DOUBLE_LESS_THAN => q{<<}; +const my $GREATER_THAN => q{>}; +const my $GREATER_THAN_OR_EQUAL => q{>=}; +const my $DOUBLE_GREATER_THAN => q{>>}; + +const my $LEFT_PARENS => q{(}; +const my $RIGHT_PARENS => q{)}; +const my $LEFT_SQUARE => q{[}; +const my $RIGHT_SQUARE => q{]}; +const my $LEFT_ANGLE => q{<}; +const my $RIGHT_ANGLE => q{>}; + +const my $TRUE => 1; +const my $FALSE => 0; + +=head1 NAME + +Lintian::Relation::Predicate - Lintian type for relationship predicates + +=head1 SYNOPSIS + + use Lintian::Relation::Predicate; + +=head1 DESCRIPTION + +This module provides functions for parsing and evaluating package +relationships such as Depends and Recommends for binary packages and +Build-Depends for source packages. It parses a relationship into an +internal format and can then answer questions such as "does this +dependency require that a given package be installed" or "is this +relationship a superset of another relationship." + +=head1 INSTANCE METHODS + +=over 4 + +=item literal + +=item C<parsable> + +=item name + +=item multiarch_qualifier + +=item version_operator + +=item reference_version + +=item build_architecture + +=item build_profile + +=cut + +has literal => ( + is => 'rw', + default => $EMPTY, + coerce => sub { my ($text) = @_; return ($text // $EMPTY); } +); + +has parsable => (is => 'rw', default => $FALSE); + +has name => ( + is => 'rw', + default => $EMPTY, + coerce => sub { my ($text) = @_; return ($text // $EMPTY); } +); + +has multiarch_qualifier => ( + is => 'rw', + default => $EMPTY, + coerce => sub { my ($text) = @_; return ($text // $EMPTY); } +); + +has version_operator => ( + is => 'rw', + default => $EMPTY, + coerce => sub { my ($text) = @_; return ($text // $EMPTY); } +); + +has reference_version => ( + is => 'rw', + default => $EMPTY, + coerce => sub { my ($text) = @_; return ($text // $EMPTY); } +); + +has build_architecture => ( + is => 'rw', + default => $EMPTY, + coerce => sub { my ($text) = @_; return ($text // $EMPTY); } +); + +has build_profile => ( + is => 'rw', + default => $EMPTY, + coerce => sub { my ($text) = @_; return ($text // $EMPTY); } +); + +=item parse + +=cut + +# The internal parser which converts a single package element of a +# relationship into the parsed form used for later processing. We permit +# substvars to be used as package names so that we can use these routines with +# the unparsed debian/control file. +sub parse { + my ($self, $text, $with_restrictions) = @_; + + $with_restrictions //= $TRUE; + + # store the element as-is, so we can reconstitute it later + $self->literal($text); + + if ( + $text =~ m{ + ^\s* # skip leading whitespace + ( # package name or substvar (1) + (?: # start of the name + [a-zA-Z0-9][a-zA-Z0-9+.-]* # start of a package name + | # or + \$\{[a-zA-Z0-9:-]+\} # substvar + ) # end of start of the name + (?: # substvars may be mixed in + [a-zA-Z0-9+.-]+ # package name portion + | # or + \$\{[a-zA-Z0-9:-]+\} # substvar + )* # zero or more portions or substvars + ) # end of package name or substvar + (?:[:]([a-z0-9-]+))? # optional Multi-arch arch specification (2) + (?: # start of optional version + \s* \( # open parenthesis for version part + \s* (<<|<=|>=|>>|[=<>]) # relation part (3) + \s* ([^\)]+) # version (4) + \s* \) # closing parenthesis + )? # end of optional version + (?: # start of optional architecture + \s* \[ # open bracket for architecture + \s* ([^\]]+) # architectures (5) + \s* \] # closing bracket + )? # end of optional architecture + (?: # start of optional restriction + \s* < # open bracket for restriction + \s* ([^,]+) # don't parse restrictions now + \s* > # closing bracket + )? # end of optional restriction + \s* $}x + ) { + $self->parsable($TRUE); + + $self->name($1); + $self->multiarch_qualifier($2); + $self->version_operator($3); + $self->reference_version($4); + $self->build_architecture($5); + $self->build_profile($6); + + $self->reference_version($EMPTY) + unless length $self->version_operator; + + $self->version_operator($DOUBLE_LESS_THAN) + if $self->version_operator eq $LESS_THAN; + + $self->version_operator($DOUBLE_GREATER_THAN) + if $self->version_operator eq $GREATER_THAN; + + unless ($with_restrictions) { + $self->multiarch_qualifier('any'); + $self->version_operator($EMPTY); + $self->reference_version($EMPTY); + $self->build_architecture($EMPTY); + $self->build_profile($EMPTY); + } + } + + return; +} + +=item satisfies + +=cut + +# This internal function does the heavily lifting of comparing two +# elements. +# +# Takes two elements and returns true iff the second can be deduced from the +# first. If the second is falsified by the first (in other words, if self +# actually satisfies not other), return 0. Otherwise, return undef. The 0 return +# is used by implies_element_inverse. +sub satisfies { + my ($self, $other) = @_; + + if (!$self->parsable || !$other->parsable) { + + return 1 + if $self->to_string eq $other->to_string; + + return undef; + } + + # If the names don't match, there is no relationship between them. + return undef + if $self->name ne $other->name; + + # the restriction formula forms a disjunctive normal form expression one + # way to check whether A <dnf1> satisfies A <dnf2> is to check: + # + # if dnf1 == dnf1 OR dnf2: + # the second dependency is superfluous because the first dependency + # applies in all cases the second one applies + # + # an easy way to check for equivalence of the two dnf expressions would be + # to construct the truth table for both expressions ("dnf1" and "dnf1 OR + # dnf2") for all involved profiles and then comparing whether they are + # equal + # + # the size of the truth tables grows with 2 to the power of the amount of + # involved profile names but since there currently only exist six possible + # profile names (see data/fields/build-profiles) that should be okay + # + # FIXME: we are not doing this check yet so if we encounter a dependency + # with build profiles we assume that one does not satisfy the other: + + return undef + if length $self->build_profile + || length $other->build_profile; + + # If the names match, then the only difference is in the architecture or + # version clauses. First, check architecture. The architectures for self + # must be a superset of the architectures for other. + my @self_arches = split($SPACE, $self->build_architecture); + my @other_arches = split($SPACE, $other->build_architecture); + if (@self_arches || @other_arches) { + my $self_arch_neg = @self_arches && $self_arches[0] =~ /^!/; + my $other_arch_neg = @other_arches && $other_arches[0] =~ /^!/; + + # If self has no arches, it is a superset of other and we should fall through + # to the version check. + if (not @self_arches) { + # nothing + } + + # If other has no arches, it is a superset of self and there are no useful + # implications. + elsif (not @other_arches) { + + return undef; + } + + # Both have arches. If neither are negated, we know nothing useful + # unless other is a subset of self. + elsif (not $self_arch_neg and not $other_arch_neg) { + my %self_arches = map { $_ => 1 } @self_arches; + my $subset = 1; + for my $arch (@other_arches) { + $subset = 0 unless $self_arches{$arch}; + } + + return undef + unless $subset; + } + + # If both are negated, we know nothing useful unless self is a subset of + # other (and therefore has fewer things excluded, and therefore is more + # general). + elsif ($self_arch_neg and $other_arch_neg) { + my %other_arches = map { $_ => 1 } @other_arches; + my $subset = 1; + for my $arch (@self_arches) { + $subset = 0 unless $other_arches{$arch}; + } + + return undef + unless $subset; + } + + # If other is negated and self isn't, we'd need to know the full list of + # arches to know if there's any relationship, so bail. + elsif (not $self_arch_neg and $other_arch_neg) { + + return undef; + } + +# If self is negated and other isn't, other is a subset of self iff none of the +# negated arches in self are present in other. + elsif ($self_arch_neg and not $other_arch_neg) { + my %other_arches = map { $_ => 1 } @other_arches; + my $subset = 1; + for my $arch (@self_arches) { + $subset = 0 if $other_arches{substr($arch, 1)}; + } + + return undef + unless $subset; + } + } + + # Multi-arch architecture specification + + # According to the spec, only the special value "any" is allowed + # and it is "recommended" to consider "other such package + # relations as unsatisfiable". That said, there seem to be an + # interest in supporting ":<arch>" as well, so we will (probably) + # have to accept those as well. + # + # Other than that, we would need to know that the package has the + # field "Multi-arch: allowed", but we cannot check that here. So + # we assume that it is okay. + + # pkg has no chance of satisfing pkg:Y unless Y is 'any' + return undef + if !length $self->multiarch_qualifier + && length $other->multiarch_qualifier + && $other->multiarch_qualifier ne 'any'; + + # TODO: Review this case. Are there cases where other cannot + # disprove self due to the ":any"-qualifier? For now, we + # assume there are no such cases. + # pkg:X has no chance of satisfying pkg + return undef + if length $self->multiarch_qualifier + && !length $other->multiarch_qualifier; + + # For now assert that only the identity holds. In practise, the + # "pkg:X" (for any valid value of X) seems to satisfy "pkg:any", + # fixing that is a TODO (because version clauses complicates + # matters) + # pkg:X has no chance of satisfying pkg:Y unless X equals Y + return undef + if length $self->multiarch_qualifier + && length $other->multiarch_qualifier + && $self->multiarch_qualifier ne $other->multiarch_qualifier; + + # Now, down to version. The implication is true if self's clause is stronger + # than other's, or is equivalent. + + # If other has no version clause, then self's clause is always stronger. + return 1 + unless length $other->version_operator; + +# If other does have a version clause, then self must also have one to have any +# useful relationship. + return undef + unless length $self->version_operator; + + # other wants an exact version, so self must provide that exact version. self + # disproves other if other's version is outside the range enforced by self. + if ($other->version_operator eq $EQUAL) { + if ($self->version_operator eq $DOUBLE_LESS_THAN) { + return versions_lte($self->reference_version, + $other->reference_version) ? 0 : undef; + } elsif ($self->version_operator eq $LESS_THAN_OR_EQUAL) { + return versions_lt($self->reference_version, + $other->reference_version) ? 0 : undef; + } elsif ($self->version_operator eq $DOUBLE_GREATER_THAN) { + return versions_gte($self->reference_version, + $other->reference_version) ? 0 : undef; + } elsif ($self->version_operator eq $GREATER_THAN_OR_EQUAL) { + return versions_gt($self->reference_version, + $other->reference_version) ? 0 : undef; + } elsif ($self->version_operator eq $EQUAL) { + return versions_equal($self->reference_version, + $other->reference_version) ? 1 : 0; + } + } + +# A greater than clause may disprove a less than clause. Otherwise, if +# self's clause is <<, <=, or =, the version must be <= other's to satisfy other. + if ($other->version_operator eq $LESS_THAN_OR_EQUAL) { + if ($self->version_operator eq $DOUBLE_GREATER_THAN) { + return versions_gte($self->reference_version, + $other->reference_version) ? 0 : undef; + } elsif ($self->version_operator eq $GREATER_THAN_OR_EQUAL) { + return versions_gt($self->reference_version, + $other->reference_version) ? 0 : undef; + } elsif ($self->version_operator eq $EQUAL) { + return versions_lte($self->reference_version, + $other->reference_version) ? 1 : 0; + } else { + return versions_lte($self->reference_version, + $other->reference_version) ? 1 : undef; + } + } + + # Similar, but << is stronger than <= so self's version must be << other's + # version if the self relation is <= or =. + if ($other->version_operator eq $DOUBLE_LESS_THAN) { + if ( $self->version_operator eq $DOUBLE_GREATER_THAN + || $self->version_operator eq $GREATER_THAN_OR_EQUAL) { + return versions_gte($self->reference_version, + $self->reference_version) ? 0 : undef; + } elsif ($self->version_operator eq $DOUBLE_LESS_THAN) { + return versions_lte($self->reference_version, + $other->reference_version) ? 1 : undef; + } elsif ($self->version_operator eq $EQUAL) { + return versions_lt($self->reference_version, + $other->reference_version) ? 1 : 0; + } else { + return versions_lt($self->reference_version, + $other->reference_version) ? 1 : undef; + } + } + + # Same logic as above, only inverted. + if ($other->version_operator eq $GREATER_THAN_OR_EQUAL) { + if ($self->version_operator eq $DOUBLE_LESS_THAN) { + return versions_lte($self->reference_version, + $other->reference_version) ? 0 : undef; + } elsif ($self->version_operator eq $LESS_THAN_OR_EQUAL) { + return versions_lt($self->reference_version, + $other->reference_version) ? 0 : undef; + } elsif ($self->version_operator eq $EQUAL) { + return versions_gte($self->reference_version, + $other->reference_version) ? 1 : 0; + } else { + return versions_gte($self->reference_version, + $other->reference_version) ? 1 : undef; + } + } + if ($other->version_operator eq $DOUBLE_GREATER_THAN) { + if ( $self->version_operator eq $DOUBLE_LESS_THAN + || $self->version_operator eq $LESS_THAN_OR_EQUAL) { + return versions_lte($self->reference_version, + $other->reference_version) ? 0 : undef; + } elsif ($self->version_operator eq $DOUBLE_GREATER_THAN) { + return versions_gte($self->reference_version, + $other->reference_version) ? 1 : undef; + } elsif ($self->version_operator eq $EQUAL) { + return versions_gt($self->reference_version, + $other->reference_version) ? 1 : 0; + } else { + return versions_gt($self->reference_version, + $other->reference_version) ? 1 : undef; + } + } + + return undef; +} + +=item satisfies_inverse + +=cut + +# This internal function does the heavy lifting of inverse implication between +# two elements. Takes two elements and returns true iff the falsehood of +# the second can be deduced from the truth of the first. In other words, self +# satisfies not other, or restated, other satisfies not self. (Since if a satisfies b, not b +# satisfies not a.) Due to the return value of implies_element(), we can let it +# do most of the work. +sub satisfies_inverse { + my ($self, $other) = @_; + + my $result = $self->satisfies($other); + return undef + if !defined $result; + + return $result ? 0 : 1; +} + +=item to_string + +=cut + +sub to_string { + my ($self) = @_; + + # return the original value + return $self->literal + unless $self->parsable; + + my $text = $self->name; + + $text .= $COLON . $self->multiarch_qualifier + if length $self->multiarch_qualifier; + + $text + .= $SPACE + . $LEFT_PARENS + . $self->version_operator + . $SPACE + . $self->reference_version + . $RIGHT_PARENS + if length $self->version_operator; + + $text.= $SPACE . $LEFT_SQUARE . $self->build_architecture . $RIGHT_SQUARE + if length $self->build_architecture; + + $text .= $SPACE . $LEFT_ANGLE . $self->build_profile . $RIGHT_ANGLE + if length $self->build_profile; + + return $text; +} + +=back + +=head1 AUTHOR + +Originally written by Russ Allbery <rra@debian.org> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Relation/Version.pm b/lib/Lintian/Relation/Version.pm new file mode 100644 index 0000000..d3552b7 --- /dev/null +++ b/lib/Lintian/Relation/Version.pm @@ -0,0 +1,213 @@ +# -*- perl -*- +# Lintian::Relation::Version -- comparison operators on Debian versions + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2004-2009 Russ Allbery <rra@debian.org> +# Copyright (C) 2009 Adam D. Barratt <adam@adam-barratt.org.uk> +# +# This program is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by the Free +# Software Foundation; either version 2 of the License, or (at your option) +# any later version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +# FITNESS FOR A PARTICULAR PURPOSE. See the GNU 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::Relation::Version; + +use v5.20; +use warnings; +use utf8; + +use Exporter qw(import); + +BEGIN { + our @EXPORT_OK = qw(versions_equal versions_lte versions_gte versions_lt + versions_gt versions_compare versions_comparator); + our %EXPORT_TAGS = ('all' => \@EXPORT_OK); +} + +use AptPkg::Config '$_config'; +use Carp qw(croak); +use Const::Fast; +use Unicode::UTF8 qw(encode_utf8); + +const my $EQUAL => q{=}; + +my $versioning = do { + my $config = AptPkg::Config->new; + $config->init; + $config->system->versioning; +}; + +=head1 NAME + +Lintian::Relation::Version - Comparison operators on Debian versions + +=head1 SYNOPSIS + + print encode_utf8("yes\n") if versions_equal('1.0', '1.00'); + print encode_utf8("yes\n") if versions_gte('1.1', '1.0'); + print encode_utf8("no\n") if versions_lte('1.1', '1.0'); + print encode_utf8("yes\n") if versions_gt('1.1', '1.0'); + print encode_utf8("no\n") if versions_lt('1.1', '1.1'); + print encode_utf8("yes\n") if versions_compare('1.1', '<=', '1.1'); + +=head1 DESCRIPTION + +This module provides five functions for comparing version numbers. The +underlying implementation uses C<libapt-pkg-perl> to ensure that +the results match what dpkg will expect. + +=head1 FUNCTIONS + +=over 4 + +=item versions_equal(A, B) + +Returns true if A is equal to B (C<=>) and false otherwise. + +=cut + +sub versions_equal { + my ($p, $q) = @_; + my $result; + + return 1 if $p eq $q; + + $result = $versioning->compare($p, $q); + + return ($result == 0); +} + +=item versions_lte(A, B) + +Returns true if A is less than or equal (C<< <= >>) to B and false +otherwise. + +=cut + +sub versions_lte { + my ($p, $q) = @_; + my $result; + + return 1 if $p eq $q; + + $result = $versioning->compare($p, $q); + + return ($result <= 0); +} + +=item versions_gte(A, B) + +Returns true if A is greater than or equal (C<< >= >>) to B and false +otherwise. + +=cut + +sub versions_gte { + my ($p, $q) = @_; + my $result; + + return 1 if $p eq $q; + + $result = $versioning->compare($p, $q); + + return ($result >= 0); +} + +=item versions_lt(A, B) + +Returns true if A is less than (C<<< << >>>) B and false otherwise. + +=cut + +sub versions_lt { + my ($p, $q) = @_; + my $result; + + return 0 if $p eq $q; + + $result = $versioning->compare($p, $q); + + return ($result < 0); +} + +=item versions_gt(A, B) + +Returns true if A is greater than (C<<< >> >>>) B and false otherwise. + +=cut + +sub versions_gt { + my ($p, $q) = @_; + my $result; + + return 0 if $p eq $q; + + $result = $versioning->compare($p, $q); + + return ($result > 0); +} + +=item versions_compare(A, OP, B) + +Returns true if A OP B, where OP is one of C<=>, C<< <= >>, C<< >= >>, +C<<< << >>>, or C<<< >> >>>, and false otherwise. + +=cut + +sub versions_compare { + my ($p, $op, $q) = @_; + if ($op eq $EQUAL) { return versions_equal($p, $q) } + elsif ($op eq '<=') { return versions_lte($p, $q) } + elsif ($op eq '>=') { return versions_gte($p, $q) } + elsif ($op eq '<<') { return versions_lt($p, $q) } + elsif ($op eq '>>') { return versions_gt($p, $q) } + else { croak encode_utf8("unknown operator $op") } +} + +=item versions_comparator (A, B) + +Returns -1, 0 or 1 if the version A is (respectively) less than, equal +to or greater than B. This is useful for (e.g.) sorting a list of +versions: + + foreach my $version (sort versions_comparator @versions) { + ... + } + +=cut + +# Use a prototype to avoid confusing Perl when used with sort. + +sub versions_comparator { + my ($p, $q) = @_; + return $versioning->compare($p, $q); +} + +=back + +=head1 AUTHOR + +Originally written by Russ Allbery <rra@debian.org> for Lintian and adapted +to use libapt-pkg-perl by Adam D. Barratt <adam@adam-barratt-org.uk>. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Reporting/ResourceManager.pm b/lib/Lintian/Reporting/ResourceManager.pm new file mode 100644 index 0000000..171b6b7 --- /dev/null +++ b/lib/Lintian/Reporting/ResourceManager.pm @@ -0,0 +1,233 @@ +# Copyright (C) 2014 Niels Thykier <niels@thykier.net> +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, you can find it on the World Wide +# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +# A simple resource manager for html_reports +package Lintian::Reporting::ResourceManager; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(croak); +use Const::Fast; +use File::Basename qw(basename); +use File::Copy qw(copy); +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::Util qw(get_file_digest); + +const my $SPACE => q{ }; +const my $SLASH => q{/}; +const my $EQUALS => q{=}; + +const my $BASE64_UNIT => 4; +const my $WIDELY_READABLE_FOLDER => oct(755); + +=head1 NAME + +Lintian::Reporting::ResourceManager -- A simple resource manager for html_reports + +=head1 SYNOPSIS + + use Lintian::Reporting::ResourceManager; + + my $resMan = Lintian::Reporting::ResourceManager->new( + 'html_dir' => 'path/to/HTML-root', + ); + # Copy the resource + $resMan->install_resource('path/to/my-image.png', { install_method => 'copy'} ); + # Move the resource + $resMan->install_resource('path/to/generated-styles.css'); + print encode_utf8('Image: ' . $resMan->resource_url('my-image.png'), "\n"); + print encode_utf8('CSS: ' . $resMan->resource_url('generated-styles.css'), "\n"); + +=head1 DESCRIPTION + +A simple resource manager for Lintian's reporting tool, +B<html_reports>. + + +=head1 CLASS METHODS + +=over 4 + +=item new(TYPE, OPTS) + +Instantiates a new resource manager. + +OPTS is a key-value list, which must contain the key "html_dir" set to +the root of the HTML path. It is beneath this path that all resources +will be installed + +=cut + +sub new { + my ($class, %opts) = @_; + my $self = {%opts,}; + croak encode_utf8('Missing required parameter html_dir (or it is undef)') + if not defined $opts{'html_dir'}; + $self->{'_resource_cache'} = {}; + $self->{'_resource_integrity'} = {}; + return bless($self, $class); +} + +=back + +=head1 INSTANCE METHODS + +=over 4 + +=item install_resource(RESOURCE[, OPT]) + +Installs RESOURCE into the html root. The resource may be renamed +(based on content etc.). + +Note that the basename of RESOURCE must be unique between all +resources installed. See L</resource_url(RESOURCE_NAME)>. + +If OPT is given, it must be a hashref with 0 or more of the following +keys (and values). + +=over 4 + +=item install_method + +Can be "copy" or "move" (default). If set to "move", the original file +will be renamed into its new location. Otherwise, a copy is done and +the original file is left in place. + +=item source_file + +By default, the path denoted by RESOURCE is both the resource name and +the source file. This option can be used to install a given file as +RESOURCE regardless of the basename of the source file. + +If this is passed, RESOURCE must be a basename (i.e. without any +slashes). + +=back + +=cut + +sub install_resource { + my ($self, $resource_name, $opt) = @_; + my $resource_root = $self->{'html_dir'} . '/resources'; + my $method = 'move'; + my ($basename, $install_name, $resource, $digest, $b64digest); + $method = $opt->{'install_method'} + if $opt && exists($opt->{'install_method'}); + if ($opt && exists($opt->{'source_file'})) { + $basename = $resource_name; + $resource = $opt->{'source_file'}; + + if ($basename =~ m{ / }msx) { + + croak encode_utf8( + join($SPACE, + qq(Resource "${resource_name}" must not contain "/"), + 'when source_file is given') + ); + } + } else { + $basename = basename($resource_name); + $resource = $resource_name; + } + $digest = get_file_digest('sha256', $resource); + $install_name = $digest->clone->hexdigest; + $b64digest = $digest->b64digest; + + while (length($b64digest) % $BASE64_UNIT) { + $b64digest .= $EQUALS; + } + + croak encode_utf8("Resource name ${basename} already in use") + if defined($self->{'_resource_cache'}{$basename}); + if ($basename =~ m/^.+(\.[^\.]+)$/xsm) { + my $ext = $1; + $install_name .= $ext; + } + + if (!-d $resource_root) { + mkdir($resource_root, $WIDELY_READABLE_FOLDER) + or die encode_utf8("Cannot mkdir $resource_root"); + } + + my $target_file = "$resource_root/$install_name"; + if ($method eq 'move') { + rename($resource, $target_file) + or die encode_utf8("Cannot rename $resource to $target_file"); + + } elsif ($method eq 'copy') { + copy($resource, $target_file) + or croak encode_utf8("Cannot copy $resource to $target_file: $!"); + } else { + croak encode_utf8( + join($SPACE, + "Unknown install method ${method}", + '- please use "move" or "copy"') + ); + } + $self->{'_resource_cache'}{$basename} = $target_file; + $self->{'_resource_integrity'}{$basename} = "sha256-${b64digest}"; + return; +} + +=item resource_url(RESOURCE_NAME) + +Returns the path (relative to the HTML root) to a resource installed +via L</install_resource(RESOURCE)>, where RESOURCE_NAME is the +basename of the path given to install_resource. + +=cut + +sub resource_url { + my ($self, $resource_name) = @_; + croak encode_utf8("Unknown resource $resource_name") + if not defined($self->{'_resource_cache'}{$resource_name}); + return $self->{'_resource_cache'}{$resource_name}; +} + +=item resource_integrity_value(RESOURCE_NAME) + +Return a string that is valid in the "integrity" field of a C<< <link> +>> HTML tag. (See https://www.w3.org/TR/SRI/) + +=cut + +sub resource_integrity_value { + my ($self, $resource_name) = @_; + croak encode_utf8("Unknown resource $resource_name") + if not defined($self->{'_resource_integrity'}{$resource_name}); + return $self->{'_resource_integrity'}{$resource_name}; +} + +=back + +=head1 AUTHOR + +Originally written by Niels Thykier <niels@thykier.net> for Lintian. + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Reporting/Util.pm b/lib/Lintian/Reporting/Util.pm new file mode 100644 index 0000000..ecf34cf --- /dev/null +++ b/lib/Lintian/Reporting/Util.pm @@ -0,0 +1,217 @@ +# Hey emacs! This is a -*- Perl -*- script! +# Lintian::Reporting::Util -- Perl utility functions for lintian's reporting framework + +# 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::Reporting::Util; + +=head1 NAME + +Lintian::Reporting::Util - Lintian utility functions + +=head1 SYNOPSIS + + use Lintian::Reporting::Util qw(load_state_cache find_backlog); + + my $cache = load_state_cache('path/to/state-dir'); + my @backlog = find_backlog('2.12', $cache); + +=head1 DESCRIPTION + +This module contains a number of utility subs that are nice to have +for the reporting framework, but on their own did not warrant their +own module. + +Most subs are imported only on request. + +=head1 FUNCTIONS + +=over 4 + +=cut + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Exporter qw(import); +use File::Temp qw(tempfile); +use List::Util qw(shuffle); +use Path::Tiny; +use Syntax::Keyword::Try; +use Unicode::UTF8 qw(encode_utf8); +use YAML::XS (); + +use Lintian::Relation::Version qw(versions_equal versions_comparator); + +our @EXPORT_OK = ( + qw( + load_state_cache + save_state_cache + find_backlog + ) +); + +const my $WIDELY_READABLE => oct(644); + +=item load_state_cache(STATE_DIR) + +[Reporting tools only] Load the state cache from STATE_DIR. + +=cut + +sub load_state_cache { + my ($state_dir) = @_; + my $state_file = "$state_dir/state-cache"; + my $state = {}; + + return $state + unless -e $state_file; + + my $yaml = path($state_file)->slurp; + + try { + $state = YAML::XS::Load($yaml); + + } catch { + # Not sure what Load does in case of issues; perldoc YAML says + # very little about it. Based on YAML::Error, I guess it will + # write stuff to STDERR and use die/croak, but it remains a + # guess. + die encode_utf8( + "$state_file was invalid; please fix or remove it.\n$@"); + } + + $state //= {}; + + if (ref($state) ne 'HASH') { + die encode_utf8("$state_file was invalid; please fix or remove it."); + } + return $state; +} + +=item save_state_cache(STATE_DIR, STATE) + +[Reporting tools only] Save the STATE cache to STATE_DIR. + +=cut + +sub save_state_cache { + my ($state_dir, $state) = @_; + my $state_file = "$state_dir/state-cache"; + my ($tmp_fd, $tmp_path); + + ($tmp_fd, $tmp_path) = tempfile('state-cache-XXXXXX', DIR => $state_dir); + ## TODO: Should tmp_fd be binmode'd as we use YAML::XS? + + # atomic replacement of the state file; not a substitute for + # proper locking, but it will at least ensure that the file + # is in a consistent state. + try { + print {$tmp_fd} encode_utf8(YAML::XS::Dump($state)); + + close($tmp_fd) or die encode_utf8("close $tmp_path: $!"); + + # There is no secret in this. Set it to 0644, so it does not + # require sudo access on lintian.d.o to read the file. + chmod($WIDELY_READABLE, $tmp_path); + + rename($tmp_path, $state_file) + or die encode_utf8("rename $tmp_path -> $state_file: $!"); + + } catch { + my $err = $@; + if (-e $tmp_path) { + # Ignore error as we have a more important one + unlink($tmp_path) + or warn encode_utf8("Cannot unlink $tmp_path"); + } + die encode_utf8($err); + + # perlcritic 1.140-1 requires the semicolon on the next line + }; + + return 1; +} + +=item find_backlog(LINTIAN_VERSION, STATE) + +[Reporting tools only] Given the current lintian version and the +harness state, return a list of group ids that are part of the +backlog. The list is sorted based on what version of Lintian +processed the package. + +Note the result is by design not deterministic to reduce the +risk of all large packages being in the same run (e.g. like +gcc-5 + gcc-5-cross + gcc-6 + gcc-6-cross). + +=cut + +sub find_backlog { + my ($lintian_version, $state) = @_; + my (@backlog, %by_version, @low_priority); + for my $group_id (keys(%{$state->{'groups'}})) { + my $last_version = '0'; + my $group_data = $state->{'groups'}{$group_id}; + my $is_out_of_date; + # Does this group repeatedly fail with the current version + # of lintian? + if ( exists($group_data->{'processing-errors'}) + and $group_data->{'processing-errors'} > 2 + and exists($group_data->{'last-error-by'}) + and $group_data->{'last-error-by'} ne $lintian_version) { + # To avoid possible "starvation", we will give lower priority + # to packages that repeatedly fail. They will be retried as + # the backlog is cleared. + push(@low_priority, $group_id); + next; + } + if (exists($group_data->{'out-of-date'})) { + $is_out_of_date = $group_data->{'out-of-date'}; + } + if (exists($group_data->{'last-processed-by'})) { + $last_version = $group_data->{'last-processed-by'}; + } + $is_out_of_date = 1 + if not versions_equal($last_version, $lintian_version); + push(@{$by_version{$last_version}}, $group_id) if $is_out_of_date; + } + for my $v (sort(versions_comparator keys(%by_version))) { + push(@backlog, shuffle(@{$by_version{$v}})); + } + push(@backlog, shuffle(@low_priority)) if @low_priority; + return @backlog; +} + +=back + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Screen.pm b/lib/Lintian/Screen.pm new file mode 100644 index 0000000..28d8c85 --- /dev/null +++ b/lib/Lintian/Screen.pm @@ -0,0 +1,80 @@ +# 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::Screen; + +use v5.20; +use warnings; +use utf8; + +use Moo::Role; +use namespace::clean; + +=head1 NAME + +Lintian::Screen -- Common facilities for Lintian screens + +=head1 SYNOPSIS + + use Moo; + use namespace::clean; + + with('Lintian::Screen'); + +=head1 DESCRIPTION + +A class for masking Lintian tags after they are issued + +=head1 INSTANCE METHODS + +=over 4 + +=item name + +=item advocates + +=item reason + +=item see_also + +=cut + +has name => (is => 'rw', default => sub { {} }); +has advocates => (is => 'rw', default => sub { {} }); +has reason => (is => 'rw', default => sub { {} }); +has see_also => (is => 'rw', default => sub { {} }); + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Screen/Autotools/LongLines.pm b/lib/Lintian/Screen/Autotools/LongLines.pm new file mode 100644 index 0000000..1de9b85 --- /dev/null +++ b/lib/Lintian/Screen/Autotools/LongLines.pm @@ -0,0 +1,61 @@ +# 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::Screen::Autotools::LongLines; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Screen'; + +sub suppress { + my ($self, $processable, $hint) = @_; + + my $item = $hint->pointer->item; + + # ./configure script in source root only + return 1 + if $item->name eq 'configure' + && ( defined $processable->patched->resolve_path('configure.in') + || defined $processable->patched->resolve_path('configure.ac')); + + # Automake's Makefile.in in any folder + return 1 + if $item->basename eq 'Makefile.in' + && defined $processable->patched->resolve_path( + $item->dirname . '/Makefile.am'); + + # any m4 macro as long as ./configure is present + return 1 + if $item->name =~ m{^ m4/ }x + && defined $processable->patched->resolve_path('configure'); + + 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/Screen/Coq/Cmxs/Prerequisites.pm b/lib/Lintian/Screen/Coq/Cmxs/Prerequisites.pm new file mode 100644 index 0000000..aaf4600 --- /dev/null +++ b/lib/Lintian/Screen/Coq/Cmxs/Prerequisites.pm @@ -0,0 +1,49 @@ +# 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::Screen::Coq::Cmxs::Prerequisites; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Screen'; + +sub suppress { + my ($self, $processable, $hint) = @_; + + my $item = $hint->pointer->item; + + return 1 + if $item->name =~ m{ [.]cmxs $}x + && ( $processable->type eq 'binary' + || $processable->type eq 'udeb'); + + 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/Screen/Emacs/Elpa/Scripts.pm b/lib/Lintian/Screen/Emacs/Elpa/Scripts.pm new file mode 100644 index 0000000..a943620 --- /dev/null +++ b/lib/Lintian/Screen/Emacs/Elpa/Scripts.pm @@ -0,0 +1,50 @@ +# 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::Screen::Emacs::Elpa::Scripts; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Screen'; + +sub suppress { + my ($self, $processable, $hint) = @_; + + my $item = $hint->pointer->item; + + return 1 + if $item->name =~ m{^usr/lib/emacsen-common/packages/} + && ( $processable->type eq 'binary' + || $processable->type eq 'udeb') + && $processable->relation('strong')->satisfies('emacsen-common'); + + 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/Screen/Examples/InTests.pm b/lib/Lintian/Screen/Examples/InTests.pm new file mode 100644 index 0000000..c1bc63f --- /dev/null +++ b/lib/Lintian/Screen/Examples/InTests.pm @@ -0,0 +1,47 @@ +# 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::Screen::Examples::InTests; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Screen'; + +sub suppress { + my ($self, $processable, $hint) = @_; + + my $item = $hint->pointer->item; + + return 1 + if $item->name =~ m{^ test s? / }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/Screen/Examples/Ship/Devhelp.pm b/lib/Lintian/Screen/Examples/Ship/Devhelp.pm new file mode 100644 index 0000000..2727628 --- /dev/null +++ b/lib/Lintian/Screen/Examples/Ship/Devhelp.pm @@ -0,0 +1,47 @@ +# 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::Screen::Examples::Ship::Devhelp; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Screen'; + +sub suppress { + my ($self, $processable, $hint) = @_; + + my $item = $hint->pointer->item; + + return 1 + if $item->name =~ m{^ usr/share/doc/ [^/]+ /examples/ }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/Screen/Glibc/Control/Ldconfig.pm b/lib/Lintian/Screen/Glibc/Control/Ldconfig.pm new file mode 100644 index 0000000..403d940 --- /dev/null +++ b/lib/Lintian/Screen/Glibc/Control/Ldconfig.pm @@ -0,0 +1,45 @@ +# 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::Screen::Glibc::Control::Ldconfig; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Screen'; + +sub suppress { + my ($self, $processable, $hint) = @_; + + return 1 + if $processable->source_name eq 'glibc'; + + 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/Screen/Python/Egg/Metadata.pm b/lib/Lintian/Screen/Python/Egg/Metadata.pm new file mode 100644 index 0000000..facff08 --- /dev/null +++ b/lib/Lintian/Screen/Python/Egg/Metadata.pm @@ -0,0 +1,53 @@ +# 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::Screen::Python::Egg::Metadata; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Screen'; + +sub suppress { + my ($self, $processable, $hint) = @_; + + my $item = $hint->pointer->item; + + return 1 + if $item->dirname =~ m{ [^/] [.] dist-info / $}x + && defined $item->parent_dir->child('METADATA') + && defined $item->parent_dir->child('WHEEL'); + + return 1 + if $item->dirname =~ m{ [^/] [.] egg-info / $}x + && defined $item->parent_dir->child('PKG-INFO'); + + 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/Screen/Toolchain/Gnat/AliReadOnly.pm b/lib/Lintian/Screen/Toolchain/Gnat/AliReadOnly.pm new file mode 100644 index 0000000..682f549 --- /dev/null +++ b/lib/Lintian/Screen/Toolchain/Gnat/AliReadOnly.pm @@ -0,0 +1,52 @@ +# 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::Screen::Toolchain::Gnat::AliReadOnly; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Screen'; + +sub suppress { + my ($self, $processable, $hint) = @_; + + my $item = $hint->pointer->item; + + return 1 + if $item->name + =~ m{^ usr/lib/ [^/]+ /ada/adalib/ [^/]+ / [^/]+ [.] ali \b }x + && ( $processable->type eq 'binary' + || $processable->type eq 'udeb') + && $processable->name =~ /-dev$/ + && $processable->relation('strong')->satisfies('gnat'); + + 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/Screen/Web/Cgi/Scripts.pm b/lib/Lintian/Screen/Web/Cgi/Scripts.pm new file mode 100644 index 0000000..f667111 --- /dev/null +++ b/lib/Lintian/Screen/Web/Cgi/Scripts.pm @@ -0,0 +1,48 @@ +# 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::Screen::Web::Cgi::Scripts; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Screen'; + +sub suppress { + my ($self, $processable, $hint) = @_; + + my $item = $hint->pointer->item; + + return 1 + if ($item->is_script || $item->is_elf) + && $item->name =~ m{^ usr/lib/cgi-bin/ }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/SlidingWindow.pm b/lib/Lintian/SlidingWindow.pm new file mode 100644 index 0000000..2274d78 --- /dev/null +++ b/lib/Lintian/SlidingWindow.pm @@ -0,0 +1,171 @@ +# -*- perl -*- + +# Copyright (C) 2013 Bastien ROUCARIES +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::SlidingWindow; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Unicode::UTF8 qw(encode_utf8); + +use Moo; +use namespace::clean; + +const my $DEFAULT_BLOCK_SIZE => 4096; +const my $EMPTY => q{}; + +has handle => (is => 'rw'); +has blocksize => (is => 'rw', default => $DEFAULT_BLOCK_SIZE); +has blocknumber => (is => 'rw', default => -1); +has blocksub => (is => 'rw', default => undef); +has _queue => (is => 'rw', default => sub {[q{}, q{}]}); + +sub readwindow { + my ($self) = @_; + my $window; + + my $first = $self->blocknumber < 0; + { + # This path is too hot for autodie at its current performance + # (at the time of writing, that would be autodie/2.23). + # - Benchmark chromium-browser/32.0.1700.123-2/source + no autodie qw(read); + my $blocksize = $self->blocksize; + # Read twice the amount in the first window and split that + # into "two parts". That way we avoid half a block followed + # by a full block with the first half being identical to the + # previous one. + $blocksize *= 2 if $first; + my $res = read($self->handle, $window, $blocksize); + if (not $res) { + die encode_utf8("read failed: $!\n") unless defined($res); + return; + } + } + + if(defined($self->blocksub)) { + local $_ = $window; + $self->blocksub->(); + $window = $_; + } + + $self->blocknumber($self->blocknumber + 1); + + if ($first && $self->blocksize < length($window)) { + # Split the first block into two windows. We assume here that + # if the two halves are not of equal length, then it is + # because the file is shorter than 2*blocksize. In this case, + # make the second half the shorter (it shouldn't matter and it + # is easier to do this way). + my $blocksize = $self->blocksize; + $self->_queue->[0] = substr($window, 0, $blocksize); + $self->_queue->[1] = substr($window, $blocksize); + return $window; + } + shift(@{$self->_queue}); + push(@{$self->_queue}, $window); + return join($EMPTY, @{$self->_queue}); +} + +=head1 NAME + +Lintian::SlidingWindow - Lintian interface to sliding window match + +=head1 SYNOPSIS + + use Lintian::SlidingWindow; + + my $sfd = Lintian::SlidingWindow->new('<','someevilfile.c', sub { $_ = lc($_); }); + my $window; + while ($window = $sfd->readwindow) { + if (index($window, 'evil') > -1) { + if($window =~ + m/software \s++ shall \s++ + be \s++ used \s++ for \s++ good \s*+ ,?+ \s*+ + not \s++ evil/xsim) { + # do something like : tag 'license-problem-json-evil'; + } + } + } + +=head1 DESCRIPTION + +Lintian::SlidingWindow provides a way of matching some pattern, +including multi line pattern, without needing to fully load the +file in memory. + +=head1 CLASS METHODS + +=over 4 + +=item new(HANDLE[, BLOCKSUB[, BLOCKSIZE]]) + +Create a new sliding window by reading from a given HANDLE, which must +be open for reading. Optionally run BLOCKSUB against each block. Note +that BLOCKSUB should apply transform byte by byte and does not depend +of context. + +Each window consists of up to two blocks of BLOCKSIZE characters. + +=back + +=head1 INSTANCE METHODS + +=over 4 + +=item readwindow + +Return a new block of sliding window. Return undef at end of file. + +=item C<blocksize> + +=item blocknumber + +=item handle + +=item blocksub + +=back + +=head1 DIAGNOSTICS + +=over 4 + +=item no data type specified + +=back + +=head1 AUTHOR + +Originally written by Bastien ROUCARIES for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Spelling.pm b/lib/Lintian/Spelling.pm new file mode 100644 index 0000000..1a8d7fc --- /dev/null +++ b/lib/Lintian/Spelling.pm @@ -0,0 +1,295 @@ +# -*- perl -*- +# Lintian::Spelling -- Lintian spelling checks shared between multiple scripts + +# Copyright (C) 2009 Russ Allbery +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 1998 Richard Braakman +# Copyright (C) 2023 Axel Beckert +# +# This program is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by the Free +# Software Foundation; either version 2 of the License, or (at your option) +# any later version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +# FITNESS FOR A PARTICULAR PURPOSE. See the GNU 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::Spelling; + +use v5.20; +use warnings; +use utf8; + +use Exporter qw(import); + +our @EXPORT_OK = qw( + check_spelling + check_spelling_picky +); + +use Carp qw(croak); +use Const::Fast; +use Unicode::UTF8 qw(encode_utf8); + +const my $SPACE => q{ }; +const my $DOUBLE_QUOTE => q{"}; + +=head1 NAME + +Lintian::Spelling -- Lintian spell checks shared between multiple scripts + +=head1 SYNOPSIS + + use Lintian::Spelling qw(check_spelling); + +=head1 DESCRIPTION + +This module provides functions to do some Lintian checks that need to be +done in multiple places. There are certain low-level checks, such as +validating a maintainer name and e-mail address or checking spelling, +which apply in multiple situations and should be done in multiple checks +scripts or in checks scripts and the Lintian front-end. + +The functions provided by this module issue tags directly, usually either +taking the tag name to issue as an argument or dynamically constructing +the tag name based on function parameters. The caller is responsible for +ensuring that all tags are declared in the relevant *.desc file with +proper descriptions and other metadata. The possible tags issued by each +function are described in the documentation for that function. + +=head1 FUNCTIONS + +=over 4 + +=item check_spelling(TEXT,[ EXCEPTIONS,] CODEREF) + +Performs a spelling check of TEXT. Call CODEREF once for each unique +misspelling with the following arguments: + +=over 4 + +=item The misspelled word/phrase + +=item The correct word/phrase + +=back + +If EXCEPTIONS is given, it will be used as an array ref of exceptions. +Any lowercase word appearing as a key of that array will never be +considered a spelling mistake (exception being if it is a part of a +multiword misspelling). + +Returns the number of spelling mistakes found in TEXT. + +=cut + +my (%CORRECTIONS, @CORRECTIONS_MULTIWORD); + +sub check_spelling { + my ($data, $text, $acceptable, $code_ref, $duplicate_check) = @_; + + croak encode_utf8('No spelling data') + unless defined $data; + + return 0 + unless $text; + + if ( !defined $code_ref + && defined $acceptable + && ref($acceptable) eq 'CODE') { + $code_ref = $acceptable; + $acceptable = []; + } + + $acceptable //= []; + $duplicate_check //= 1; + + my %exceptions = map { $_ => 1 } @{$acceptable}; + + my (%seen, %duplicates, $last_word, $quoted); + my $counter = 0; + my $text_orig = $text; + + if (!%CORRECTIONS) { + my $corrections_multiword + = $data->load('spelling/corrections-multiword', '\|\|'); + my $corrections = $data->load('spelling/corrections', '\|\|'); + for my $misspelled ($corrections->all) { + $CORRECTIONS{$misspelled} = $corrections->value($misspelled); + } + for my $misspelled_regex ($corrections_multiword->all) { + my $correct = $corrections_multiword->value($misspelled_regex); + push(@CORRECTIONS_MULTIWORD, + [qr/\b($misspelled_regex)\b/, $correct]); + } + } + + $text =~ tr/[]//d; + # Strip () except for "(s)" suffixes. + $text =~ s/(\((?!s\))|(?<!\(s)\))//gi; + $text =~ s/(\w-)\s*\n\s*/$1/; + $text =~ tr/\r\n \t/ /s; + $text =~ s/\s++/ /g; + + # trim both ends + $text =~ s/^\s+|\s+$//g; + + for my $word (split($SPACE, $text)) { + my $ends_with_punct = 0; + my $q = $word =~ tr/"/"/; + # Change quoting on "foo or foo" but not "foo". + if ($q & 1) { + $quoted = not $quoted; + } + $ends_with_punct = 1 if $word =~ s/[.,;:?!]+$//; + + if ($duplicate_check and defined($last_word) and $last_word eq $word) { + # Avoid flagging words inside quoted text. + $code_ref->("$word $word (duplicate word)", $word) + if not $quoted + and not $duplicates{$word}++ + and not $ends_with_punct + and $text_orig !~ /\b$word\s*\($word\b/ + and $text_orig !~ /\b$word\)\s*$word\b/; + } + + if ($word =~ m/^[A-Za-z]+$/ and not $ends_with_punct) { + $last_word = $word; + } else { + $last_word = undef; + } + + next + if $word =~ /^[A-Z]{1,5}\z/; + + # Some exceptions are based on case (e.g. "teH"). + next + if exists $exceptions{$word}; + + my $lcword = lc $word; + if (exists $CORRECTIONS{$lcword} + && !exists $exceptions{$lcword}) { + + $counter++; + my $correction = $CORRECTIONS{$lcword}; + + if ($word =~ /^[A-Z]+$/) { + $correction = uc $correction; + } elsif ($word =~ /^[A-Z]/) { + $correction = ucfirst $correction; + } + + next + if $seen{$lcword}++; + + $code_ref->($word, $correction); + } + } + + # Special case for correcting multi-word strings. + for my $cm (@CORRECTIONS_MULTIWORD) { + my ($oregex, $correction) = @{$cm}; + if ($text =~ $oregex) { + my $word = $1; + if ($word =~ /^[A-Z]+$/) { + $correction = uc $correction; + } elsif ($word =~ /^[A-Z]/) { + $correction = ucfirst $correction; + } + $counter++; + next if $seen{lc $word}++; + $code_ref->( + $DOUBLE_QUOTE . $word . $DOUBLE_QUOTE, + $DOUBLE_QUOTE . $correction . $DOUBLE_QUOTE + ); + } + } + + return $counter; +} + +=item check_spelling_picky(TEXT, CODEREF) + +Performs a spelling check of TEXT. Call CODEREF once for each unique +misspelling with the following arguments: + +=over 4 + +=item The misspelled word/phrase + +=item The correct word/phrase + +=back + +This method performs some pickier corrections - such as checking for common +capitalization mistakes - which would are not included in check_spelling as +they are not appropriate for some files, such as changelogs. + +Returns the number of spelling mistakes found in TEXT. + +=cut + +sub check_spelling_picky { + my ($data, $text, $code_ref) = @_; + + croak encode_utf8('No spelling data') + unless defined $data; + + my %seen; + my $counter = 0; + my $corrections_case= $data->load('spelling/corrections-case', '\|\|'); + + # Check this first in case it's contained in square brackets and + # removed below. + if ($text =~ /meta\s+package/) { + $counter++; + $code_ref->('meta package', 'metapackage'); + } + + # Exclude text enclosed in square brackets as it could be a package list + # or similar which may legitimately contain lower-cased versions of + # the words. + $text =~ s/\[.+?\]//sg; + $text =~ tr/\r\n \t/ /s; + $text =~ s/\s++/ /g; + + # trim both ends + $text =~ s/^\s+|\s+$//g; + + for my $word (split(/\s+/, $text)) { + $word =~ s/^\(|[).,?!:;]+$//g; + if ($corrections_case->recognizes($word)) { + $counter++; + next if $seen{$word}++; + $code_ref->($word, $corrections_case->value($word)); + } + } + + return $counter; +} + +=back + +=head1 AUTHOR + +Originally written by Russ Allbery <rra@debian.org> for Lintian. Based on +code from checks scripts by Marc Brockschmidt and Richard Braakman. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Storage/MLDBM.pm b/lib/Lintian/Storage/MLDBM.pm new file mode 100644 index 0000000..f58cb8c --- /dev/null +++ b/lib/Lintian/Storage/MLDBM.pm @@ -0,0 +1,128 @@ +# -*- perl -*- Lintian::Storage::MLDBM +# +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Storage::MLDBM; + +use v5.20; +use warnings; +use utf8; + +use BerkeleyDB; +use Const::Fast; +use MLDBM qw(BerkeleyDB::Btree Storable); +use Path::Tiny; +use Syntax::Keyword::Try; +use Unicode::UTF8 qw(encode_utf8 decode_utf8); + +const my $EMPTY => q{}; +const my $HYPHEN => q{-}; + +use Moo; +use namespace::clean; + +=head1 NAME + +Lintian::Storage::MLDBM - store multi-level hashes on disk + +=head1 SYNOPSIS + + use Lintian::Storage::MLDBM; + +=head1 DESCRIPTION + +Lintian::Storage::MLDBM provides an interface to store data on disk to preserve memory. + +=head1 INSTANCE METHODS + +=over 4 + +=item tempfile + +=item tied_hash + +=cut + +has tempfile => (is => 'rw'); +has tied_hash => (is => 'rw', default => sub { {} }); + +=item create + +=cut + +sub create { + my ($self, $description) = @_; + + $description //= $EMPTY; + + $description .= $HYPHEN + if length $description; + + my $stem = "mldbm-$description"; + + my $tempfile + = Path::Tiny->tempfile(TEMPLATE => $stem . 'XXXXXXXX', UNLINK => 0); + $self->tempfile($tempfile); + + try { + tie( + %{$self->tied_hash}, 'MLDBM', + -Filename => $tempfile->stringify, + -Flags => DB_CREATE + ); + + } catch { + die encode_utf8("Cannot create database in $tempfile: $@"); + }; + + return; +} + +=item DEMOLISH + +=cut + +sub DEMOLISH { + my ($self, $in_global_destruction) = @_; + + untie %{$self->tied_hash}; + + $self->tempfile->remove + if defined $self->tempfile; + + return; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for +Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Tag.pm b/lib/Lintian/Tag.pm new file mode 100644 index 0000000..7c93086 --- /dev/null +++ b/lib/Lintian/Tag.pm @@ -0,0 +1,297 @@ +# -*- perl -*- +# Lintian::Tag -- interface to tag metadata + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2009 Russ Allbery +# 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, see <http://www.gnu.org/licenses/>. + +package Lintian::Tag; + +use v5.20; +use warnings; +use utf8; + +use Carp qw(croak); +use Const::Fast; +use Email::Address::XS; +use List::SomeUtils qw(none first_value); +use Syntax::Keyword::Try; +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::Deb822; + +use Moo; +use namespace::clean; + +const my $EMPTY => q{}; +const my $SLASH => q{/}; + +# Ordered lists of visibilities, used for display level parsing. +our @VISIBILITIES= qw(classification pedantic info warning error); + +=head1 NAME + +Lintian::Tag - Lintian interface to tag metadata + +=head1 SYNOPSIS + + my $tag = Lintian::Tag->new; + +=head1 DESCRIPTION + +This module provides an interface to tag metadata as gleaned from the +*.desc files describing the checks. It can be used to retrieve specific +metadata elements or to format the tag description. + +=head1 INSTANCE METHODS + +=over 4 + +=item name + +=item visibility + +=item check + +=item name_spaced + +=item show_always + +=item experimental + +=item explanation + +=item see_also + +=item renamed_from + +=item profile + +=cut + +has name => ( + is => 'rw', + coerce => sub { my ($text) = @_; return ($text // $EMPTY); }, + default => $EMPTY +); + +has visibility => ( + is => 'rw', + lazy => 1, + coerce => sub { + my ($text) = @_; + + $text //= $EMPTY; + croak encode_utf8("Unknown tag visibility $text") + if none { $text eq $_ } @VISIBILITIES; + + return $text; + }, + default => $EMPTY +); + +has check => ( + is => 'rw', + coerce => sub { my ($text) = @_; return ($text // $EMPTY); }, + default => $EMPTY +); + +has name_spaced => ( + is => 'rw', + coerce => sub { my ($boolean) = @_; return ($boolean // 0); }, + default => 0 +); + +has show_always => ( + is => 'rw', + coerce => sub { my ($boolean) = @_; return ($boolean // 0); }, + default => 0 +); + +has experimental => ( + is => 'rw', + coerce => sub { my ($boolean) = @_; return ($boolean // 0); }, + default => 0 +); + +has explanation => ( + is => 'rw', + coerce => sub { my ($text) = @_; return ($text // $EMPTY); }, + default => $EMPTY +); + +has see_also => ( + is => 'rw', + coerce => sub { my ($arrayref) = @_; return ($arrayref // []); }, + default => sub { [] } +); + +has renamed_from => ( + is => 'rw', + coerce => sub { my ($arrayref) = @_; return ($arrayref // []); }, + default => sub { [] } +); + +has screens => ( + is => 'rw', + coerce => sub { my ($arrayref) = @_; return ($arrayref // []); }, + default => sub { [] } +); + +=item load(PATH) + +Loads a tag description from PATH. + +=cut + +sub load { + my ($self, $profile, $tagpath) = @_; + + croak encode_utf8('No profile') + unless defined $profile; + + croak encode_utf8("Cannot read tag file from $tagpath") + unless -r $tagpath; + + my $deb822 = Lintian::Deb822->new; + my @sections = $deb822->read_file($tagpath); + + my $fields = shift @sections; + + $self->check($fields->value('Check')); + $self->name_spaced($fields->value('Name-Spaced') eq 'yes'); + $self->show_always($fields->value('Show-Always') eq 'yes'); + + my $name = $fields->value('Tag'); + $name = $self->check . $SLASH . $name + if $self->name_spaced; + + $self->name($name); + + $self->visibility($fields->value('Severity')); + $self->experimental($fields->value('Experimental') eq 'yes'); + + $self->explanation($fields->text('Explanation') || $fields->text('Info')); + + my @see_also = $fields->trimmed_list('See-Also', qr{,}); + @see_also = $fields->trimmed_list('Ref', qr{,}) + unless @see_also; + + $self->see_also(\@see_also); + + $self->renamed_from([$fields->trimmed_list('Renamed-From')]); + + croak encode_utf8("No Tag field in $tagpath") + unless length $self->name; + + my @screens; + for my $section (@sections) { + + my $screen_name = $section->value('Screen'); + + my $relative = $screen_name; + $relative =~ s{^([[:lower:]])}{\U$1}; + $relative =~ s{/([[:lower:]])}{/\U$1}g; + $relative =~ s{-([[:lower:]])}{\U$1}g; + + $relative .= '.pm'; + + my @candidates= map { + ( + ($_ // q{.})."/lib/Lintian/Screen/$relative", + ($_ // q{.})."/screens/$relative" + ) + } @{$profile->safe_include_dirs}; + + my $absolute = first_value { -e } @candidates; + die encode_utf8( + "Cannot find screen $screen_name (looking for $relative)") + unless length $absolute; + + try { + require $absolute; + } catch { + die encode_utf8("Cannot load screen $absolute: $@"); + } + + my $module = $relative; + $module =~ s{ [.]pm $}{}x; + $module =~ s{/}{::}g; + + my $screen = "Lintian::Screen::$module"->new; + + $screen->name($screen_name); + + my @advocates= Email::Address::XS->parse($section->value('Advocates')); + $screen->advocates(\@advocates); + + $screen->reason($section->text('Reason')); + + my @see_also_screen = $section->trimmed_list('See-Also', qr{,}); + $screen->see_also(\@see_also_screen); + + push(@screens, $screen); + } + + $self->screens(\@screens); + + return; +} + +=item code() + +Returns the one-letter code for the tag. This will be a letter chosen +from C<E>, C<W>, C<I>, or C<P>, based on the tag visibility, and +other attributes (such as whether experimental is set). This code will +never be C<O> or C<X>; overrides and experimental tags are handled +separately. + +=cut + +# Map visibility levels to tag codes. +our %CODES = ( + 'error' => 'E', + 'warning' => 'W', + 'info' => 'I', + 'pedantic' => 'P', + 'classification' => 'C', +); + +sub code { + my ($self) = @_; + + return $CODES{$self->visibility}; +} + +=back + +=head1 AUTHOR + +Originally written by Russ Allbery <rra@debian.org> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Util.pm b/lib/Lintian/Util.pm new file mode 100644 index 0000000..c512451 --- /dev/null +++ b/lib/Lintian/Util.pm @@ -0,0 +1,674 @@ +# Hey emacs! This is a -*- Perl -*- script! +# Lintian::Util -- Perl utility functions for lintian + +# Copyright (C) 1998 Christian Schwarz +# 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::Util; + +use v5.20; +use warnings; +use utf8; + +use Exporter qw(import); + +# Force export as soon as possible, since some of the modules we load also +# depend on us and the sequencing can cause things not to be exported +# otherwise. +our @EXPORT_OK; + +BEGIN { + + @EXPORT_OK = ( + qw( + get_file_checksum + get_file_digest + human_bytes + perm2oct + locate_executable + match_glob + normalize_pkg_path + normalize_link_target + is_ancestor_of + drain_pipe + drop_relative_prefix + read_md5sums + utf8_clean_log + utf8_clean_bytes + version_from_changelog + $PKGNAME_REGEX + $PKGREPACK_REGEX + $PKGVERSION_REGEX + ) + ); +} + +use Carp qw(croak); +use Const::Fast; +use Cwd qw(abs_path); +use Digest::MD5; +use Digest::SHA; +use List::SomeUtils qw(first_value); +use Path::Tiny; +use Regexp::Wildcards; +use Unicode::UTF8 qw(valid_utf8 encode_utf8); + +use Lintian::Deb822; +use Lintian::Changelog; +use Lintian::Relation::Version qw(versions_equal versions_comparator); + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $NEWLINE => qq{\n}; +const my $SLASH => q{/}; +const my $DOT => q{.}; +const my $DOUBLEDOT => q{..}; +const my $BACKSLASH => q{\\}; + +const my $DEFAULT_READ_SIZE => 4096; +const my $KIB_UNIT_FACTOR => 1024; +const my $COMFORT_THRESHOLD => 1536; + +const my $OWNER_READ => oct(400); +const my $OWNER_WRITE => oct(200); +const my $OWNER_EXECUTE => oct(100); +const my $SETUID => oct(4000); +const my $SETUID_OWNER_EXECUTE => oct(4100); +const my $GROUP_READ => oct(40); +const my $GROUP_WRITE => oct(20); +const my $GROUP_EXECUTE => oct(10); +const my $SETGID => oct(2000); +const my $SETGID_GROUP_EXECUTE => oct(2010); +const my $WORLD_READ => oct(4); +const my $WORLD_WRITE => oct(2); +const my $WORLD_EXECUTE => oct(1); +const my $STICKY => oct(1000); +const my $STICKY_WORLD_EXECUTE => oct(1001); + +# preload cache for common permission strings +# call overhead o perm2oct was measurable on chromium-browser/32.0.1700.123-2 +# load time went from ~1.5s to ~0.1s; of 115363 paths, only 306 were uncached +# standard file, executable file, standard dir, dir with suid, symlink +my %OCTAL_LOOKUP = map { $_ => perm2oct($_) } qw( + -rw-r--r-- + -rwxr-xr-x + drwxr-xr-x + drwxr-sr-x + lrwxrwxrwx +); + +my $rw = Regexp::Wildcards->new(type => 'jokers'); + +=head1 NAME + +Lintian::Util - Lintian utility functions + +=head1 SYNOPSIS + + use Lintian::Util; + +=head1 DESCRIPTION + +This module contains a number of utility subs that are nice to have, +but on their own did not warrant their own module. + +Most subs are imported only on request. + +=head1 VARIABLES + +=over 4 + +=item $PKGNAME_REGEX + +Regular expression that matches valid package names. The expression +is not anchored and does not enforce any "boundary" characters. + +=cut + +our $PKGNAME_REGEX = qr/[a-z0-9][-+\.a-z0-9]+/; + +=item $PKGREPACK_REGEX + +Regular expression that matches "repacked" package names. The expression is +not anchored and does not enforce any "boundary" characters. It should only +be applied to the upstream portion (see #931846). + +=cut + +our $PKGREPACK_REGEX = qr/(dfsg|debian|ds|repack)/; + +=item $PKGVERSION_REGEX + +Regular expression that matches valid package versions. The +expression is not anchored and does not enforce any "boundary" +characters. + +=cut + +our $PKGVERSION_REGEX = qr{ + (?: \d+ : )? # Optional epoch + [0-9][0-9A-Za-z.+:~]* # Upstream version (with no hyphens) + (?: - [0-9A-Za-z.+:~]+ )* # Optional debian revision (+ upstreams versions with hyphens) + }xa; + +=back + +=head1 FUNCTIONS + +=over 4 + +=item drain_pipe(FD) + +Reads and discards any remaining contents from FD, which is assumed to +be a pipe. This is mostly done to avoid having the "write"-end die +with a SIGPIPE due to a "broken pipe" (which can happen if you just +close the pipe). + +May cause an exception if there are issues reading from the pipe. + +Caveat: This will block until the pipe is closed from the "write"-end, +so only use it with pipes where the "write"-end will eventually close +their end by themselves (or something else will make them close it). + +=cut + +sub drain_pipe { + my ($fd) = @_; + my $buffer; + + 1 while (read($fd, $buffer, $DEFAULT_READ_SIZE) > 0); + + return 1; +} + +=item get_file_digest(ALGO, FILE) + +Creates an ALGO digest object that is seeded with the contents of +FILE. If you just want the hex digest, please use +L</get_file_checksum(ALGO, FILE)> instead. + +ALGO can be 'md5' or shaX, where X is any number supported by +L<Digest::SHA> (e.g. 'sha256'). + +This sub is a convenience wrapper around Digest::{MD5,SHA}. + +=cut + +sub get_file_digest { + my ($alg, $file) = @_; + + open(my $fd, '<', $file) + or die encode_utf8("Cannot open $file"); + + my $digest; + if (lc($alg) eq 'md5') { + $digest = Digest::MD5->new; + } elsif (lc($alg) =~ /sha(\d+)/) { + $digest = Digest::SHA->new($1); + } + $digest->addfile($fd); + close($fd); + + return $digest; +} + +=item get_file_checksum(ALGO, FILE) + +Returns a hexadecimal string of the message digest checksum generated +by the algorithm ALGO on FILE. + +ALGO can be 'md5' or shaX, where X is any number supported by +L<Digest::SHA> (e.g. 'sha256'). + +This sub is a convenience wrapper around Digest::{MD5,SHA}. + +=cut + +sub get_file_checksum { + my @paths = @_; + + my $digest = get_file_digest(@paths); + + return $digest->hexdigest; +} + +=item perm2oct(PERM) + +Translates PERM to an octal permission. PERM should be a string describing +the permissions as done by I<tar t> or I<ls -l>. That is, it should be a +string like "-rw-r--r--". + +If the string does not appear to be a valid permission, it will cause +a trappable error. + +Examples: + + # Good + perm2oct('-rw-r--r--') == oct(644) + perm2oct('-rwxr-xr-x') == oct(755) + + # Bad + perm2oct('broken') # too short to be recognised + perm2oct('-resurunet') # contains unknown permissions + +=cut + +sub perm2oct { + my ($text) = @_; + + my $lookup = $OCTAL_LOOKUP{$text}; + return $lookup + if defined $lookup; + + my $octal = 0; + + # Types: + # file (-), block/character device (b & c), directory (d), + # hardlink (h), symlink (l), named pipe (p). + if ( + $text !~ m{^ [-bcdhlp] # file type + ([-r])([-w])([-xsS]) # user + ([-r])([-w])([-xsS]) # group + ([-r])([-w])([-xtT]) # other + }xsm + ) { + croak encode_utf8("$text does not appear to be a permission string"); + } + + $octal |= $OWNER_READ if $1 eq 'r'; + $octal |= $OWNER_WRITE if $2 eq 'w'; + $octal |= $OWNER_EXECUTE if $3 eq 'x'; + $octal |= $SETUID if $3 eq 'S'; + $octal |= $SETUID_OWNER_EXECUTE if $3 eq 's'; + $octal |= $GROUP_READ if $4 eq 'r'; + $octal |= $GROUP_WRITE if $5 eq 'w'; + $octal |= $GROUP_EXECUTE if $6 eq 'x'; + $octal |= $SETGID if $6 eq 'S'; + $octal |= $SETGID_GROUP_EXECUTE if $6 eq 's'; + $octal |= $WORLD_READ if $7 eq 'r'; + $octal |= $WORLD_WRITE if $8 eq 'w'; + $octal |= $WORLD_EXECUTE if $9 eq 'x'; + $octal |= $STICKY if $9 eq 'T'; + $octal |= $STICKY_WORLD_EXECUTE if $9 eq 't'; + + $OCTAL_LOOKUP{$text} = $octal; + + return $octal; +} + +=item human_bytes(SIZE) + +=cut + +sub human_bytes { + my ($size) = @_; + + my @units = qw(B kiB MiB GiB); + + my $unit = shift @units; + + while ($size > $COMFORT_THRESHOLD && @units) { + + $size /= $KIB_UNIT_FACTOR; + $unit = shift @units; + } + + my $human = sprintf('%.0f %s', $size, $unit); + + return $human; +} + +=item locate_executable (CMD) + +=cut + +sub locate_executable { + my ($command) = @_; + + return $EMPTY + unless exists $ENV{PATH}; + + my @folders = grep { length } split(/:/, $ENV{PATH}); + my $path = first_value { -x "$_/$command" } @folders; + + return ($path // $EMPTY); +} + +=item drop_relative_prefix(STRING) + +Remove an initial ./ from STRING, if present + +=cut + +sub drop_relative_prefix { + my ($name) = @_; + + my $copy = $name; + $copy =~ s{^\./}{}s; + + return $copy; +} + +=item version_from_changelog + +=cut + +sub version_from_changelog { + my ($package_path) = @_; + + my $changelog_path = "$package_path/debian/changelog"; + + return $EMPTY + unless -e $changelog_path; + + my $contents = path($changelog_path)->slurp_utf8; + my $changelog = Lintian::Changelog->new; + + $changelog->parse($contents); + my @entries = @{$changelog->entries}; + + return $entries[0]->{'Version'} + if @entries; + + return $EMPTY; +} + +=item match_glob( $glob, @things_to_test ) + +Resembles the same semantic as Text::Glob's match_glob(), but with the +proper escaping of Regexp::Wildcards and pre-configured for Lintian's +purpose. No more directly having to access module variables either. + +=cut + +sub match_glob { + my ($glob, @things_to_test) = @_; + my $re = $rw->convert($glob); + + return grep { /^$re\z/ } @things_to_test; +} + +=item normalize_pkg_path(PATH) + +Normalize PATH by removing superfluous path segments. PATH is assumed +to be relative the package root. Note that the result will never +start nor end with a slash, even if PATH does. + +As the name suggests, this is a path "normalization" rather than a +true path resolution (for that use Cwd::realpath). Particularly, +it assumes none of the path segments are symlinks. + +normalize_pkg_path will return C<q{}> (i.e. the empty string) if PATH +is normalized to the root dir and C<undef> if the path cannot be +normalized without escaping the package root. + +=item normalize_link_target(CURDIR, LINK_TARGET) + +Normalize the path obtained by following a link with LINK_TARGET as +its target from CURDIR as the current directory. CURDIR is assumed to +be relative to the package root. Note that the result will never +start nor end with a slash, even if CURDIR or DEST does. + +normalize_pkg_path will return C<q{}> (i.e. the empty string) if the +target is the root dir and C<undef> if the path cannot be normalized +without escaping the package root. + +B<CAVEAT>: This function is I<not always sufficient> to test if it is +safe to open a given symlink. Use C<is_ancestor_of(PARENTDIR, PATH)> for +that. If you must use this function, remember to check that the +target is not a symlink (or if it is, that it can be resolved safely). + +=cut + +sub normalize_link_target { + my ($path, $target) = @_; + + if (substr($target, 0, 1) eq $SLASH) { + # Link is absolute + $path = $target; + } else { + # link is relative + $path = "$path/$target"; + } + + return normalize_pkg_path($path); +} + +sub normalize_pkg_path { + my ($path) = @_; + + return $EMPTY + if $path eq $SLASH; + + my @dirty = split(m{/}, $path); + my @clean = grep { length } @dirty; + + my @final; + for my $component (@clean) { + + if ($component eq $DOT) { + # do nothing + + } elsif ($component eq $DOUBLEDOT) { + # are we out of bounds? + my $discard = pop @final; + return undef + unless defined $discard; + + } else { + push(@final, $component); + } + } + + # empty if we end in the root + my $normalized = join($SLASH, @final); + + return $normalized; +} + +=item is_ancestor_of(PARENTDIR, PATH) + +Returns true if and only if PATH is PARENTDIR or a path stored +somewhere within PARENTDIR (or its subdirs). + +This function will resolve the paths; any failure to resolve the path +will cause a trappable error. + +=cut + +sub is_ancestor_of { + my ($ancestor, $file) = @_; + + my $resolved_file = abs_path($file); + croak encode_utf8("resolving $file failed: $!") + unless defined $resolved_file; + + my $resolved_ancestor = abs_path($ancestor); + croak encode_utf8("resolving $ancestor failed: $!") + unless defined $resolved_ancestor; + + my $len; + return 1 if $resolved_ancestor eq $resolved_file; + # add a slash, "path/some-dir" is not "path/some-dir-2" and this + # allows us to blindly match against the root dir. + $resolved_file .= $SLASH; + $resolved_ancestor .= $SLASH; + + # If $resolved_file is contained within $resolved_ancestor, then + # $resolved_ancestor will be a prefix of $resolved_file. + $len = length($resolved_ancestor); + if (substr($resolved_file, 0, $len) eq $resolved_ancestor) { + return 1; + } + return 0; +} + +=item read_md5sums + +=item unescape_md5sum_filename + +=cut + +sub unescape_md5sum_filename { + my ($string, $problematic) = @_; + + # done if there are no escapes + return $string + unless $problematic; + + # split into individual characters + my @array = split(//, $string); + +# https://www.gnu.org/software/coreutils/manual/html_node/md5sum-invocation.html + my $path; + my $escaped = 0; + for my $char (@array) { + + # start escape sequence + if ($char eq $BACKSLASH && !$escaped) { + $escaped = 1; + next; + } + + # unescape newline + $char = $NEWLINE + if $char eq 'n' && $escaped; + + # append character + $path .= $char; + + # end any escape sequence + $escaped = 0; + } + + # do not stop inside an escape sequence + die encode_utf8('Name terminated inside an escape sequence') + if $escaped; + + return $path; +} + +sub read_md5sums { + my ($text) = @_; + + my %checksums; + my @errors; + + my @lines = split(/\n/, $text); + + while (defined(my $line = shift @lines)) { + + next + unless length $line; + + # make sure there are two spaces in between + $line =~ /^((?:\\)?\S{32}) (.*)$/; + + my $checksum = $1; + my $string = $2; + + unless (length $checksum && length $string) { + + push(@errors, "Odd text: $line"); + next; + } + + my $problematic = 0; + + # leading slash in checksum indicates an escaped name + $problematic = 1 + if $checksum =~ s{^\\}{}; + + my $path = unescape_md5sum_filename($string, $problematic); + + push(@errors, "Empty name for checksum $checksum") + unless length $path; + + $checksums{$path} = $checksum; + } + + return (\%checksums, \@errors); +} + +=item utf8_clean_log + +=cut + +sub utf8_clean_log { + my ($bytes) = @_; + + my $hex_sequence = sub { + my ($unclean_bytes) = @_; + return '{hex:' . sprintf('%vX', $unclean_bytes) . '}'; + }; + + my $utf8_clean_word = sub { + my ($word) = @_; + return utf8_clean_bytes($word, $SLASH, $hex_sequence); + }; + + my $utf8_clean_line = sub { + my ($line) = @_; + return utf8_clean_bytes($line, $SPACE, $utf8_clean_word); + }; + + return utf8_clean_bytes($bytes, $NEWLINE, $utf8_clean_line) . $NEWLINE; +} + +=item utf8_clean_bytes + +=cut + +sub utf8_clean_bytes { + my ($bytes, $separator, $utf8_clean_part) = @_; + + my @utf8_clean_parts; + + my $regex = quotemeta($separator); + my @parts = split(/$regex/, $bytes); + + for my $part (@parts) { + + if (valid_utf8($part)) { + push(@utf8_clean_parts, $part); + + } else { + push(@utf8_clean_parts, $utf8_clean_part->($part)); + } + } + + return join($separator, @utf8_clean_parts); +} + +=back + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Version.pm b/lib/Lintian/Version.pm new file mode 100644 index 0000000..959804f --- /dev/null +++ b/lib/Lintian/Version.pm @@ -0,0 +1,122 @@ +# +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2013 Niels Thykier +# Copyright (C) 2017 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::Version; + +use v5.20; +use warnings; +use utf8; + +our @EXPORT_OK = ( + qw( + guess_version + ) +); + +use Exporter qw(import); + +use Const::Fast; +use Unicode::UTF8 qw(decode_utf8); + +use Lintian::IPC::Run3 qw(safe_qx); +use Lintian::Util qw(version_from_changelog); + +const my $EMPTY => q{}; + +=head1 NAME + +Lintian::Version - routines to determine Lintian version + +=head1 SYNOPSIS + + use Lintian::Version; + +=head1 DESCRIPTION + +Lintian::Version can help guess the current Lintian version. + +=head1 INSTANCE METHODS + +=over 4 + +=item guess_version + +=cut + +sub guess_version { + my ($lintian_base) = @_; + + my $guess = version_from_git($lintian_base); + $guess ||= version_from_changelog($lintian_base); + + return $guess; +} + +=item version_from_git + +=cut + +sub version_from_git { + my ($source_path) = @_; + + my $git_path = "$source_path/.git"; + + return $EMPTY + unless -d $git_path; + + # Example outputs: + # 2.115.3-49-g086a9a113 + # 2.115.3-49-g086a9a113-dirty + my $describe = decode_utf8( + safe_qx('git', "--git-dir=$git_path", 'describe', '--dirty')); + chomp $describe; + + # Modify it to make it a valid native version number and make it + # look more debianish like these: + # 2.115.3+49commits+git086a9a113 + # 2.115.3+49commits+git086a9a113+dirty + my $guess = $describe; + $guess =~ s/ - ( \d+ ) -g /+${1}commits+git/sx; + $guess =~ s/ - /+/sxg; + + return ($guess // $EMPTY); +} + +=back + +=head1 AUTHOR + +Originally written by Niels Thykier <niels@thykier.net> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Test/Lintian.pm b/lib/Test/Lintian.pm new file mode 100644 index 0000000..4bcf72b --- /dev/null +++ b/lib/Test/Lintian.pm @@ -0,0 +1,697 @@ +# Copyright (C) 1998 Richard Braakman +# Copyright (C) 2012 Niels Thykier +# 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 Test::Lintian; + +=head1 NAME + +Test::Lintian -- Check Lintian files for issues + +=head1 SYNOPSIS + + # file 1 + use Test::Lintian; + use Test::More import => ['done_testing']; + test_load_profiles('some/path'); + + done_testing; + + # file 2 + use Test::Lintian; + use Test::More import => ['done_testing']; + load_profile_for_test('vendor/profile', 'some/path', '/usr/share/lintian'); + test_check_desc('some/path/checks'); + test_load_checks('some/path/checks'); + test_tags_implemented('some/path/checks'); + + done_testing; + +=head1 DESCRIPTION + +A testing framework for testing various Lintian files for common +errors. + +=cut + +use v5.20; +use warnings; +use utf8; + +my $CLASS = __PACKAGE__; +my $PROFILE; +our @EXPORT = qw( + load_profile_for_test + + test_check_desc + test_load_checks + test_load_profiles + + program_name_to_perl_paths +); + +use parent 'Test::Builder::Module'; + +use Cwd qw(realpath); +use Const::Fast; +use File::Basename qw(basename); +use File::Find (); +use List::SomeUtils qw{any}; +use Path::Tiny; +use Syntax::Keyword::Try; +use Unicode::UTF8 qw(valid_utf8 decode_utf8 encode_utf8); + +use Lintian::Spelling qw(check_spelling); +use Lintian::Deb822; +use Lintian::Profile; +use Lintian::Tag; + +const my $EMPTY => q{}; +const my $COLON => q{:}; +const my $MAXIMUM_TAG_LENGTH => 68; + +my %visibilities = map { $_ => 1 } @Lintian::Tag::VISIBILITIES; +my %check_types = map { $_ => 1 } qw(binary changes source udeb); +my %known_html_tags = map { $_ => 1 } qw(a em i tt); + +# lazy-load this (so loading a profile can affect it) +my %URLS; + +=head1 FUNCTIONS + +=over 4 + +=item test_check_desc(OPTS, CHECKS...) + +Test check desc files (and the tags in them) for common errors. + +OPTS is a HASHREF containing key/value pairs, which are +described below. + +CHECKS is a list of paths in which to check desc files. Any given +element in CHECKS can be either a file or a dir. Files are assumed to +be check desc file. Directories are searched and all I<.desc> files +in those dirs are processed. + +As the number of tests depends on the number of tags in desc, it is +difficult to "plan ahead" when using this test. It is therefore +recommended to not specify a plan and use done_testing(). + +This sub uses a Data file (see L</load_profile_for_test ([PROFNAME[, INC...]])>). + +OPTS may contain the following key/value pairs: + +=over 4 + +=item filter + +If defined, it is a filter function that examines $_ (or its first +argument) and returns a truth value if C<$_> should be considered or +false otherwise. C<$_> will be the path to the current file (or dir) +in question; it may be relative or absolute. + +NB: I<all> elements in CHECKS are subject to the filter. + +CAVEAT: If the filter rejects a directory, none of the files in it will be +considered either. Even if the filter accepts a file, that file will +only be processed if it has the proper extension (i.e. with I<.desc>). + +=item translation + +If defined and a truth value, the desc files are expected to contain +translations. Otherwise, they must be regular checks. + +=back + +=cut + +sub test_check_desc { + my ($opts, @dirs) = @_; + + my $builder = $CLASS->builder; + my $colldir = '/usr/share/lintian/collection'; + my $find_opt = {'filter' => undef,}; + my $tested = 0; + + $find_opt->{'filter'} = $opts->{'filter'} + if exists $opts->{'filter'}; + + $opts //= {}; + + load_profile_for_test(); + + my @descs = map { _find_check($find_opt, $_) } @dirs; + foreach my $desc_file (@descs) { + + my $bytes = path($desc_file)->slurp; + $builder->ok(valid_utf8($bytes), + "File $desc_file does not use a national encoding."); + next + unless valid_utf8($bytes); + + my $deb822 = Lintian::Deb822->new; + + my @sections; + try { + @sections = $deb822->read_file($desc_file); + + } catch { + my $err = $@; + $err =~ s/ at .*? line \d+\s*\n//; + $builder->ok(0, "Cannot parse $desc_file"); + $builder->diag("Error: $err"); + next; + } + + my ($header, @tagpara) = @sections; + + my $content_type = 'Check'; + my $cname = $header->value('Check-Script'); + my $ctype = $header->value('Type'); + my $i = 1; # paragraph counter. + $builder->ok(1, "Can parse check $desc_file"); + + $builder->isnt_eq($cname, $EMPTY, + "$content_type has a name ($desc_file)"); + + # From here on, we just use "$cname" as name of the check, so + # we don't need to choose been it and $tname. + $cname = '<missing>' if $cname eq $EMPTY; + $tested += 2; + + if ($cname eq 'lintian') { + my $reason = 'check "lintian" does not have a type'; + # skip these two tests for this special case... + $builder->skip("Special case, $reason"); + $builder->skip("Special case, $reason"); + } elsif ($builder->isnt_eq($ctype, $EMPTY, "$cname has a type")) { + my @bad; + # new lines are not allowed, map them to "\\n" for readability. + $ctype =~ s/\n/\\n/g; + foreach my $type (split /\s*+,\s*+/, $ctype) { + push @bad, $type unless exists $check_types{$type}; + } + $builder->is_eq(join(', ', @bad), + $EMPTY,"The type of $cname is valid"); + } else { + $builder->skip( + "Cannot check type of $cname is valid (field is empty/missing)" + ); + } + + for my $tpara (@tagpara) { + + my $tag = $tpara->value('Tag'); + my $visibility = $tpara->value('Severity'); + my $explanation = $tpara->value('Explanation'); + + my (@htmltags, %seen); + + $i++; + + # Tag name + $builder->isnt_eq($tag, $EMPTY, "Tag in check $cname has a name") + or $builder->diag("$cname: Paragraph number $i\n"); + $tag = '<N/A>' if $tag eq $EMPTY; + $builder->ok($tag =~ /^[\w0-9.+-]+$/, 'Tag has valid characters') + or $builder->diag("$cname: $tag\n"); + $builder->cmp_ok(length $tag, '<=', $MAXIMUM_TAG_LENGTH, + 'Tag is not too long') + or $builder->diag("$cname: $tag\n"); + + # Visibility + $builder->ok($visibility && exists $visibilities{$visibility}, + 'Tag has valid visibility') + or $builder->diag("$cname: $tag visibility: $visibility\n"); + + # Explanation + my $mistakes = 0; + my $handler = sub { + my ($incorrect, $correct) = @_; + $builder->diag( + "Spelling ($cname/$tag): $incorrect => $correct"); + $mistakes++; + }; + # FIXME: There are a couple of known false-positives that + # breaks the test. + # check_spelling($profile, $explanation, $handler); + $builder->is_eq($mistakes, 0, + "$content_type $cname: $tag has no spelling errors"); + + $builder->ok( + $explanation !~ /(?:^| )(?:[Ww]e|I)\b/, + 'Tag explanation does not speak of "I", or "we"' + )or $builder->diag("$content_type $cname: $tag\n"); + + $builder->ok( + $explanation !~ /(\S\w)\. [^ ]/ + || $1 =~ /^\.[ge]$/, # for 'e.g.'/'i.e.' + 'Tag explanation uses two spaces after a full stop' + ) or $builder->diag("$content_type $cname: $tag\n"); + + $builder->ok($explanation !~ /(\S\w\. )/, + 'Tag explanation uses only two spaces after a full stop') + or $builder->diag("$content_type $cname: $tag ($1)\n"); + + $builder->ok(valid_utf8($explanation), + 'Tag explanation must be written in UTF-8') + or $builder->diag("$content_type $cname: $tag\n"); + + # Check the tag explanation for unescaped <> or for unknown tags + # (which probably indicate the same thing). + while ($explanation + =~ s{<([^\s>]+)(?:\s+href=\"[^\"]+\")?>.*?</\1>}{}s){ + push @htmltags, $1; + } + @htmltags + = grep { !exists $known_html_tags{$_} && !$seen{$_}++ }@htmltags; + $builder->is_eq(join(', ', @htmltags), + $EMPTY, 'Tag explanation has no unknown html tags') + or $builder->diag("$content_type $cname: $tag\n"); + + $builder->ok($explanation !~ /[<>]/, + 'Tag explanation has no stray angle brackets') + or $builder->diag("$content_type $cname: $tag\n"); + + if ($tpara->declares('See-Also')) { + + my @issues = map { _check_reference($_) } + $tpara->trimmed_list('See-Also', qr{ \s* , \s* }x); + + my $text = join("\n\t", @issues); + + $builder->ok(!@issues, 'Proper references are used') + or $builder->diag("$content_type $cname: $tag\n\t$text"); + } + } + } + + $builder->cmp_ok($tested, '>', 0, 'Tested at least one desc file') + if @descs; + return; +} + +=item test_load_profiles(ROOT, INC...) + +Test that all profiles in I<ROOT/profiles> are loadable. INC will be +the INC path used as include path for the profile. + +If INC is omitted, then the include path will consist of (ROOT, +'/usr/share/lintian'). Otherwise, INC will be used as is (and should +include ROOT). + +This sub will do one test per profile loaded. + +=cut + +sub test_load_profiles { + my ($dir, @inc) = @_; + + my $builder = $CLASS->builder; + my $absdir = realpath $dir; + my $sre; + my %opt = ('no_chdir' => 1,); + + if (not defined $absdir) { + die encode_utf8("$dir cannot be resolved: $!"); + } + + $absdir = "$absdir/profiles"; + $sre = qr{\Q$absdir\E/}; + + @inc = ($absdir, '/usr/share/lintian') unless @inc; + + $opt{'wanted'} = sub { + my $profname = $File::Find::name; + + return + unless $profname =~ s/\.profile$//; + $profname =~ s/^$sre//; + + my $profile = Lintian::Profile->new; + + try { + $profile->load($profname, \@inc, 0); + + } catch { + $builder->diag("Load error: $@\n"); + $profile = 0; + } + + $builder->ok($profile, "$profname is loadable."); + }; + + File::Find::find(\%opt, $absdir); + return; +} + +=item test_load_checks(OPTS, DIR[, CHECKNAMES...]) + +Test that the Perl module implementation of the checks can be loaded +and has a run sub. + +OPTS is a HASHREF containing key/value pairs, which are +described below. + +DIR is the directory where the checks can be found. + +CHECKNAMES is a list of check names. If CHECKNAMES is given, only the +checks in this list will be processed. Otherwise, all the checks in +DIR will be processed. + +For planning purposes, every check processed counts for 2 tests and +the call itself does on additional check. So if CHECKNAMES contains +10 elements, then 21 tests will be done (2 * 10 + 1). Filtered out +checks will I<not> be counted. + +All data files created at compile time or in the file scope will be +loaded immediately (instead of lazily as done during the regular +runs). This is done to spot missing data files or typos in their +names. Therefore, this sub will load a profile if one hasn't been +loaded already. (see L</load_profile_for_test ([PROFNAME[, +INC...]])>) + +OPTS may contain the following key/value pairs: + +=over 4 + +=item filter + +If defined, it is a filter function that examines $_ (or its first +argument) and returns a truth value if C<$_> should be considered or +false otherwise. C<$_> will be the path to the current file (or dir) +in question; it may be relative or absolute. + +NB: filter is I<not> used if CHECKNAMES is given. + +CAVEAT: If the filter rejects a directory, none of the files in it will be +considered either. Even if the filter accepts a file, that file will +only be processed if it has the proper extension (i.e. with I<.desc>). + +=back + +=cut + +sub test_load_checks { + my ($opts, $dir, @check_names) = @_; + + my $builder = $CLASS->builder; + + unless (@check_names) { + my $find_opt = {'want-check-name' => 1,}; + $find_opt->{'filter'} = $opts->{'filter'} if exists $opts->{'filter'}; + @check_names = _find_check($find_opt, $dir); + } else { + $builder->skip('Given an explicit list of checks'); + } + + $builder->skip('No desc files found') + unless @check_names; + + my $profile = load_profile_for_test(); + + foreach my $check_name (@check_names) { + + my $path = $profile->check_path_by_name->{$check_name}; + try { + require $path; + + } catch { + $builder->skip( +"Cannot check if $check_name has entry points due to load error" + ); + next; + } + + $builder->ok(1, "Check $check_name can be loaded"); + + my $module = $profile->check_module_by_name->{$check_name}; + + $builder->diag( + "Warning: check $check_name uses old entry point ::run\n") + if $module->can('run') && !$module->DOES('Lintian::Check'); + + # setup and breakdown should only be used together with files + my $has_entrypoint = any { $module->can($_) } + qw(source binary udeb installable changes always files); + + if ( + !$builder->ok( + $has_entrypoint, "Check $check_name has entry point" + ) + ){ + $builder->diag("Expected package name is $module\n"); + } + } + return; +} + +=item load_profile_for_test ([PROFNAME[, INC...]]) + +Load a Lintian::Profile and ensure Data files can be used. This is +needed if the test needs to access a data file or if a special profile +is needed for the test. It does I<not> test the profile for issues. + +PROFNAME is the name of the profile to load. It can be omitted, in +which case the sub ensures that a profile has been loaded. If no +profile has been loaded, 'debian/main' will be loaded. + +INC is a list of extra "include dirs" (or Lintian "roots") to be used +for finding the profile. If not specified, it defaults to +I<$ENV{'LINTIAN_BASE'}> and I</usr/share/lintian> (in order). +INC is ignored if a profile has already been loaded. + +CAVEAT: Only one profile can be loaded in a given test. Once a +profile has been loaded, it is not possible to replace it with another +one. So if this is invoked multiple times, PROFNAME must be omitted +or must match the name of the loaded profile. + +=cut + +sub load_profile_for_test { + my ($profname, @inc) = @_; + + # We have loaded a profile and are not asked to + # load a specific one - then current one will do. + return $PROFILE + if $PROFILE and not $profname; + + die encode_utf8("Cannot load two profiles.\n") + if $PROFILE and $PROFILE->name ne $profname; + + # Already loaded? stop here + # We just need it for spell checking, so debian/main should + # do just fine... + return $PROFILE + if $PROFILE; + + $profname ||= 'debian/main'; + + $PROFILE = Lintian::Profile->new; + $PROFILE->load($profname, [@inc, $ENV{'LINTIAN_BASE'}]); + + $ENV{'LINTIAN_CONFIG_DIRS'} = join($COLON, @inc); + + return $PROFILE; +} + +sub _check_reference { + my ($see_also) = @_; + + my @issues; + + my @MARKDOWN_CAPABLE = ( + $PROFILE->menu_policy, + $PROFILE->perl_policy, + $PROFILE->python_policy, + $PROFILE->java_policy, + $PROFILE->vim_policy, + $PROFILE->lintian_manual, + $PROFILE->developer_reference, + $PROFILE->policy_manual, + $PROFILE->debconf_specification, + $PROFILE->menu_specification, + $PROFILE->doc_base_specification, + $PROFILE->filesystem_hierarchy_standard, + ); + + my %by_shorthand = map { $_->shorthand => $_ } @MARKDOWN_CAPABLE; + + # We use this to check for explicit links where it is possible to use + # a manual ref. + unless (%URLS) { + for my $manual (@MARKDOWN_CAPABLE) { + + my $volume = $manual->shorthand; + + for my $section_key ($manual->all){ + my $entry = $manual->value($section_key); + + my $url = $entry->{$section_key}{url}; + next + unless length $url; + + $URLS{$url} = "$volume $section_key"; + } + } + } + + if ( $see_also =~ m{^https?://bugs.debian.org/(\d++)$} + || $see_also + =~ m{^https?://bugs.debian.org/cgi-bin/bugreport.cgi\?/.*bug=(\d++).*$} + ) { + push(@issues, "replace '$see_also' with '#$1'"); + + } elsif (exists $URLS{$see_also}) { + push(@issues, "replace '$see_also' with '$URLS{$see_also}'"); + + } elsif ($see_also =~ m/^([\w-]++)\s++(\S++)$/) { + + my $volume = $1; + my $section = $2; + + if (exists $by_shorthand{$volume}) { + + my $manual = $by_shorthand{$volume}; + + push(@issues, "unknown section '$section' in $volume") + unless length $manual->markdown_citation($section); + + } else { + push(@issues, "unknown manual '$volume'"); + } + + } else { + # Check it is a valid reference like URLs or #123456 + # NB: "policy 10.1" references already covered above + push(@issues, "unknown or malformed reference '$see_also'") + if $see_also !~ /^#\d+$/ # debbugs reference + && $see_also !~ m{^(?:ftp|https?)://} # browser URL + && $see_also !~ m{^/} # local file reference + && $see_also !~ m{[\w_-]+\(\d\w*\)$}; # man reference + } + + return @issues; +} + +sub _find_check { + my ($find_opt, $input) = @_; + $find_opt//= {}; + my $filter = $find_opt->{'filter'}; + + if ($filter) { + local $_ = $input; + # filtered out? + return () unless $filter->($_); + } + + if (-d $input) { + my (@result, $regex); + if ($find_opt->{'want-check-name'}) { + $regex = qr{^\Q$input\E/*}; + } + my $wanted = sub { + if (defined $filter) { + local $_ = $_; + if (not $filter->($_)) { + # filtered out; if a dir - filter the + # entire dir. + $File::Find::prune = 1 if -d; + return; + } + } + return unless m/\.desc$/ and -e; + if ($regex) { + s/$regex//; + s/\.desc$//; + } + push @result, $_; + }; + my $opt = { + 'wanted' => $wanted, + 'no_chdir' => 1, + }; + File::Find::find($opt, $input); + return @result; + } + + return ($input); +} + +=item program_name_to_perl_paths(PROGNAME) + +Map the program name (e.g. C<$0>) to a list of directories or/and +files that should be processed. + +This helper sub is mostly useful for splitting up slow tests run over +all Perl scripts/modules in Lintian. This allows better use of +multiple cores. Example: + + + t/scripts/my-test/ + runner.pl + checks.t -> runner.pl + collection.t -> runner.pl + ... + +And then in runner.pl: + + use Test::Lintian; + + my @paths = program_name_to_perl_paths($0); + # test all files/dirs listed in @paths + +For a more concrete example, see t/scripts/01-critic/ and the +files/symlinks beneath it. + +=cut + +{ + + my %SPECIAL_PATHS = ( + 'docs-examples' => ['doc/examples/checks'], + 'test-scripts' => [qw(t/scripts t/templates)], + ); + + sub program_name_to_perl_paths { + my ($program) = @_; + # We need the basename before resolving the path (because + # afterwards it is "runner.pl" and we want it to be e.g. + # "checks.t" or "collections.t"). + my $basename = basename($program, '.t'); + + if (exists($SPECIAL_PATHS{$basename})) { + return @{$SPECIAL_PATHS{$basename}}; + } + + return ($basename); + } +} + +=back + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Test/Lintian/Build.pm b/lib/Test/Lintian/Build.pm new file mode 100644 index 0000000..b6819af --- /dev/null +++ b/lib/Test/Lintian/Build.pm @@ -0,0 +1,163 @@ +# Copyright (C) 2018 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 Test::Lintian::Build; + +=head1 NAME + +Test::Lintian::Build -- routines to prepare the work directories + +=head1 SYNOPSIS + + use Test::Lintian::Build qw(build_subject); + +=head1 DESCRIPTION + +The routines in this module prepare the work directories in which the +tests are run. To do so, they use the specifications in the test set. + +=cut + +use v5.20; +use warnings; +use utf8; + +use Exporter qw(import); + +BEGIN { + our @EXPORT_OK = qw( + build_subject + ); +} + +use Carp; +use Const::Fast; +use Cwd; +use IPC::Run3; +use List::SomeUtils qw(any); +use Path::Tiny; +use Unicode::UTF8 qw(valid_utf8 encode_utf8); + +use Lintian::Util qw(utf8_clean_log); + +use Test::Lintian::ConfigFile qw(read_config); +use Test::Lintian::Hooks qw(find_missing_prerequisites); + +const my $SLASH => q{/}; +const my $WAIT_STATUS_SHIFT => 8; + +=head1 FUNCTIONS + +=over 4 + +=item build_subject(PATH) + +Populates a work directory RUN_PATH with data from the test located +in SPEC_PATH. The optional parameter REBUILD forces a rebuild if true. + +=cut + +sub build_subject { + my ($sourcepath, $buildpath) = @_; + + # check test architectures + die encode_utf8('DEB_HOST_ARCH is not set.') + unless (length $ENV{'DEB_HOST_ARCH'}); + + # read dynamic file names + my $runfiles = "$sourcepath/files"; + my $files = read_config($runfiles); + + # read dynamic case data + my $rundescpath + = $sourcepath . $SLASH . $files->unfolded_value('Fill-Values'); + my $testcase = read_config($rundescpath); + + # skip test if marked + my $skipfile = "$sourcepath/skip"; + if (-e $skipfile) { + my $reason = path($skipfile)->slurp_utf8 || 'No reason given'; + say encode_utf8("Skipping test: $reason"); + return; + } + + # skip if missing prerequisites + my $missing = find_missing_prerequisites($testcase); + if (length $missing) { + say encode_utf8("Missing prerequisites: $missing"); + return; + } + + path($buildpath)->remove_tree + if -e $buildpath; + + path($buildpath)->mkpath; + + # get lintian subject + croak encode_utf8('Could not get subject of Lintian examination.') + unless $testcase->declares('Build-Product'); + + my $build_product = $testcase->unfolded_value('Build-Product'); + my $subject = "$buildpath/$build_product"; + + say encode_utf8("Building in $buildpath"); + + my $command = $testcase->unfolded_value('Build-Command'); + if (length $command) { + + my $savedir = Cwd::getcwd; + chdir($buildpath) + or die encode_utf8("Cannot change to directory $buildpath"); + + my $combined_bytes; + + # array command breaks test files/contents/contains-build-path + run3($command, \undef, \$combined_bytes, \$combined_bytes); + my $status = ($? >> $WAIT_STATUS_SHIFT); + + chdir($savedir) + or die encode_utf8("Cannot change to directory $savedir"); + + # sanitize log so it is UTF-8 from here on + my $utf8_bytes = utf8_clean_log($combined_bytes); + print $utf8_bytes; + + croak encode_utf8("$command failed") + if $status; + } + + croak encode_utf8('Build was unsuccessful.') + unless -e $subject; + + die encode_utf8("Cannot link to build product $build_product") + if system("cd $buildpath; ln -s $build_product subject"); + + return; +} + +=back + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Test/Lintian/ConfigFile.pm b/lib/Test/Lintian/ConfigFile.pm new file mode 100644 index 0000000..162b49c --- /dev/null +++ b/lib/Test/Lintian/ConfigFile.pm @@ -0,0 +1,132 @@ +# Copyright (C) 2018 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 Test::Lintian::ConfigFile; + +=head1 NAME + +Test::Lintian::ConfigFile -- generic helper routines for colon-delimited configuration files + +=head1 SYNOPSIS + +use Test::Lintian::ConfigFile qw(read_config); +my $desc = read_config('t/tags/testname/desc'); + +=head1 DESCRIPTION + +Routines for dealing with colon-delimited configuration files. + +=cut + +use v5.20; +use warnings; +use utf8; + +use Exporter qw(import); + +BEGIN { + our @EXPORT_OK = qw( + read_config + write_config + ); +} + +use Carp; +use Const::Fast; +use List::SomeUtils qw(any); +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::Deb822; + +const my $SPACE => q{ }; +const my $COLON => q{:}; +const my $NEWLINE => qq{\n}; + +=head1 FUNCTIONS + +=over 4 + +=item read_config(PATH, HASHREF) + +Reads the configuration file located at PATH into a hash and +returns it. When also passed a HASHREF, will fill that instead. + +=cut + +sub read_config { + my ($configpath) = @_; + + croak encode_utf8("Cannot find file $configpath.") + unless -e $configpath; + + my $deb822 = Lintian::Deb822->new; + my @sections = $deb822->read_file($configpath); + die encode_utf8("$configpath does not have exactly one paragraph") + unless @sections == 1; + + my $config = $sections[0]; + + return $config; +} + +=item write_config(TEST_CASE, PATH) + +Write the config described by hash reference TEST_CASE to the file named PATH. + +=cut + +sub write_config { + my ($testcase, $path) = @_; + + my $desc = path($path); + $desc->remove; + + my @lines; + for my $name (sort $testcase->names) { + + my @elements = $testcase->trimmed_list($name); + + # multi-line output for some fields + if (@elements > 1 + && any { fc eq fc($name) } qw(Test-For Test-Against)) { + push(@lines, $name . $COLON . $NEWLINE); + push(@lines, $SPACE . $_ . $NEWLINE) for @elements; + next; + } + + push(@lines, + $name . $COLON . $SPACE . $testcase->value($name) . $NEWLINE); + } + + $desc->append_utf8(@lines); + + return; +} + +=back + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Test/Lintian/Filter.pm b/lib/Test/Lintian/Filter.pm new file mode 100644 index 0000000..4b6ea8a --- /dev/null +++ b/lib/Test/Lintian/Filter.pm @@ -0,0 +1,378 @@ +# 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 Test::Lintian::Filter; + +=head1 NAME + +Test::Lintian::Filter -- Functions to select with tests to run + +=head1 SYNOPSIS + + use Test::Lintian::Filter qw(find_selected_lintian_testpaths); + my @testpaths = find_selected_lintian_testpaths('suite:changes'); + +=head1 DESCRIPTION + +Functions that parse the optional argument 'only_run' to find the +tests that are supposed to run. + +=cut + +use v5.20; +use warnings; +use utf8; + +use Exporter qw(import); + +BEGIN { + our @EXPORT_OK = qw( + find_selected_scripts + find_selected_lintian_testpaths + ); +} + +use Carp; +use Const::Fast; +use File::Spec::Functions qw(rel2abs splitpath catpath); +use File::Find::Rule; +use List::SomeUtils qw(uniq none); +use List::Util qw(any all); +use Path::Tiny; +use Text::CSV; +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::Profile; +use Test::Lintian::ConfigFile qw(read_config); + +my @LINTIAN_SUITES = qw(recipes); + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $VERTICAL_BAR => q{|}; +const my $DESC => 'desc'; +const my $SEPARATED_BY_COLON => qr/([^:]+):([^:]+)/; + +=head1 FUNCTIONS + +=over 4 + +=item get_suitepath(TEST_SET, SUITE) + +Returns a string containing all test belonging to suite SUITE relative +to path TEST_SET. + +=cut + +sub get_suitepath { + my ($basepath, $suite) = @_; + my $suitepath = rel2abs($suite, $basepath); + + croak encode_utf8("Cannot find suite $suite in $basepath") + unless -d $suitepath; + + return $suitepath; +} + +=item find_selected_scripts(SCRIPT_PATH, ONLY_RUN) + +Find all test scripts in SCRIPT_PATH that are identified by the +user's selection string ONLY_RUN. + +=cut + +sub find_selected_scripts { + my ($scriptpath, $onlyrun) = @_; + + my @found; + + my @selectors = split(m/\s*,\s*/, $onlyrun//$EMPTY); + + if ((any { $_ eq 'suite:scripts' } @selectors) || !length $onlyrun) { + @found = File::Find::Rule->file()->name('*.t')->in($scriptpath); + } else { + foreach my $selector (@selectors) { + my ($prefix, $lookfor) = ($selector =~ /$SEPARATED_BY_COLON/); + + next if defined $prefix && $prefix ne 'script'; + $lookfor = $selector unless defined $prefix; + + # look for files with the standard suffix + my $withsuffix = rel2abs("$lookfor.t", $scriptpath); + push(@found, $withsuffix) if -e $withsuffix; + + # look for script with exact name + my $exactpath = rel2abs($lookfor, $scriptpath); + push(@found, $exactpath) if -e $exactpath; + + # also add entire directory if name matches + push(@found, File::Find::Rule->file()->name('*.t')->in($exactpath)) + if -d $exactpath; + } + } + + my @sorted = sort +uniq @found; + + return @sorted; +} + +=item find_selected_lintian_testpaths(TEST_SET, ONLY_RUN) + +Find all those test paths with Lintian tests located in the directory +TEST_SET and identified by the user's selection string ONLY_RUN. + +=cut + +sub find_selected_lintian_testpaths { + + my ($testset, $onlyrun) = @_; + + my $filter = { + 'tag' => [], + 'suite' => [], + 'test' => [], + 'check' => [], + 'skeleton' => [], + }; + my @filter_no_prefix; + + if (!length $onlyrun) { + $filter->{suite} = [@LINTIAN_SUITES]; + } else { + + my @selectors = split(m/\s*,\s*/, $onlyrun); + + foreach my $selector (@selectors) { + + foreach my $wanted (keys %{$filter}) { + my ($prefix, $lookfor) = ($selector =~ /$SEPARATED_BY_COLON/); + + next if defined $prefix && $prefix ne $wanted; + + push(@{$filter->{$wanted}}, $lookfor) if length $lookfor; + push(@filter_no_prefix, $selector) unless length $lookfor; + } + } + } + + my $profile = Lintian::Profile->new; + $profile->load(undef, undef, 0); + + my @found; + foreach my $suite (sort @LINTIAN_SUITES) { + + my @insuite; + my $suitepath = get_suitepath($testset, $suite); + + # find all tests for selected suites + if (any { $_ eq $suite } @{$filter->{suite}}) { + push(@insuite, find_all_testpaths($suitepath)); + } + + # find explicitly selected tests + foreach my $testname (@{$filter->{test}}) { + my @withtests = find_testpaths_by_name($suitepath, $testname); + push(@insuite, @withtests); + } + + # find tests for selected checks and tags + if (scalar @{$filter->{check}} || scalar @{$filter->{tag}}) { + + my %wanted = map { $_ => 1 } @{$filter->{check}}; + + for my $tag_name (@{$filter->{tag}}) { + + my $tag = $profile->get_tag($tag_name); + unless ($tag) { + say encode_utf8("Tag $tag_name not found"); + return (); + } + + if (none { $tag_name eq $_ } $profile->enabled_tags) { + say encode_utf8("Tag $tag_name not enabled"); + return (); + } + + $wanted{$tag->check} = 1; + } + + for my $testpath (find_all_testpaths($suitepath)) { + my $desc = read_config("$testpath/eval/" . $DESC); + + next + unless $desc->declares('Check'); + + for my $check ($desc->trimmed_list('Check')) { + push(@insuite, $testpath) + if exists $wanted{$check}; + } + } + } + + # find tests for selected skeleton + if (scalar @{$filter->{skeleton}}) { + + my %wanted = map { $_ => 1 } @{$filter->{skeleton}}; + + for my $testpath (find_all_testpaths($suitepath)) { + my $desc = read_config("$testpath/build-spec/fill-values"); + + next + unless $desc->declares('Skeleton'); + + my $skeleton = $desc->unfolded_value('Skeleton'); + push(@insuite, $testpath) + if exists $wanted{$skeleton}; + } + } + + # guess what was meant by selection without prefix + for my $parameter (@filter_no_prefix) { + push(@insuite,find_testpaths_by_name($suitepath, $parameter)); + + if ($parameter eq 'legacy' + || exists $profile->check_module_by_name->{$parameter}) { + + push(@insuite, + find_testpaths_by_name($suitepath, "$parameter-*")); + } + } + + push(@found, sort +uniq @insuite); + } + + return @found; +} + +=item find_all_testpaths(PATH) + +Returns an array containing all test paths located under PATH. They +are identified as test paths by a specially named file containing +the test description (presently 'desc'). + +=cut + +sub find_all_testpaths { + my ($directory) = @_; + my @descfiles = File::Find::Rule->file()->name($DESC)->in($directory); + + my @testpaths= map { path($_)->parent->parent->stringify }@descfiles; + + return @testpaths; +} + +=item find_testpaths_by_name(PATH, NAME) + +Returns an array containing all test paths with the name NAME +located under PATH. The test paths are identified as such +by a specially named file containing the test description +(presently 'desc'). + +=cut + +sub find_testpaths_by_name { + my ($path, $name) = @_; + + my @named = File::Find::Rule->directory()->name($name)->in($path); + my @testpaths= grep { defined } + map { -e rel2abs('eval/' . $DESC, $_) ? $_ : undef } @named; + + return @testpaths; +} + +=item find_all_tags(TEST_PATH) + +Returns an array containing all tags that somehow concern the test +located in TEST_PATH. + +=cut + +sub find_all_tags { + my ($testpath) = @_; + + my $desc = read_config("$testpath/eval/" . $DESC); + + return $EMPTY + unless $desc->declares('Check'); + + my $profile = Lintian::Profile->new; + $profile->load(undef, undef, 0); + + my @check_names = $desc->trimmed_list('Check'); + my @unknown + = grep { !exists $profile->check_module_by_name->{$_} } @check_names; + + die encode_utf8('Unknown Lintian checks: ' . join($SPACE, @unknown)) + if @unknown; + + my %tags; + for my $name (@check_names) { + $tags{$_} = 1 for @{$profile->tag_names_for_check->{$name}}; + } + + return keys %tags + unless $desc->declares('Test-Against'); + + # read hints from specification + my $temp = Path::Tiny->tempfile; + die encode_utf8("hintextract failed: $!") + if system('private/hintextract', '-f', 'EWI', "$testpath/hints", + $temp->stringify); + my @lines = $temp->lines_utf8({ chomp => 1 }); + + my $csv = Text::CSV->new({ sep_char => $VERTICAL_BAR }); + + my %expected; + foreach my $line (@lines) { + + my $status = $csv->parse($line); + die encode_utf8("Cannot parse line $line: " . $csv->error_diag) + unless $status; + + my ($type, $package, $name, $details) = $csv->fields; + + die encode_utf8("Cannot parse line $line") + unless all { length } ($type, $package, $name); + + $expected{$name} = 1; + } + + # remove tags not appearing in specification + foreach my $name (keys %tags) { + delete $tags{$name} + unless $expected{$name}; + } + + # add tags listed in Test-Against + my @test_against = $desc->trimmed_list('Test-Against'); + $tags{$_} = 1 for @test_against; + + return keys %tags; +} + +=back + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Test/Lintian/Helper.pm b/lib/Test/Lintian/Helper.pm new file mode 100644 index 0000000..518d036 --- /dev/null +++ b/lib/Test/Lintian/Helper.pm @@ -0,0 +1,198 @@ +# Copyright (C) 1998 Richard Braakman +# Copyright (C) 2008 Frank Lichtenheld +# Copyright (C) 2008, 2009 Russ Allbery +# Copyright (C) 2018 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 Test::Lintian::Helper; + +=head1 NAME + +Test::Lintian::Helper -- Helper functions for various testing parts + +=head1 SYNOPSIS + + use Test::Lintian::Helper qw(get_latest_policy); + my $policy_version = get_latest_policy(); + +=head1 DESCRIPTION + +Helper functions for preparing and running Lintian tests. + +=cut + +use v5.20; +use warnings; +use utf8; + +use Exporter qw(import); + +BEGIN { + our @EXPORT_OK = qw( + cache_dpkg_architecture_values + get_latest_policy + get_recommended_debhelper_version + copy_dir_contents + rfc822date + ); +} + +use Carp; +use File::Spec::Functions qw(abs2rel rel2abs); +use File::Path qw(remove_tree); +use Path::Tiny; +use POSIX qw(locale_h strftime); +use Unicode::UTF8 qw(encode_utf8 decode_utf8); + +use Lintian::IPC::Run3 qw(safe_qx); +use Lintian::Profile; + +=head1 FUNCTIONS + +=over 4 + +=item cache_dpkg_architecture_values() + +Ensures that the output from dpkg-architecture has been cached. + +=cut + +sub cache_dpkg_architecture_values { + + my $output = decode_utf8(safe_qx('dpkg-architecture')); + + die encode_utf8('dpkg-architecture failed') + if $?; + + $output = decode_utf8($output) + if length $output; + + my @lines = split(/\n/, $output); + + for my $line (@lines) { + my ($k, $v) = split(/=/, $line, 2); + $ENV{$k} = $v; + } + + return; +} + +=item get_latest_policy() + +Returns a list with two elements. The first is the most recent version +of the Debian policy. The second is its effective date. + +=cut + +sub get_latest_policy { + my $profile = Lintian::Profile->new; + $profile->load(undef, undef, 0); + + my $releases = $profile->data->policy_releases; + + my $version = $releases->latest_version; + die encode_utf8('Could not get latest policy version.') + unless defined $version; + my $epoch = $releases->epoch($version); + die encode_utf8('Could not get latest policy date.') + unless defined $epoch; + + return ($version, $epoch); +} + +=item get_recommended_debhelper_version() + +Returns the version of debhelper recommended in 'debhelper/compat-level' +via Lintian::Data, relative to the established LINTIAN_BASE. + +=cut + +sub get_recommended_debhelper_version { + my $profile = Lintian::Profile->new; + $profile->load(undef, undef, 0); + + my $compat_level = $profile->data->debhelper_levels; + + return $compat_level->value('recommended'); +} + +=item copy_dir_contents(SRC_DIR, TARGET_DIR) + +Populates TARGET_DIR with files/dirs from SRC_DIR, preserving all attributes but +dereferencing links. For an empty directory, no dummy file is required. + +=cut + +sub copy_dir_contents { + my ($source, $destination) = @_; + + # 'cp -r' cannot overwrite directories with files or vice versa + my @paths = File::Find::Rule->in($source); + foreach my $path (@paths) { + + my $relative = abs2rel($path, $source); + my $prospective = rel2abs($relative, $destination); + + # recursively delete directories to be replaced by a file + remove_tree($prospective) + if -d $prospective && -e $path && !-d _; + + # remove files to be replaced by a directory + if (-e $prospective && !-d _ && -d $path) { + unlink($prospective) + or die encode_utf8("Cannot unlink $prospective"); + } + } + + # 'cp -r' with a dot will error without files present + if (scalar path($source)->children) { + + system('cp', '-rp', "$source/.", '-t', $destination)== 0 + or croak encode_utf8("Could not copy $source to $destination: $!"); + } + return 1; +} + +=item rfc822date(EPOCH) + +Returns a string with the date and time described by EPOCH, formatted +according to RFC822. + +=cut + +sub rfc822date { + my ($epoch) = @_; + + my $old_locale = setlocale(LC_TIME, 'C'); + my $datestring = strftime('%a, %d %b %Y %H:%M:%S %z', localtime($epoch)); + setlocale(LC_TIME, $old_locale); + + return $datestring; +} + +=back + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Test/Lintian/Hooks.pm b/lib/Test/Lintian/Hooks.pm new file mode 100644 index 0000000..4c8d848 --- /dev/null +++ b/lib/Test/Lintian/Hooks.pm @@ -0,0 +1,228 @@ +# Copyright (C) 2018 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 Test::Lintian::Hooks; + +=head1 NAME + +Test::Lintian::Hooks -- hook routines for the test runners + +=head1 SYNOPSIS + + use Test::Lintian::Hooks qw(sed_hook); + sed_hook('script.sed', 'input.file'); + +=head1 DESCRIPTION + +Various hook routines for the test runners. + +=cut + +use v5.20; +use warnings; +use utf8; + +use Exporter qw(import); + +BEGIN { + our @EXPORT_OK = qw( + sed_hook + sort_lines + calibrate + find_missing_prerequisites + ); +} + +use Capture::Tiny qw(capture_merged); +use Carp; +use Const::Fast; +use Cwd qw(getcwd); +use File::Basename; +use File::Find::Rule; +use File::Path; +use File::stat; +use IPC::Run3; +use List::SomeUtils qw(any); +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8 decode_utf8); + +const my $NEWLINE => qq{\n}; +const my $WAIT_STATUS_SHIFT => 8; + +=head1 FUNCTIONS + +=over 4 + +=item sed_hook(SCRIPT, SUBJECT, OUTPUT) + +Runs the parser sed on file SUBJECT using the instructions in SCRIPT +and places the result in the file OUTPUT. + +=cut + +sub sed_hook { + my ($script, $path, $output) = @_; + + croak encode_utf8("Parser script $script does not exist.") + unless -e $script; + + my @command = (qw{sed -r -f}, $script, $path); + my $bytes; + run3(\@command, \undef, \$bytes); + my $status = ($? >> $WAIT_STATUS_SHIFT); + + croak encode_utf8("Hook failed: sed -ri -f $script $path > $output: $!") + if $status; + + # already in bytes + path($output)->spew($bytes); + + croak encode_utf8("Did not create parser output file $output.") + unless -e $output; + + return $output; +} + +=item sort_lines(UNSORTED, SORTED) + +Sorts the file UNSORTED line by line and places the result into the +file SORTED. + +=cut + +sub sort_lines { + my ($path, $sorted) = @_; + + open(my $rfd, '<', $path) + or croak encode_utf8("Could not open pre-sort file $path: $!"); + my @lines = sort map { decode_utf8($_) } <$rfd>; + close $rfd + or carp encode_utf8("Could not close open pre-sort file $path: $!"); + + open(my $wfd, '>', $sorted) + or croak encode_utf8("Could not open sorted file $sorted: $!"); + print {$wfd} encode_utf8($_) for @lines; + close $wfd + or carp encode_utf8("Could not close sorted file $sorted: $!"); + + return $sorted; +} + +=item calibrate(SCRIPT, ACTUAL, EXPECTED, CALIBRATED) + +Executes calibration script SCRIPT with the three arguments EXPECTED, +ACTUAL and CALIBRATED, all of which are file paths. Please note that +the order of arguments in this function corresponds to the +bookkeeping logic of ACTUAL vs EXPECTED. The order for the script is +different. + +=cut + +sub calibrate { + my ($hook, $actual, $expected, $calibrated) = @_; + + if (-x $hook) { + system($hook, $expected, $actual, $calibrated) == 0 + or croak encode_utf8("Hook $hook failed on $actual: $!"); + croak encode_utf8("No calibrated hints created in $calibrated") + unless -e $calibrated; + return $calibrated; + } + return $expected; +} + +=item find_missing_prerequisites(TEST_CASE) + +Returns a string with missing dependencies, if applicable, that would +be necessary to run the test described by hash DESC. + +=cut + +sub find_missing_prerequisites { + my ($testcase) = @_; + + # without prerequisites, no need to look + return undef + unless any { $testcase->declares($_) } + qw(Build-Depends Build-Conflicts Test-Depends Test-Conflicts); + + # create a temporary file + my $temp = Path::Tiny->tempfile( + TEMPLATE => 'lintian-test-build-depends-XXXXXXXXX'); + my @lines; + + # dpkg-checkbuilddeps requires a Source: field + push(@lines, 'Source: bd-test-pkg'); + + my $build_depends = join( + ', ', + grep { length }( + $testcase->value('Build-Depends'),$testcase->value('Test-Depends') + ) + ); + + push(@lines, "Build-Depends: $build_depends") + if length $build_depends; + + my $build_conflicts = join( + ', ', + grep { length }( + $testcase->value('Build-Conflicts'), + $testcase->value('Test-Conflicts') + ) + ); + push(@lines, "Build-Conflicts: $build_conflicts") + if length $build_conflicts; + + $temp->spew_utf8(join($NEWLINE, @lines) . $NEWLINE); + + # run dpkg-checkbuilddeps + my $command = "dpkg-checkbuilddeps $temp"; + my ($missing, $status) = capture_merged { system($command); }; + $status >>= $WAIT_STATUS_SHIFT; + + $missing = decode_utf8($missing) + if length $missing; + + die encode_utf8("$command failed: $missing") + if !$status && length $missing; + + # parse for missing prerequisites + if ($missing =~ s{\A dpkg-checkbuilddeps: [ ] (?:error: [ ])? }{}xsm) { + $missing =~ s{Unmet build dependencies}{Unmet}gi; + chomp($missing); + # expect exactly one line. + die encode_utf8("Unexpected output from dpkg-checkbuilddeps: $missing") + if $missing =~ s{\n}{\\n}gxsm; + return $missing; + } + + return undef; +} + +=back + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Test/Lintian/Output/EWI.pm b/lib/Test/Lintian/Output/EWI.pm new file mode 100644 index 0000000..74fab49 --- /dev/null +++ b/lib/Test/Lintian/Output/EWI.pm @@ -0,0 +1,117 @@ +# 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 Test::Lintian::Output::EWI; + +=head1 NAME + +Test::Lintian::Output::EWI -- routines to process EWI hints + +=head1 SYNOPSIS + + use Path::Tiny; + use Test::Lintian::Output::EWI qw(to_universal); + + my $ewi = path("path to an EWI hint file")->slurp_utf8; + my $universal = to_universal($ewi); + +=head1 DESCRIPTION + +Helper routines to deal with C<EWI> hints and hint files + +=cut + +use v5.20; +use warnings; +use utf8; + +use Exporter qw(import); + +BEGIN { + our @EXPORT_OK = qw( + to_universal + ); +} + +use Carp; +use Const::Fast; +use List::Util qw(all); +use Unicode::UTF8 qw(encode_utf8); + +use Test::Lintian::Output::Universal qw(universal_string order); + +const my $EMPTY => q{}; +const my $NEWLINE => qq{\n}; + +=head1 FUNCTIONS + +=over 4 + +=item to_universal(STRING) + +Converts the C<EWI> hint data contained in STRING to universal hints. +They are likewise delivered in a multi-line string. + +=cut + +sub to_universal { + my ($ewi) = @_; + + my @unsorted; + + my @lines = split($NEWLINE, $ewi); + chomp @lines; + + foreach my $line (@lines) { + + # no hint in this line + next if $line =~ /^N: /; + + # look for "EWI: package[ type]: name details" + my ($code, $package, $type, $name, $details) + = $line=~ /^(.): (\S+)(?: (changes|source|udeb))?: (\S+)(?: (.*))?$/; + + # for binary packages, the type field is empty + $type //= 'binary'; + + croak encode_utf8("Cannot parse line $line") + unless all { length } ($code, $package, $type, $name); + + my $converted = universal_string($package, $type, $name, $details); + push(@unsorted, $converted); + } + + my @sorted = reverse sort { order($a) cmp order($b) } @unsorted; + + my $universal = $EMPTY; + $universal .= $_ . $NEWLINE for @sorted; + + return $universal; +} + +=back + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Test/Lintian/Output/Universal.pm b/lib/Test/Lintian/Output/Universal.pm new file mode 100644 index 0000000..707b958 --- /dev/null +++ b/lib/Test/Lintian/Output/Universal.pm @@ -0,0 +1,189 @@ +# 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 Test::Lintian::Output::Universal; + +=head1 NAME + +Test::Lintian::Output::Universal -- routines to process universal hints + +=head1 SYNOPSIS + + use Test::Lintian::Output::Universal qw(get_tag_names); + + my $filepath = "path to a universal hint file"; + my @tags = get_tag_names($filepath); + +=head1 DESCRIPTION + +Helper routines to deal with universal hints and hint files. This is an +abstract format that has the minimum information found in all Lintian +output formats. + +=cut + +use v5.20; +use warnings; +use utf8; + +use Exporter qw(import); + +BEGIN { + our @EXPORT_OK = qw( + get_tag_names + order + package_name + package_type + tag_name + parse_line + universal_string + ); +} + +use Carp; +use Const::Fast; +use List::SomeUtils qw(uniq); +use List::Util qw(all); +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8); + +const my $SPACE => q{ }; +const my $COLON => q{:}; +const my $LPARENS => q{(}; +const my $RPARENS => q{)}; + +=head1 FUNCTIONS + +=over 4 + +=item get_tag_names(PATH) + +Gets all the tag names mentioned in universal hint file located +at PATH. + +=cut + +sub get_tag_names { + my ($path) = @_; + + my @lines = path($path)->lines_utf8({ chomp => 1 }); + my @names = map { tag_name($_) } @lines; + + return uniq @names; +} + +=item order + +=cut + +sub order { + my ($line) = @_; + + return package_type($line) . $line; +} + +=item package_name + +=cut + +sub package_name { + my ($line) = @_; + + my ($package, undef, undef, undef) = parse_line($line); + return $package; +} + +=item package_type + +=cut + +sub package_type { + my ($line) = @_; + + my (undef, $type, undef, undef) = parse_line($line); + return $type; +} + +=item tag_name + +=cut + +sub tag_name { + my ($line) = @_; + + my (undef, undef, $name, undef) = parse_line($line); + return $name; +} + +=item parse_line + +=cut + +sub parse_line { + my ($line) = @_; + + my ($package, $type, $name, $details) + = $line =~ qr/^(\S+)\s+\(([^)]+)\):\s+(\S+)(?:\s+(.*))?$/; + + croak encode_utf8("Cannot parse line $line") + unless all { length } ($package, $type, $name); + + return ($package, $type, $name, $details); +} + +=item universal_string + +=cut + +sub universal_string { + my ($package, $type, $name, $details) = @_; + + croak encode_utf8('Need a package name') + unless length $package; + croak encode_utf8('Need a package type') + unless length $type; + croak encode_utf8('Need a tag name') + unless length $name; + + my $line + = $package. $SPACE. $LPARENS. $type. $RPARENS. $COLON. $SPACE. $name; + $line .= $SPACE . $details + if length $details; + + return $line; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Test/Lintian/Prepare.pm b/lib/Test/Lintian/Prepare.pm new file mode 100644 index 0000000..8914fcc --- /dev/null +++ b/lib/Test/Lintian/Prepare.pm @@ -0,0 +1,551 @@ +# Copyright (C) 2018-2020 Felix Lechner +# 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 Test::Lintian::Prepare; + +=head1 NAME + +Test::Lintian::Prepare -- routines to prepare the work directories + +=head1 SYNOPSIS + + use Test::Lintian::Prepare qw(prepare); + +=head1 DESCRIPTION + +The routines in this module prepare the work directories in which the +tests are run. To do so, they use the specifications in the test set. + +=cut + +use v5.20; +use warnings; +use utf8; + +use Exporter qw(import); + +BEGIN { + our @EXPORT_OK = qw( + prepare + filleval + ); +} + +use Carp; +use Const::Fast; +use Cwd qw(getcwd); +use File::Copy; +use File::Find::Rule; +use File::Path qw(make_path remove_tree); +use File::stat; +use List::Util qw(max); +use Path::Tiny; +use Text::Template; +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::Deb822::Section; + +use Test::Lintian::ConfigFile qw(read_config write_config); +use Test::Lintian::Helper qw(rfc822date copy_dir_contents); +use Test::Lintian::Templates + qw(copy_skeleton_template_sets remove_surplus_templates fill_skeleton_templates); + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $SLASH => q{/}; +const my $COMMA => q{,}; + +=head1 FUNCTIONS + +=over 4 + +=item prepare(SPEC_PATH, SOURCE_PATH, TEST_SET, REBUILD) + +Populates a work directory SOURCE_PATH with data from the test located +in SPEC_PATH. The optional parameter REBUILD forces a rebuild if true. + +=cut + +sub prepare { + my ($specpath, $sourcepath, $testset, $force_rebuild)= @_; + + say encode_utf8('------- Preparation starts here -------'); + say encode_utf8("Work directory is $sourcepath."); + + # for template fill, earliest date without timewarp warning + my $data_epoch = $ENV{'POLICY_EPOCH'}//time; + + # read defaults + my $defaultspath = "$testset/defaults"; + + # read default file names + my $defaultfilespath = "$defaultspath/files"; + die encode_utf8("Cannot find $defaultfilespath") + unless -e $defaultfilespath; + + # read file and adjust data age threshold + my $files = read_config($defaultfilespath); + # $data_epoch= max($data_epoch, stat($defaultfilespath)->mtime); + + # read test data + my $descpath = $specpath . $SLASH . $files->unfolded_value('Fill-Values'); + my $desc = read_config($descpath); + # $data_epoch= max($data_epoch, stat($descpath)->mtime); + + # read test defaults + my $descdefaultspath + = $defaultspath . $SLASH . $files->unfolded_value('Fill-Values'); + my $defaults = read_config($descdefaultspath); + # $data_epoch= max($data_epoch, stat($descdefaultspath)->mtime); + + # start with a shallow copy of defaults + my $testcase = Lintian::Deb822::Section->new; + $testcase->store($_, $defaults->value($_)) for $defaults->names; + + die encode_utf8("Name missing for $specpath") + unless $desc->declares('Testname'); + + die encode_utf8('Outdated test specification (./debian/debian exists).') + if -e "$specpath/debian/debian"; + + if (-d $sourcepath) { + + # check for old build artifacts + my $buildstamp = "$sourcepath/build-stamp"; + say encode_utf8('Found old build artifact.') if -e $buildstamp; + + # check for old debian/debian directory + my $olddebiandir = "$sourcepath/debian/debian"; + say encode_utf8('Found old debian/debian directory.') + if -e $olddebiandir; + + # check for rebuild demand + say encode_utf8('Forcing rebuild.') if $force_rebuild; + + # delete work directory + if($force_rebuild || -e $buildstamp || -e $olddebiandir) { + say encode_utf8("Removing work directory $sourcepath."); + remove_tree($sourcepath); + } + } + + # create work directory + unless (-d $sourcepath) { + say encode_utf8("Creating directory $sourcepath."); + make_path($sourcepath); + } + + # delete old test scripts + my @oldrunners = File::Find::Rule->file->name('*.t')->in($sourcepath); + if (@oldrunners) { + unlink(@oldrunners) + or die encode_utf8("Cannot unlink @oldrunners"); + } + + my $skeletonname = $desc->unfolded_value('Skeleton'); + if (length $skeletonname) { + + # load skeleton + my $skeletonpath = "$testset/skeletons/$skeletonname"; + my $skeleton = read_config($skeletonpath); + + $testcase->store($_, $skeleton->value($_)) for $skeleton->names; + } + + # populate working directory with specified template sets + copy_skeleton_template_sets($testcase->value('Template-Sets'), + $sourcepath, $testset) + if $testcase->declares('Template-Sets'); + + # delete templates for which we have originals + remove_surplus_templates($specpath, $sourcepath); + + # copy test specification to working directory + my $offset = path($specpath)->relative($testset)->stringify; + say encode_utf8( + "Copy test specification $offset from $testset to $sourcepath."); + copy_dir_contents($specpath, $sourcepath); + + my $valuefolder = $testcase->unfolded_value('Fill-Values-Folder'); + if (length $valuefolder) { + + # load all the values in the fill values folder + my $valuepath = "$sourcepath/$valuefolder"; + my @filepaths + = File::Find::Rule->file->name('*.values')->in($valuepath); + + for my $filepath (sort @filepaths) { + my $fill_values = read_config($filepath); + + $testcase->store($_, $fill_values->value($_)) + for $fill_values->names; + } + } + + # add individual settings after skeleton + $testcase->store($_, $desc->value($_)) for $desc->names; + + # record path to specification + $testcase->store('Spec-Path', $specpath); + + # record path to specification + $testcase->store('Source-Path', $sourcepath); + + # add other helpful info to testcase + $testcase->store('Source', $testcase->unfolded_value('Testname')) + unless $testcase->declares('Source'); + + # record our effective data age as date, unless given + $testcase->store('Date', rfc822date($data_epoch)) + unless $testcase->declares('Date'); + + warn encode_utf8('Cannot override Architecture: in test ' + . $testcase->unfolded_value('Testname')) + if $testcase->declares('Architecture'); + + die encode_utf8('DEB_HOST_ARCH is not set.') + unless defined $ENV{'DEB_HOST_ARCH'}; + $testcase->store('Host-Architecture', $ENV{'DEB_HOST_ARCH'}); + + die encode_utf8('Could not get POLICY_VERSION.') + unless defined $ENV{'POLICY_VERSION'}; + $testcase->store('Standards-Version', $ENV{'POLICY_VERSION'}) + unless $testcase->declares('Standards-Version'); + + die encode_utf8('Could not get DEFAULT_DEBHELPER_COMPAT.') + unless defined $ENV{'DEFAULT_DEBHELPER_COMPAT'}; + $testcase->store('Dh-Compat-Level', $ENV{'DEFAULT_DEBHELPER_COMPAT'}) + unless $testcase->declares('Dh-Compat-Level'); + + # add additional version components + if ($testcase->declares('Version')) { + + # add upstream version + my $upstream_version = $testcase->unfolded_value('Version'); + $upstream_version =~ s/-[^-]+$//; + $upstream_version =~ s/(-|^)(\d+):/$1/; + $testcase->store('Upstream-Version', $upstream_version); + + # version without epoch + my $no_epoch = $testcase->unfolded_value('Version'); + $no_epoch =~ s/^\d+://; + $testcase->store('No-Epoch', $no_epoch); + + unless ($testcase->declares('Prev-Version')) { + my $prev_version = '0.0.1'; + $prev_version .= '-1' + unless $testcase->unfolded_value('Type') eq 'native'; + + $testcase->store('Prev-Version', $prev_version); + } + } + + # calculate build dependencies + warn encode_utf8('Cannot override Build-Depends:') + if $testcase->declares('Build-Depends'); + combine_fields($testcase, 'Build-Depends', $COMMA . $SPACE, + 'Default-Build-Depends', 'Extra-Build-Depends'); + + # calculate build conflicts + warn encode_utf8('Cannot override Build-Conflicts:') + if $testcase->declares('Build-Conflicts'); + combine_fields($testcase, 'Build-Conflicts', $COMMA . $SPACE, + 'Default-Build-Conflicts', 'Extra-Build-Conflicts'); + + # fill testcase with itself; do it twice to make sure all is done + my $hashref = deb822_section_to_hash($testcase); + $hashref = fill_hash_from_hash($hashref); + $hashref = fill_hash_from_hash($hashref); + write_hash_to_deb822_section($hashref, $testcase); + + say encode_utf8($EMPTY); + + # fill remaining templates + fill_skeleton_templates($testcase->value('Fill-Targets'), + $hashref, $data_epoch, $sourcepath, $testset) + if $testcase->declares('Fill-Targets'); + + # write the dynamic file names + my $runfiles = path($sourcepath)->child('files'); + write_config($files, $runfiles->stringify); + + # set mtime for dynamic file names + $runfiles->touch($data_epoch); + + # write the dynamic test case file + my $rundesc + = path($sourcepath)->child($files->unfolded_value('Fill-Values')); + write_config($testcase, $rundesc->stringify); + + # set mtime for dynamic test data + $rundesc->touch($data_epoch); + + say encode_utf8($EMPTY); + + # announce data age + say encode_utf8('Data epoch is : '. rfc822date($data_epoch)); + + return; +} + +=item filleval(SPEC_PATH, EVAL_PATH, TEST_SET, REBUILD) + +Populates a evaluation directory EVAL_PATH with data from the test located +in SPEC_PATH. The optional parameter REBUILD forces a rebuild if true. + +=cut + +sub filleval { + my ($specpath, $evalpath, $testset, $force_rebuild)= @_; + + say encode_utf8('------- Filling evaluation starts here -------'); + say encode_utf8("Evaluation directory is $evalpath."); + + # read defaults + my $defaultspath = "$testset/defaults"; + + # read default file names + my $defaultfilespath = "$defaultspath/files"; + die encode_utf8("Cannot find $defaultfilespath") + unless -e $defaultfilespath; + + # read file with default file names + my $files = read_config($defaultfilespath); + + # read test data + my $descpath + = $specpath . $SLASH . $files->unfolded_value('Test-Specification'); + my $desc = read_config($descpath); + + # read test defaults + my $descdefaultspath + = $defaultspath . $SLASH . $files->unfolded_value('Test-Specification'); + my $defaults = read_config($descdefaultspath); + + # start with a shallow copy of defaults + my $testcase = Lintian::Deb822::Section->new; + $testcase->store($_, $defaults->value($_)) for $defaults->names; + + die encode_utf8("Name missing for $specpath") + unless $desc->declares('Testname'); + + # delete old test scripts + my @oldrunners = File::Find::Rule->file->name('*.t')->in($evalpath); + if (@oldrunners) { + unlink(@oldrunners) + or die encode_utf8("Cannot unlink @oldrunners"); + } + + $testcase->store('Skeleton', $desc->value('Skeleton')) + unless $testcase->declares('Skeleton'); + + my $skeletonname = $testcase->unfolded_value('Skeleton'); + if (length $skeletonname) { + + # load skeleton + my $skeletonpath = "$testset/skeletons/$skeletonname"; + my $skeleton = read_config($skeletonpath); + + $testcase->store($_, $skeleton->value($_)) for $skeleton->names; + } + + # add individual settings after skeleton + $testcase->store($_, $desc->value($_)) for $desc->names; + + # populate working directory with specified template sets + copy_skeleton_template_sets($testcase->value('Template-Sets'), + $evalpath, $testset) + if $testcase->declares('Template-Sets'); + + # delete templates for which we have originals + remove_surplus_templates($specpath, $evalpath); + + # copy test specification to working directory + my $offset = path($specpath)->relative($testset)->stringify; + say encode_utf8( + "Copy test specification $offset from $testset to $evalpath."); + copy_dir_contents($specpath, $evalpath); + + my $valuefolder = $testcase->unfolded_value('Fill-Values-Folder'); + if (length $valuefolder) { + + # load all the values in the fill values folder + my $valuepath = "$evalpath/$valuefolder"; + my @filepaths + = File::Find::Rule->file->name('*.values')->in($valuepath); + + for my $filepath (sort @filepaths) { + my $fill_values = read_config($filepath); + + $testcase->store($_, $fill_values->value($_)) + for $fill_values->names; + } + } + + # add individual settings after skeleton + $testcase->store($_, $desc->value($_)) for $desc->names; + + # fill testcase with itself; do it twice to make sure all is done + my $hashref = deb822_section_to_hash($testcase); + $hashref = fill_hash_from_hash($hashref); + $hashref = fill_hash_from_hash($hashref); + write_hash_to_deb822_section($hashref, $testcase); + + say encode_utf8($EMPTY); + + # fill remaining templates + fill_skeleton_templates($testcase->value('Fill-Targets'), + $hashref, time, $evalpath, $testset) + if $testcase->declares('Fill-Targets'); + + # write the dynamic file names + my $runfiles = path($evalpath)->child('files'); + write_config($files, $runfiles->stringify); + + # write the dynamic test case file + my $rundesc + = path($evalpath)->child($files->unfolded_value('Test-Specification')); + write_config($testcase, $rundesc->stringify); + + say encode_utf8($EMPTY); + + return; +} + +=item combine_fields + +=cut + +sub combine_fields { + my ($testcase, $destination, $delimiter, @sources) = @_; + + return + unless length $destination; + + # we are combining these contents + my @contents; + for my $source (@sources) { + push(@contents, $testcase->value($source)) + if length $source; + $testcase->drop($source); + } + + # combine + for my $content (@contents) { + $testcase->store( + $destination, + join($delimiter, + grep { length }($testcase->value($destination),$content)) + ); + } + + # delete the combined entry if it is empty + $testcase->drop($destination) + unless length $testcase->value($destination); + + return; +} + +=item deb822_section_to_hash + +=cut + +sub deb822_section_to_hash { + my ($section) = @_; + + my %hash; + for my $name ($section->names) { + + my $transformed = lc $name; + $transformed =~ s/-/_/g; + + $hash{$transformed} = $section->value($name); + } + + return \%hash; +} + +=item write_hash_to_deb822_section + +=cut + +sub write_hash_to_deb822_section { + my ($hashref, $section) = @_; + + for my $name ($section->names) { + + my $transformed = lc $name; + $transformed =~ s/-/_/g; + + $section->store($name, $hashref->{$transformed}); + } + + return; +} + +=item fill_hash_from_hash + +=cut + +sub fill_hash_from_hash { + my ($hashref, $delimiters) = @_; + + $delimiters //= ['[%', '%]']; + + my %origin = %{$hashref}; + my %destination; + + # fill hash with itself + for my $key (keys %origin) { + + my $template = $origin{$key} // $EMPTY; + my $filler= Text::Template->new(TYPE => 'STRING', SOURCE => $template); + croak encode_utf8( + "Cannot read template $template: $Text::Template::ERROR") + unless $filler; + + my $generated + = $filler->fill_in(HASH => \%origin, DELIMITERS => $delimiters); + croak encode_utf8("Could not create string from template $template") + unless defined $generated; + $destination{$key} = $generated; + } + + return \%destination; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Test/Lintian/Run.pm b/lib/Test/Lintian/Run.pm new file mode 100644 index 0000000..4fb7c97 --- /dev/null +++ b/lib/Test/Lintian/Run.pm @@ -0,0 +1,570 @@ +# Copyright (C) 2018 Felix Lechner +# 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 Test::Lintian::Run; + +=head1 NAME + +Test::Lintian::Run -- generic runner for all suites + +=head1 SYNOPSIS + + use Test::Lintian::Run qw(runner); + + my $runpath = "test working directory"; + + runner($runpath); + +=head1 DESCRIPTION + +Generic test runner for all Lintian test suites + +=cut + +use v5.20; +use warnings; +use utf8; + +use Exporter qw(import); + +BEGIN { + our @EXPORT_OK = qw( + logged_runner + runner + check_result + ); +} + +use Capture::Tiny qw(capture_merged); +use Const::Fast; +use Cwd qw(getcwd); +use File::Basename qw(basename); +use File::Spec::Functions qw(abs2rel rel2abs splitpath catpath); +use File::Compare; +use File::Copy; +use File::stat; +use IPC::Run3; +use List::Compare; +use List::Util qw(max min any all); +use Path::Tiny; +use Syntax::Keyword::Try; +use Test::More; +use Text::Diff; +use Unicode::UTF8 qw(encode_utf8 decode_utf8); + +use Lintian::Deb822; +use Lintian::Profile; + +use Test::Lintian::ConfigFile qw(read_config); +use Test::Lintian::Helper qw(rfc822date); +use Test::Lintian::Hooks + qw(find_missing_prerequisites sed_hook sort_lines calibrate); +use Test::Lintian::Output::Universal qw(get_tag_names order); + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $INDENT => $SPACE x 2; +const my $SLASH => q{/}; +const my $NEWLINE => qq{\n}; +const my $YES => q{yes}; +const my $NO => q{no}; + +const my $WAIT_STATUS_SHIFT => 8; + +# turn off the @@-style headers in Text::Diff +no warnings 'redefine'; +sub Text::Diff::Unified::file_header { return $EMPTY; } +sub Text::Diff::Unified::hunk_header { return $EMPTY; } + +=head1 FUNCTIONS + +=over 4 + +=item logged_runner(RUN_PATH) + +Starts the generic test runner for the test located in RUN_PATH +and logs the output. + +=cut + +sub logged_runner { + my ($runpath) = @_; + + my $error; + + # read dynamic file names + my $runfiles = "$runpath/files"; + my $files = read_config($runfiles); + + # set path to logfile + my $logpath = $runpath . $SLASH . $files->unfolded_value('Log'); + + my $log_bytes = capture_merged { + try { + # call runner + runner($runpath, $logpath) + + } catch { + # catch any error + $error = $@; + } + }; + + my $log = decode_utf8($log_bytes); + + # append runner log to population log + path($logpath)->append_utf8($log) if length $log; + + # add error if there was one + path($logpath)->append_utf8($error) if length $error; + + # print log and die on error + if ($error) { + print encode_utf8($log) + if length $log && $ENV{'DUMP_LOGS'}//$NO eq $YES; + die encode_utf8("Runner died for $runpath: $error"); + } + + return; +} + +=item runner(RUN_PATH) + +This routine provides the basic structure for all runners and runs the +test located in RUN_PATH. + +=cut + +sub runner { + my ($runpath, @exclude)= @_; + + # set a predictable locale + $ENV{'LC_ALL'} = 'C'; + + say encode_utf8($EMPTY); + say encode_utf8('------- Runner starts here -------'); + + # bail out if runpath does not exist + BAIL_OUT(encode_utf8("Cannot find test directory $runpath.")) + unless -d $runpath; + + # announce location + say encode_utf8("Running test at $runpath."); + + # read dynamic file names + my $runfiles = "$runpath/files"; + my $files = read_config($runfiles); + + # get file age + my $spec_epoch = stat($runfiles)->mtime; + + # read dynamic case data + my $rundescpath + = $runpath . $SLASH . $files->unfolded_value('Test-Specification'); + my $testcase = read_config($rundescpath); + + # get data age + $spec_epoch = max(stat($rundescpath)->mtime, $spec_epoch); + say encode_utf8('Specification is from : '. rfc822date($spec_epoch)); + + say encode_utf8($EMPTY); + + # age of runner executable + my $runner_epoch = $ENV{'RUNNER_EPOCH'}//time; + say encode_utf8('Runner modified on : '. rfc822date($runner_epoch)); + + # age of harness executable + my $harness_epoch = $ENV{'HARNESS_EPOCH'}//time; + say encode_utf8('Harness modified on : '. rfc822date($harness_epoch)); + + # calculate rebuild threshold + my $threshold= max($spec_epoch, $runner_epoch, $harness_epoch); + say encode_utf8('Rebuild threshold is : '. rfc822date($threshold)); + + say encode_utf8($EMPTY); + + # age of Lintian executable + my $lintian_epoch = $ENV{'LINTIAN_EPOCH'}//time; + say encode_utf8('Lintian modified on : '. rfc822date($lintian_epoch)); + + my $testname = $testcase->unfolded_value('Testname'); + # name of encapsulating directory should be that of test + my $expected_name = path($runpath)->basename; + die encode_utf8( + "Test in $runpath is called $testname instead of $expected_name") + unless $testname eq $expected_name; + + # skip test if marked + my $skipfile = "$runpath/skip"; + if (-e $skipfile) { + my $reason = path($skipfile)->slurp_utf8 || 'No reason given'; + say encode_utf8("Skipping test: $reason"); + plan skip_all => "(disabled) $reason"; + } + + # skip if missing prerequisites + my $missing = find_missing_prerequisites($testcase); + if (length $missing) { + say encode_utf8("Missing prerequisites: $missing"); + plan skip_all => $missing; + } + + # check test architectures + unless (length $ENV{'DEB_HOST_ARCH'}) { + say encode_utf8('DEB_HOST_ARCH is not set.'); + BAIL_OUT(encode_utf8('DEB_HOST_ARCH is not set.')); + } + my $platforms = $testcase->unfolded_value('Test-Architectures'); + if ($platforms ne 'any') { + + my @wildcards = split($SPACE, $platforms); + my $match = 0; + for my $wildcard (@wildcards) { + + my @command = ( + qw{dpkg-architecture -a}, + $ENV{'DEB_HOST_ARCH'}, '-i', $wildcard + ); + run3(\@command, \undef, \undef, \undef); + my $status = ($? >> $WAIT_STATUS_SHIFT); + + unless ($status) { + $match = 1; + last; + } + } + unless ($match) { + say encode_utf8('Architecture mismatch'); + plan skip_all => encode_utf8('Architecture mismatch'); + } + } + + plan skip_all => 'No package found' + unless -e "$runpath/subject"; + + # set the testing plan + plan tests => 1; + + my $subject = path("$runpath/subject")->realpath; + + # get lintian subject + die encode_utf8('Could not get subject of Lintian examination.') + unless -e $subject; + + # run lintian + $ENV{'LINTIAN_COVERAGE'}.= ",-db,./cover_db-$testname" + if exists $ENV{'LINTIAN_COVERAGE'}; + + my $lintian_command_line + = $testcase->unfolded_value('Lintian-Command-Line'); + my $command + = "cd $runpath; $ENV{'LINTIAN_UNDER_TEST'} $lintian_command_line $subject"; + say encode_utf8($command); + my ($output, $status) = capture_merged { system($command); }; + $status >>= $WAIT_STATUS_SHIFT; + + $output = decode_utf8($output) + if length $output; + + say encode_utf8("$command exited with status $status."); + say encode_utf8($output) if $status == 1; + + my $expected_status = $testcase->unfolded_value('Exit-Status'); + + my @errors; + push(@errors, + "Exit code $status differs from expected value $expected_status.") + if $testcase->declares('Exit-Status') + && $status != $expected_status; + + # filter out some warnings if running under coverage + my @lines = split(/\n/, $output); + if (exists $ENV{LINTIAN_COVERAGE}) { + # Devel::Cover causes deep recursion warnings. + @lines = grep { + !m{^Deep [ ] recursion [ ] on [ ] subroutine [ ] + "[^"]+" [ ] at [ ] .*B/Deparse.pm [ ] line [ ] + \d+}xsm + } @lines; + } + + # put output back together + $output = $EMPTY; + $output .= $_ . $NEWLINE for @lines; + + die encode_utf8('No match strategy defined') + unless $testcase->declares('Match-Strategy'); + + my $match_strategy = $testcase->unfolded_value('Match-Strategy'); + + if ($match_strategy eq 'literal') { + push(@errors, check_literal($testcase, $runpath, $output)); + + } elsif ($match_strategy eq 'hints') { + push(@errors, check_hints($testcase, $runpath, $output)); + + } else { + die encode_utf8("Unknown match strategy $match_strategy."); + } + + my $okay = !(scalar @errors); + + if ($testcase->declares('Todo')) { + + my $explanation = $testcase->unfolded_value('Todo'); + diag encode_utf8("TODO ($explanation)"); + + TODO: { + local $TODO = $explanation; + ok($okay, 'Lintian passes for test marked TODO.'); + } + + return; + } + + diag encode_utf8($_ . $NEWLINE) for @errors; + + ok($okay, "Lintian passes for $testname"); + + return; +} + +=item check_literal + +=cut + +sub check_literal { + my ($testcase, $runpath, $output) = @_; + + # create expected output if it does not exist + my $expected = "$runpath/literal"; + path($expected)->touch + unless -e $expected; + + my $raw = "$runpath/literal.actual"; + path($raw)->spew_utf8($output); + + # run a sed-script if it exists + my $actual = "$runpath/literal.actual.parsed"; + my $script = "$runpath/post-test"; + if (-e $script) { + sed_hook($script, $raw, $actual); + } else { + die encode_utf8("Could not copy actual hints $raw to $actual: $!") + if system('cp', '-p', $raw, $actual); + } + + return check_result($testcase, $runpath, $expected, $actual); +} + +=item check_hints + +=cut + +sub check_hints { + my ($testcase, $runpath, $output) = @_; + + # create expected hints if there are none; helps when calibrating new tests + my $expected = "$runpath/hints"; + path($expected)->touch + unless -e $expected; + + my $raw = "$runpath/hints.actual"; + path($raw)->spew_utf8($output); + + # run a sed-script if it exists + my $actual = "$runpath/hints.actual.parsed"; + my $sedscript = "$runpath/post-test"; + if (-e $sedscript) { + sed_hook($sedscript, $raw, $actual); + } else { + die encode_utf8("Could not copy actual hints $raw to $actual: $!") + if system('cp', '-p', $raw, $actual); + } + + # calibrate hints; may write to $actual + my $calibrated = "$runpath/hints.specified.calibrated"; + my $calscript = "$runpath/test-calibration"; + if(-x $calscript) { + calibrate($calscript, $actual, $expected, $calibrated); + } else { + die encode_utf8( + "Could not copy expected hints $expected to $calibrated: $!") + if system('cp', '-p', $expected, $calibrated); + } + + return check_result($testcase, $runpath, $calibrated, $actual); +} + +=item check_result(DESC, EXPECTED, ACTUAL) + +This routine checks if the EXPECTED hints match the calibrated ACTUAL for the +test described by DESC. For some additional checks, also need the ORIGINAL +hints before calibration. Returns a list of errors, if there are any. + +=cut + +sub check_result { + my ($testcase, $runpath, $expectedpath, $actualpath) = @_; + + my @errors; + + my @expectedlines = path($expectedpath)->lines_utf8; + my @actuallines = path($actualpath)->lines_utf8; + + push(@expectedlines, $NEWLINE) + unless @expectedlines; + push(@actuallines, $NEWLINE) + unless @actuallines; + + my $match_strategy = $testcase->unfolded_value('Match-Strategy'); + + if ($match_strategy eq 'hints') { + @expectedlines + = reverse sort { order($a) cmp order($b) } @expectedlines; + @actuallines + = reverse sort { order($a) cmp order($b) } @actuallines; + } + + my $diff = diff(\@expectedlines, \@actuallines, { CONTEXT => 0 }); + my @difflines = split(/\n/, $diff); + chomp @difflines; + + # diag encode_utf8("Difflines: $_") for @difflines; + + if(@difflines) { + + if ($match_strategy eq 'literal') { + push(@errors, 'Literal output does not match'); + + } elsif ($match_strategy eq 'hints') { + + push(@errors, 'Hints do not match'); + + @difflines = reverse sort @difflines; + my $hintdiff; + $hintdiff .= $_ . $NEWLINE for @difflines; + path("$runpath/hintdiff")->spew_utf8($hintdiff // $EMPTY); + + } else { + die encode_utf8("Unknown match strategy $match_strategy."); + } + + push(@errors, $EMPTY); + + push(@errors, '--- ' . abs2rel($expectedpath)); + push(@errors, '+++ ' . abs2rel($actualpath)); + push(@errors, @difflines); + + push(@errors, $EMPTY); + } + + # stop if the test is not about hints + return @errors + unless $match_strategy eq 'hints'; + + # get expected tags + my @expected = sort +get_tag_names($expectedpath); + + #diag encode_utf8("=Expected tag: $_") for @expected; + + # look out for tags being tested + my @related; + + if ( $testcase->declares('Check') + && $testcase->unfolded_value('Check') ne 'all') { + + my $profile = Lintian::Profile->new; + $profile->load(undef, undef, 0); + + # use tags related to checks declared + my @check_names = $testcase->trimmed_list('Check'); + my @unknown + = grep { !exists $profile->check_module_by_name->{$_} } @check_names; + + die encode_utf8('Unknown Lintian checks: ' . join($SPACE, @unknown)) + if @unknown; + + push(@related, @{$profile->tag_names_for_check->{$_} // []}) + for @check_names; + + @related = sort @related; + + } else { + # otherwise, look for all expected tags + @related = @expected; + } + + #diag encode_utf8("#Related tag: $_") for @related; + + # calculate Test-For and Test-Against; results are sorted + my $material = List::Compare->new(\@expected, \@related); + my @test_for = $material->get_intersection; + my @test_against = $material->get_Ronly; + + #diag encode_utf8("+Test-For: $_") for @test_for; + #diag encode_utf8("-Test-Against (calculated): $_") for @test_against; + + # get actual tags from output + my @actual = sort +get_tag_names($actualpath); + + #diag encode_utf8("*Actual tag found: $_") for @actual; + + # check for blacklisted tags; result is sorted + my @unexpected + = List::Compare->new(\@test_against, \@actual)->get_intersection; + + # warn about unexpected tags + if (@unexpected) { + push(@errors, 'Unexpected tags:'); + push(@errors, $INDENT . $_) for @unexpected; + push(@errors, $EMPTY); + } + # find tags not seen; result is sorted + my @missing = List::Compare->new(\@test_for, \@actual)->get_Lonly; + + # warn about missing tags + if (@missing) { + push(@errors, 'Missing tags:'); + push(@errors, $INDENT . $_) for @missing; + push(@errors, $EMPTY); + } + + return @errors; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Test/Lintian/Templates.pm b/lib/Test/Lintian/Templates.pm new file mode 100644 index 0000000..b52df15 --- /dev/null +++ b/lib/Test/Lintian/Templates.pm @@ -0,0 +1,348 @@ +# Copyright (C) 2018 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 Test::Lintian::Templates; + +=head1 NAME + +Test::Lintian::Templates -- Helper routines dealing with templates + +=head1 SYNOPSIS + +use Test::Lintian::Templates qw(fill_template); + +my $data = { 'placeholder' => 'value' }; +my $file = '/path/to/generated/file'; + +fill_template("$file.in", $file, $data); + +=head1 DESCRIPTION + +Routines for dealing with templates in Lintian test specifications. + +=cut + +use v5.20; +use warnings; +use utf8; + +use Exporter qw(import); + +BEGIN { + our @EXPORT_OK = qw( + copy_skeleton_template_sets + remove_surplus_templates + fill_skeleton_templates + fill_whitelisted_templates + fill_all_templates + fill_template + ); +} + +use Carp; +use Const::Fast; +use List::Util qw(max); +use File::Path qw(make_path); +use File::Spec::Functions qw(rel2abs abs2rel); +use File::Find::Rule; +use File::stat; +use Path::Tiny; +use Text::Template; +use Unicode::UTF8 qw(encode_utf8); + +use Test::Lintian::ConfigFile qw(read_config); +use Test::Lintian::Helper qw(copy_dir_contents); + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $DOT => q{.}; +const my $COMMA => q{,}; +const my $COLON => q{:}; + +=head1 FUNCTIONS + +=over 4 + +=item copy_skeleton_template_sets(INSTRUCTIONS, RUN_PATH, SUITE, TEST_SET) + +Copies template sets belonging to SUITE into the test working directory +RUN_PATH according to INSTRUCTIONS. The INSTRUCTIONS are the target +directory relative to RUN_PATH followed by the name of the template set +in parentheses. Multiple such instructions must be separated by commas. + +=cut + +sub copy_skeleton_template_sets { + my ($instructions, $runpath, $testset)= @_; + + # populate working directory with specified template sets + for my $placement (split($COMMA, $instructions)) { + + my ($relative, $name) + =($placement =~ qr/^\s*([^()\s]+)\s*\(([^()\s]+)\)\s*$/); + + croak encode_utf8('No template destination specified in skeleton.') + unless length $relative; + + croak encode_utf8('No template set specified in skeleton.') + unless length $name; + + my $templatesetpath = "$testset/templates/$name"; + croak encode_utf8( + "Cannot find template set '$name' at $templatesetpath.") + unless -d $templatesetpath; + + say encode_utf8( + "Installing template set '$name'" + . ( + $relative ne $DOT ? " to ./$relative." : $EMPTY + ) + ); + + # create directory + my $destination = "$runpath/$relative"; + make_path($destination); + + # copy template set + copy_dir_contents($templatesetpath, $destination) + if -d $templatesetpath; + } + return; +} + +=item remove_surplus_templates(SRC_DIR, TARGET_DIR) + +Removes from TARGET_DIR any templates that have corresponding originals +in SRC_DIR. + +=cut + +sub remove_surplus_templates { + my ($source, $destination) = @_; + + my @originals = File::Find::Rule->file->in($source); + foreach my $original (@originals) { + my $relative = abs2rel($original, $source); + my $template = rel2abs("$relative.in", $destination); + + if (-e $template) { + unlink($template) + or die encode_utf8("Cannot unlink $template"); + } + } + return; +} + +=item fill_skeleton_templates(INSTRUCTIONS, HASH, EPOCH, RUN_PATH, TEST_SET) + +Fills the templates specified in INSTRUCTIONS using the data in HASH. Only +fills templates when the generated files are not present or are older than +either the file modification time of the template or the age of the data +as evidenced by EPOCH. The INSTRUCTIONS are the target directory relative +to RUN_PATH followed by the name of the whitelist in parentheses. Multiple +instructions must be separated by commas. + +=cut + +sub fill_skeleton_templates { + my ($instructions, $testcase, $threshold, $runpath, $testset)= @_; + + for my $target (split(/$COMMA/, $instructions)) { + + my ($relative, $name) + =($target=~ qr/^\s*([^()\s]+)\s*(?:\(([^()\s]+)\))?\s*$/); + + croak encode_utf8('No fill destination specified in skeleton.') + unless length $relative; + + if (length $name) { + + # template set + my $whitelistpath = "$testset/whitelists/$name"; + croak encode_utf8( + "Cannot find template whitelist '$name' at $whitelistpath") + unless -e $whitelistpath; + + say encode_utf8($EMPTY); + + say encode_utf8( + 'Generate files ' + . ( + $relative ne $DOT ? "in ./$relative " : $EMPTY + ) + . "from templates using whitelist '$name'." + ); + my $whitelist = read_config($whitelistpath); + + my @candidates = $whitelist->trimmed_list('May-Generate'); + my $destination = "$runpath/$relative"; + + say encode_utf8( + 'Fill templates' + . ( + $relative ne $DOT ? " in ./$relative" : $EMPTY + ) + . $COLON + . $SPACE + . join($SPACE, @candidates) + ); + + foreach my $candidate (@candidates) { + my $generated = rel2abs($candidate, $destination); + my $template = "$generated.in"; + + # fill template if needed + fill_template($template, $generated, $testcase, $threshold) + if -e $template; + } + + }else { + + # single file + say encode_utf8("Filling template: $relative"); + + my $generated = rel2abs($relative, $runpath); + my $template = "$generated.in"; + + # fill template if needed + fill_template($template, $generated, $testcase, $threshold) + if -e $template; + } + } + return; +} + +=item fill_whitelisted_templates(DIR, WHITE_LIST, HASH, HASH_EPOCH) + +Generates all files in array WHITE_LIST relative to DIR from their templates, +which are assumed to have the same file name but with extension '.in', using +data provided in HASH. The optional argument HASH_EPOCH can be used to +preserve files when no generation is necessary. + +=cut + +sub fill_whitelisted_templates { + my ($directory, $whitelistpath, $data, $data_epoch) = @_; + + croak encode_utf8("No whitelist found at $whitelistpath") + unless -e $whitelistpath; + + my $whitelist = read_config($whitelistpath); + my @list = $whitelist->trimmed_list('May-Generate'); + + foreach my $file (@list) { + my $generated = rel2abs($file, $directory); + my $template = "$generated.in"; + + # fill template if needed + fill_template($template, $generated, $data, $data_epoch) + if -e $template; + } + return; +} + +=item fill_all_templates(HASH, DIR) + +Fills all templates in DIR with data from HASH. + +=cut + +sub fill_all_templates { + my ($data, $data_epoch, $directory) = @_; + + my @templates = File::Find::Rule->name('*.in')->in($directory); + foreach my $template (@templates) { + my ($generated) = ($template =~ qr/^(.+?)\.in$/); + + # fill template if needed + fill_template($template, $generated, $data, $data_epoch); + } + return; +} + +=item fill_template(TEMPLATE, GENERATED, HASH, HASH_EPOCH, DELIMITERS) + +Fills template TEMPLATE with data from HASH and places the result in +file GENERATED. When given HASH_EPOCH, will evaluate beforehand if a +substitution is necessary based on file modification times. The optional +parameter DELIMITERS can be used to change the standard delimiters. + +=cut + +sub fill_template { + my ($template, $generated, $data, $data_epoch, $delimiters) = @_; + + my $generated_epoch + = length $generated && -e $generated ? stat($generated)->mtime : 0; + my $template_epoch + = length $template && -e $template ? stat($template)->mtime : time; + my $threshold = max($template_epoch, $data_epoch//time); + + if ($generated_epoch <= $threshold) { + + my $filler= Text::Template->new( + TYPE => 'FILE', + DELIMITERS => ['[%', '%]'], + SOURCE => $template + ); + croak encode_utf8( + "Cannot read template $template: $Text::Template::ERROR") + unless $filler; + + open(my $handle, '>', $generated) + or croak encode_utf8("Could not open file $generated: $!"); + $filler->fill_in( + OUTPUT => $handle, + HASH => $data, + DELIMITERS => $delimiters + ) + or croak encode_utf8( + "Could not create file $generated from template $template"); + close $handle + or carp encode_utf8("Could not close file $generated: $!"); + + # transfer file permissions from template to generated file + my $stat = stat($template) + or croak encode_utf8("stat $template failed: $!"); + chmod $stat->mode, $generated + or croak encode_utf8("chmod $generated failed: $!"); + + # set mtime to $threshold + path($generated)->touch($threshold); + } + + # delete template + if (-e $generated) { + unlink($template) + or die encode_utf8("Cannot unlink $template"); + } + + return; +} + +=back + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Test/ScriptAge.pm b/lib/Test/ScriptAge.pm new file mode 100644 index 0000000..dcab63b --- /dev/null +++ b/lib/Test/ScriptAge.pm @@ -0,0 +1,109 @@ +# 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 Test::ScriptAge; + +=head1 NAME + +Test::ScriptAge -- routines relating to the age of Perl scripts + +=head1 SYNOPSIS + + my $executable_epoch = Test::ScriptAge::our_modification_epoch(); + print encode_utf8('This script was last modified at ' . localtime($executable_epoch) . "\n"); + + my $perl_epoch = Test::ScriptAge::perl_modification_epoch(); + print encode_utf8('Perl was last modified at ' . localtime($perl_epoch) . "\n"); + +=head1 DESCRIPTION + +Routines to calculated modification times of Perl scripts. + +=cut + +use v5.20; +use warnings; +use utf8; + +use Exporter qw(import); + +BEGIN { + our @EXPORT_OK = qw( + perl_modification_epoch + our_modification_epoch + ); +} + +use File::stat; +use File::Spec::Functions qw(rel2abs); +use List::Util qw(max); +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8); + +=head1 FUNCTIONS + +=over 4 + +=item perl_modification_epoch + +Calculate the time our Perl was last modified. + +=cut + +sub perl_modification_epoch { + my $perlpath = rel2abs($^X); + return stat($perlpath)->mtime; +} + +=item our_modification_epoch + +Calculate the time our scripts, including all libraries, was last modified. + +=cut + +sub our_modification_epoch { + my (undef, $callerpath, undef) = caller; + + my @paths = map { rel2abs($_) } ($callerpath, values %INC); + if (my @relative = grep { !/^\// } @paths){ + warn encode_utf8( + 'Relative paths in running_epoch: '.join(', ', @relative)); + } + my @epochs = map { path($_)->stat->mtime } @paths; + return max @epochs; +} + +=back + +=head1 AUTHOR + +Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Test/StagedFileProducer.pm b/lib/Test/StagedFileProducer.pm new file mode 100644 index 0000000..ada9069 --- /dev/null +++ b/lib/Test/StagedFileProducer.pm @@ -0,0 +1,314 @@ +# Copyright (C) 2018 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 Test::StagedFileProducer; + +=head1 NAME + +Test::StagedFileProducer -- mtime-based file production engine + +=head1 SYNOPSIS + + use Test::StagedFileProducer; + + my $wherever = '/your/test/directory'; + + my $producer = Test::StagedFileProducer->new(path => $wherever); + $producer->exclude("$wherever/log", "$wherever/build-stamp"); + + my $output = "$wherever/file.out"; + $producer->add_stage( + products => [$output], + build =>sub { + print encode_utf8("Building $output.\n"); + }, + skip =>sub { + print encode_utf8("Skipping $output.\n"); + } + ); + + $producer->run(minimum_epoch => time, verbose => 1); + +=head1 DESCRIPTION + +Provides a way to define and stack file production stages that all +depend on subsets of the same group of files. + +After the stages are defined, the processing engine takes an inventory +of all files in a target directory. It excludes some files, like logs, +that should not be considered. + +Each stage adds its own products to the list of files to be excluded +before deciding whether to produce them. The decision is based on +relative file modification times, in addition to a systemic rebuilding +threshold. Before rebuilding, each stage asks a lower stage to make +the same determination. + +The result is an engine with file production stages that depend on +successively larger sets of files. + +=cut + +use v5.20; +use warnings; +use utf8; + +use Carp; +use Const::Fast; +use File::Find::Rule; +use File::Spec::Functions qw(abs2rel); +use File::stat; +use List::Util qw(min max); +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8); + +use Test::Lintian::Helper qw(rfc822date); + +const my $EMPTY => q{}; +const my $SPACE => q{ }; + +=head1 FUNCTIONS + +=over 4 + +=item new(path => PATH) + +Create a new instance focused on files in directory PATH. + +=cut + +sub new { + my ($class, %params) = @_; + + my $self = bless {}, $class; + + croak encode_utf8('Cannot proceed without a path.') + unless exists $params{path}; + $self->{path} = $params{path}; + + $self->{exclude} = []; + $self->{stages} = []; + + return $self; +} + +=item exclude(LIST) + +Excludes all absolute paths in LIST from all mtime comparisons. +This is especially useful for logs. Calls to Path::Tiny->realpath +are made to ensure the elements are canonical and have a chance +of matching something returned by File::Find::Rule. + +=cut + +sub exclude { + my ($self, @list) = @_; + + push(@{$self->{exclude}}, grep { defined } @list); + + return; +} + +=item add_stage(HASH) + +Add a stage defined by HASH to the processing engine for processing +after stages previously added. HASH can define the following keys: + +$HASH{products} => LIST; a list of full-path filenames to be +produced. + +$HASH{minimum_epoch} => EPOCH; an integer threshold for maximum age + +$HASH{build} => SUB; a sub executed when production is required. + +$HASH{skip} => SUB; a sub executed when production is not required. + +=cut + +sub add_stage { + my ($self, %stage) = @_; + + push(@{$self->{stages}}, \%stage); + + return; +} + +=item run(PARAMETERS) + +Runs the defined engine using the given parameters, which are +arranged in a matching list suitable for assignment to a hash. +The following two parameters are currently available: + +minimum_epoch => EPOCH; a systemic threshold, in epochs, below +which rebuilding is mandatory for any product. + +verbose => BOOLEAN; an option to enable more verbose reporting + +=cut + +sub run { + my ($self, %params) = @_; + + $self->{minimum_epoch} = $params{minimum_epoch} // 0; + $self->{verbose} = $params{verbose} // 0; + + # take an mtime inventory of all files in path + $self->{mtimes} + = { map { $_ => path($_)->stat->mtime } + File::Find::Rule->file->in($self->{path}) }; + + say encode_utf8( + 'Found the following file modification times (most recent first):') + if $self->{verbose}; + + my @ordered= reverse sort { $self->{mtimes}{$a} <=> $self->{mtimes}{$b} } + keys %{$self->{mtimes}}; + foreach my $file (@ordered) { + my $relative = abs2rel($file, $self->{path}); + say encode_utf8(rfc822date($self->{mtimes}{$file}) . " : $relative") + if $self->{verbose}; + } + + $self->_process_remaining_stages(@{$self->{exclude}}); + + return; +} + +=item _process_remaining_stages(LIST) + +An internal subroutine that is used recursively to execute +the stages. The list passed describes the list of files to +be excluded from subsequent mtime calculations. + +Please note that the bulk of the execution takes place +after calling the next lower stage. That is to ensure that +any lower build targets (or products, in our parlance) are +met before the present stage attempts to do its job. + +=cut + +sub _process_remaining_stages { + my ($self, @exclude) = @_; + + if (scalar @{$self->{stages}}) { + + # get the next processing stage + my %stage = %{ pop(@{$self->{stages}}) }; + + # add our products to the list of files excluded + my @products = grep { defined } @{$stage{products}//[]}; + push(@exclude, @products); + + # pass to next lower stage for potential rebuilding + $self->_process_remaining_stages(@exclude); + + # get good paths that will match those of File::Find + @exclude = map { path($_)->realpath } @exclude; + + say encode_utf8($EMPTY) if $self->{verbose}; + + my @relative = sort map { abs2rel($_, $self->{path}) } @products; + say encode_utf8( + 'Considering production of: ' . join($SPACE, @relative)) + if $self->{verbose}; + + say encode_utf8('Excluding: ' + . join($SPACE, sort map { abs2rel($_, $self->{path}) } @exclude)) + if $self->{verbose}; + + my %relevant = %{$self->{mtimes}}; + delete @relevant{@exclude}; + +# my @ordered= reverse sort { $relevant{$a} <=> $relevant{$b} } +# keys %relevant; +# foreach my $file (@ordered) { +# say encode_utf8(rfc822date($relevant{$file}) . ' : ' . abs2rel($file, $self->{path})) +# if $self->{verbose}; +# } + + say encode_utf8($EMPTY) if $self->{verbose}; + + my $file_epoch = (max(values %relevant))//time; + say encode_utf8( + 'Input files modified on : '. rfc822date($file_epoch)) + if $self->{verbose}; + + my $systemic_minimum_epoch = $self->{minimum_epoch} // 0; + say encode_utf8('Systemic minimum epoch is : ' + . rfc822date($systemic_minimum_epoch)) + if $self->{verbose}; + + my $stage_minimum_epoch = $stage{minimum_epoch} // 0; + say encode_utf8('Stage minimum epoch is : ' + . rfc822date($stage_minimum_epoch)) + if $self->{verbose}; + + my $threshold + = max($stage_minimum_epoch, $systemic_minimum_epoch, $file_epoch); + say encode_utf8( + 'Rebuild threshold is : '. rfc822date($threshold)) + if $self->{verbose}; + + say encode_utf8($EMPTY) if $self->{verbose}; + + my $product_epoch + = min(map { -e ? path($_)->stat->mtime : 0 } @products); + if($product_epoch) { + say encode_utf8( + 'Products modified on : '. rfc822date($product_epoch)) + if $self->{verbose}; + } else { + say encode_utf8('At least one product is not present.') + if $self->{verbose}; + } + + # not producing if times are equal; resolution 1 sec + if ($product_epoch < $threshold) { + + say encode_utf8('Producing: ' . join($SPACE, @relative)) + if $self->{verbose}; + + $stage{build}->() if exists $stage{build}; + + # sometimes the products are not the newest files + path($_)->touch(time) for @products; + + } else { + + say encode_utf8( + 'Skipping production of: ' . join($SPACE, @relative)) + if $self->{verbose}; + + $stage{skip}->() if exists $stage{skip}; + } + } + + return; +} + +=back + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et |