vcs.maemo.org Git - maemian/blob - nokia-lintian/lib/Checker.pm

   1 # Checker -- Perl checker functions for lintian
   2 # $Id$
   3
   4 # Copyright (C) 2004 Jeroen van Wolffelaar
   5 #
   6 # This program is free software; you can redistribute it and/or modify
   7 # it under the terms of the GNU General Public License as published by
   8 # the Free Software Foundation; either version 2 of the License, or
   9 # (at your option) any later version.
  10 #
  11 # This program is distributed in the hope that it will be useful,
  12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 # GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License
  17 # along with this program.  If not, you can find it on the World Wide
  18 # Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
  19 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  20 # MA 02110-1301, USA.
  21
  22 package Checker;
  23 use strict;
  24 no strict 'refs';
  25
  26 use Pipeline;
  27 use Tags;
  28 use Cwd 'cwd';
  29
  30 # Quiet "Name "main::LINTIAN_ROOT" used only once"
  31 # The variable comes from 'lintian'
  32 () = $main::LINTIAN_ROOT;
  33 my $LINTIAN_ROOT = $main::LINTIAN_ROOT;
  34
  35 # Can also be more precise later on (only verbose with checker actions) but for
  36 # now this will do --Jeroen
  37 my $verbose = $::verbose;
  38 my $debug = $::debug;
  39
  40 my %checks;
  41 # For source, binary, udeb, the names of applicable checks
  42 my %checks_per_type;
  43
  44 # Register a check. Argument is a hash with info
  45 sub register {
  46         my $info = $_[0];
  47         fail("Duplicate check $info->{'check-script'}")
  48                 if exists $checks{$info->{'check-script'}};
  49
  50         $checks{$info->{'check-script'}} = $info;
  51 }
  52
  53 sub runcheck {
  54         my ($pkg, $type, $info, $name) = @_;
  55
  56         # Will be set to 2 if error is encountered
  57         my $return = 0;
  58
  59         print "N: Running check: $name ...\n" if $debug;
  60
  61         my $check = $checks{$name};
  62
  63         # require has a anti-require-twice cache
  64         require "$LINTIAN_ROOT/checks/$name";
  65
  66         #print STDERR "Now running $name...\n";
  67         $name =~ s/[-.]/_/g;
  68         eval { &{'Lintian::'.$name.'::run'}($pkg, $type, $info) };
  69         if ( $@ ) {
  70             print STDERR $@;
  71             print STDERR "internal error: cannot run $name check on package $pkg\n";
  72             $return = 2;
  73         }
  74
  75         return $return;
  76 }
  77
  78 1;
  79
  80 # Local Variables:
  81 # indent-tabs-mode: t
  82 # cperl-indent-level: 8
  83 # End:
  84 # vim: ts=4 sw=4 noet