Author: jeroen
Date: 2004-05-01 22:17:57 +0200 (Sat, 01 May 2004)
New Revision: 243
Added:
trunk/lib/Checker.pm
Modified:
trunk/frontend/lintian
Log:
Actual execution of the check scripts now in a module too... /me now nearly
complete understands perl modules
Modified: trunk/frontend/lintian
===================================================================
--- trunk/frontend/lintian 2004-05-01 17:56:16 UTC (rev 242)
+++ trunk/frontend/lintian 2004-05-01 20:17:57 UTC (rev 243)
@@ -43,14 +43,14 @@
# binary and source pkgs
use vars qw($verbose);
$verbose = 0; #flag for -v|--verbose switch
-my $debug = 0; #flag for -d|--debug switch
+our $debug = 0; #flag for -d|--debug switch
my @debug;
my $check_everything = 0; #flag for -a|--all switch
my $lintian_info = 0; #flag for -i|--info switch
-my $display_infotags = 0; #flag for -I|--display-info switch
+our $display_infotags = 0; #flag for -I|--display-info switch
my $unpack_level = undef; #flag for -l|--unpack-level switch
-my $no_override = 0; #flag for -o|--no-override switch
-my $show_overrides = 0; #flag for --show-overrides switch
+our $no_override = 0; #flag for -o|--no-override switch
+our $show_overrides = 0; #flag for --show-overrides switch
my $check_md5sums = 0; #flag for -m|--md5sums switch
my $allow_root = 0; #flag for --allow-root swtich
my $packages_file = 0; #string for the -p option
@@ -61,7 +61,7 @@
my $OPT_LINTIAN_SECTION = ""; #string for the --release option
# These options can also be used via default or environment variables
my $LINTIAN_CFG = ""; #config file to use
-my $LINTIAN_ROOT; #location of the lintian modules
+our $LINTIAN_ROOT; #location of the lintian modules
my @packages;
@@ -80,7 +80,7 @@
my %checks;
my %check_abbrev;
my %unpack_infos;
-my %experimental_tag;
+our %experimental_tag;
my %check_info;
# reset configuration variables
@@ -478,6 +478,7 @@
require Util;
require Pipeline;
require Read_pkglists;
+
import Util;
import Pipeline;
@@ -1060,6 +1061,8 @@
$exit_code = 0;
+require Checker;
+
# for each package (the `reverse sort' is to make sure that source packages are
# before the corresponding binary packages--this has the advantage that binary
# can use information from the source packages if these are unpacked)
@@ -1250,80 +1253,14 @@
next PACKAGE;
}
- print "N: Running check: $check ...\n" if $debug;
+ my $returnvalue = Checker::runcheck($pkg, $long_type, $check);
+ # Set exit_code correctly if there was not yet an exit code
+ $exit_code = $returnvalue unless $exit_code;
- my $cmd = "$LINTIAN_ROOT/checks/$ci->{'script'}";
-
- my $PIPE=FileHandle->new;
- unless (pipeline_open($PIPE, sub { exec $cmd, $pkg, $long_type })) {
- print STDERR "internal error: cannot open input pipe to command
$cmd: $!\n";
+ if ($returnvalue == 2) {
print "N: Skipping $action of $long_type package $pkg\n";
- $exit_code = 2;
next PACKAGE;
}
- my $suppress;
- while (<$PIPE>) {
- chop;
-
- # error/warning/info ?
- if (/^[EWI]: \S+ \S+:\s+\S+/o) {
- $suppress = (/^I: / and not $display_infotags);
-
- # change "pkg binary:" to just "pkg:"
- s/^(.: \S+)\s+binary:/$1:/;
-
- # remove `[EWI]:' for override matching
- my $tag_long = $_;
- $tag_long =~ s/^.:\s+//;
- $tag_long =~ s/\s+$//;
- $tag_long =~ s/\s+/ /g;
-
- my $tag_short;
- if ($tag_long =~ /^([^:]*): (\S+)/) {
- $tag_short = "$1: $2";
- } else {
- die "couldn't parse tag_long $tag_long to create
tag_short";
- }
-
- if ($experimental_tag{$2}) {
- s/^.:/X:/;
- }
-
- # overridden?
- if (not $no_override and
- ((exists $overridden{$tag_long}) or
- (exists $overridden{$tag_short}))) {
- # yes, this tag is overridden
- $overridden{$tag_long}++ if exists
$overridden{$tag_long};
- $overridden{$tag_short}++ if exists
$overridden{$tag_short};
- s/^.:/O:/;
- print "$_\n"
- if $show_overrides or ($verbose and not $suppress);
- } else {
- # no, just display it
- print "$_\n"
- if not $suppress;
- }
-
- # error?
- if (/^E:/) {
- $exit_code or ($exit_code = 1);
- }
- } else {
- # no, so just display it
- print "$_\n";
- }
- }
- unless (close($PIPE)) {
- if ($!) {
- print STDERR "internal error: cannot close input pipe to
command $cmd: $!";
- } else {
- print STDERR "internal error: cannot run $check check on
package $pkg\n";
- }
- print "N: Skipping $action of $long_type package $pkg\n";
- $exit_code = 2;
- next PACKAGE;
- }
}
# report unused overrides
Added: trunk/lib/Checker.pm
===================================================================
--- trunk/lib/Checker.pm 2004-05-01 17:56:16 UTC (rev 242)
+++ trunk/lib/Checker.pm 2004-05-01 20:17:57 UTC (rev 243)
@@ -0,0 +1,127 @@
+# Checker -- Perl checker functions for lintian
+# $Id$
+
+# Copyright (C) 1998-2004 Various authors
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+# MA 02111-1307, USA.
+
+package Checker;
+use strict;
+
+use Pipeline;
+
+my $LINTIAN_ROOT = $::LINTIAN_ROOT;
+
+# Can also be more precise later on (only verbose with checker actions) but for
+# now this will do --Jeroen
+my $verbose = $::verbose;
+my $debug = $::debug;
+
+# Not very neat to do like this... but the code wasn't neat to begin with :-/
+my $display_infotags = $::display_infotags;
+my $no_override = $::no_override;
+my $show_overrides = $::show_overrides;
+# I want a reference... Yes it's very evil
+my %experimental_tag; *experimental_tag = \%::experimental_tag;
+
+
+sub runcheck {
+ my $pkg = shift;
+ my $type = shift;
+ my $name = shift;
+
+ # Will be set to 1 if error is encountered
+ my $return = 0;
+ my %overridden;
+
+ print "N: Running check: $name ...\n" if $debug;
+
+ my $cmd = "$LINTIAN_ROOT/checks/$name";
+
+ my $PIPE=FileHandle->new;
+ unless (pipeline_open($PIPE, sub { exec $cmd, $pkg, $type })) {
+ print STDERR "internal error: cannot open input pipe to command
$cmd: $!\n";
+ return 2;
+ }
+ my $suppress;
+ while (<$PIPE>) {
+ chop;
+
+ # error/warning/info ?
+ if (/^[EWI]: \S+ \S+:\s+\S+/o) {
+ $suppress = (/^I: / and not $display_infotags);
+
+ # change "pkg binary:" to just "pkg:"
+ s/^(.: \S+)\s+binary:/$1:/;
+
+ # remove `[EWI]:' for override matching
+ my $tag_long = $_;
+ $tag_long =~ s/^.:\s+//;
+ $tag_long =~ s/\s+$//;
+ $tag_long =~ s/\s+/ /g;
+
+ my $tag_short;
+ if ($tag_long =~ /^([^:]*): (\S+)/) {
+ $tag_short = "$1: $2";
+ } else {
+ die "couldn't parse tag_long $tag_long to
create tag_short";
+ }
+
+ if ($experimental_tag{$2}) {
+ s/^.:/X:/;
+ }
+
+ # overridden?
+ if (not $no_override and
+ ((exists $overridden{$tag_long}) or
+ (exists $overridden{$tag_short}))) {
+ # yes, this tag is overridden
+ $overridden{$tag_long}++ if exists
$overridden{$tag_long};
+ $overridden{$tag_short}++ if exists
$overridden{$tag_short};
+ s/^.:/O:/;
+ print "$_\n"
+ if $show_overrides or ($verbose and not
$suppress);
+ } else {
+ # no, just display it
+ print "$_\n"
+ if not $suppress;
+ }
+
+ # error?
+ if (/^E:/) {
+ $return = 1;
+ }
+ } else {
+ # no, so just display it
+ print "$_\n";
+ }
+ }
+ unless (close($PIPE)) {
+ if ($!) {
+ print STDERR "internal error: cannot close input pipe
to command $cmd: $!";
+ } else {
+ print STDERR "internal error: cannot run $name check on
package $pkg\n";
+ }
+ return 2;
+ }
+
+ return $return;
+}
+
+1;
+
+# vim: ts=4 sw=4 noet
Property changes on: trunk/lib/Checker.pm
___________________________________________________________________
Name: svn:keywords
+ Id
