diff options
Diffstat (limited to 'lib/Lintian/Check/Debian/Copyright/Dep5.pm')
| -rw-r--r-- | lib/Lintian/Check/Debian/Copyright/Dep5.pm | 968 |
1 files changed, 968 insertions, 0 deletions
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 |