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