vcs.maemo.org Git - maemian/blob - nokia-lintian/checks/nmu

   1 # nmu -- lintian check script -*- perl -*-
   2
   3 # Copyright (C) 2004 Jeroen van Wolffelaar
   4 #
   5 # This program is free software; you can redistribute it and/or modify
   6 # it under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation; either version 2 of the License, or
   8 # (at your option) any later version.
   9 #
  10 # This program is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 # GNU General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program.  If not, you can find it on the World Wide
  17 # Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
  18 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  19 # MA 02110-1301, USA.
  20
  21 package Lintian::nmu;
  22 use strict;
  23 use Tags;
  24 use Util;
  25
  26 sub run {
  27
  28 my $pkg = shift;
  29 my $type = shift;
  30 my $changelog_mentions_nmu = 0;
  31 my $changelog_mentions_qa = 0;
  32 my $uploader = undef;
  33
  34 # This isn't really an NMU check, but right now no other check looks at
  35 # debian/changelog in source packages.  Catch a debian/changelog file that's a
  36 # symlink.  If it was a symlink to a file we didn't unpack, bail rather than
  37 # abort.
  38 if (-l "debfiles/changelog") {
  39     tag "changelog-is-symlink", "";
  40     return 0 unless -f "debfiles/changelog";
  41 }
  42
  43 open (CHANGELOG, '<', "debfiles/changelog")
  44     or fail("Failed opening changelog");
  45 <CHANGELOG>;
  46 my $firstline = 1;
  47 while (<CHANGELOG>) {
  48         if ($firstline) {
  49                 $changelog_mentions_nmu = 1
  50                         if (/\bnmu\b/i or /non-maintainer upload/i) and not /(ackno|\back\b|confir|incorporat)/i;
  51                 $changelog_mentions_qa = 1 if /orphan/i or /qa (?:group )?upload/i;
  52                 $firstline = 0 if /^\s+\S/;
  53         }
  54         if (/^ -- ([^>]+>)/) {
  55                 $uploader = canonicalize($1);
  56                 last;
  57         }
  58 }
  59 close CHANGELOG;
  60
  61 my $version = getfield("version");
  62 my $maintainer = canonicalize(getfield("maintainer"));
  63 my $uploaders = getfield("uploaders");
  64
  65 my $version_nmuness = 0;
  66 if ($version =~ /-[^.-]+(\.[^.-]+)?(\.[^.-]+)?$/) {
  67         $version_nmuness = 1 if defined $1;
  68         $version_nmuness = 2 if defined $2;
  69 }
  70 if ($version =~ /\+nmu\d+$/) {
  71         $version_nmuness = 1;
  72 }
  73 if ($version =~ /\+b\d+$/) {
  74         $version_nmuness = 2;
  75 }
  76
  77 my $upload_is_nmu = $uploader ne $maintainer;
  78 if (defined $uploaders) {
  79         my @uploaders = map { canonicalize($_) } split /,/, $uploaders;
  80         $upload_is_nmu = 0 if grep /^\s*\Q$uploader\E\s*$/, @uploaders;
  81 }
  82
  83 # No such thing as NMUs in Ubuntu-land.
  84 if ($version =~ /ubuntu/) {
  85     $upload_is_nmu = 0;
  86     $version_nmuness = 0;
  87 }
  88
  89 if ($maintainer =~ /packages\@qa.debian.org/) {
  90         tag "orphaned-package-should-not-have-uploaders", ""
  91                 if defined $uploaders;
  92         tag "qa-upload-has-incorrect-version-number", "$version"
  93                 if $version_nmuness == 1;
  94         tag "changelog-should-mention-qa", ""
  95                 if !$changelog_mentions_qa;
  96 } else {
  97         tag "changelog-should-mention-nmu", ""
  98                 if !$changelog_mentions_nmu && $upload_is_nmu;
  99         tag "changelog-should-not-mention-nmu", ""
 100                 if $changelog_mentions_nmu && !$upload_is_nmu;
 101         tag "source-nmu-has-incorrect-version-number", "$version"
 102                 if $upload_is_nmu && $version_nmuness != 1;
 103         tag "maintainer-upload-has-incorrect-version-number", "$version"
 104                 if !$upload_is_nmu && $version_nmuness;
 105 }
 106
 107 }
 108
 109 sub getfield {
 110         return undef if not open (FIELD, '<', "fields/" . shift);
 111         my $field = <FIELD>;
 112         close FIELD;
 113         $field =~ s/\n$//;
 114         return $field;
 115 }
 116
 117 # Canonicalize a maintainer address with respect to case.  E-mail addresses
 118 # are case-insensitive in the right-hand side.
 119 sub canonicalize {
 120         my ($maintainer) = @_;
 121         $maintainer =~ s/(<[^>\@]+\@)([\w.-]+)>/$1 . lc ($2)/e;
 122         return $maintainer;
 123 }
 124
 125 1;
 126
 127 # Local Variables:
 128 # indent-tabs-mode: t
 129 # cperl-indent-level: 8
 130 # End:
 131 # vim: ts=4 sw=4